gidl/src/Gidl.hs

module Gidl
  ( run
  ) where

import Data.Char
import Data.Monoid
import Data.Maybe (catMaybes)
import Control.Monad
import System.Console.GetOpt
import System.Environment
import System.Exit
import Text.Show.Pretty

import Ivory.Artifact
import Gidl.Parse
import Gidl.Interface
import Gidl.Backend.Haskell
import Gidl.Backend.Ivory
import Gidl.Backend.Rpc (rpcBackend)
import Gidl.Backend.Tower

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
  | IvoryBackend
  | TowerBackend
  | RpcBackend
  deriving (Eq, Show)

data Opts = Opts
  { backend :: Backend
  , idlpath :: FilePath
  , outpath :: FilePath
  , packagename :: String
  , namespace :: String
  , debug :: Bool
  , 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   = ""
  , debug       = False
  , help        = False
  }

setBackend :: String -> OptParser Opts
setBackend b = case map toUpper b of
  "HASKELL"     -> success (\o -> o { backend = HaskellBackend })
  "IVORY"       -> success (\o -> o { backend = IvoryBackend })
  "TOWER"       -> success (\o -> o { backend = TowerBackend })
  "HASKELL-RPC" -> success (\o -> o { backend = RpcBackend })
  _             -> invalid e
  where e = "\"" ++ b ++ "\" is not a valid backend.\n"
          ++ "Supported backends: haskell, ivory, tower, haskell-rpc"
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 })

setDebug :: OptParser Opts
setDebug = success (\o -> o { debug = True })

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 ""  ["debug"]     (NoArg setDebug)
      "enable debugging 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 -> putStrLn ("Error parsing " ++ (idlpath opts) ++ ": " ++ e)
              >> exitFailure
    Right (te, ie) -> do
      when (debug opts) $ do
        putStrLn (ppShow te)
        putStrLn (ppShow ie)
      let InterfaceEnv ie' = ie
          interfaces = map snd ie'
          b = case backend opts of
                HaskellBackend -> haskellBackend
                IvoryBackend -> ivoryBackend
                TowerBackend -> towerBackend
                RpcBackend -> rpcBackend
      artifactBackend opts (b interfaces (packagename opts) (namespace opts))

  where
  artifactBackend :: Opts -> [Artifact] -> IO ()
  artifactBackend opts as = do
    when (debug opts) $ mapM_ printArtifact as
    es <- mapM (putArtifact (outpath opts)) as
    case catMaybes es of
      [] -> exitSuccess
      ees -> putStrLn (unlines ees) >> exitFailure