Add optional To/FromJSON instances to Types and Interfaces

src/Gidl/Backend/Haskell.hs

@@ -21,11 +21,11 @@ haskellBackend (TypeEnv te) (InterfaceEnv ie) pkgname namespace_raw =
   [ artifactPath "src" m | m <- sourceMods
   ]
   where
-  tmods = [ typeModule (namespace ++ ["Types"]) t
+  tmods = [ typeModule False (namespace ++ ["Types"]) t
           | (_tn, t) <- te
           , isUserDefined t
           ]
-  imods = [ interfaceModule (namespace ++ ["Interface"]) i
+  imods = [ interfaceModule False (namespace ++ ["Interface"]) i
           | (_iname, i) <- ie
           ]
   sourceMods = tmods ++ imods

src/Gidl/Backend/Haskell/Interface.hs

@@ -13,13 +13,14 @@ import Gidl.Backend.Haskell.Types
 import Ivory.Artifact
 import Text.PrettyPrint.Mainland
 
-interfaceModule :: [String] -> Interface -> Artifact
-interfaceModule modulepath i =
+interfaceModule :: Bool -> [String] -> Interface -> Artifact
+interfaceModule useAeson modulepath i =
   artifactPath (intercalate "/" modulepath) $
   artifactText ((ifModuleName i) ++ ".hs") $
   prettyLazyText 80 $
-  stack
+  stack $
     [ text "{-# LANGUAGE DeriveDataTypeable #-}"
+    , text "{-# LANGUAGE DeriveGeneric #-}"
     , empty
     , text "module"
       <+> im (ifModuleName i)
@@ -27,9 +28,10 @@ interfaceModule modulepath i =
     , empty
     , stack $ typeimports ++ extraimports
     , empty
-    , schemaDoc (ifModuleName i) (producerSchema i)
+    , schemaDoc useAeson (ifModuleName i) (producerSchema i)
+    , empty
+    , schemaDoc useAeson (ifModuleName i) (consumerSchema i)
     , empty
-    , schemaDoc (ifModuleName i) (consumerSchema i)
     ]
   where
   im mname = mconcat $ punctuate dot
@@ -45,13 +47,16 @@ interfaceModule modulepath i =
   extraimports = [ text "import Data.Serialize"
                  , text "import Data.Typeable"
                  , text "import Data.Data"
-                 , text "import qualified Test.QuickCheck as Q" ]
+                 , text "import GHC.Generics (Generic)"
+                 , text "import qualified Test.QuickCheck as Q"
+                 ] ++
+                 [ text "import Data.Aeson (ToJSON,FromJSON)" | useAeson ]
 
-schemaDoc :: String -> Schema -> Doc
-schemaDoc interfaceName (Schema schemaName [])     =
+schemaDoc :: Bool -> String -> Schema -> Doc
+schemaDoc _ interfaceName (Schema schemaName [])     =
     text "-- Cannot define" <+> text schemaName  <+> text "schema for"
         <+> text interfaceName <+> text "interface: schema is empty"
-schemaDoc interfaceName (Schema schemaName schema) = stack
+schemaDoc useAeson interfaceName (Schema schemaName schema) = stack $
     [ text "-- Define" <+> text schemaName  <+> text "schema for"
         <+> text interfaceName <+> text "interface"
     , text "data" <+> text typeName
@@ -99,10 +104,13 @@ schemaDoc interfaceName (Schema schemaName schema) = stack
         ]
     , empty
     , arbitraryInstance typeName
-    ]
+    , empty
+    ] ++
+    [ toJSONInstance   typeName | useAeson ] ++
+    [ fromJSONInstance typeName | useAeson ]
   where
   constructorName n = userTypeModuleName n ++ schemaName
-  deriv = text "deriving (Eq, Show, Data, Typeable)"
+  deriv = text "deriving (Eq, Show, Data, Typeable, Generic)"
   typeName = interfaceName ++ schemaName
 
 ifModuleName :: Interface -> String

src/Gidl/Backend/Haskell/Types.hs

@@ -10,28 +10,33 @@ import Text.PrettyPrint.Mainland
 
 -- invariant: only make a typeModule from a StructType, NewtypeType, or EnumType
 -- i.e. when isUserDefined is true.
-typeModule :: [String] -> Type -> Artifact
-typeModule modulepath t =
+typeModule :: Bool -> [String] -> Type -> Artifact
+typeModule useAeson modulepath t =
   artifactPath (intercalate "/" modulepath) $
   artifactText ((typeModuleName t) ++ ".hs") $
   prettyLazyText 80 $
-  stack
+  stack $
     [ text "{-# LANGUAGE RecordWildCards #-}"
     , text "{-# LANGUAGE DeriveDataTypeable #-}"
+    , text "{-# LANGUAGE DeriveGeneric #-}"
     , empty
     , text "module"
       <+> tm (typeModuleName t)
       <+> text "where"
     , empty
     , stack (imports ++
+              [ text "import Data.Aeson (ToJSON,FromJSON)" | useAeson ] ++
               [ text "import Data.Serialize"
               , text "import Data.Typeable"
               , text "import Data.Data"
+              , text "import GHC.Generics (Generic)"
               , text "import qualified Test.QuickCheck as Q"
               ])
     , empty
     , typeDecl t
-    ]
+    ] ++
+    [ toJSONInstance   (typeModuleName t) | useAeson ] ++
+    [ fromJSONInstance (typeModuleName t) | useAeson ]
   where
   imports = map (importDecl tm)
           $ nub
@@ -93,6 +98,18 @@ arbitraryInstance tname = stack
       ]
   ]
 
+-- | Produce a ToJSON instance.
+--
+-- NOTE: this instance relies on a GHC that supports Generics.
+toJSONInstance :: TypeName -> Doc
+toJSONInstance tname = nest 2 (text "instance ToJSON" <+> text tname)
+
+-- | Produce a FromJSON instance.
+--
+-- NOTE: this instance relies on a GHC that supports Generics.
+fromJSONInstance :: TypeName -> Doc
+fromJSONInstance tname = nest 2 (text "instance FromJSON" <+> text tname)
+
 typeDecl :: Type -> Doc
 typeDecl t@(StructType _ ss) = stack
   [ text "data" <+> text tname <+> equals
@@ -127,14 +144,14 @@ typeDecl t@(StructType _ ss) = stack
   ]
   where
   tname = typeModuleName t
-  deriv = typeDeriving ["Eq", "Show", "Data", "Typeable"]
+  deriv = typeDeriving ["Eq", "Show", "Data", "Typeable", "Generic"]
 
 typeDecl t@(PrimType (Newtype _ n)) = stack
   [ text "newtype" <+> text tname <+> equals
   , indent 2 $ text tname <+> align
         (lbrace <+> text ("un" ++ tname) <+> text "::" <+>
          text (typeHaskellType (PrimType n)) </>
-         rbrace <+> typeDeriving ["Eq", "Show", "Data", "Typeable"])
+         rbrace <+> typeDeriving ["Eq", "Show", "Data", "Typeable", "Generic"])
   , empty
   , text ("put" ++ tname) <+> colon <> colon <+> text "Putter" <+> text tname
   , text ("put" ++ tname) <+> parens (text tname <+> text "a") <+> equals
@@ -200,7 +217,7 @@ typeDecl t@(PrimType (EnumType _ s es)) = stack
   , arbitraryInstance tname
   ]
   where
-  deriv = typeDeriving ["Eq", "Show", "Ord", "Data", "Typeable"]
+  deriv = typeDeriving ["Eq", "Show", "Ord", "Data", "Typeable", "Generic"]
   tname = typeModuleName t
 
 typeDecl t = error ("typeDecl: cannot create Haskell decl for type " ++ show t)

src/Gidl/Backend/Rpc.hs

@@ -8,7 +8,8 @@ import Gidl.Backend.Cabal
            (cabalFileArtifact,CabalFile(..),defaultCabalFile,filePathToPackage)
 import Gidl.Backend.Haskell.Interface (interfaceModule,ifModuleName)
 import Gidl.Backend.Haskell.Types (typeModule,isUserDefined,typeModuleName)
-import Gidl.Interface (Interface(..),InterfaceEnv(..),MethodName,Method(..))
+import Gidl.Interface
+           (Interface(..),InterfaceEnv(..),MethodName,Method(..),Perm(..))
 import Gidl.Types (Type,TypeEnv(..))
 
 import Data.Char (isSpace)
@@ -36,18 +37,18 @@ rpcBackend typeEnv@(TypeEnv te) ifaceEnv@(InterfaceEnv ie) pkgName nsStr =
   namespace  = strToNs nsStr
 
   buildDeps  = [ "cereal", "QuickCheck", "snap-core", "snap-server", "stm"
-               , "bytestring" ]
+               , "bytestring", "aeson" ]
 
   modules    = [ filePathToPackage (artifactFileName m) | m <- sourceMods ]
 
   sourceMods = tmods ++ imods
 
-  tmods      = [ typeModule (namespace ++ ["Types"]) t
+  tmods      = [ typeModule True (namespace ++ ["Types"]) t
                | (_tn, t) <- te
                , isUserDefined t
                ]
 
-  imods      = concat [ [ interfaceModule (namespace ++ ["Interface"]) i
+  imods      = concat [ [ interfaceModule True (namespace ++ ["Interface"]) i
                         , rpcModule typeEnv namespace i ]
                       | (_iname, i) <- ie
                       ]
@@ -180,21 +181,36 @@ runServerDef typeEnv iface = hang 2 (text "rpcServer" <+> body)
     nest 2 (text "manager" <+> char '=' <+/> align (text "..."))
 
 
-
-
 -- | Define one route for each interface member
 routes :: TypeEnv -> Interface -> Doc
-routes typeEnv iface =
+routes types iface =
   text "route" <+> methods
 
   where
 
-  methods =
-    align (char '[' <> stack (punctuate comma (map mkRoute (allMethods iface)))
-                    <> char ']')
+  methods = align (char '['
+         <> stack (punctuate comma (concatMap (mkRoute types) (allMethods iface)))
+         <> char ']')
+
+mkRoute :: TypeEnv -> (MethodName,Method) -> [Doc]
+mkRoute types (name,method) =
+  [ tuple [ text (show name), h ] | h <- handlersFor method ]
+  where
+  handlersFor (StreamMethod _  ty) = [ readMethod types ty ]
+  handlersFor (AttrMethod perm ty) = [ m types ty | m <- permMethods perm ]
+
+
+permMethods :: Perm -> [ TypeEnv -> Type -> Doc ]
+permMethods Read      = [ readMethod              ]
+permMethods Write     = [ writeMethod             ]
+permMethods ReadWrite = [ readMethod, writeMethod ]
+
+
+readMethod :: TypeEnv -> Type -> Doc
+readMethod types _ = text "writeBS \"read\""
 
-  mkRoute (name,method) =
-    tuple [ text (show name), text "writeBS \"foo\"" ]
+writeMethod :: TypeEnv -> Type -> Doc
+writeMethod types _ = text "writeBS \"write\""
 
 
 -- Pretty-printing Helpers -----------------------------------------------------