gidl: start ivory backend with copypaste of haskell backend

gidl.cabal

@@ -21,7 +21,11 @@ library
                        Gidl.Backend.Haskell,
                        Gidl.Backend.Haskell.Interface,
                        Gidl.Backend.Haskell.Test,
-                       Gidl.Backend.Haskell.Types
+                       Gidl.Backend.Haskell.Types,
+                       Gidl.Backend.Ivory,
+                       Gidl.Backend.Ivory.Interface,
+                       Gidl.Backend.Ivory.Test,
+                       Gidl.Backend.Ivory.Types
 
   build-depends:       base >=4.7 && <4.8,
                        hashable,

src/Gidl/Backend/Ivory.hs

@@ -0,0 +1,50 @@
+module Gidl.Backend.Ivory where
+
+import Gidl.Types
+import Gidl.Interface
+import Gidl.Backend.Cabal
+import Gidl.Backend.Ivory.Types
+import Gidl.Backend.Ivory.Test
+import Gidl.Backend.Ivory.Interface
+
+import Ivory.Artifact
+
+import Data.Char (isSpace)
+
+ivoryBackend :: TypeEnv -> InterfaceEnv -> String -> String -> [Artifact]
+ivoryBackend te@(TypeEnv te') ie@(InterfaceEnv ie') pkgname namespace_raw =
+  [ cabalFileArtifact cf
+  , makefile
+  , artifactPath "tests" serializeTestMod
+  ] ++
+  [ artifactPath "src" m | m <- sourceMods
+  ]
+  where
+  tmods = [ typeModule (namespace ++ ["Types"]) tr
+          | (tn, _t) <- te'
+          , let tr = typeDescrToRepr tn te
+          , isUserDefined tr
+          ]
+  imods = [ interfaceModule (namespace ++ ["Interface"]) ir
+          | (iname, _i) <- ie'
+          , let ir = interfaceDescrToRepr iname ie te
+          ]
+  sourceMods = tmods ++ imods
+  cf = (defaultCabalFile pkgname cabalmods deps) { tests = [ serializeTest ] }
+  cabalmods = [ filePathToPackage (artifactFileName m) | m <- sourceMods ]
+  deps = [ "cereal", "QuickCheck" ]
+
+  serializeTest = defaultCabalTest "serialize-test" "SerializeTest.hs"
+                      (pkgname:deps)
+  serializeTestMod = serializeTestModule namespace
+                        [ interfaceDescrToRepr iname ie te | (iname, _i) <- ie']
+
+  namespace = dotwords namespace_raw
+
+
+  dotwords :: String -> [String]
+  dotwords s = case dropWhile isDot s of
+    "" -> []
+    s' -> let  (w, s'') = break isDot s' in w : dotwords s''
+  isDot c = (c == '.') || isSpace c
+

src/Gidl/Backend/Ivory/Interface.hs

@@ -0,0 +1,121 @@
+
+module Gidl.Backend.Ivory.Interface where
+
+
+import Data.Monoid
+import Data.List (intercalate, nub)
+import Data.Char (toUpper)
+
+import Gidl.Types
+import Gidl.Interface
+import Gidl.Schema
+import Gidl.Backend.Ivory.Types
+import Ivory.Artifact
+import Text.PrettyPrint.Mainland
+
+interfaceModule :: [String] -> InterfaceRepr -> Artifact
+interfaceModule modulepath ir =
+  artifactPath (intercalate "/" modulepath) $
+  artifactText ((ifModuleName ir) ++ ".hs") $
+  prettyLazyText 80 $
+  stack
+    [ text "{-# LANGUAGE DeriveDataTypeable #-}"
+    , empty
+    , text "module"
+      <+> im (ifModuleName ir)
+      <+> text "where"
+    , empty
+    , stack $ typeimports ++ extraimports
+    , empty
+    , schemaDoc (ifModuleName ir) (producerSchema ir)
+    , empty
+    , schemaDoc (ifModuleName ir) (consumerSchema ir)
+    ]
+  where
+  im mname = mconcat $ punctuate dot
+                     $ map text (modulepath ++ [mname])
+  tm mname = mconcat $ punctuate dot
+                     $ 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"
+                 , text "import Data.Typeable"
+                 , text "import Data.Data"
+                 , text "import qualified Test.QuickCheck as Q" ]
+
+schemaDoc :: 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
+    [ 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 ]
+    , 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
+  deriv = text "deriving (Eq, Show, Data, Typeable)"
+  typeName = interfaceName ++ schemaName
+
+ifModuleName :: InterfaceRepr -> String
+ifModuleName (InterfaceRepr iname _) = aux iname
+  where
+  aux :: String -> String
+  aux = first_cap . u_to_camel
+  first_cap (s:ss) = (toUpper s) : ss
+  first_cap []     = []
+  u_to_camel ('_':'i':[]) = []
+  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 [] = []
+
+

src/Gidl/Backend/Ivory/Test.hs

@@ -0,0 +1,70 @@
+
+module Gidl.Backend.Ivory.Test where
+
+
+import Data.Monoid
+import Gidl.Interface
+import Gidl.Schema
+import Gidl.Backend.Ivory.Interface
+import Ivory.Artifact
+import Text.PrettyPrint.Mainland
+
+serializeTestModule :: [String] -> [InterfaceRepr] -> Artifact
+serializeTestModule modulepath irs =
+  artifactText "SerializeTest.hs" $
+  prettyLazyText 80 $
+  stack
+    [ text "{-# LANGUAGE ScopedTypeVariables #-}"
+    , empty
+    , text "module Main where"
+    , empty
+    , text "import Data.Serialize"
+    , text "import System.Exit (exitFailure, exitSuccess)"
+    , text "import qualified Test.QuickCheck as Q"
+    , empty
+    , stack [ text "import" <+> im (ifModuleName ir) | ir <- irs ]
+    , empty
+    , text "main :: IO ()"
+    , text "main" <+> equals <+> text "do" <+> align (stack
+        ([ testSchema ir (producerSchema ir) </> testSchema ir (consumerSchema ir)
+         | ir <- irs ] ++
+         [ text "exitSuccess" ]))
+    , empty
+    , props
+    ]
+  where
+  im mname = mconcat $ punctuate dot
+                     $ map text (modulepath ++ ["Interface", mname])
+
+testSchema :: InterfaceRepr -> Schema -> Doc
+testSchema ir (Schema sn []) =
+  text "-- no tests for empty schema" <+> text (ifModuleName ir ++ sn)
+testSchema ir (Schema sn _) = stack
+  [ text "runQC" <+> parens
+      (text "serializeRoundtrip ::" <+> text sname <+> text "-> Bool")
+  , text "runQC" <+> parens
+      (text "serializeManyRoundtrip ::" <+> brackets (text sname) <+> text "-> Bool")
+  ]
+  where sname = ifModuleName ir ++ sn
+
+props :: Doc
+props = stack
+  [ text "serializeRoundtrip :: (Serialize a, Eq a) => a -> Bool"
+  , text "serializeRoundtrip v = case runGet get (runPut (put v)) of"
+  , indent 2 $ text "Left e -> False"
+  , indent 2 $ text "Right v' -> v == v'"
+  , empty
+  , text "serializeManyRoundtrip :: (Serialize a, Eq a) => [a] -> Bool"
+  , text "serializeManyRoundtrip vs ="
+  , indent 2 $ text "case runGet (mapM (const get) vs) (runPut (mapM_ put vs)) of"
+  , indent 4 $ text "Left e -> False"
+  , indent 4 $ text "Right vs' -> vs == vs'"
+  , empty
+
+  , text "runQC :: Q.Testable p => p -> IO ()"
+  , text "runQC prop = do"
+  , indent 2 $ text "r <- Q.quickCheckWithResult Q.stdArgs prop"
+  , indent 2 $ text "case r of"
+  , indent 4 $ text "Q.Success {} -> return ()"
+  , indent 4 $ text "_ -> exitFailure"
+ ]

src/Gidl/Backend/Ivory/Types.hs

@@ -0,0 +1,243 @@
+
+module Gidl.Backend.Ivory.Types where
+
+import Data.Monoid
+import Data.List (intercalate, nub)
+import Data.Char (toUpper)
+import Gidl.Types
+import Ivory.Artifact
+import Text.PrettyPrint.Mainland
+
+-- invariant: only make a typeModule from a StructType, NewtypeType, or EnumType
+-- i.e. when isUserDefined is true.
+typeModule :: [String] -> TypeRepr -> Artifact
+typeModule modulepath tr@(TypeRepr _ td) =
+  artifactPath (intercalate "/" modulepath) $
+  artifactText ((typeModuleName tr) ++ ".hs") $
+  prettyLazyText 80 $
+  stack
+    [ text "{-# LANGUAGE RecordWildCards #-}"
+    , text "{-# LANGUAGE DeriveDataTypeable #-}"
+    , 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"
+              ])
+    , empty
+    , typeDecl typename td
+    ]
+  where
+  imports = map (importDecl tm)
+          $ nub
+          $ map importType
+          $ typeLeaves td
+  typename = typeModuleName tr
+  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) = "()"
+
+typeModuleName :: TypeRepr -> String
+typeModuleName (TypeRepr tn (StructType _)) = userTypeModuleName tn
+typeModuleName (TypeRepr tn (NewtypeType _)) = userTypeModuleName tn
+typeModuleName (TypeRepr tn (EnumType _)) = userTypeModuleName tn
+typeModuleName (TypeRepr _ (AtomType _)) = error "do not take typeModuleName of an AtomType"
+typeModuleName (TypeRepr _ VoidType) = error "do not take typeModuleName of a VoidType"
+
+userTypeModuleName :: String -> String
+userTypeModuleName = first_cap . u_to_camel
+  where
+  first_cap (s:ss) = (toUpper s) : ss
+  first_cap []     = []
+  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)
+      ]
+  ]
+
+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)
+      | (i,t) <- ss ]
+  , empty
+  , text ("put" ++ tname) <+> colon <> colon <+> text "Putter" <+> text tname
+  , text ("put" ++ tname) <+> text tname <> text "{..}" <+> equals <+> 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
+  ]
+  where deriv = typeDeriving ["Eq", "Show", "Data", "Typeable"]
+
+typeDecl tname (NewtypeType (Newtype n)) = 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"])
+  , 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
+      | (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"]
+
+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))
+
+data ImportType = LibraryType String
+                | UserType String
+                | NoImport
+                deriving (Eq, Show)
+
+importType :: TypeRepr -> ImportType
+importType (TypeRepr _ (AtomType a)) =
+  case a of
+    AtomWord _ -> LibraryType "Data.Word"
+    AtomInt _ -> LibraryType "Data.Int"
+    _ -> NoImport
+importType (TypeRepr _ VoidType) = NoImport
+importType (TypeRepr n _) = UserType n
+
+isUserDefined :: TypeRepr -> Bool
+isUserDefined tr = case importType tr of
+  UserType _ -> True
+  _ -> False
+
+
+importDecl :: (String -> Doc) -> ImportType -> Doc
+importDecl _ (LibraryType p) =
+  text "import" <+> text p
+importDecl mkpath (UserType t) =
+  text "import" <+> mkpath (userTypeModuleName t)
+importDecl _ NoImport = empty
+
+
+encloseStack :: Doc -> Doc -> Doc -> [Doc] -> Doc
+encloseStack l r p ds = case ds of
+  [] -> empty -- l </> r
+  [d] -> l <+> d </> r
+  _ -> align (l <+> (folddoc (\a b -> a </> p <+> b) ds) </> r)
+