egisonc.hs

module Main where
import Language.Egison.Core
import Language.Egison.Types
import Language.Egison.Parser
import Control.Monad.Error
import System.Cmd (system)
import System.Console.GetOpt
import System.FilePath (dropExtension)
import System.Environment
import System.Directory (doesFileExist, copyFile, removeFile)
import System.Exit (ExitCode (..), exitWith, exitFailure)
import System.IO
import Paths_egison

templateFile :: String
templateFile = "etc/template.hs"

templateFileForTest :: String
templateFileForTest = "etc/template-for-test.hs"

main :: IO ()
main = do 
  args <- getArgs
  let (actions, nonOpts, _) = getOpt Permute options args
  let opts = foldl (flip id) defaultOptions actions
  case opts of
    Options {optShowHelp = True} -> printHelp
    Options {optShowVersion = True} -> printVersionNumber
    Options {optOutput = output} ->
      if null nonOpts
        then showUsage
        else do
          let inFile = nonOpts !! 0
              outExec = case output of
                Just outFile -> outFile
                Nothing -> dropExtension inFile
          process opts inFile outExec

data Options = Options {
    optShowVersion :: Bool,
    optShowHelp :: Bool,
    optOutput :: Maybe String,
    optProf :: Bool,
    optTest :: Bool
    }

showUsage :: IO ()
showUsage = do
  putStrLn "egisonc: no input files"
  
defaultOptions :: Options
defaultOptions = Options {
    optShowVersion = False,
    optShowHelp = False,
    optOutput = Nothing,
    optProf = False,
    optTest = False
    }

options :: [OptDescr (Options -> Options)]
options = [
  Option ['v', 'V'] ["version"]
    (NoArg (\opts -> opts {optShowVersion = True}))
    "show version number",
  Option ['h', '?'] ["help"]
    (NoArg (\opts -> opts {optShowHelp = True}))
    "show usage information",
  Option ['o'] ["output"]
    (ReqArg (\out opts -> opts {optOutput = Just out})
            "FILE")
    "output file to write",
  Option ['p'] ["prof"]
    (NoArg (\opts -> opts {optProf = True}))
    "use profiling system",
  Option ['t'] ["test"]
    (NoArg (\opts -> opts {optTest = True}))
    "execute test expressions"
  ]

printVersionNumber :: IO ()
printVersionNumber = do
  putStrLn egisonVersion
  exitWith ExitSuccess

printHelp :: IO ()
printHelp = do
  putStrLn "Usage: egisonc [options] file"
  putStrLn ""
  putStrLn "Options:"
  putStrLn "  --help                Display this information"
  putStrLn "  --version             Display egison version information"
  putStrLn "  --output filename     Write executable to the given filename"
  putStrLn "  --prof                Make use of GHC profiling system"
  putStrLn "  --test                Execute test expressions"
  putStrLn ""
  exitWith ExitSuccess

process :: Options -> String -> String -> IO ()
process opts inFile outExec = do
  result <- (runIOThrows $ liftM show $ createHaskellFile opts inFile)
  case result of
   Just errMsg -> putStrLn errMsg
   _ -> compileHaskellFile opts outExec

appendLoadExprForCoreLibraries :: [TopExpr] -> [TopExpr]
appendLoadExprForCoreLibraries topExprs = [(Load "lib/core/base.egi"),
                                           (Load "lib/core/number.egi"),
                                           (Load "lib/core/collection.egi"),
                                           (Load "lib/core/array.egi")
                                           ] ++ topExprs
   
createHaskellFile :: Options -> String -> IOThrowsError ()
createHaskellFile opts inFile =
  case opts of
    Options {optTest = True} -> do
      templatePath <- liftIO $ getDataFileName templateFileForTest
      liftIO $ copyFile templatePath "./_tmp.hs"
      egisonProgram <- liftIO $ readFile inFile
      topExprs <- liftThrows $ readTopExprList egisonProgram
      topExprs2 <- expandLoadExprs opts $ appendLoadExprForCoreLibraries topExprs
      liftIO $ appendFile "./_tmp.hs" "\ntopExprs :: [TopExpr]\n"
      liftIO $ appendFile "./_tmp.hs" "topExprs = "
      liftIO $ appendFile "./_tmp.hs" $ show topExprs2
      return ()
    _ -> do
      templatePath <- liftIO $ getDataFileName templateFile
      liftIO $ copyFile templatePath "./_tmp.hs"
      egisonProgram <- liftIO $ readFile inFile
      topExprs <- liftThrows $ readTopExprList egisonProgram
      topExprs2 <- expandLoadExprs opts $ appendLoadExprForCoreLibraries topExprs
      liftIO $ appendFile "./_tmp.hs" "\ntopExprs :: [TopExpr]\n"
      liftIO $ appendFile "./_tmp.hs" "topExprs = "
      liftIO $ appendFile "./_tmp.hs" $ show topExprs2
      return ()

expandLoadExprs :: Options -> [TopExpr] -> IOThrowsError [TopExpr]
expandLoadExprs _ [] = return []
expandLoadExprs opts ((LoadFile filename):topExprs) = do
  result <- liftIO $ doesFileExist filename
  if result
    then do
      loadProgram <- liftIO $ readFile filename
      loadTopExprs <- liftThrows $ readTopExprList loadProgram
      rets <- expandLoadExprs opts topExprs
      return $ loadTopExprs ++ rets
    else throwError $ Default $ "File does not exist: " ++ filename
expandLoadExprs opts ((Load libname):topExprs) = do
  filename <- liftIO (getDataFileName libname)
  result <- liftIO $ doesFileExist filename
  if result
    then do
      loadProgram <- liftIO $ readFile filename
      loadTopExprs <- liftThrows $ readTopExprList loadProgram
      rets <- expandLoadExprs opts topExprs
      return $ loadTopExprs ++ rets
    else throwError $ Default $ "Library does not exist: " ++ libname
expandLoadExprs opts (topExpr@(Test _):topExprs) =
  case opts of
    Options {optTest = True} -> do
      rets <- expandLoadExprs opts topExprs
      return $ topExpr:rets
    _ -> expandLoadExprs opts topExprs
expandLoadExprs opts (topExpr:topExprs) = do
  rets <- expandLoadExprs opts topExprs
  return $ topExpr:rets
  
compileHaskellFile :: Options -> String -> IO ()
compileHaskellFile opts filename = do
  let ghc = "ghc"
  case opts of
    Options {optProf = True} ->
      system $ ghc ++ " -prof -auto-all -o " ++ filename ++ " _tmp.hs"
    _ ->
      system $ ghc ++ " -O2 -o " ++ filename ++ " _tmp.hs"
  removeFile "./_tmp.hs"
  removeFile "./_tmp.hi"
  removeFile "./_tmp.o"
  return ()