gidl: interfaces now have cereal instances

src/Gidl/Backend/Haskell/Interface.hs

@@ -8,12 +8,13 @@ import Data.Char (toUpper)
 
 import Gidl.Types
 import Gidl.Interface
+import Gidl.Schema
 import Gidl.Backend.Haskell.Types
 import Ivory.Artifact
 import Text.PrettyPrint.Mainland
 
 interfaceModule :: [String] -> InterfaceRepr -> Artifact
-interfaceModule modulepath ir@(InterfaceRepr iname i) =
+interfaceModule modulepath ir@(InterfaceRepr _ i) =
   artifactPath (intercalate "/" modulepath) $
   artifactText ((ifModuleName ir) ++ ".hs") $
   prettyLazyText 80 $
@@ -22,13 +23,11 @@ interfaceModule modulepath ir@(InterfaceRepr iname i) =
       <+> im (ifModuleName ir)
       <+> text "where"
     , empty
-    , stack [ text "import" <+> im (ifModuleName iir)
-            | iir <- interfaceParents i
-            ]
-    , stack $ map (importDecl tm)
-            $ nub
-            $ map importType
-            $ interfaceTypes ir
+    , stack $ typeimports ++ extraimports
+    , empty
+    , schemaDoc (ifModuleName ir) "Producer" (producerSchema ir)
+    , empty
+    , schemaDoc (ifModuleName ir) "Consumer" (consumerSchema ir)
     ]
   where
   im mname = mconcat $ punctuate dot
@@ -37,6 +36,58 @@ interfaceModule modulepath ir@(InterfaceRepr iname i) =
                      $ map text (typepath modulepath ++ ["Types", mname])
     where typepath = reverse . drop 1 . reverse
 
+  typeimports = map (importDecl tm)
+              $ nub
+              $ map importType
+              $ interfaceTypes ir
+  extraimports = [ text "import Data.Serialize" ]
+
+schemaDoc :: String -> String -> Schema -> Doc
+schemaDoc interfaceName schemaName (Schema [])     =
+    text "-- Cannot define" <+> text schemaName  <+> text "schema for"
+        <+> text interfaceName <+> text "interface: schema is empty"
+schemaDoc interfaceName schemaName (Schema schema) = stack
+    [ text "-- Define" <+> text schemaName  <+> text "schema for"
+        <+> text interfaceName <+> text "interface"
+    , text "data" <+> text typeName
+    , indent 2 $ encloseStack equals deriv (text "|")
+        [ text (constructorName n) <+> text (typeHaskellType t)
+        | (_, (Message n t)) <- schema
+        ]
+    , empty
+    , text ("put" ++ typeName) <+> colon <> colon <+> text "Putter" <+> text typeName
+    , stack
+        [ text ("put" ++ typeName)
+            <+> parens (text (constructorName n) <+> text "m")
+            <+> equals
+            <+> text "put" <> text (cerealSize Bits32) <+> ppr h <+> text ">>"
+            <+> text "put" <+> text "m"
+        | (h, Message n _) <- schema ]
+
+    , text ("get" ++ typeName) <+> colon <> colon <+> text "Get" <+> text typeName
+    , text ("get" ++ typeName) <+> equals <+> text "do"
+    , indent 2 $ stack
+        [ text "a" <+> text "<- get" <> text (cerealSize Bits32)
+        , text "case a of"
+        , indent 2 $ stack $
+            [ ppr h <+> text "-> do" </> (indent 2 (stack
+                [ text "m <- get"
+                , text "return" <+> parens (text (constructorName n) <+> text "m")
+                ]))
+            | (h,Message n _) <- schema
+            ] ++
+            [ text "_ -> fail"
+              <+> dquotes (text "encountered unknown tag in get" <> text typeName)
+            ]
+        ]
+    , empty
+    , serializeInstance typeName
+    ]
+  where
+  constructorName n = userTypeModuleName n ++ schemaName
+  deriv = text "deriving (Eq, Show)"
+  typeName = interfaceName ++ schemaName
+
 ifModuleName :: InterfaceRepr -> String
 ifModuleName (InterfaceRepr iname _) = aux iname
   where
@@ -49,3 +100,5 @@ ifModuleName (InterfaceRepr iname _) = aux iname
   u_to_camel ('_':a:as) = (toUpper a) : u_to_camel as
   u_to_camel (a:as) = a : u_to_camel as
   u_to_camel [] = []
+
+

src/Gidl/Backend/Haskell/Types.hs

@@ -136,7 +136,7 @@ typeDecl tname (EnumType (EnumT s es)) = stack
       [ text ("toEnum _ = error \"toEnum: invalid value for " ++ tname ++ "\"") ] ++
       [ text "fromEnum" <+> text (userTypeModuleName i) <+> equals <+> ppr e
       | (i,e) <- es ]
-  , empty 
+  , empty
   , text ("put" ++ tname) <+> colon <> colon <+> text "Putter" <+> text tname
   , stack
       [ text ("put" ++ tname) <+> text (userTypeModuleName i) <+> equals <+> 
@@ -200,7 +200,7 @@ importDecl _ NoImport = empty
 
 encloseStack :: Doc -> Doc -> Doc -> [Doc] -> Doc
 encloseStack l r p ds = case ds of
-  [] -> l </> r
+  [] -> empty -- l </> r
   [d] -> l <+> d </> r
   _ -> align (l <+> (folddoc (\a b -> a </> p <+> b) ds) </> r)
 

src/Gidl/Interface.hs

@@ -30,15 +30,12 @@ interfaceParents :: Interface i t -> [i]
 interfaceParents (Interface parents _) = parents
 
 interfaceTypes :: InterfaceRepr -> [TypeRepr]
-interfaceTypes ir@(InterfaceRepr iname i) = nub (concatMap aux ms)
+interfaceTypes ir@(InterfaceRepr iname i) = nub (map (methodT . snd) ms)
   where
-  (Interface _ ms) = i
-  aux = typeLeaves
-      . methodT
-      . snd
-  methodT :: Method TypeRepr -> Type TypeRepr
-  methodT (AttrMethod _ (TypeRepr _ t)) = t
-  methodT (StreamMethod _ (TypeRepr _ t)) = t
+  ms = interfaceMethods ir
+  methodT :: Method TypeRepr -> TypeRepr
+  methodT (AttrMethod _ tr) = tr
+  methodT (StreamMethod _ tr) = tr
 
 
 data InterfaceRepr = InterfaceRepr InterfaceName (Interface InterfaceRepr TypeRepr)