gidl: generate quickcheck test suite for haskell backend

Makefile

@@ -14,3 +14,11 @@ create-sandbox:
 	cabal sandbox add-source $(IVORY_REPO)/ivory-artifact
 	cabal install --dependencies-only
 
+test: haskell-backend-test
+
+haskell-backend-test:
+	cabal run gidl-haskell-backend-test-gen
+	make -C tests/gidl-haskell-backend-test create-sandbox
+	make -C tests/gidl-haskell-backend-test
+	make -C tests/gidl-haskell-backend-test test
+

gidl.cabal

@@ -20,6 +20,7 @@ library
                        Gidl.Backend.Cabal,
                        Gidl.Backend.Haskell,
                        Gidl.Backend.Haskell.Interface,
+                       Gidl.Backend.Haskell.Test,
                        Gidl.Backend.Haskell.Types
 
   build-depends:       base >=4.7 && <4.8,
@@ -32,7 +33,7 @@ library
   default-language:    Haskell2010
   ghc-options:         -Wall
 
-executable             gidl-test
+executable             gidl-haskell-backend-test-gen
   main-is:             Test.hs
   hs-source-dirs:      tests
   build-depends:       base >= 4.6,

src/Gidl/Backend/Cabal.hs

@@ -15,6 +15,16 @@ data CabalFile =
     , hs_source_dirs :: [String]
     , default_language :: String
     , ghc_options :: String
+    , tests :: [CabalTest]
+    } deriving (Eq, Show)
+
+data CabalTest =
+  CabalTest
+    { test_name :: String
+    , test_type :: String
+    , test_hs_source_dirs :: [String]
+    , test_main_is :: String
+    , test_build_depends :: [String]
     } deriving (Eq, Show)
 
 defaultCabalFile :: String -> [String] -> [String] -> CabalFile
@@ -27,6 +37,16 @@ defaultCabalFile name_ exposed_modules_ build_depends_ = CabalFile
   , hs_source_dirs = ["src"]
   , default_language = "Haskell2010"
   , ghc_options = "-Wall"
+  , tests = []
+  }
+
+defaultCabalTest :: String -> String -> [String] -> CabalTest
+defaultCabalTest name_ main_ build_depends_ = CabalTest
+  { test_name = name_
+  , test_type = "exitcode-stdio-1.0"
+  , test_hs_source_dirs = ["tests"]
+  , test_main_is = main_
+  , test_build_depends = "base >= 4.7" : build_depends_
   }
 
 cabalFileArtifact :: CabalFile -> Artifact
@@ -48,11 +68,36 @@ cabalFileArtifact CabalFile{..} = artifactText (name ++ ".cabal") $
       , text "default-language:" <+> text default_language
       , text "ghc-options:" <+> text ghc_options
       ]
+    , stack [ cabalTestDoc t | t <- tests ]
     ]
 
+cabalTestDoc :: CabalTest -> Doc
+cabalTestDoc CabalTest{..} =
+  text "Test-Suite" <+> text test_name </> indent 2 (stack
+    [ text "type:" <+> text test_type
+    , text "hs-source-dirs:" <+> sep (punctuate comma (map text test_hs_source_dirs))
+    , text "main-is:" <+> text test_main_is
+    , text "build-depends:" <+> align (stack (punctuate comma (map text test_build_depends)))
+    ])
+
 filePathToPackage :: String -> String
 filePathToPackage ('.':'h':'s':[]) = []
 filePathToPackage ('/':as) = '.' : filePathToPackage as
 filePathToPackage (a:as) = a : filePathToPackage as
 filePathToPackage [] = []
 
+makefile :: Artifact
+makefile = artifactText "Makefile" $
+  prettyLazyText 80 $ stack
+    [ text "default:"
+    , text "\tcabal build"
+    , empty
+    , text "create-sandbox:"
+    , text "\tcabal sandbox init"
+    , text "\tcabal install --enable-tests --dependencies-only"
+    , empty
+    , text "test:"
+    , text "\tcabal test"
+    , empty
+    ]
+

src/Gidl/Backend/Haskell.hs

@@ -5,6 +5,7 @@ import Gidl.Parse
 import Gidl.Interface
 import Gidl.Backend.Cabal
 import Gidl.Backend.Haskell.Types
+import Gidl.Backend.Haskell.Test
 import Gidl.Backend.Haskell.Interface
 
 import Ivory.Artifact
@@ -14,7 +15,12 @@ import System.Exit (exitFailure, exitSuccess)
 
 haskellBackend :: TypeEnv -> InterfaceEnv -> String -> [String] -> [Artifact]
 haskellBackend te@(TypeEnv te') ie@(InterfaceEnv ie') pkgname namespace =
-  cabalFileArtifact cf : (map (artifactPath "src") (tmods ++ imods))
+  [ cabalFileArtifact cf
+  , makefile
+  , artifactPath "tests" serializeTestMod
+  ] ++
+  [ artifactPath "src" m | m <- sourceMods
+  ]
   where
   tmods = [ typeModule (namespace ++ ["Types"]) tr
           | (tn, _t) <- te'
@@ -25,10 +31,16 @@ haskellBackend te@(TypeEnv te') ie@(InterfaceEnv ie') pkgname namespace =
           | (iname, _i) <- ie'
           , let ir = interfaceDescrToRepr iname ie te
           ]
-  cf = defaultCabalFile pkgname mods deps
-  mods = [ filePathToPackage (artifactFileName m) | m <- (tmods ++ imods)]
+  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']
+
 
 runHaskellBackend :: FilePath -> String -> [String] -> FilePath -> IO ()
 runHaskellBackend idlfile pkgname namespace outdir = do

src/Gidl/Backend/Haskell/Interface.hs

@@ -25,9 +25,9 @@ interfaceModule modulepath ir =
     , empty
     , stack $ typeimports ++ extraimports
     , empty
-    , schemaDoc (ifModuleName ir) "Producer" (producerSchema ir)
+    , schemaDoc (ifModuleName ir) (producerSchema ir)
     , empty
-    , schemaDoc (ifModuleName ir) "Consumer" (consumerSchema ir)
+    , schemaDoc (ifModuleName ir) (consumerSchema ir)
     ]
   where
   im mname = mconcat $ punctuate dot
@@ -43,11 +43,11 @@ interfaceModule modulepath ir =
   extraimports = [ text "import Data.Serialize"
                  , text "import qualified Test.QuickCheck as Q" ]
 
-schemaDoc :: String -> String -> Schema -> Doc
-schemaDoc interfaceName schemaName (Schema [])     =
+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 schemaName (Schema schema) = stack
+schemaDoc interfaceName (Schema schemaName schema) = stack
     [ text "-- Define" <+> text schemaName  <+> text "schema for"
         <+> text interfaceName <+> text "interface"
     , text "data" <+> text typeName

src/Gidl/Backend/Haskell/Test.hs

@@ -0,0 +1,70 @@
+
+module Gidl.Backend.Haskell.Test where
+
+
+import Data.Monoid
+import Gidl.Interface
+import Gidl.Schema
+import Gidl.Backend.Haskell.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/Schema.hs

@@ -9,12 +9,12 @@ import Gidl.Interface
 type MsgId = Word32
 data Message = Message String TypeRepr
              deriving (Eq, Show)
-data Schema = Schema [(MsgId, Message)]
+data Schema = Schema String [(MsgId, Message)]
             deriving (Eq, Show)
 
 
 producerSchema :: InterfaceRepr -> Schema
-producerSchema ir = Schema [(mkMsgId m, m) | m <- messages ]
+producerSchema ir = Schema "Producer" [(mkMsgId m, m) | m <- messages ]
   where
   messages = concatMap mkMessages (interfaceMethods ir)
   mkMessages (streamname, (StreamMethod _ tr)) =
@@ -24,7 +24,7 @@ producerSchema ir = Schema [(mkMsgId m, m) | m <- messages ]
     [ Message (attrname ++ "_val") tr ]
 
 consumerSchema :: InterfaceRepr -> Schema
-consumerSchema ir = Schema [(mkMsgId m, m) | m <- messages ]
+consumerSchema ir = Schema "Consumer" [(mkMsgId m, m) | m <- messages ]
   where
   messages = concatMap mkMessages (interfaceMethods ir)