gidl: structs may contain structs

README.md

@@ -26,7 +26,7 @@ the following primitives:
     - Wraps an existing atomic or enum type with a new type
 - User-defined Structures:
     - Set of named fields. Corresponds to a record or a C struct.
-    - All fields are atomic, enum, or newtypes.
+    - Fields may be of any other user-defined type
 
 ### Interfaces
 

src/Gidl/Backend/Haskell/Types.hs

@@ -40,7 +40,7 @@ typeModule useAeson modulepath t =
   where
   imports = map (importDecl tm)
           $ nub
-          $ map (importType . PrimType)
+          $ map importType
           $ typeLeaves t
   tm mname = mconcat $ punctuate dot
                      $ map text (modulepath ++ [mname])
@@ -115,19 +115,19 @@ typeDecl t@(StructType _ ss) = stack
   [ text "data" <+> text tname <+> equals
   , indent 2 $ text tname
   , indent 4 $ encloseStack lbrace (rbrace <+> deriv) comma
-      [ text i <+> colon <> colon <+> text (typeHaskellType (PrimType st))
+      [ text i <+> colon <> colon <+> text (typeHaskellType st)
       | (i,st) <- ss ]
   , empty
   , text ("put" ++ tname) <+> colon <> colon <+> text "Putter" <+> text tname
   , text ("put" ++ tname) <+> text tname <> text "{..}" <+> equals <+> text "do"
   , indent 2 $ stack
-      [ primTypePutter st <+> text i
+      [ typePutter st <+> text i
       | (i,st) <- ss ]
   , empty
   , text ("get" ++ tname) <+> colon <> colon <+> text "Get" <+> text tname
   , text ("get" ++ tname) <+> equals <+> text "do"
   , indent 2 $ stack $
-      [ text i <+> text "<-" <+> primTypeGetter st
+      [ text i <+> text "<-" <+> typeGetter st
       | (i,st) <- ss ] ++
       [ text "return" <+> text tname <> text "{..}" ]
   , empty
@@ -222,6 +222,10 @@ typeDecl t@(PrimType (EnumType _ s es)) = stack
 
 typeDecl t = error ("typeDecl: cannot create Haskell decl for type " ++ show t)
 
+typePutter :: Type -> Doc
+typePutter (PrimType p) = primTypePutter p
+typePutter struct = text "put" <> text (typeModuleName struct)
+
 primTypePutter :: PrimType -> Doc
 primTypePutter (Newtype tn _) = text "put" <> text (userTypeModuleName tn)
 primTypePutter (EnumType tn _ _) = text "put" <> text (userTypeModuleName tn)
@@ -234,6 +238,11 @@ primTypePutter (AtomType AtomFloat) = text "putFloat32be"
 primTypePutter (AtomType AtomDouble) = text "putFloat64be"
 primTypePutter VoidType = text "put"
 
+
+typeGetter :: Type -> Doc
+typeGetter (PrimType p) = primTypeGetter p
+typeGetter struct = text "get" <> text (typeModuleName struct)
+
 primTypeGetter :: PrimType -> Doc
 primTypeGetter (Newtype tn _) = text "get" <> text (userTypeModuleName tn)
 primTypeGetter (EnumType tn _ _) = text "get" <> text (userTypeModuleName tn)

src/Gidl/Backend/Ivory/Schema.hs

@@ -140,12 +140,6 @@ schemaDoc interfaceName (Schema schemaName schema) = stack
   accessorName n = userEnumValueName n ++ schemaName
   typeName = interfaceName ++ schemaName
 
-typeIvoryArea :: Type -> Doc
-typeIvoryArea t@(StructType _ _) = parens (text (typeIvoryType t))
-typeIvoryArea   (PrimType VoidType) = error "should not take typeIvoryArea of VoidType"
-typeIvoryArea t@(PrimType (AtomType _)) = parens (text "Stored" <+> text (typeIvoryType t))
-typeIvoryArea t@(PrimType _) = parens (text "Stored" <+> text (typeIvoryType t) <> dot <> text (typeIvoryType t))
-
 parserName :: String -> String
 parserName tn = userEnumValueName tn ++ "Parser"
 senderName :: String -> String

src/Gidl/Backend/Ivory/Types.hs

@@ -60,7 +60,7 @@ typeModule modulepath t =
   where
   imports = map (importDecl (typeModulePath modulepath))
           $ nub
-          $ map (importType . PrimType)
+          $ map importType
           $ typeLeaves t
 
 typeModulePath :: [String] -> String -> Doc
@@ -74,6 +74,16 @@ typeImportedIvoryType t@(PrimType (EnumType tn _ _)) =
   userTypeModuleName tn ++ "." ++ typeIvoryType t
 typeImportedIvoryType t = typeIvoryType t
 
+typeIvoryArea :: Type -> Doc
+typeIvoryArea t@(StructType _ _) = parens (text (typeIvoryType t))
+typeIvoryArea   (PrimType VoidType) = error "should not take typeIvoryArea of VoidType"
+typeIvoryArea t@(PrimType (AtomType _)) = parens (text "Stored" <+> text (typeIvoryType t))
+typeIvoryArea t@(PrimType _) = parens (text "Stored" <+> text (typeIvoryType t) <> dot <> text (typeIvoryType t))
+
+typeIvoryAreaStructQQ :: Type -> Doc
+typeIvoryAreaStructQQ (StructType n _) = text "Struct" <+> text (userTypeStructName n)
+typeIvoryAreaStructQQ t = typeIvoryArea t
+
 typeIvoryType :: Type -> String
 typeIvoryType (StructType tn _) = "Struct \"" ++ userTypeStructName tn ++ "\""
 typeIvoryType (PrimType (Newtype tn _)) = userTypeModuleName tn
@@ -139,7 +149,7 @@ typeDecl t@(StructType tname ss) = stack
   , text "struct" <+> structname
   , indent 2 $ encloseStack lbrace rbrace semi
       [ text i <+> colon <> colon
-       <+> text "Stored" <+> text (typeImportedIvoryType (PrimType st))
+       <+> typeIvoryAreaStructQQ st
       | (i,st) <- ss ]
   , text "|]"
   , empty
@@ -162,7 +172,7 @@ typeDecl t@(StructType tname ss) = stack
       , text "wrappedPackMod" <+> packRep
       ] ++
       [ text "depend" <+> text (qualifiedIvoryPackageName dt)
-      | dt <- fmap PrimType (typeLeaves t)
+      | dt <- typeLeaves t
       , isUserDefined dt
       ]
 
@@ -197,7 +207,7 @@ typeDecl t@(PrimType (Newtype tname n)) = stack
       , text "wrappedPackMod" <+> packRep
       ] ++
       [ text "depend" <+> text (qualifiedIvoryPackageName dt)
-      | dt <- fmap PrimType (typeLeaves t)
+      | dt <- typeLeaves t
       , isUserDefined dt
       ]
   ]

src/Gidl/Backend/Tower/Schema.hs

@@ -9,8 +9,7 @@ import Gidl.Types
 import Gidl.Interface
 import Gidl.Schema
 import Gidl.Backend.Ivory.Types
-import Gidl.Backend.Ivory.Schema ( ifModuleName, parserName, senderName
-                                 , typeIvoryArea)
+import Gidl.Backend.Ivory.Schema (ifModuleName, parserName, senderName)
 import Ivory.Artifact
 import Text.PrettyPrint.Mainland
 

src/Gidl/Backend/Tower/Server.hs

@@ -8,7 +8,7 @@ import Data.List (intercalate, nub)
 import Gidl.Interface
 import Gidl.Schema
 import Gidl.Backend.Ivory.Types
-import Gidl.Backend.Ivory.Schema (ifModuleName, typeIvoryArea)
+import Gidl.Backend.Ivory.Schema (ifModuleName)
 import Ivory.Artifact
 import Text.PrettyPrint.Mainland
 

src/Gidl/Parse.hs

@@ -104,7 +104,7 @@ toEnv decls = do
                   ++ "' repeated in declaration of 'Enum " ++ n ++ "'")
           return (n, PrimType (EnumType n s ts))
         toType (StructDecl n ss) = local (n:) $ do
-          ps <- mapM (getPrimType . snd) ss
+          ps <- mapM (getType . snd) ss
           return (n, StructType n (zip (map fst ss) ps))
         toType _ = error "[unreachable]"
 

src/Gidl/Types.hs

@@ -27,14 +27,14 @@ insertType tn t e@(TypeEnv te) = case lookupTypeName tn e of
   Nothing -> TypeEnv ((tn,t):te)
   Just _ -> error ("insertType invariant broken: type " ++ tn ++ " already exists")
 
-typeLeaves :: Type -> [PrimType]
+typeLeaves :: Type -> [Type]
 typeLeaves (StructType _ s) = nub (map snd s)
-typeLeaves (PrimType (Newtype _ tn)) = [tn]
+typeLeaves (PrimType (Newtype _ tn)) = [PrimType tn]
 typeLeaves _ = []
 
 
 sizeOf :: Type -> Integer
-sizeOf (StructType _ s) = sum [ sizeOf (PrimType tr) | (_, tr) <- s ]
+sizeOf (StructType _ s) = sum [ sizeOf tr | (_, tr) <- s ]
 sizeOf (PrimType (Newtype _ tr)) = sizeOf (PrimType tr)
 sizeOf (PrimType (EnumType _ bs _)) = bitsSize bs
 sizeOf (PrimType (AtomType (AtomInt bs))) = bitsSize bs

src/Gidl/Types/AST.hs

@@ -11,7 +11,7 @@ emptyTypeEnv :: TypeEnv
 emptyTypeEnv = TypeEnv []
 
 data Type
-  = StructType String [(Identifier, PrimType)]
+  = StructType String [(Identifier, Type)]
   | PrimType PrimType
   deriving (Eq, Show)
 

tests/example.idl

@@ -46,12 +46,9 @@
 (def-newtype lon_t sint32_t)
 (def-newtype meters_t float_t)
 
+-- Structures may contain structures.
 (def-struct timed_coord_t
-  (lat lat_t)
-  (lon lon_t)
-  (alt meters_t)
+  (coord coordinate_t)
   (time time_micros_t))
 
 -------------------------------------------------------------------------------