gidl: command line frontend ftw

Makefile

@@ -17,8 +17,10 @@ create-sandbox:
 test: haskell-backend-test
 
 haskell-backend-test:
-	cabal run gidl-haskell-backend-test-gen
+	cabal run gidl -- -b haskell -i tests/example.idl -o tests/gidl-haskell-backend-test -p gidl-haskell-backend-test -n Gidl.Haskell.Test
 	make -C tests/gidl-haskell-backend-test create-sandbox
 	make -C tests/gidl-haskell-backend-test
 	make -C tests/gidl-haskell-backend-test test
 
+haskell-backend-test-clean:
+	-rm -rf tests/gidl-haskell-backend-test

executables/Main.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import Gidl (run)
+
+main :: IO ()
+main = run

gidl.cabal

@@ -33,12 +33,13 @@ library
   default-language:    Haskell2010
   ghc-options:         -Wall
 
-executable             gidl-haskell-backend-test-gen
-  main-is:             Test.hs
-  hs-source-dirs:      tests
+executable             gidl
+  main-is:             Main.hs
+  hs-source-dirs:      executables
   build-depends:       base >= 4.6,
                        ivory-artifact,
                        gidl
 
   default-language:    Haskell2010
   ghc-options:         -Wall
+

src/Gidl.hs

@@ -1,2 +1,123 @@
-module Gidl where
+module Gidl
+  ( run
+  ) where
+
+import Data.Char
+import Data.Monoid
+import Data.Maybe (catMaybes)
+import System.Console.GetOpt
+import System.Environment
+import System.Exit
+
+import Ivory.Artifact
+import Gidl.Parse
+import Gidl.Backend.Haskell
+
+data OptParser opt = OptParser [String] (opt -> opt)
+instance Monoid (OptParser opt) where
+  mempty = OptParser [] id
+  OptParser as f `mappend` OptParser bs g = OptParser (as ++ bs) (f . g)
+
+success :: (opt -> opt) -> OptParser opt
+success  = OptParser []
+
+invalid :: String -> OptParser opt
+invalid e = OptParser [e] id
+
+parseOptions :: [OptDescr (OptParser opt)] -> [String]
+             -> Either [String] (opt -> opt)
+parseOptions opts args = case getOpt Permute opts args of
+  (fs,[],[]) -> case mconcat fs of
+    OptParser [] f -> Right f
+    OptParser es _ -> Left es
+  (_,_,es) -> Left es
+
+data Backend
+  = HaskellBackend
+  deriving (Eq, Show)
+
+data Opts = Opts
+  { backend :: Backend
+  , idlpath :: FilePath
+  , outpath :: FilePath
+  , packagename :: String
+  , namespace :: String
+  , help :: Bool
+  }
+
+initialOpts :: Opts
+initialOpts = Opts
+  { backend     = error (usage ["must specify a backend"])
+  , idlpath     = error (usage ["must specify an idl file"])
+  , outpath     = error (usage ["must specify an output path"])
+  , packagename = error  (usage ["must specify a package name"])
+  , namespace   = ""
+  , help        = False
+  }
+
+setBackend :: String -> OptParser Opts
+setBackend b = case map toUpper b of
+  "HASKELL" -> success (\o -> o { backend = HaskellBackend })
+  _         -> invalid ("\"" ++ b ++ "\" is not a valid backend.\n"
+                          ++ "Supported backends: haskell")
+
+setIdlPath :: String -> OptParser Opts
+setIdlPath p = success (\o -> o { idlpath = p })
+
+setOutPath :: String -> OptParser Opts
+setOutPath p = success (\o -> o { outpath = p })
+
+setPackageName :: String -> OptParser Opts
+setPackageName p = success (\o -> o { packagename = p })
+
+setNamespace :: String -> OptParser Opts
+setNamespace p = success (\o -> o { namespace = p })
+
+setHelp :: OptParser Opts
+setHelp = success (\o -> o { help = True })
+
+options :: [OptDescr (OptParser Opts)]
+options =
+  [ Option "b" ["backend"]   (ReqArg setBackend "BACKEND")
+      "code generator backend"
+  , Option "i" ["idl"]       (ReqArg setIdlPath "FILE")
+      "IDL file"
+  , Option "o" ["out"]       (ReqArg setOutPath "DIR")
+      "root directory for output"
+  , Option "p" ["package"]   (ReqArg setPackageName "NAME")
+      "package name for output"
+  , Option "n" ["namespace"] (ReqArg setNamespace "NAME")
+      "namespace for output"
+  , Option "h" ["help"]      (NoArg setHelp)
+      "display this message and exit"
+  ]
+
+parseOpts :: [String] -> IO Opts
+parseOpts args = case parseOptions options args of
+  Right f -> let opts = f initialOpts in
+    if help opts then putStrLn (usage []) >> exitSuccess
+                 else return opts
+  Left errs -> putStrLn (usage errs) >> exitFailure
+
+
+usage :: [String] -> String
+usage errs = usageInfo banner options
+  where
+  banner = unlines (errs ++ ["", "Usage: gidl OPTIONS"])
+
+run :: IO ()
+run = do
+  args <- getArgs
+  opts <- parseOpts args
+  idl <- readFile (idlpath opts)
+  case parseDecls idl of
+    Left e -> print e >> exitFailure
+    Right (te, ie) ->
+      case backend opts of
+        HaskellBackend -> do
+          let as = haskellBackend te ie (packagename opts) (namespace opts)
+          es <- mapM (putArtifact (outpath opts)) as
+          case catMaybes es of
+            [] -> exitSuccess
+            ees -> putStrLn (unlines ees) >> exitFailure
 

src/Gidl/Backend/Haskell.hs

@@ -1,7 +1,6 @@
 module Gidl.Backend.Haskell where
 
 import Gidl.Types
-import Gidl.Parse
 import Gidl.Interface
 import Gidl.Backend.Cabal
 import Gidl.Backend.Haskell.Types
@@ -10,11 +9,10 @@ import Gidl.Backend.Haskell.Interface
 
 import Ivory.Artifact
 
-import Data.Maybe (catMaybes)
-import System.Exit (exitFailure, exitSuccess)
+import Data.Char (isSpace)
 
-haskellBackend :: TypeEnv -> InterfaceEnv -> String -> [String] -> [Artifact]
-haskellBackend te@(TypeEnv te') ie@(InterfaceEnv ie') pkgname namespace =
+haskellBackend :: TypeEnv -> InterfaceEnv -> String -> String -> [Artifact]
+haskellBackend te@(TypeEnv te') ie@(InterfaceEnv ie') pkgname namespace_raw =
   [ cabalFileArtifact cf
   , makefile
   , artifactPath "tests" serializeTestMod
@@ -41,17 +39,12 @@ haskellBackend te@(TypeEnv te') ie@(InterfaceEnv ie') pkgname namespace =
   serializeTestMod = serializeTestModule namespace
                         [ interfaceDescrToRepr iname ie te | (iname, _i) <- ie']
 
+  namespace = dotwords namespace_raw
 
-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
 
+  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