thma/LtuPatternFactory
1
1
Fork 0
mirror of https://github.com/thma/LtuPatternFactory.git synced 2024-12-04 12:43:14 +03:00
Code Issues Projects Releases Wiki Activity

reformatedd source code

Browse Source
This commit is contained in:
Mahler 2018-12-06 18:08:36 +01:00
parent e6e5836a03
commit 1181509025
18 changed files with 145 additions and 140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
src/AbstractFactory.hs
View File

@ -1,13 +1,13 @@
module AbstractFactory where
import System.Info (os) -- provide Platform information
import System.Info (os)
-- | representation of a Button UI widget
data Button = Button
-- | representation of a Button UI widget
data Button = Button
{ label :: String -- the text label of the button
, render :: Button -> IO () -- a platform specific rendering action
}
-- | rendering a Button for the WIN platform (we just simulate it by printing the label)
-- | rendering a Button for the WIN platform (we just simulate it by printing the label)
winPaint :: Button -> IO ()
winPaint btn = putStrLn $ "winButton: " ++ label btn
@ -15,10 +15,10 @@ winPaint btn = putStrLn $ "winButton: " ++ label btn
osxPaint :: Button -> IO ()
osxPaint btn = putStrLn $ "osxButton: " ++ label btn
-- | paint a button by using the Buttons render function
-- | paint a button by using the Buttons render function
paint :: Button -> IO ()
paint btn@(Button _ render) = render btn
paint btn@(Button _ render) = render btn
-- | a representation of the operating system platform
data Platform = OSX | WIN | NIX | Other
@ -33,13 +33,13 @@ platform = case os of
-- | create a button for os platform with label lbl
createButton :: String -> Button
createButton lbl = case platform of
OSX -> Button lbl osxPaint
WIN -> Button lbl winPaint
NIX -> Button lbl (\btn -> putStrLn $ "nixButton: " ++ label btn)
Other -> Button lbl (\btn -> putStrLn $ "otherButton: " ++ label btn)
OSX -> Button lbl osxPaint
WIN -> Button lbl winPaint
NIX -> Button lbl (\btn -> putStrLn $ "nixButton: " ++ label btn)
Other -> Button lbl (\btn -> putStrLn $ "otherButton: " ++ label btn)
abstractFactoryDemo = do
putStrLn "AbstractFactory -> functions as data type values"
putStrLn "AbstractFactory -> functions as data type values"
let exit = createButton "Exit" -- using the "abstract" API to create buttons
let ok = createButton "OK"
paint ok -- using the "abstract" API to paint buttons
@ -47,4 +47,4 @@ abstractFactoryDemo = do
paint $ Button "Apple" osxPaint -- paint a platform specific button
paint $ Button "Pi" -- paint a user-defined button
(\btn -> putStrLn $ "raspberryButton: " ++ label btn)
(\btn -> putStrLn $ "raspberryButton: " ++ label btn)

14
src/Adapter.hs
View File

@ -1,8 +1,8 @@
module Adapter where
module Adapter where
backend :: c -> d
backend = undefined
marshal :: a -> c
marshal = undefined
@ -12,7 +12,7 @@ unmarshal = undefined
adapter :: a -> b
adapter = unmarshal . backend . marshal
-- a 24:00 hour clock representation of time
-- a 24:00 hour clock representation of time
newtype WallTime = WallTime (Int, Int) deriving (Show)
-- this is our backend. It can add minutes to a WallTime representation
@ -32,7 +32,7 @@ newtype Minute = Minute Int deriving (Show)
-- convert a Minute value into a WallTime representation
marshalMW :: Minute -> WallTime
marshalMW (Minute x) =
marshalMW (Minute x) =
let (h,m) = x `quotRem` 60
in WallTime (h `rem` 24, m)
@ -40,12 +40,12 @@ marshalMW (Minute x) =
unmarshalWM :: WallTime -> Minute
unmarshalWM (WallTime (h,m)) = Minute $ 60 * h + m
-- this is our frontend that add Minutes to a time of a day
-- this is our frontend that add Minutes to a time of a day
-- measured in minutes
addMinutesAdapter :: Int -> Minute -> Minute
addMinutesAdapter x = unmarshalWM . addMinutesToWallTime x . marshalMW
adapterDemo = do
adapterDemo = do
putStrLn "Adapter -> function composition"
print $ addMinutesAdapter 100 $ Minute 400
putStrLn ""
putStrLn ""

4
src/Builder.hs
View File

@ -1,6 +1,6 @@
module Builder where
-- accountNo, Name, branch, balance, interestRate
-- accountNo, Name, branch, balance, interestRate
data BankAccount = BankAccount {
accountNo :: Int
, name :: String
@ -27,4 +27,4 @@ builderDemo = do
, interestRate = 2.5
}
print account2

6
src/CMarkGFMRenderer.hs
View File

@ -1,6 +1,6 @@
module CMarkGFMRenderer where
import qualified CMarkGFM as CM
import qualified Data.Text as T
import qualified CMarkGFM as CM
import qualified Data.Text as T
type MarkDown = T.Text
type HTML = T.Text
@ -12,4 +12,4 @@ markDownToHtml :: MarkDown -> HTML
markDownToHtml = id
htmlToText :: HTML -> T.Text
htmlToText = id
htmlToText = id

6
src/CheapskateRenderer.hs
View File

@ -1,9 +1,9 @@
module CheapskateRenderer
module CheapskateRenderer
( MarkDown
, HTML
, textToMarkDown
, markDownToHtml
, htmlToText
, htmlToText
) where
import qualified Cheapskate as C
@ -27,4 +27,4 @@ markDownToHtml = H.toHtml
-- | rendering a Text with html markup from HTML. Using Blaze again.
htmlToText :: HTML -> T.Text
htmlToText = T.pack . R.renderHtml
htmlToText = T.pack . R.renderHtml

2
src/Coerce.hs
View File

@ -10,7 +10,7 @@ import Control.Monad.State.Lazy -- State Monad
import Data.Typeable
-- | This module provides explicit coercion.
-- Instead of the "magic" Data.Coerce.coerce you could use wrap and unwrap to explicitely write the coercions.
-- Instead of the "magic" Data.Coerce.coerce you could use wrap and unwrap to explicitly write the coercions.
class Coerce a b | a -> b where
unwrap :: a -> b
wrap :: b -> a

24
src/Composite.hs
View File

@ -1,5 +1,5 @@
module Composite where
import Data.Semigroup (All(..))
import Data.Semigroup (All (..))
-- the composite data structure: a Test can be Empty, a single TestCase
-- or a TestSuite holding a list of Tests
@ -11,7 +11,7 @@ data Test = Empty
type TestCase = () -> Bool
-- execution of a Test.
-- execution of a Test.
run :: Test -> Bool
run Empty = True
run (TestCase t) = t () -- evaluating the TestCase by applying t to ()
@ -21,12 +21,12 @@ run (TestSuite l) = all (True ==) (map run l) -- running all tests in l and retu
-- addTesting Tests
addTest :: Test -> Test -> Test
addTest Empty t = t
addTest t Empty = t
addTest t1@(TestCase _) t2@(TestCase _) = TestSuite [t1,t2]
addTest t1@(TestCase _) (TestSuite list) = TestSuite ([t1] ++ list)
addTest (TestSuite list) t2@(TestCase _) = TestSuite (list ++ [t2])
addTest (TestSuite l1) (TestSuite l2) = TestSuite (l1 ++ l2)
addTest Empty t = t
addTest t Empty = t
addTest t1@(TestCase _) t2@(TestCase _) = TestSuite [t1,t2]
addTest t1@(TestCase _) (TestSuite list) = TestSuite ([t1] ++ list)
addTest (TestSuite list) t2@(TestCase _) = TestSuite (list ++ [t2])
addTest (TestSuite l1) (TestSuite l2) = TestSuite (l1 ++ l2)
-- in order to make Test an instance of Monoid, we have to provide
@ -37,12 +37,12 @@ instance Semigroup Test where
instance Monoid Test where
mempty = Empty
-- a few most simple test cases
t1 :: Test
-- a few most simple test cases
t1 :: Test
t1 = TestCase (\() -> True)
t2 :: Test
t2 :: Test
t2 = TestCase (\() -> True)
t3 :: Test
t3 :: Test
t3 = TestCase (\() -> False)
-- collecting all test cases in a TestSuite
ts = TestSuite [t1,t2,t3]

35
src/DependencyInjection.hs
View File

@ -1,8 +1,9 @@
module DependencyInjection where
import qualified Data.Text as T
import Control.Arrow ((>>>))
import CheapskateRenderer (HTML, MarkDown, textToMarkDown, markDownToHtml, htmlToText)
import CheapskateRenderer (HTML, MarkDown, htmlToText, markDownToHtml, textToMarkDown)
--import CMarkGFMRenderer (HTML, MarkDown, textToMarkDown, markDownToHtml, htmlToText)
import Control.Arrow ((>>>))
import qualified Data.Text as T
-- | a table of contents consists of a heading and a list of entries
data TableOfContents = Section Heading [TocEntry]
@ -16,7 +17,7 @@ data Heading = Title String | Url String String
-- | render a ToC entry as a Markdown String with the proper indentation
teToMd :: Int -> TocEntry -> String
teToMd depth (Head head) = headToMd depth head
teToMd depth (Sub toc) = tocToMd depth toc
teToMd depth (Sub toc) = tocToMd depth toc
-- | render a heading as a Markdown String with the proper indentation
headToMd :: Int -> Heading -> String
@ -29,13 +30,13 @@ tocToMd depth (Section heading entries) = headToMd depth heading ++ concatMap (t
-- | produce a String of length n, consisting only of blanks
indent :: Int -> String
indent n = replicate n ' '
indent n = replicate n ' '
-- | render a ToC as a Text (consisting of properly indented Markdown)
tocToMDText :: TableOfContents -> T.Text
tocToMDText = T.pack . tocToMd 0
-- | render a ToC as a Text with html markup.
-- | render a ToC as a Text with html markup.
-- we specify this function as a chain of parse and rendering functions that must be provided externally
tocToHtmlText :: (TableOfContents -> T.Text) -- 1. a renderer function from ToC to Text with markdown markups
-> (T.Text -> MarkDown) -- 2. a parser function from Text to a MarkDown document
@ -43,7 +44,7 @@ tocToHtmlText :: (TableOfContents -> T.Text) -- 1. a renderer function from ToC
-> (HTML -> T.Text) -- 4. a renderer function from HTML to Text
-> TableOfContents -- the actual ToC to be rendered
-> T.Text -- the Text output (containing html markup)
tocToHtmlText tocToMdText textToMd mdToHtml htmlToText =
tocToHtmlText tocToMdText textToMd mdToHtml htmlToText =
tocToMdText >>> -- 1. render a ToC as a Text (consisting of properly indented Markdown)
textToMd >>> -- 2. parse text with Markdown to a MarkDown data structure
mdToHtml >>> -- 3. convert the MarkDown data to an HTML data structure
@ -53,8 +54,8 @@ tocToHtmlText tocToMdText textToMd mdToHtml htmlToText =
-- | a default implementation of a ToC to html Text renderer.
-- this function is constructed by partially applying `tocToHtmlText` to four functions matching the signature of `tocToHtmlText`.
defaultTocToHtmlText :: TableOfContents -> T.Text
defaultTocToHtmlText =
tocToHtmlText
defaultTocToHtmlText =
tocToHtmlText
tocToMDText -- the ToC to markdown Text renderer as defined above
textToMarkDown -- a MarkDown parser, externally provided via import
markDownToHtml -- a MarkDown to HTML renderer, externally provided via import
@ -62,13 +63,13 @@ defaultTocToHtmlText =
demoDI = do
let toc = Section (Title "Chapter 1")
[ Sub $ Section (Title "Section a")
[Head $ Title "First Heading",
[ Sub $ Section (Title "Section a")
[Head $ Title "First Heading",
Head $ Url "Second Heading" "http://the.url"]
, Sub $ Section (Url "Section b" "http://the.section.b.url")
[ Sub $ Section (Title "UnderSection b1")
, Sub $ Section (Url "Section b" "http://the.section.b.url")
[ Sub $ Section (Title "UnderSection b1")
[Head $ Title "First", Head $ Title "Second"]]]
putStrLn $ T.unpack $ tocToMDText toc
putStrLn $ T.unpack $ defaultTocToHtmlText toc
putStrLn $ T.unpack $ tocToMDText toc
putStrLn $ T.unpack $ defaultTocToHtmlText toc

16
src/IdiomBrackets.hs
View File

@ -1,5 +1,7 @@
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module IdiomBrackets where
-- This module provides the Idiom Bracket syntax suggested by Conor McBride
@ -8,14 +10,14 @@ module IdiomBrackets where
class Applicative i => Idiomatic i f g | g -> f i where
idiomatic :: i f -> g
iI :: Idiomatic i f g => f -> g
iI = idiomatic . pure
data Ii = Ii
instance Applicative i => Idiomatic i x (Ii -> i x) where
idiomatic xi Ii = xi
instance Idiomatic i f g => Idiomatic i (s -> f) (i s -> g) where
idiomatic sfi si = idiomatic (sfi <*> si)
idiomatic sfi si = idiomatic (sfi <*> si)

40
src/Iterator.hs
View File

@ -1,21 +1,21 @@
module Iterator where
import Singleton (Exp (..))
import Visitor
import Singleton (Exp (..))
import Visitor
import Data.Functor.Product -- Product of Functors
import Data.Functor.Compose -- Composition of Functors
import Data.Functor.Const -- Const Functor
import Data.Functor.Identity -- Identity Functor (needed for coercion)
import Data.Monoid (Sum (..), getSum) -- Sum Monoid for Integers
import Control.Monad.State.Lazy -- State Monad
import Control.Applicative -- WrappedMonad
import Data.Coerce (coerce) -- Coercion magic
import Control.Applicative
import Control.Monad.State.Lazy
import Data.Coerce (coerce)
import Data.Functor.Compose
import Data.Functor.Const
import Data.Functor.Identity
import Data.Functor.Product
import Data.Monoid (Sum (..), getSum)
instance Functor Exp where
fmap f (Var x) = Var x
fmap f (Val a) = Val $ f a
fmap f (Add x y) = Add (fmap f x) (fmap f y)
fmap f (Mul x y) = Mul (fmap f x) (fmap f y)
fmap f (Var x) = Var x
fmap f (Val a) = Val $ f a
fmap f (Add x y) = Add (fmap f x) (fmap f y)
fmap f (Mul x y) = Mul (fmap f x) (fmap f y)
instance Traversable Exp where
traverse g (Var x) = pure $ Var x
@ -25,7 +25,7 @@ instance Traversable Exp where
-- Functor Product
(<#>) :: (Functor m, Functor n) => (a -> m b) -> (a -> n b) -> (a -> Product m n b)
(f <#> g) y = Pair (f y) (g y)
(f <#> g) y = Pair (f y) (g y)
-- Functor composition
(<.>) :: (Functor m, Functor n) => (b -> n c) -> (a -> m b) -> (a -> (Compose m n) c)
@ -67,10 +67,10 @@ wci = traverse wciBody
clwci :: String -> (Product (Product Count Count) (Compose (WrappedMonad (State Bool)) Count)) [a]
clwci = traverse (cciBody <#> lciBody <#> wciBody)
-- | the actual wordcount implementation.
-- | the actual wordcount implementation.
-- for any String a triple of linecount, wordcount, charactercount is returned
wc :: String -> (Integer, Integer, Integer)
wc str =
wc str =
let raw = clwci str
cc = coerce $ pfst (pfst raw)
lc = coerce $ psnd (pfst raw)
@ -87,11 +87,11 @@ psnd (Pair _ snd) = snd
iteratorDemo = do
putStrLn "Iterator -> Traversable"
let exp = Mul (Add (Val 3) (Val 1))
let exp = Mul (Add (Val 3) (Val 1))
(Mul (Val 2) (Var "pi"))
env = [("pi", pi)]
print $ traverse (\x c -> if even x then [x] else [2*x]) exp 0
print $ wc str

24
src/JsonPersistence.hs
View File

@ -1,15 +1,17 @@
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
module JsonPersistence where
import GHC.Generics (Generic) -- needed to derive type class instances declaratively
import Data.Aeson (ToJSON, FromJSON, eitherDecodeFileStrict, toJSON, encodeFile) -- JSON encoding/decoding
import Data.Tagged -- used to tag type information to Ids
import Data.Aeson (FromJSON, ToJSON, eitherDecodeFileStrict,
encodeFile, toJSON)
import Data.Tagged
import GHC.Generics (Generic)
type Id a = Tagged a Integer
data Identified a = Identified
{ ident :: Id a
, val :: a
, val :: a
} deriving (Eq, Ord, Read, Show, Generic, ToJSON, FromJSON)
class (ToJSON a, FromJSON a, Eq a, Show a) => Entity a where
@ -45,13 +47,13 @@ getPath :: Id a -> String
getPath (Tagged i) = ".stack-work/" ++ show i ++ ".json"
data User = User {
name :: String
, email :: String
name :: String
, email :: String
} deriving (Show, Eq, Generic, ToJSON, FromJSON, Entity)
data Post = Post {
userId :: Integer
, text :: String
userId :: Integer
, text :: String
} deriving (Show, Eq, Generic, ToJSON, FromJSON, Entity)
jsonPersistenceDemo = do

28
src/Main.hs
View File

@ -1,18 +1,18 @@
module Main where
import Strategy
import Singleton
import Pipeline
import Composite
import Visitor
import Adapter
import Builder
import TemplateMethod
import NullObject
import Iterator
import Coerce
import AbstractFactory
import JsonPersistence
import DependencyInjection
import AbstractFactory
import Adapter
import Builder
import Coerce
import Composite
import DependencyInjection
import Iterator
import JsonPersistence
import NullObject
import Pipeline
import Singleton
import Strategy
import TemplateMethod
import Visitor
main :: IO ()
main = do

28
src/NullObject.hs
View File

@ -1,7 +1,7 @@
module NullObject where
import Data.Map (Map, fromList)
import qualified Data.Map as Map (lookup) -- avoid clash with Prelude.lookup
import Control.Monad ((>=>)) -- importing the Kleisli 'fish' operator for composing monadic functions
import Control.Monad ((>=>))
import Data.Map (Map, fromList)
import qualified Data.Map as Map (lookup)
type Song = String
type Album = String
@ -16,18 +16,18 @@ songMap = fromList
albumMap :: Map Album Artist
albumMap = fromList
[("Microgravity","Biosphere")
,("Apollo: Atmospheres and Soundtracks", "Brian Eno")]
,("Apollo: Atmospheres and Soundtracks", "Brian Eno")]
artistMap :: Map Artist URL
artistMap = fromList
[("Biosphere","http://www.biosphere.no//")
,("Brian Eno", "http://www.brian-eno.net")]
,("Brian Eno", "http://www.brian-eno.net")]
loookup' :: Ord a => Map a b -> a -> Maybe b
loookup' = flip Map.lookup
loookup' = flip Map.lookup
findAlbum :: Song -> Maybe Album
findAlbum = loookup' songMap
findAlbum = loookup' songMap
findArtist :: Album -> Maybe Artist
findArtist = loookup' albumMap
@ -36,10 +36,10 @@ findWebSite :: Artist -> Maybe URL
findWebSite = loookup' artistMap
findUrlFromSong :: Song -> Maybe URL
findUrlFromSong song =
findUrlFromSong song =
case findAlbum song of
Nothing -> Nothing
Just album ->
Just album ->
case findArtist album of
Nothing -> Nothing
Just artist ->
@ -57,15 +57,15 @@ findUrlFromSong' :: Song -> Maybe URL
findUrlFromSong' song =
findAlbum song >>= \album ->
findArtist album >>= \artist ->
findWebSite artist
findWebSite artist
findUrlFromSong'' :: Song -> Maybe URL
findUrlFromSong'' song =
findAlbum song >>= findArtist >>= findWebSite
findAlbum song >>= findArtist >>= findWebSite
findUrlFromSong''' :: Song -> Maybe URL
findUrlFromSong''' =
findAlbum >=> findArtist >=> findWebSite
findAlbum >=> findArtist >=> findWebSite
nullObjectDemo = do
putStrLn "NullObject -> Maybe"
@ -86,7 +86,7 @@ nullObjectDemo = do
print $ safeRootReciprocal 0.01
{-- --This is how >=> could be implemented for Maybe:
(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> (a -> Maybe c)
(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> (a -> Maybe c)
m1 >=> m2 = \x ->
case m1 x of
Nothing -> Nothing
@ -109,4 +109,4 @@ safeRootReciprocal :: Double -> Maybe Double
safeRootReciprocal = safeReciprocal >=> safeRoot
safeRootReciprocal' :: Double -> Maybe Double
safeRootReciprocal' x = return x >>= safeReciprocal >>= safeRoot
safeRootReciprocal' x = return x >>= safeReciprocal >>= safeRoot

12
src/Pipeline.hs
View File

@ -17,7 +17,7 @@ Stream x |> f = f x
-- echo and |> are used to create the actual pipeline
pipeline :: String -> Stream Int
pipeline str =
pipeline str =
echo str |> echo . length . words |> echo . (3 *)
-- a log is just a list of Strings
@ -28,7 +28,7 @@ newtype LoggerStream a = LoggerStream (a, Log) deriving (Show, Functor)
instance Applicative LoggerStream where
pure = return
LoggerStream (f, _) <*> r = fmap f r
LoggerStream (f, _) <*> r = fmap f r
-- our definition of the Logging Stream Monad
instance Monad LoggerStream where
@ -38,8 +38,8 @@ instance Monad LoggerStream where
m1 >>= m2 = let LoggerStream(f1, l1) = m1
LoggerStream(f2, l2) = m2 f1
in LoggerStream(f2, l1 ++ l2)
-- compute length of a String and provide a log message
-- compute length of a String and provide a log message
logLength :: String -> LoggerStream Int
logLength str = let l = length(words str)
in LoggerStream (l, ["length(" ++ str ++ ") = " ++ show l])
@ -52,8 +52,8 @@ logPipeline :: String -> LoggerStream Int
logPipeline str =
return str >>= logLength >>= logMultiply
pipelineDemo = do
pipelineDemo = do
putStrLn "Pipeline -> Monad"
print $ pipeline "hello world"
print $ logPipeline "hello logging world"
putStrLn ""
putStrLn ""

8
src/Singleton.hs
View File

@ -1,7 +1,7 @@
module Singleton where
import IdiomBrackets
import IdiomBrackets
data Exp a =
data Exp a =
Var String
| Val a
| Add (Exp a) (Exp a)
@ -64,11 +64,11 @@ fetch x ((y,v):ys)
singletonDemo :: IO ()
singletonDemo = do
putStrLn "Singleton -> Applicative Functor, Pointed (and let in general)"
let exp = Mul (Add (Val 3) (Val 1))
let exp = Mul (Add (Val 3) (Val 1))
(Mul (Val 2) (Var "pi"))
env = [("pi", pi)]
print $ eval exp env
print $ eval1 exp env
print $ eval2 exp env
print $ eval3 exp env
putStrLn ""
putStrLn ""

2
src/Strategy.hs
View File

@ -15,4 +15,4 @@ strategyDemo = do
putStrLn "Strategy Pattern -> Functor (and Higher Order Functions in general)"
print $ context strategyId [1..10]
print $ context strategyDouble [1..10]
putStrLn ""
putStrLn ""

2
src/TemplateMethod.hs
View File

@ -1,6 +1,6 @@
module TemplateMethod where
import Adapter (unmarshalWM, marshalMW, addMinutesToWallTime, Minute (..), WallTime (..) )
import Adapter (Minute (..), WallTime (..), addMinutesToWallTime, marshalMW, unmarshalWM)
addMinutesTemplate :: (Int -> WallTime -> WallTime) -> Int -> Minute -> Minute
addMinutesTemplate f x =

8
src/Visitor.hs
View File

@ -1,7 +1,7 @@
module Visitor where
import Singleton (Exp (..))
import Singleton (Exp (..))
-- we are re-using the Exp data type from the Singleton example
-- we are re-using the Exp data type from the Singleton example
-- and transform it into a Foldable type:
instance Foldable Exp where
foldMap f (Val x) = f x
@ -9,11 +9,11 @@ instance Foldable Exp where
foldMap f (Mul x y) = foldMap f x `mappend` foldMap f y
filterF :: Foldable f => (a -> Bool) -> f a -> [a]
filterF p = foldMap (\a -> if p a then [a] else [])
filterF p = foldMap (\a -> if p a then [a] else [])
visitorDemo = do
putStrLn "Visitor -> Foldable -> Traversable"
let exp = Mul (Add (Val 3) (Val 2))
let exp = Mul (Add (Val 3) (Val 2))
(Mul (Val 4) (Val 6))
print exp
putStr "size of exp: "