haskell backend: working again

gidl.cabal

@@ -17,11 +17,11 @@ library
                        Gidl.Types,
                        Gidl.Types.AST,
                        Gidl.Types.Base,
-                       Gidl.Backend.Cabal
-                     --  Gidl.Backend.Haskell,
-                     --  Gidl.Backend.Haskell.Interface,
-                     --  Gidl.Backend.Haskell.Test,
-                     --  Gidl.Backend.Haskell.Types,
+                       Gidl.Backend.Cabal,
+                       Gidl.Backend.Haskell,
+                       Gidl.Backend.Haskell.Interface,
+                       Gidl.Backend.Haskell.Test,
+                       Gidl.Backend.Haskell.Types
                      --  Gidl.Backend.Ivory,
                      --  Gidl.Backend.Ivory.Interface,
                      --  Gidl.Backend.Ivory.Test,

src/Gidl.hs

@@ -13,7 +13,7 @@ import Text.Show.Pretty
 
 import Ivory.Artifact
 import Gidl.Parse
---import Gidl.Backend.Haskell
+import Gidl.Backend.Haskell
 --import Gidl.Backend.Ivory
 
 data OptParser opt = OptParser [String] (opt -> opt)
@@ -130,8 +130,7 @@ run = do
         putStrLn (ppShow ie)
       case backend opts of
         HaskellBackend -> artifactBackend opts $
-          []
-          --haskellBackend te ie (packagename opts) (namespace opts)
+          haskellBackend te ie (packagename opts) (namespace opts)
         IvoryBackend -> artifactBackend opts $
           []
           --ivoryBackend te ie (packagename opts) (namespace opts)

src/Gidl/Backend/Haskell.hs

@@ -13,7 +13,7 @@ import Data.Char (isSpace)
 import Text.PrettyPrint.Mainland
 
 haskellBackend :: TypeEnv -> InterfaceEnv -> String -> String -> [Artifact]
-haskellBackend te@(TypeEnv te') ie@(InterfaceEnv ie') pkgname namespace_raw =
+haskellBackend (TypeEnv te) (InterfaceEnv ie) pkgname namespace_raw =
   [ cabalFileArtifact cf
   , makefile
   , artifactPath "tests" serializeTestMod
@@ -21,14 +21,12 @@ haskellBackend te@(TypeEnv te') ie@(InterfaceEnv ie') pkgname namespace_raw =
   [ artifactPath "src" m | m <- sourceMods
   ]
   where
-  tmods = [ typeModule (namespace ++ ["Types"]) tr
-          | (tn, _t) <- te'
-          , let tr = typeDescrToRepr tn te
-          , isUserDefined tr
+  tmods = [ typeModule (namespace ++ ["Types"]) t
+          | (_tn, t) <- te
+          , isUserDefined t
           ]
-  imods = [ interfaceModule (namespace ++ ["Interface"]) ir
-          | (iname, _i) <- ie'
-          , let ir = interfaceDescrToRepr iname ie te
+  imods = [ interfaceModule (namespace ++ ["Interface"]) i
+          | (_iname, i) <- ie
           ]
   sourceMods = tmods ++ imods
   cf = (defaultCabalFile pkgname cabalmods deps) { tests = [ serializeTest ] }
@@ -37,8 +35,7 @@ haskellBackend te@(TypeEnv te') ie@(InterfaceEnv ie') pkgname namespace_raw =
 
   serializeTest = defaultCabalTest "serialize-test" "SerializeTest.hs"
                       (pkgname:deps)
-  serializeTestMod = serializeTestModule namespace
-                        [ interfaceDescrToRepr iname ie te | (iname, _i) <- ie']
+  serializeTestMod = serializeTestModule namespace (map snd ie)
 
   namespace = dotwords namespace_raw
 

src/Gidl/Backend/Haskell/Interface.hs

@@ -13,23 +13,23 @@ import Gidl.Backend.Haskell.Types
 import Ivory.Artifact
 import Text.PrettyPrint.Mainland
 
-interfaceModule :: [String] -> InterfaceRepr -> Artifact
-interfaceModule modulepath ir =
+interfaceModule :: [String] -> Interface -> Artifact
+interfaceModule modulepath i =
   artifactPath (intercalate "/" modulepath) $
-  artifactText ((ifModuleName ir) ++ ".hs") $
+  artifactText ((ifModuleName i) ++ ".hs") $
   prettyLazyText 80 $
   stack
     [ text "{-# LANGUAGE DeriveDataTypeable #-}"
     , empty
     , text "module"
-      <+> im (ifModuleName ir)
+      <+> im (ifModuleName i)
       <+> text "where"
     , empty
     , stack $ typeimports ++ extraimports
     , empty
-    , schemaDoc (ifModuleName ir) (producerSchema ir)
+    , schemaDoc (ifModuleName i) (producerSchema i)
     , empty
-    , schemaDoc (ifModuleName ir) (consumerSchema ir)
+    , schemaDoc (ifModuleName i) (consumerSchema i)
     ]
   where
   im mname = mconcat $ punctuate dot
@@ -41,7 +41,7 @@ interfaceModule modulepath ir =
   typeimports = map (importDecl tm)
               $ nub
               $ map importType
-              $ interfaceTypes ir
+              $ interfaceTypes i
   extraimports = [ text "import Data.Serialize"
                  , text "import Data.Typeable"
                  , text "import Data.Data"
@@ -105,8 +105,8 @@ schemaDoc interfaceName (Schema schemaName schema) = stack
   deriv = text "deriving (Eq, Show, Data, Typeable)"
   typeName = interfaceName ++ schemaName
 
-ifModuleName :: InterfaceRepr -> String
-ifModuleName (InterfaceRepr iname _) = aux iname
+ifModuleName :: Interface -> String
+ifModuleName (Interface iname _ _) = aux iname
   where
   aux :: String -> String
   aux = first_cap . u_to_camel

src/Gidl/Backend/Haskell/Test.hs

@@ -9,8 +9,8 @@ import Gidl.Backend.Haskell.Interface
 import Ivory.Artifact
 import Text.PrettyPrint.Mainland
 
-serializeTestModule :: [String] -> [InterfaceRepr] -> Artifact
-serializeTestModule modulepath irs =
+serializeTestModule :: [String] -> [Interface] -> Artifact
+serializeTestModule modulepath is =
   artifactText "SerializeTest.hs" $
   prettyLazyText 80 $
   stack
@@ -22,12 +22,12 @@ serializeTestModule modulepath irs =
     , text "import System.Exit (exitFailure, exitSuccess)"
     , text "import qualified Test.QuickCheck as Q"
     , empty
-    , stack [ text "import" <+> im (ifModuleName ir) | ir <- irs ]
+    , stack [ text "import" <+> im (ifModuleName i) | i <- is ]
     , empty
     , text "main :: IO ()"
     , text "main" <+> equals <+> text "do" <+> align (stack
-        ([ testSchema ir (producerSchema ir) </> testSchema ir (consumerSchema ir)
-         | ir <- irs ] ++
+        ([ testSchema i (producerSchema i) </> testSchema i (consumerSchema i)
+         | i <- is ] ++
          [ text "exitSuccess" ]))
     , empty
     , props
@@ -36,16 +36,16 @@ serializeTestModule modulepath irs =
   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
+testSchema :: Interface -> Schema -> Doc
+testSchema i (Schema sn []) =
+  text "-- no tests for empty schema" <+> text (ifModuleName i ++ sn)
+testSchema i (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
+  where sname = ifModuleName i ++ sn
 
 props :: Doc
 props = stack

src/Gidl/Backend/Haskell/Types.hs

@@ -10,17 +10,17 @@ 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) =
+typeModule :: [String] -> Type -> Artifact
+typeModule modulepath t =
   artifactPath (intercalate "/" modulepath) $
-  artifactText ((typeModuleName tr) ++ ".hs") $
+  artifactText ((typeModuleName t) ++ ".hs") $
   prettyLazyText 80 $
   stack
     [ text "{-# LANGUAGE RecordWildCards #-}"
     , text "{-# LANGUAGE DeriveDataTypeable #-}"
     , empty
     , text "module"
-      <+> tm (typeModuleName tr)
+      <+> tm (typeModuleName t)
       <+> text "where"
     , empty
     , stack (imports ++
@@ -30,22 +30,22 @@ typeModule modulepath tr@(TypeRepr _ td) =
               , text "import qualified Test.QuickCheck as Q"
               ])
     , empty
-    , typeDecl typename td
+    , typeDecl typename t
     ]
   where
   imports = map (importDecl tm)
           $ nub
-          $ map importType
-          $ typeLeaves td
-  typename = typeModuleName tr
+          $ map (importType . PrimType)
+          $ typeLeaves t
+  typename = typeModuleName t
   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
+typeHaskellType :: Type -> String
+typeHaskellType (StructType tn _) = userTypeModuleName tn
+typeHaskellType (PrimType (Newtype tn _)) = userTypeModuleName tn
+typeHaskellType (PrimType (EnumType tn _ _)) = userTypeModuleName tn
+typeHaskellType (PrimType  (AtomType a)) = case a of
   AtomInt Bits8  -> "Int8"
   AtomInt Bits16 -> "Int16"
   AtomInt Bits32 -> "Int32"
@@ -56,14 +56,14 @@ typeHaskellType (TypeRepr _ (AtomType a)) = case a of
   AtomWord Bits64 -> "Word64"
   AtomFloat -> "Float"
   AtomDouble -> "Double"
-typeHaskellType (TypeRepr _ VoidType) = "()"
+typeHaskellType (PrimType 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"
+typeModuleName :: Type -> String
+typeModuleName (StructType tn _) = userTypeModuleName tn
+typeModuleName (PrimType (Newtype tn _)) = userTypeModuleName tn
+typeModuleName (PrimType (EnumType tn _ _)) = userTypeModuleName tn
+typeModuleName (PrimType (AtomType _)) = error "do not take typeModuleName of an AtomType"
+typeModuleName (PrimType VoidType) = error "do not take typeModuleName of a VoidType"
 
 userTypeModuleName :: String -> String
 userTypeModuleName = first_cap . u_to_camel
@@ -93,12 +93,12 @@ arbitraryInstance tname = stack
       ]
   ]
 
-typeDecl :: TypeName -> Type TypeRepr -> Doc
-typeDecl tname (StructType (Struct ss)) = stack
+typeDecl :: String -> Type -> Doc
+typeDecl tname (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 t)
+      [ text i <+> colon <> colon <+> text (typeHaskellType (PrimType t))
       | (i,t) <- ss ]
   , empty
   , text ("put" ++ tname) <+> colon <> colon <+> text "Putter" <+> text tname
@@ -127,11 +127,11 @@ typeDecl tname (StructType (Struct ss)) = stack
   ]
   where deriv = typeDeriving ["Eq", "Show", "Data", "Typeable"]
 
-typeDecl tname (NewtypeType (Newtype n)) = stack
+typeDecl tname (PrimType (Newtype _ n)) = stack
   [ text "newtype" <+> text tname <+> equals
   , indent 2 $ text tname <+> align
         (lbrace <+> text ("un" ++ tname) <+> text "::" <+>
-         text (typeHaskellType n) </>
+         text (typeHaskellType (PrimType n)) </>
          rbrace <+> typeDeriving ["Eq", "Show", "Data", "Typeable"])
   , empty
   , text ("put" ++ tname) <+> colon <> colon <+> text "Putter" <+> text tname
@@ -153,7 +153,7 @@ typeDecl tname (NewtypeType (Newtype n)) = stack
   , arbitraryInstance tname
   ]
 
-typeDecl tname (EnumType (EnumT s es)) = stack
+typeDecl tname (PrimType (EnumType _ s es)) = stack
   [ text "data" <+> text tname
   , indent 2 $ encloseStack equals deriv (text "|")
       [ text (userTypeModuleName i)
@@ -212,16 +212,18 @@ data ImportType = LibraryType String
                 | NoImport
                 deriving (Eq, Show)
 
-importType :: TypeRepr -> ImportType
-importType (TypeRepr _ (AtomType a)) =
+importType :: Type -> ImportType
+importType (StructType n _) = UserType n
+importType (PrimType (EnumType n _ _)) = UserType n
+importType (PrimType (Newtype n _)) = UserType n
+importType (PrimType (AtomType a)) =
   case a of
     AtomWord _ -> LibraryType "Data.Word"
     AtomInt _ -> LibraryType "Data.Int"
     _ -> NoImport
-importType (TypeRepr _ VoidType) = NoImport
-importType (TypeRepr n _) = UserType n
+importType (PrimType VoidType) = NoImport
 
-isUserDefined :: TypeRepr -> Bool
+isUserDefined :: Type -> Bool
 isUserDefined tr = case importType tr of
   UserType _ -> True
   _ -> False