diff --git a/LtuPatternFactory.cabal b/LtuPatternFactory.cabal index c963783..d265bf3 100644 --- a/LtuPatternFactory.cabal +++ b/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 diff --git a/README.md b/README.md index 1cf29c0..a730446 100644 --- a/README.md +++ b/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`: diff --git a/src/Main.hs b/src/Main.hs index 9cd992d..d6eeea9 100644 --- a/src/Main.hs +++ b/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 + diff --git a/src/Pipeline.hs b/src/Pipeline.hs new file mode 100644 index 0000000..8a5d584 --- /dev/null +++ b/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 "" \ No newline at end of file diff --git a/src/Singleton.hs b/src/Singleton.hs new file mode 100644 index 0000000..297127c --- /dev/null +++ b/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 "" \ No newline at end of file diff --git a/src/Strategy.hs b/src/Strategy.hs new file mode 100644 index 0000000..eaf9451 --- /dev/null +++ b/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 "" \ No newline at end of file diff --git a/src/Visitor.hs b/src/Visitor.hs new file mode 100644 index 0000000..53d6d2f --- /dev/null +++ b/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) \ No newline at end of file