Browse Source

gidl: haskell backend produces type and cabal file artifacts

and they build!
Pat Hickey 9 years ago
parent
commit
4b5092fca4
4 changed files with 55 additions and 2 deletions
  1. 39 0
      src/Gidl/Backend/Haskell.hs
  2. 7 0
      src/Gidl/Backend/Haskell/Types.hs
  3. 1 0
      tests/.gitignore
  4. 8 2
      tests/Test.hs

+ 39 - 0
src/Gidl/Backend/Haskell.hs

@@ -1,2 +1,41 @@
 module Gidl.Backend.Haskell where
 
+import Gidl.Types
+import Gidl.Parse
+import Gidl.Interface
+import Gidl.Backend.Cabal
+import Gidl.Backend.Haskell.Types
+
+import Ivory.Artifact
+
+import Data.Maybe (catMaybes)
+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)
+  where
+  tmods = [ typeModule (namespace ++ ["Types"]) tr
+          | (tn, _t) <- te'
+          , let tr = typeDescrToRepr tn te
+          , isUserDefined tr
+          ]
+
+  cf = defaultCabalFile pkgname mods deps
+  mods = [ filePathToPackage (artifactFileName m) | m <- tmods]
+  deps = []
+
+
+runHaskellBackend :: FilePath -> String -> [String] -> FilePath -> IO ()
+runHaskellBackend idlfile pkgname namespace outdir = do
+  c <- readFile idlfile
+  case parseDecls c of
+    Left e -> print e >> exitFailure
+    Right (te, ie) -> do
+      let as = haskellBackend te ie pkgname namespace
+      es <- mapM (putArtifact outdir) as
+      case catMaybes es of
+        [] -> exitSuccess
+        ees -> putStrLn (unlines ees) >> exitFailure
+
+

+ 7 - 0
src/Gidl/Backend/Haskell/Types.hs

@@ -8,6 +8,7 @@ import Gidl.Types
 import Ivory.Artifact
 import Text.PrettyPrint.Mainland
 
+-- invariant: only make a typeModule from a StructType, NewtypeType, or EnumType
 typeModule :: [String] -> TypeRepr -> Artifact
 typeModule modulepath tr@(TypeRepr _ td) =
   artifactPath (intercalate "/" modulepath) $
@@ -115,6 +116,12 @@ importType (TypeRepr _ (AtomType a)) =
 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

+ 1 - 0
tests/.gitignore

@@ -0,0 +1 @@
+gidl-haskell-backend-test

+ 8 - 2
tests/Test.hs

@@ -6,11 +6,17 @@ import Gidl.Types
 import Gidl.Interface
 import Gidl.Parse
 import Gidl.Schema
-import Gidl.Backend.Haskell.Types
 import Gidl.Backend.Cabal
+import Gidl.Backend.Haskell.Types
+import Gidl.Backend.Haskell
 
 main :: IO ()
-main = test "tests/testtypes.sexpr"
+main = runHaskellBackend "tests/testtypes.sexpr"
+                         "gidl-haskell-backend-test"
+                         (words "Gidl Haskell Test")
+                         "tests/gidl-haskell-backend-test"
+
+  --test "tests/testtypes.sexpr"
 
 test :: FilePath -> IO ()
 test f = do