got the abstract factory stuff working - finally

LtuPatternFactory.cabal

@@ -20,6 +20,7 @@ executable LtuPatternFactory
                      , Builder
                      , Composite
                      , Iterator
+                     , JsonPersistence
                      , NullObject
                      , Pipeline
                      , Singleton

README.md

@@ -1156,8 +1156,8 @@ So the Monoid type class definition forms a *template* where the default impleme
 
 ## TBD: Factory -> Function Currying
 
-<!--
+
-### Abstract Factory -> type class polymorphism
+### Abstract Factory -> functions as data type values
 
 > The abstract factory pattern provides a way to encapsulate a group of individual factories that have a common theme without specifying their concrete classes.
 > In normal usage, the client software creates a concrete implementation of the abstract factory and then uses the generic interface of the factory to create the concrete objects that are part of the theme. 
@@ -1166,9 +1166,44 @@ So the Monoid type class definition forms a *template* where the default impleme
 > [Quoted from Wikipedia](https://en.wikipedia.org/wiki/Abstract_factory_pattern)
 
 ```haskell
+-- | representation of a Button UI widget    
+data Button = Button 
+    { label  :: String -- the text label of the button
+    , paint  :: IO ()  -- a platform dependent rendering action
+    }
 
+-- | rendering a Button for the WIN platform (we just simulate it by printing the label) 
+winPaint :: String -> IO ()
+winPaint lbl = putStrLn $ "winButton: " ++ lbl
+
+-- | 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)
+
+-- | 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 -> 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
 ```
--->
 ### 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.

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
+-- | representation of a Button UI widget    
-data Identified a = Identified
+data Button = Button 
-    { ident :: Id a
+    { label  :: String -- the text label of the button
-    , val :: a
+    , paint  :: IO ()  -- a platform dependent rendering action
-    } deriving (Eq, Ord, Read, Show, Generic, ToJSON, FromJSON)
+    }
 
-class (ToJSON a, FromJSON a, Eq a, Show a) => Entity a where
+-- | rendering a Button for the WIN platform (we just simulate it by printing the label) 
-    -- | store persistent entity of type a to a json file
+winPaint :: String -> IO ()
-    store :: Identified a -> IO ()
+winPaint lbl = putStrLn $ "winButton: " ++ lbl
-    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
+-- | rendering a Button for the OSX platform
-    retrieve :: Id a -> IO (Identified a)
+osxPaint :: String -> IO ()
-    retrieve id = do
+osxPaint lbl = putStrLn $ "osxButton: " ++ lbl
-        -- compute file path based on id
+ 
-        let jsonFileName = getPath id
+-- | enumeration of supported operating system platforms
-        -- parse entity from JSON file
+data OS = OSX | WIN deriving (Show, Eq, Enum)
-        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)
+-- | create a button for os platform with label lbl
-    publish  :: Identified a -> IO ()
+createButton :: OS -> String -> Button
-    publish = print
+createButton os lbl = 
-
+    case os of
-    -- | produce a tagged id
+        WIN -> Button lbl (winPaint lbl)
-    tagId :: Integer -> Id a
+        OSX -> Button lbl (osxPaint lbl)
-    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)
 
 abstractFactoryDemo = do
-    putStrLn "AbstractFactory -> type class polymorphism"
+    putStrLn "AbstractFactory -> functions as data type values"
-    let user = Identified 1 (User "Heinz Meier" "hm@meier.com")
+    let os = WIN
-    let post = Identified 4711 (Post 1 "My name is Heinz, this is my first post")
+    let newButton = createButton os
-    store user
+    let ok = newButton "OK"
-    store post
+    let exit = newButton "Exit"    
-    user' <- retrieve (ident user)
+    paint ok
-    publish user'
+    paint exit
-    retrieve (ident post) >>= publish
+
-    retrieve (tagId (userId (val post)) :: Id User) >>= publish
+    paint $ createButton OSX "about"
+
+    let linuxButton = Button "penguin" (putStrLn "linuxButton: penguin")    
+    paint linuxButton

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

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