bring in a bit of structure

LtuPatternFactory.cabal

@@ -3,7 +3,7 @@ version:             0.1.0.0
 -- synopsis:
 -- description:
 homepage:            https://github.com/thma/LtuPatternFactory#readme
-license:             APACHE2
+license:             Apache-2.0
 license-file:        LICENSE
 author:              Thomas Mahler
 maintainer:          thma@apache.org

README.md

@@ -41,9 +41,9 @@ context = map
 ``` 
 The `context` function uses higher order `map` function  (`map :: (a -> b) -> [a] -> [b]`) to apply the strategies to lists of numbers:
 ```haskell
-> context strategyId [1..10]
+ghci> context strategyId [1..10]
 [1,2,3,4,5,6,7,8,9,10]
-> context strategyDouble [1..10]
+ghci> context strategyDouble [1..10]
 [2,4,6,8,10,12,14,16,18,20]
 ```
 Instead of map we could use just any other function that accepts a function of type `Num a => a -> a` and applies it in a given context.
@@ -121,7 +121,7 @@ If we now bind `env` to a value as in the following snippet it is used as an imu
 main = do
   let exp = Mul (Add (Val 3) (Val 1)) 
                 (Mul (Val 2) (Var "pi"))
-  let env = [("pi", pi)]
+      env = [("pi", pi)]
   print $ eval exp env
 ```
 Experienced Haskellers will notice the ["eta-reduction smell"](https://wiki.haskell.org/Eta_conversion) in `eval (Var x) env = fetch x env` which hints at the possibilty to remove `env` as an explicit parameter. We can not do this right away as the other equations for `eval` do not allow eta-reduction. In order to do so we have to apply the combinators of the `Applicative Functor`:

src/Main.hs

@@ -1,5 +1,14 @@
 module Main where
+import Strategy  
+import Singleton
+import Pipeline
+import Visitor
 
 main :: IO ()
 main = do
-  putStrLn "hello world"
+  putStrLn "have fun with Lambda the ultimate Pattern Factory\n"
+  strategyDemo
+  singletonDemo
+  pipelineDemo
+  visitorDemo
+

src/Pipeline.hs

@@ -0,0 +1,51 @@
+-- The DeriveFunctor Language Pragma provides automatic derivation of Functor instances
+{-# LANGUAGE DeriveFunctor #-}
+module Pipeline where
+
+-- The Stream type is a wrapper around an arbitrary payload type 'a'
+newtype Stream a = Stream a deriving (Show)
+
+-- echo lifts an item of type 'a' into the Stream context
+echo :: a -> Stream a
+echo = Stream
+
+-- the 'andThen' operator used for chaining commands
+infixl 7 |>
+(|>) :: Stream a -> (a -> Stream b) -> Stream b
+Stream x |> f = f x
+
+
+-- echo and |> are used to create the actual pipeline
+pipeline :: String -> Stream Int
+pipeline str = 
+  echo str |> echo . length . words |> echo . (3 *)
+
+
+-- the Stream type is extened by an Int that keeps the counter state
+newtype CountingStream a = CountingStream (a, Int) deriving (Show, Functor)
+
+-- as any Monad must be an Applicative we also have to instantiate Applicative
+instance Applicative CountingStream where
+  pure = return
+  CountingStream (f, _) <*> r = fmap f r
+
+-- our definition of the Stream Monad
+instance Monad CountingStream where
+  -- returns a Stream wrapping a tuple of the actual payload and an initial counter state of 0
+  return a = CountingStream (a, 0)
+  -- we define (>>=) to reach an incremented counter to the subsequent action
+  m >>= k = let CountingStream(a, c1) = m
+                next                  = k a
+                CountingStream(b, c2) = next
+            in CountingStream (b, c1 + 1 + c2)
+
+-- instead of echo and |> we now use the "official" monadic versions return and >>=
+countingPipeline :: String -> CountingStream Int
+countingPipeline str =
+  return str >>= return . length . words >>= return . (3 *)
+
+pipelineDemo = do 
+    putStrLn "Pipeline vs. Monad"
+    print $ pipeline "hello world"
+    print $ countingPipeline "hello counting world"
+    putStrLn ""

src/Singleton.hs

@@ -0,0 +1,65 @@
+module Singleton 
+    (
+        singletonDemo
+    )
+where
+
+data Exp = Var String
+    | Val Double
+    | Add Exp Exp
+    | Mul Exp Exp
+
+type Env = [(String, Double)]
+
+-- the naive implementation of eval:
+-- the environment is threaded into each recursive call of eval
+-- as an explicit parameter e
+eval :: Exp -> Env -> Double
+eval (Var x)   e = fetch x e
+eval (Val i)   e = i
+eval (Add p q) e = eval p e + eval q e
+eval (Mul p q) e = eval p e * eval q e
+
+-- the K combinator
+k :: a -> env -> a
+k x e = x
+-- the S combinator
+s :: (env -> a -> b) -> (env -> a) -> env -> b
+s ef es e = ef e (es e)
+
+-- the SK combinator based implementation
+-- the threading of the env into recursive calls is by the S combinator
+-- currying allows to omit the explicit parameter e
+eval1 :: Exp -> Env -> Double
+eval1 (Var x)   = fetch x
+eval1 (Val i)   = k i
+eval1 (Add p q) = k (+) `s` eval1 p `s` eval1 q
+eval1 (Mul p q) = k (*) `s` eval1 p `s` eval1 q
+
+-- instance Applicative ((->) r) where
+-- pure x _ = x
+-- f <*> g  = \x -> f x (g x)
+
+-- applicative functor based implementation
+-- the K and S magic is now done by pure and <*>
+eval2 :: Exp -> Env -> Double
+eval2 (Var x)   = fetch x
+eval2 (Val i)   = pure i
+eval2 (Add p q) = pure (+) <*> eval2 p  <*> eval2 q
+eval2 (Mul p q) = pure (*) <*> eval2 p  <*> eval2 q
+
+-- simple environment lookup
+fetch :: String -> Env -> Double
+fetch x []        = error $ "variable " ++ x ++ " is not defined"
+fetch x ((y,v):ys)
+    | x == y    = v
+    | otherwise = fetch x ys
+
+singletonDemo :: IO ()
+singletonDemo = do
+    putStrLn "Singleton vs. Applicative Functor, Pointed (and let in general)"
+    let exp = Mul (Add (Val 3) (Val 1)) 
+                  (Mul (Val 2) (Var "pi"))
+        env = [("pi", pi)]
+    print $ eval exp env
+    putStrLn ""

src/Strategy.hs

@@ -0,0 +1,18 @@
+module Strategy where
+
+-- first we define two simple strategies that map numbers to numbers:
+strategyId :: Num a => a -> a
+strategyId n = n
+
+strategyDouble :: Num a => a -> a
+strategyDouble n = 2*n
+
+-- now we define a context that applies a function of type Num a => a -> a to a list of a's:
+context :: Num a => (a -> a) -> [a] -> [a]
+context = fmap
+
+strategyDemo = do
+    putStrLn "Strategy Pattern vs. Functor (and Higher Order Functions in general)"
+    print $ context strategyId [1..10]
+    print $ context strategyDouble [1..10]
+    putStrLn ""

src/Visitor.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE DeriveFoldable #-}
+module Visitor where
+--import Data.Foldable
+
+data Exp a = 
+    Val a
+    | Add (Exp a) (Exp a)
+    | Mul (Exp a) (Exp a)
+    deriving (Show, Foldable)
+{-
+instance Foldable Exp where
+    foldMap f Empty = mempty
+    foldMap f (Val x) = f x
+    foldMap f (Add x y) = foldMap f x ++ foldMap f y
+        where (++) = mappend
+    foldMap f (Mul x y) = foldMap f x ++ foldMap f y
+        where (++) = mappend
+-}
+
+visitorDemo = do
+    putStrLn "Visitor vs. Foldable, Traversable"
+    let exp = Mul (Add (Val 3) (Val 1)) 
+                  (Mul (Val 4) (Val pi))
+    print exp
+    putStr "size of exp: "
+    print (length exp)