JsContracts-0.4: src/Jscc.hs

-- JavaScript Contract Compiler
module Main where

import System.Console.GetOpt
import System.Environment
import System.Directory
import System.FilePath
import System.Exit
import Control.Monad
import BrownPLT.JavaScript.Contracts
import Paths_JsContracts -- created by Cabal
import BrownPLT.JavaScript.Parser (parseJavaScriptFromFile)

data Flag
  = Help
  | Release
  | Debug
  | Namespace String
  | Interface String
  deriving (Eq,Ord,Show)
      

options ::  [ OptDescr Flag ]
options =
  [ Option ['h'] ["help"] (NoArg Help)
      "display this help message"
  , Option ['r'] ["release"]  (NoArg Release)
      "encapsulate, ignoring all contracts"
  , Option ['d'] ["debug"] (NoArg Debug)
      "enable contracts and encapsulate (default)"
  , Option ['n'] ["namespace"] (ReqArg Namespace "NAMESPACE")
      "exports names to the namespace"
  , Option ['i'] ["interface"] (ReqArg Interface "PATH")
      "path to the interface; uses module.jsi by default"
  ]

usage = usageInfo
  "Usage: jscc [options] module.js\nOptions:\n" options

main = do
  args <- getArgs
  dataDir <- getDataDir
  let (opts, nonOpts, errors) = getOpt RequireOrder options args
  unless (null errors) $ do
    mapM_ putStrLn  errors
    fail "jscc terminated"
  checkHelp opts
  (isDebugMode, opts) <- getDebugMode opts
  (namespace, opts) <- getNamespace opts
  (ifacePath, opts) <- getInterfacePath opts nonOpts
  when (not $ null opts) $ do
    putStrLn $ "spurious arguments: " ++ (show opts)
    fail "jscc terminated"
  case nonOpts of
    [implPath] -> do
      checkFile implPath
      rawImpl <- readFile implPath
      let boilerplatePath = dataDir </> "contracts.js"
      rawBoilerplate <- readFile boilerplatePath
      interface <- parseInterface ifacePath
      let result = if isDebugMode
                     then compileFormatted rawImpl implPath rawBoilerplate 
                            interface
                     else compileRelease rawImpl implPath rawBoilerplate
                            interface namespace
      putStrLn result
      return () 
    otherwise -> do
      putStrLn "expected a single filename.js"
      fail "jscc terminated"

checkFile path = do
  exists <- doesFileExist path
  unless exists $ do
    putStrLn $ "could not find the file: " ++ path
    exitFailure

getDebugMode (Release:rest) = return (False,rest)
getDebugMode (Debug:rest) = return (True,rest)
getDebugMode rest = return (True,rest)

getNamespace ((Namespace s):rest) = return (Just s, rest)
getNamespace rest = return (Nothing,rest)

checkHelp (Help:_) = do
  putStrLn usage
  exitSuccess
checkHelp _ = return ()

getInterfacePath :: [Flag] -> [String] -> IO (FilePath,[Flag])
getInterfacePath (Interface path:rest) _ = do
  checkFile path
  return (path,rest)
getInterfacePath rest (implPath:_) = do
  let path = addExtension (dropExtension implPath) "jsi"
  checkFile path
  return (path,rest)
getInterfacePath _ [] = do
  putStrLn "Invalid arguments (use -h for help)"
  exitFailure