huskc.hs

{- |
Module      : Main
Copyright   : Justin Ethier
Licence     : MIT (see LICENSE in the distribution)

Maintainer  : github.com/justinethier
Portability : portable

A front-end for the husk compiler
-}

module Main where
import Paths_husk_scheme
import Language.Scheme.Compiler
import Language.Scheme.Compiler.Types
import qualified Language.Scheme.Core
import Language.Scheme.Types     -- Scheme data types
import Language.Scheme.Variables -- Scheme variable operations
import Control.Monad.Error
import System.Cmd (system)
import System.Console.GetOpt
import System.FilePath (dropExtension)
import System.Environment
import System.Exit (ExitCode (..), exitWith, exitFailure)
import System.IO

main :: IO ()
main = do 

  -- Read command line args and process options
  args <- getArgs
  let (actions, nonOpts, msgs) = getOpt Permute options args
  opts <- foldl (>>=) (return defaultOptions) actions
  let Options {optOutput = output, optLibs = lib, optDynamic = dynamic, optCustomOptions = extra, optSchemeRev = langrev} = opts

  if null nonOpts
     then showUsage
     else do
        let inFile = nonOpts !! 0
            outHaskell = (dropExtension inFile) ++ ".hs"
            outExec = case output of
              Just inFile -> inFile
              Nothing -> dropExtension inFile
            extraOpts = case extra of
              Just args -> args
              Nothing -> ""
-- TODO: pass language revision
        process inFile outHaskell outExec lib dynamic extraOpts langrev

-- 
-- For an explanation of the command line options code, see:
-- http://leiffrenzel.de/papers/commandline-options-in-haskell.html
--

-- |Data type to handle command line options that take parameters
data Options = Options {
    optOutput :: Maybe String, -- Executable file to write
    optLibs :: Bool, -- Debug flag, whether to compile standard libraries
    optDynamic :: Bool, -- Flag for dynamic linking of compiled executable
    optCustomOptions :: Maybe String, -- Custom options to ghc
    optSchemeRev :: String -- Scheme Language version
    }

-- |Default values for the command line options
defaultOptions :: Options
defaultOptions = Options {
    optOutput = Nothing,
    optLibs = True,
    optDynamic = False,
    optCustomOptions = Nothing, 
    optSchemeRev = "5"
    }

-- |Command line options
options :: [OptDescr (Options -> IO Options)]
options = [
  Option ['r'] ["revision"] (ReqArg writeRxRSVersion "Scheme") "scheme RxRS version",
  Option ['V'] ["version"] (NoArg showVersion) "show version number",
  Option ['h', '?'] ["help"] (NoArg showHelp) "show usage information",
  Option ['o'] ["output"] (ReqArg writeExec "FILE") "output file to write",
  Option ['d'] ["dynamic"] (NoArg getDynamic) "use dynamic linking for the compiled executable",
  Option ['x'] ["extra"] (ReqArg getExtraArgs "Args") "extra arguments to ghc",

  Option [] ["debug"] (NoArg showDebug) "show debug information",
  Option [] ["nolibs"] (NoArg getNoLibs) "a DEBUG option to use interpreted libraries instead of compiling them"
  ]

writeRxRSVersion arg opt = return opt { optSchemeRev = arg }

-- |Determine executable file to write. 
--  This version just takes a name from the command line option
writeExec arg opt = return opt { optOutput = Just arg }

getNoLibs opt = return opt { optLibs = False }

getDynamic opt = return opt { optDynamic = True }

getExtraArgs arg opt = return opt { optCustomOptions = Just arg }

-- TODO: would nice to have this as well as a 'real' usage printout, perhaps via --help

-- |Print a usage message
showUsage :: IO ()
showUsage = do
  putStrLn "huskc: no input files"

showHelp :: Options -> IO Options
showHelp _ = do
  putStrLn "Usage: huskc [options] file"
  putStrLn ""
  putStrLn "  Options:"
  putStrLn ""
  putStrLn "  --help                Display this information"
  putStrLn "  --version             Display husk version information"
  putStrLn "  --revision rev        Specify the scheme revision to use:"
  putStrLn ""
  putStrLn "                          5 - r5rs (default)"
  putStrLn "                          7 - r7rs small"
  putStrLn ""
  putStrLn "  --output filename     Write executable to the given filename"
  putStrLn "  --dynamic             Use dynamic Haskell libraries, if available"
  putStrLn "                        (Requires libraries built via --enable-shared)"
  putStrLn "  --extra args          Pass extra arguments directly to ghc"
  putStrLn ""
  exitWith ExitSuccess

-- |Print debug information
showDebug :: Options -> IO Options
showDebug _ = do
  stdlib <- getDataFileName "lib/stdlib.scm"
  putStrLn $ "stdlib: " ++ stdlib
  putStrLn ""
  exitWith ExitSuccess

-- |Print version information
showVersion :: Options -> IO Options
showVersion _ = do
  Language.Scheme.Core.showBanner
  exitWith ExitSuccess

-- |High level code to compile the given file
process :: String -> String -> String -> Bool -> Bool -> String -> String -> IO ()
process inFile outHaskell outExec libs dynamic extraArgs langrev = do
  env <- case langrev of
            "7" -> Language.Scheme.Core.r7rsEnv'
            _ -> Language.Scheme.Core.r5rsEnv'
  stdlib <- getDataFileName "lib/stdlib.scm"
  srfi55 <- getDataFileName "lib/srfi/srfi-55.scm" -- (require-extension)

  let stdlibArg = if libs
                     then Just stdlib
                     else Nothing

  result <- (Language.Scheme.Core.runIOThrows $ liftM show $ compileSchemeFile env stdlibArg srfi55 inFile outHaskell langrev)
  case result of
   Just errMsg -> putStrLn errMsg
   _ -> compileHaskellFile outHaskell outExec dynamic extraArgs

-- |Compile a scheme file to haskell
compileSchemeFile :: Env -> Maybe String -> String -> String -> String -> String -> IOThrowsError LispVal
compileSchemeFile env stdlib srfi55 filename outHaskell langrev = do
  let conv :: LispVal -> String
      conv (String s) = s
      compileLibraries = case stdlib of
        Just _ -> True
        _ -> False

  -- TODO: clean this up later
  --moduleFile <- liftIO $ getDataFileName "lib/modules.scm"

  (String nextFunc, libsC, libSrfi55C, libModules) <- case (stdlib, langrev) of
    (Just stdlib', "5") -> do
      -- TODO: it is only temporary to compile the standard library each time. It should be 
      --       precompiled and just added during the ghc compilation
      libsC <- compileLisp env stdlib' "run" (Just "exec55")
      libSrfi55C <- compileLisp env srfi55 "exec55" (Just "exec55_3")
      --libModules <- compileLisp env moduleFile "exec55_2" (Just "exec55_3")
      liftIO $ Language.Scheme.Core.registerExtensions env getDataFileName
      return (String "exec", libsC, libSrfi55C, []) --libModules)
    (_, _) -> return (String "run", [], [], [])

  -- Initialize the compiler module and begin
  _ <- initializeCompiler env
  execC <- compileLisp env filename nextFunc Nothing

  -- Append any additional import modules
  List imports <- getNamespacedVar env 't' {-"internal"-} "imports"
  let moreHeaderImports = map conv imports

  outH <- liftIO $ openFile outHaskell WriteMode
  _ <- liftIO $ writeList outH headerComment
  _ <- liftIO $ writeList outH headerModule
  _ <- liftIO $ writeList outH $ map (\mod -> "import " ++ mod ++ " ") $ headerImports ++ moreHeaderImports
  filepath <- liftIO $ getDataFileName ""
  _ <- liftIO $ writeList outH $ header filepath compileLibraries langrev
  _ <- liftIO $ case compileLibraries of
    True -> do
      _ <- writeList outH $ map show libsC
      _ <- hPutStrLn outH " ------ END OF STDLIB ------"
      _ <- writeList outH $ map show libSrfi55C
      hPutStrLn outH " ------ END OF SRFI 55 ------"
      -- _ <- writeList outH $ map show libModules
      hPutStrLn outH " ------ END OF MODULES ------"
    False -> do
      hPutStrLn outH "exec _ _ _ _ = return $ Nil \"\"" -- Placeholder
  _ <- liftIO $ writeList outH $ map show execC
  _ <- liftIO $ hClose outH
  if not (null execC)
     then return $ Nil "" -- Dummy value
     else throwError $ Default "Empty file" --putStrLn "empty file"

-- |Compile the intermediate haskell file using GHC
compileHaskellFile :: String -> String -> Bool -> String -> IO() --ThrowsError LispVal
compileHaskellFile hsInFile objOutFile dynamic extraArgs = do
  let ghc = "ghc" -- Need to make configurable??
      dynamicArg = if dynamic then "-dynamic" else ""
  compileStatus <- system $ ghc ++ " " ++ dynamicArg ++ " " ++ extraArgs ++ " -cpp --make -package ghc -o " ++ objOutFile ++ " " ++ hsInFile

-- TODO: delete intermediate hs files if requested

  case compileStatus of
    ExitFailure _code -> exitWith compileStatus
    ExitSuccess -> return ()

-- |Helper function to write a list of abstract Haskell code to file
writeList outH (l : ls) = do
  hPutStrLn outH l
  writeList outH ls
writeList outH _ = do
  hPutStr outH ""