From 2fa85a03f8b86b48586ad61e3a8f4fbee3db7ba8 Mon Sep 17 00:00:00 2001 From: thma Date: Sat, 24 Nov 2018 22:00:32 +0100 Subject: [PATCH] got the abstract factory stuff working - finally --- LtuPatternFactory.cabal | 1 + README.md | 41 +++++++++++++++++-- src/AbstractFactory.hs | 90 +++++++++++++++-------------------------- src/JsonPersistence.hs | 66 ++++++++++++++++++++++++++++++ src/Main.hs | 2 + 5 files changed, 139 insertions(+), 61 deletions(-) create mode 100644 src/JsonPersistence.hs diff --git a/LtuPatternFactory.cabal b/LtuPatternFactory.cabal index d496919..f82059c 100644 --- a/LtuPatternFactory.cabal +++ b/LtuPatternFactory.cabal @@ -20,6 +20,7 @@ executable LtuPatternFactory , Builder , Composite , Iterator + , JsonPersistence , NullObject , Pipeline , Singleton diff --git a/README.md b/README.md index 65937b2..9fb4961 100644 --- a/README.md +++ b/README.md @@ -1156,8 +1156,8 @@ So the Monoid type class definition forms a *template* where the default impleme ## TBD: Factory -> Function Currying - ### Builder -> record syntax, smart constructor > The Builder is a design pattern designed to provide a flexible solution to various object creation problems in object-oriented programming. The intent of the Builder design pattern is to separate the construction of a complex object from its representation. diff --git a/src/AbstractFactory.hs b/src/AbstractFactory.hs index 3056164..d62ea96 100644 --- a/src/AbstractFactory.hs +++ b/src/AbstractFactory.hs @@ -1,65 +1,39 @@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} -{-# LANGUAGE OverloadedStrings #-} module AbstractFactory 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 -type Id a = Tagged a Integer -data Identified a = Identified - { ident :: Id a - , val :: a - } deriving (Eq, Ord, Read, Show, Generic, ToJSON, FromJSON) +-- | representation of a Button UI widget +data Button = Button + { label :: String -- the text label of the button + , paint :: IO () -- a platform dependent rendering action + } -class (ToJSON a, FromJSON a, Eq a, Show a) => Entity a where - -- | store persistent entity of type a to a json file - store :: Identified a -> IO () - store identified@(Identified id val) = do - -- compute file path based on entity id - let jsonFileName = getPath id - -- serialize entity as JSON and write to file - encodeFile jsonFileName identified +-- | rendering a Button for the WIN platform (we just simulate it by printing the label) +winPaint :: String -> IO () +winPaint lbl = putStrLn $ "winButton: " ++ lbl - -- | load persistent entity of type a and identified by id - retrieve :: Id a -> IO (Identified a) - retrieve id = do - -- compute file path based on id - let jsonFileName = getPath id - -- parse entity from JSON file - eitherEntity <- eitherDecodeFileStrict jsonFileName - case eitherEntity of - Left msg -> fail msg - Right e -> return e +-- | rendering a Button for the OSX platform +osxPaint :: String -> IO () +osxPaint lbl = putStrLn $ "osxButton: " ++ lbl + +-- | enumeration of supported operating system platforms +data OS = OSX | WIN deriving (Show, Eq, Enum) - -- | publish an entity (e.g. to a message bus, or just print it out) - publish :: Identified a -> IO () - publish = print - - -- | produce a tagged id - tagId :: Integer -> Id a - tagId = Tagged - --- | compute path of data file -getPath :: Id a -> String -getPath (Tagged i) = ".stack-work/" ++ show i ++ ".json" - -data User = User { - name :: String - , email :: String -} deriving (Show, Eq, Generic, ToJSON, FromJSON, Entity) - -data Post = Post { - userId :: Integer - , text :: String -} deriving (Show, Eq, Generic, ToJSON, FromJSON, Entity) +-- | create a button for os platform with label lbl +createButton :: OS -> String -> Button +createButton os lbl = + case os of + WIN -> Button lbl (winPaint lbl) + OSX -> Button lbl (osxPaint lbl) abstractFactoryDemo = do - putStrLn "AbstractFactory -> type class polymorphism" - let user = Identified 1 (User "Heinz Meier" "hm@meier.com") - let post = Identified 4711 (Post 1 "My name is Heinz, this is my first post") - store user - store post - user' <- retrieve (ident user) - publish user' - retrieve (ident post) >>= publish - retrieve (tagId (userId (val post)) :: Id User) >>= publish \ No newline at end of file + putStrLn "AbstractFactory -> functions as data type values" + let os = WIN + let newButton = createButton os + let ok = newButton "OK" + let exit = newButton "Exit" + paint ok + paint exit + + paint $ createButton OSX "about" + + let linuxButton = Button "penguin" (putStrLn "linuxButton: penguin") + paint linuxButton \ No newline at end of file diff --git a/src/JsonPersistence.hs b/src/JsonPersistence.hs new file mode 100644 index 0000000..16e068b --- /dev/null +++ b/src/JsonPersistence.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +{-# 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 + +type Id a = Tagged a Integer +data Identified a = Identified + { ident :: Id a + , val :: a + } deriving (Eq, Ord, Read, Show, Generic, ToJSON, FromJSON) + +class (ToJSON a, FromJSON a, Eq a, Show a) => Entity a where + -- | store persistent entity of type a to a json file + store :: Identified a -> IO () + store identified@(Identified id val) = do + -- compute file path based on entity id + let jsonFileName = getPath id + -- serialize entity as JSON and write to file + encodeFile jsonFileName identified + + -- | load persistent entity of type a and identified by id + retrieve :: Id a -> IO (Identified a) + retrieve id = do + -- compute file path based on id + let jsonFileName = getPath id + -- parse entity from JSON file + eitherEntity <- eitherDecodeFileStrict jsonFileName + case eitherEntity of + Left msg -> fail msg + Right e -> return e + + -- | publish an entity (e.g. to a message bus, or just print it out) + publish :: Identified a -> IO () + publish = print + + -- | produce a tagged id + tagId :: Integer -> Id a + tagId = Tagged + +-- | compute path of data file +getPath :: Id a -> String +getPath (Tagged i) = ".stack-work/" ++ show i ++ ".json" + +data User = User { + name :: String + , email :: String +} deriving (Show, Eq, Generic, ToJSON, FromJSON, Entity) + +data Post = Post { + userId :: Integer + , text :: String +} deriving (Show, Eq, Generic, ToJSON, FromJSON, Entity) + +jsonPersistenceDemo = do + putStrLn "JsonPersistence" + let user = Identified 1 (User "Heinz Meier" "hm@meier.com") + let post = Identified 4711 (Post 1 "My name is Heinz, this is my first post") + store user + store post + user' <- retrieve (ident user) + publish user' + retrieve (ident post) >>= publish + retrieve (tagId (userId (val post)) :: Id User) >>= publish diff --git a/src/Main.hs b/src/Main.hs index ff1e20a..90fabe9 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -11,6 +11,7 @@ import NullObject import Iterator import Coerce import AbstractFactory +import JsonPersistence main :: IO () main = do @@ -26,3 +27,4 @@ main = do nullObjectDemo iteratorDemo abstractFactoryDemo + jsonPersistenceDemo