ivory backend: wip

- we have some issues with ivory structs to work out -they cannot
be nested, for example, and newtypes over structs don't work either
so i'm going to change the gidl model rather than try to fit just a subset

Makefile

@@ -27,6 +27,7 @@ haskell-backend-test-clean:
 
 ivory-backend-test:
 	cabal run gidl -- -b ivory \
+		--debug \
 		-i tests/example.idl \
 		-o tests/gidl-ivory-backend-test \
 		-p gidl-ivory-backend-test \

src/Gidl.hs

@@ -5,6 +5,7 @@ module Gidl
 import Data.Char
 import Data.Monoid
 import Data.Maybe (catMaybes)
+import Control.Monad
 import System.Console.GetOpt
 import System.Environment
 import System.Exit
@@ -44,6 +45,7 @@ data Opts = Opts
   , outpath :: FilePath
   , packagename :: String
   , namespace :: String
+  , debug :: Bool
   , help :: Bool
   }
 
@@ -54,6 +56,7 @@ initialOpts = Opts
   , outpath     = error (usage ["must specify an output path"])
   , packagename = error (usage ["must specify a package name"])
   , namespace   = ""
+  , debug       = False
   , help        = False
   }
 
@@ -76,6 +79,9 @@ setPackageName p = success (\o -> o { packagename = p })
 setNamespace :: String -> OptParser Opts
 setNamespace p = success (\o -> o { namespace = p })
 
+setDebug :: OptParser Opts
+setDebug = success (\o -> o { debug = True })
+
 setHelp :: OptParser Opts
 setHelp = success (\o -> o { help = True })
 
@@ -91,6 +97,8 @@ options =
       "package name for output"
   , Option "n" ["namespace"] (ReqArg setNamespace "NAME")
       "namespace for output"
+  , Option ""  ["debug"]     (NoArg setDebug)
+      "enable debugging output"
   , Option "h" ["help"]      (NoArg setHelp)
       "display this message and exit"
   ]
@@ -125,6 +133,7 @@ run = do
   where
   artifactBackend :: Opts -> [Artifact] -> IO ()
   artifactBackend opts as = do
+    when (debug opts) $ mapM_ printArtifact as
     es <- mapM (putArtifact (outpath opts)) as
     case catMaybes es of
       [] -> exitSuccess

src/Gidl/Backend/Ivory.hs

@@ -24,7 +24,8 @@ ivoryBackend te@(TypeEnv te') ie@(InterfaceEnv ie') pkgname namespace_raw =
           , let tr = typeDescrToRepr tn te
           , isUserDefined tr
           ]
-  imods = [ interfaceModule (namespace ++ ["Interface"]) ir
+  imods = [] -- DISABLE UNTIL WE GET TYPES RIGHT
+  _imods =[ interfaceModule (namespace ++ ["Interface"]) ir
           | (iname, _i) <- ie'
           , let ir = interfaceDescrToRepr iname ie te
           ]

src/Gidl/Backend/Ivory/Interface.hs

@@ -56,49 +56,9 @@ schemaDoc interfaceName (Schema schemaName schema) = stack
         <+> text interfaceName <+> text "interface"
     , text "data" <+> text typeName
     , indent 2 $ encloseStack equals deriv (text "|")
-        [ text (constructorName n) <+> text (typeHaskellType t)
+        [ text (constructorName n) <+> text (typeIvoryType 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 ]
-    , empty
-    , 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
-    , empty
-    , text ("arbitrary" ++ typeName) <+> colon <> colon <+> text "Q.Gen" <+> text typeName
-    , text ("arbitrary" ++ typeName) <+> equals
-    , indent 2 $ text "Q.oneof" <+> encloseStack lbracket rbracket comma
-        [ text "do" </> (indent 4 (stack
-           [ text "a <- Q.arbitrary"
-           , text "return" <+> parens (text (constructorName n) <+> text "a")
-           ]))
-        | (_, Message n _) <- schema
-        ]
-    , empty
-    , arbitraryInstance typeName
     ]
   where
   constructorName n = userTypeModuleName n ++ schemaName

src/Gidl/Backend/Ivory/Types.hs

@@ -3,7 +3,7 @@ module Gidl.Backend.Ivory.Types where
 
 import Data.Monoid
 import Data.List (intercalate, nub)
-import Data.Char (toUpper)
+import Data.Char (toUpper, toLower)
 import Gidl.Types
 import Ivory.Artifact
 import Text.PrettyPrint.Mainland
@@ -16,18 +16,20 @@ typeModule modulepath tr@(TypeRepr _ td) =
   artifactText ((typeModuleName tr) ++ ".hs") $
   prettyLazyText 80 $
   stack
-    [ text "{-# LANGUAGE RecordWildCards #-}"
-    , text "{-# LANGUAGE DeriveDataTypeable #-}"
+    [ text "{-# LANGUAGE DataKinds #-}"
+    , text "{-# LANGUAGE TypeOperators #-}"
+    , text "{-# LANGUAGE QuasiQuotes #-}"
+    , text "{-# LANGUAGE GeneralizedNewtypeDeriving #-}"
+    , text "{-# LANGUAGE FlexibleInstances #-}"
+    , text "{-# OPTIONS_GHC -fno-warn-orphans #-}"
     , empty
     , text "module"
       <+> tm (typeModuleName tr)
       <+> text "where"
     , empty
     , stack (imports ++
-              [ text "import Data.Serialize"
-              , text "import Data.Typeable"
-              , text "import Data.Data"
-              , text "import qualified Test.QuickCheck as Q"
+              [ text "import Ivory.Language"
+              , text "import Ivory.Serialize"
               ])
     , empty
     , typeDecl typename td
@@ -41,22 +43,22 @@ typeModule modulepath tr@(TypeRepr _ td) =
   tm mname = mconcat $ punctuate dot
                      $ map text (modulepath ++ [mname])
 
-typeHaskellType :: TypeRepr -> String
-typeHaskellType (TypeRepr tn (StructType _)) = userTypeModuleName tn
-typeHaskellType (TypeRepr tn (NewtypeType _)) = userTypeModuleName tn
-typeHaskellType (TypeRepr tn (EnumType _)) = userTypeModuleName tn
-typeHaskellType (TypeRepr _ (AtomType a)) = case a of
-  AtomInt Bits8  -> "Int8"
-  AtomInt Bits16 -> "Int16"
-  AtomInt Bits32 -> "Int32"
-  AtomInt Bits64 -> "Int64"
-  AtomWord Bits8  -> "Word8"
-  AtomWord Bits16 -> "Word16"
-  AtomWord Bits32 -> "Word32"
-  AtomWord Bits64 -> "Word64"
-  AtomFloat -> "Float"
-  AtomDouble -> "Double"
-typeHaskellType (TypeRepr _ VoidType) = "()"
+typeIvoryType :: TypeRepr -> String
+typeIvoryType (TypeRepr tn (StructType _)) = "Struct \"" ++ userTypeStructName tn ++ "\""
+typeIvoryType (TypeRepr tn (NewtypeType _)) = userTypeModuleName tn
+typeIvoryType (TypeRepr tn (EnumType _)) = userTypeModuleName tn
+typeIvoryType (TypeRepr _ (AtomType a)) = case a of
+  AtomInt Bits8  -> "Sint8"
+  AtomInt Bits16 -> "Sint16"
+  AtomInt Bits32 -> "Sint32"
+  AtomInt Bits64 -> "Sint64"
+  AtomWord Bits8  -> "Uint8"
+  AtomWord Bits16 -> "Uint16"
+  AtomWord Bits32 -> "Uint32"
+  AtomWord Bits64 -> "Uint64"
+  AtomFloat -> "IFloat"
+  AtomDouble -> "IDouble"
+typeIvoryType (TypeRepr _ VoidType) = "()" -- XXX this is gonna cause trouble buddy
 
 typeModuleName :: TypeRepr -> String
 typeModuleName (TypeRepr tn (StructType _)) = userTypeModuleName tn
@@ -66,144 +68,91 @@ typeModuleName (TypeRepr _ (AtomType _)) = error "do not take typeModuleName of
 typeModuleName (TypeRepr _ VoidType) = error "do not take typeModuleName of a VoidType"
 
 userTypeModuleName :: String -> String
-userTypeModuleName = first_cap . u_to_camel
+userTypeModuleName = first_cap . userEnumValueName
   where
   first_cap (s:ss) = (toUpper s) : ss
   first_cap []     = []
+
+userEnumValueName :: String -> String
+userEnumValueName = first_lower . u_to_camel
+  where
+  first_lower (s:ss) = (toLower s) : ss
+  first_lower []     = []
   u_to_camel ('_':'t':[]) = []
   u_to_camel ('_':[]) = []
   u_to_camel ('_':a:as) = (toUpper a) : u_to_camel as
   u_to_camel (a:as) = a : u_to_camel as
   u_to_camel [] = []
 
-serializeInstance :: TypeName -> Doc
-serializeInstance tname = stack
-  [ text "instance Serialize" <+> text tname <+> text "where"
-  , indent 2 $ stack
-      [ text "put" <+> equals <+> text ("put" ++ tname)
-      , text "get" <+> equals <+> text ("get" ++ tname)
-      ]
-  ]
-
-arbitraryInstance :: TypeName -> Doc
-arbitraryInstance tname = stack
-  [ text "instance Q.Arbitrary" <+> text tname <+> text "where"
-  , indent 2 $ stack
-      [ text "arbitrary" <+> equals <+> text ("arbitrary" ++ tname)
-      ]
-  ]
+userTypeStructName :: String -> String
+userTypeStructName = first_lower . drop_t_suffix
+  where
+  first_lower (s:ss) = (toLower s) : ss
+  first_lower []     = []
+  drop_t_suffix []     = []
+  drop_t_suffix ('_':'t':[]) = []
+  drop_t_suffix (a:as) = a : drop_t_suffix as
 
 typeDecl :: TypeName -> Type TypeRepr -> Doc
-typeDecl tname (StructType (Struct ss)) = stack
-  [ text "data" <+> text tname <+> equals
-  , indent 2 $ text tname
-  , indent 4 $ encloseStack lbrace (rbrace <+> deriv) comma
-      [ text i <+> colon <> colon <+> text (typeHaskellType t)
+typeDecl tname td@(StructType (Struct ss)) = stack
+  [ text "[ivory|"
+  , text "struct" <+> structname
+  , indent 2 $ encloseStack lbrace rbrace semi
+      [ text i <+> colon <> colon <+> text "Stored" <+> text (typeIvoryType t) -- XXX AREA TYPE
       | (i,t) <- ss ]
+  , text "|]"
   , empty
-  , text ("put" ++ tname) <+> colon <> colon <+> text "Putter" <+> text tname
-  , text ("put" ++ tname) <+> text tname <> text "{..}" <+> equals <+> text "do"
+  , text (userEnumValueName tname) <> text "TypesModule :: Module"
+  , text (userEnumValueName tname) <> text "TypesModule" <+> equals
+    <+> text "package" <+> dquotes (structname <> text "_types") <+> text "$ do"
   , indent 2 $ stack
-      [ text "put" <+> text i
-      | (i,_) <- ss ]
-  , empty
-  , text ("get" ++ tname) <+> colon <> colon <+> text "Get" <+> text tname
-  , text ("get" ++ tname) <+> equals <+> text "do"
-  , indent 2 $ stack $
-      [ text i <+> text "<- get"
-      | (i,_) <- ss ] ++
-      [ text "return" <+> text tname <> text "{..}" ]
-  , empty
-  , serializeInstance tname
-  , empty
-  , text ("arbitrary" ++ tname) <+> colon <> colon <+> text "Q.Gen" <+> text tname
-  , text ("arbitrary" ++ tname) <+> equals <+> text "do"
-  , indent 2 $ stack $
-      [ text i <+> text "<- Q.arbitrary"
-      | (i,_) <- ss ] ++
-      [ text "return" <+> text tname <> text "{..}" ]
-  , empty
-  , arbitraryInstance tname
+      [ text "defStruct"
+        <+> parens (text "Proxy :: Proxy" <+> dquotes structname)
+      , text "depend serializeModule"
+      , stack is
+      ]
+
   ]
-  where deriv = typeDeriving ["Eq", "Show", "Data", "Typeable"]
+  where
+  is = map userIModDependency $ nub $ typeLeaves td
+  structname = text (userTypeStructName tname)
+
+typeDecl tname (NewtypeType (Newtype n)) =
+  case baseType n of
+    TypeRepr _ (StructType _) -> stack
+      [ text "type" <+> text tname <+> equals <+> text (typeIvoryType (baseType n)) ]
+    _ -> stack
+      [ text "newtype" <+> text tname <+> equals
+      , indent 2 $ text tname <+> align
+            (lbrace <+> text ("un" ++ tname) <+> text "::" <+>
+             text (typeIvoryType n) </>
+             rbrace <+> typeDeriving (words "IvoryType IvoryVar IvoryExpr IvoryEq IvoryStore IvoryInit IvoryZeroVal"))
+      ]
 
-typeDecl tname (NewtypeType (Newtype n)) = stack
+typeDecl tname (EnumType (EnumT s es)) = stack
   [ text "newtype" <+> text tname <+> equals
   , indent 2 $ text tname <+> align
         (lbrace <+> text ("un" ++ tname) <+> text "::" <+>
-         text (typeHaskellType n) </>
-         rbrace <+> typeDeriving ["Eq", "Show", "Data", "Typeable"])
+         text bt </>
+         rbrace <+> typeDeriving (words "IvoryType IvoryVar IvoryExpr IvoryEq IvoryStore IvoryInit IvoryZeroVal"))
   , empty
-  , text ("put" ++ tname) <+> colon <> colon <+> text "Putter" <+> text tname
-  , text ("put" ++ tname) <+> parens (text tname <+> text "a") <+> equals <+> text "put a"
-  , empty
-  , text ("get" ++ tname) <+> colon <> colon <+> text "Get" <+> text tname
-  , text ("get" ++ tname) <+> equals <+> text "do"
-  , indent 2 $ stack $
-      [ text "a" <+> text "<- get"
-      , text "return" <+> parens (text tname <+> text "a") ]
-  , empty
-  , serializeInstance tname
-  , text ("arbitrary" ++ tname) <+> colon <> colon <+> text "Q.Gen" <+> text tname
-  , text ("arbitrary" ++ tname) <+> equals <+> text "do"
-  , indent 2 $ stack $
-      [ text "a" <+> text "<- Q.arbitrary"
-      , text "return" <+> parens (text tname <+> text "a") ]
-  , empty
-  , arbitraryInstance tname
-  ]
-
-typeDecl tname (EnumType (EnumT s es)) = stack
-  [ text "data" <+> text tname
-  , indent 2 $ encloseStack equals deriv (text "|")
-      [ text (userTypeModuleName i)
-      | (i, _) <- es ]
-  , empty
-  , text "instance Enum" <+> text tname <+> text "where"
-  , indent 2 $ stack $
-      [ text "toEnum" <+> ppr e <+> equals <+> text (userTypeModuleName i)
-      | (i,e) <- es ] ++
-      [ text ("toEnum _ = error \"toEnum: invalid value for " ++ tname ++ "\"") ] ++
-      [ text "fromEnum" <+> text (userTypeModuleName i) <+> equals <+> ppr e
-      | (i,e) <- es ]
-  , empty
-  , text ("put" ++ tname) <+> colon <> colon <+> text "Putter" <+> text tname
   , stack
-      [ text ("put" ++ tname) <+> text (userTypeModuleName i) <+> equals <+> 
-          text "put" <> text (cerealSize s) <+> ppr e
+      [ stack
+        [ empty
+        , text (userEnumValueName i) <+> colon <> colon <+> text tname
+        , text (userEnumValueName i) <+> equals <+> text tname <+> ppr e
+        ]
       | (i,e) <- es ]
-  , empty
-  , text ("get" ++ tname) <+> colon <> colon <+> text "Get" <+> text tname
-  , text ("get" ++ tname) <+> equals <+> text "do"
-  , indent 2 $ stack
-      [ text "a" <+> text "<- get" <> text (cerealSize s)
-      , text "case a of"
-      , indent 2 $ stack $
-          [ ppr e <+> text "-> return" <+> text (userTypeModuleName i)
-          | (i,e) <- es
-          ] ++ [text "_ -> fail \"invalid value in get"  <> text tname <> text"\"" ]
-      ]
-  , empty
-  , serializeInstance tname
-  , empty
-  , text ("arbitrary" ++ tname) <+> colon <> colon <+> text "Q.Gen" <+> text tname
-  , text ("arbitrary" ++ tname) <+> equals
-  , indent 2 $ text "Q.elements" <+> encloseStack lbracket rbracket comma
-                                      [ text (userTypeModuleName i) | (i,_e) <- es ]
-  , empty
-  , arbitraryInstance tname
   ]
-  where deriv = typeDeriving ["Eq", "Show", "Ord", "Data", "Typeable"]
+  where
+  bt = case s of
+    Bits8 -> "Uint8"
+    Bits16 -> "Uint16"
+    Bits32 -> "Uint32"
+    Bits64 -> "Uint64"
 
 typeDecl tn _ = error ("typeDecl: cannot create decl for built in type " ++ tn)
 
-cerealSize :: Bits -> String
-cerealSize Bits8  = "Word8"
-cerealSize Bits16 = "Word16be"
-cerealSize Bits32 = "Word32be"
-cerealSize Bits64 = "Word64be"
-
-
 typeDeriving :: [String] -> Doc
 typeDeriving cs = text "deriving" <+> parens (commasep (map text cs))
 
@@ -213,11 +162,7 @@ data ImportType = LibraryType String
                 deriving (Eq, Show)
 
 importType :: TypeRepr -> ImportType
-importType (TypeRepr _ (AtomType a)) =
-  case a of
-    AtomWord _ -> LibraryType "Data.Word"
-    AtomInt _ -> LibraryType "Data.Int"
-    _ -> NoImport
+importType (TypeRepr _ (AtomType _)) = NoImport
 importType (TypeRepr _ VoidType) = NoImport
 importType (TypeRepr n _) = UserType n
 
@@ -227,6 +172,12 @@ isUserDefined tr = case importType tr of
   _ -> False
 
 
+userIModDependency :: TypeRepr -> Doc
+userIModDependency tr = case baseType tr of
+  (TypeRepr sn (StructType _)) ->
+    text "depend" <+> text (userTypeStructName sn) <> text "TypesModule"
+  _ -> empty
+
 importDecl :: (String -> Doc) -> ImportType -> Doc
 importDecl _ (LibraryType p) =
   text "import" <+> text p

src/Gidl/Types.hs

@@ -6,6 +6,7 @@ module Gidl.Types
   , lookupTypeName
   , insertType
   , typeLeaves
+  , baseType
   , typeDescrToRepr
   , sizeOf
   , voidTypeRepr
@@ -75,3 +76,8 @@ bitsSize Bits8  = 1
 bitsSize Bits16 = 2
 bitsSize Bits32 = 4
 bitsSize Bits64 = 8
+
+-- Reduce a newtype to the innermost concrete type
+baseType :: TypeRepr -> TypeRepr
+baseType (TypeRepr _ (NewtypeType (Newtype t))) = baseType t
+baseType a = a

tests/example.idl

@@ -35,6 +35,11 @@
   (lon lon_t)
   (alt meters_t)))
 
+(def-struct timed_coord_t
+ ((coord coordinate_t)
+  (time time_micros_t)))
+
+
 (def-newtype waypoint_t coordinate_t)
 
 -- Todo: the following interface syntax and semantics are a strawman.
@@ -52,7 +57,7 @@
 
 (def-interface controllable_vehicle_i
   ((current_waypoint (attr read      waypoint_t))
-   (next_waypoint    (attr readwrite waypoint_t)))
+   (next_waypoint    (attr readwrite timed_coord_t)))
   (vehicle_i)) -- Inherits from interface vehicle
 
 -- The idea here is that, when negotiating a gidl connection, the client can