write reflection demo

LtuPatternFactory.cabal

@@ -38,6 +38,7 @@ executable LtuPatternFactory
                      , AspectPascal
                      , MiniPascal
                      , HigherOrder
+                     , Reflection
 
   main-is:             Main.hs
   default-language:    Haskell2010
@@ -81,6 +82,7 @@ test-suite LtuPatternFactory-Demo
                     , AspectPascal
                     , MiniPascal
                     , HigherOrder
+                    , Reflection
 
     hs-source-dirs: src
     main-is:        Main.hs

src/JsonPersistence.hs

@@ -1,58 +1,38 @@
-{-# LANGUAGE DeriveAnyClass        #-}
-{-# LANGUAGE DeriveGeneric         #-}
-module JsonPersistence where
-import           Data.Aeson   (FromJSON, ToJSON, eitherDecodeFileStrict,
-                               encodeFile, toJSON)
---import           Data.Tagged
-import           GHC.Generics (Generic)
+{-# LANGUAGE ScopedTypeVariables   #-}
+module JsonPersistence 
+    ( Id
+    , Entity
+    , store
+    , retrieve
+    ) where
+import           Data.Aeson   (FromJSON, ToJSON, eitherDecodeFileStrict, encodeFile, toJSON)
+import           Data.Typeable
 
+-- | Identifier for an Entity
 type Id = String
 
-class (ToJSON a, FromJSON a, Eq a, Show a) => Entity a where
-    -- | store persistent entity of type a and identified by an Id to a json file
+-- | The Entity type class provides generic persistence to JSON files
+class (ToJSON a, FromJSON a, Eq a, Show a, Typeable a) => Entity a where
+
+    -- | store entity of type a and identified by an Id to a json file
     store :: Id -> a -> IO ()
     store id entity = do
-        -- compute file path based on entity id
-        let jsonFileName = getPath id
+        -- compute file path based on concrete type and entity id
+        let jsonFileName = getPath (typeRep ([] :: [a])) id
         -- serialize entity as JSON and write to file
         encodeFile jsonFileName entity
 
-    -- | load persistent entity of type a and identified by id
+    -- | load persistent entity of type a and identified by an Id
     retrieve :: Id -> IO a
     retrieve id = do
-        -- compute file path based on id
-        let jsonFileName = getPath id
+        -- compute file path based on entity type and entity id
+        let jsonFileName = getPath (typeRep ([] :: [a])) 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  :: a -> IO ()
-    publish = print
-
 -- | compute path of data file
-getPath :: Id -> String
-getPath id = ".stack-work/" ++ id ++ ".json"
-
-data User = User {
-      name  :: String
-    , email :: String
-} deriving (Show, Eq, Generic, ToJSON, FromJSON, Entity)
-
-data Post = Post {
-      userId :: Id
-    , text   :: String
-} deriving (Show, Eq, Generic, ToJSON, FromJSON, Entity)
-
-jsonPersistenceDemo = do
-    putStrLn "JsonPersistence"
-    let user = User "Heinz Meier" "hm@meier.com"
-    let post = Post "1" "My name is Heinz, this is my first post"
-    store "1" user
-    store "4711" post
-    user' <- retrieve "1" :: IO User
-    publish user'
-    (retrieve "4711" :: IO Post) >>= publish
-
+getPath :: TypeRep -> String -> String
+getPath tr id = ".stack-work/" ++ show tr ++ "." ++ id ++ ".json"

src/Main.hs

@@ -20,6 +20,7 @@ import           Visitor
 import           MapReduce
 import           MiniPascal
 import           AspectPascal
+import           Reflection
 
 main :: IO ()
 main = do
@@ -35,7 +36,7 @@ main = do
   nullObjectDemo
   iteratorDemo
   abstractFactoryDemo
-  jsonPersistenceDemo
+  reflectionDemo
   demoDI
   interpreterDemo
   infinityDemo

src/Reflection.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE DeriveAnyClass        #-}
+{-# LANGUAGE DeriveGeneric         #-}
+module Reflection where
+
+import           JsonPersistence (Id, Entity, store, retrieve)
+import           Data.Aeson   (FromJSON, ToJSON)
+import           GHC.Generics (Generic)
+
+data User = User {
+      name  :: String
+    , email :: String
+} deriving (Show, Eq, Generic, ToJSON, FromJSON, Entity)
+
+data Post = Post {
+      userId :: Id
+    , text   :: String
+} deriving (Show, Eq, Generic, ToJSON, FromJSON, Entity)
+
+retrieveUser :: Id -> IO User
+retrieveUser = retrieve
+
+retrievePost :: Id -> IO Post
+retrievePost = retrieve
+
+reflectionDemo = do
+    putStrLn "Reflection"
+    let user = User "Heinz Meier" "hm@meier.com"
+    let post = Post "1" "My name is Heinz, this is my first post"
+
+    store "1" user
+    store "4711" post
+
+    user' <- retrieve "1" :: IO User
+    user' <- retrieveUser "1"
+    print user'
+
+    retrievePost "4711" >>= print
+