shell.hs

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

Maintainer  : github.com/justinethier
Stability   : experimental
Portability : portable

This file implements a REPL /shell/ to host the interpreter, and also
allows execution of stand-alone files containing Scheme code.
-}

module Main where
import qualified Language.Scheme.Core as LSC -- Scheme Interpreter
import Language.Scheme.Types                 -- Scheme data types
import qualified Language.Scheme.Util as LSU (countAllLetters, countLetters, strip)
import qualified Language.Scheme.Variables as LSV -- Scheme variable operations
import Control.Monad.Error
import qualified Data.Char as DC
import qualified Data.List as DL
import Data.Maybe (fromMaybe)
import System.Console.GetOpt
import qualified System.Console.Haskeline as HL
import qualified System.Console.Haskeline.Completion as HLC
import System.Environment
import System.Exit (exitSuccess)
import System.IO

main :: IO ()
main = do 
  args <- getArgs

  let (actions, nonOpts, _) = getOpt Permute options args
  opts <- foldl (>>=) (return defaultOptions) actions
  let Options {optInter = interactive, optSchemeRev = schemeRev} = opts

  if null nonOpts
     then do 
       LSC.showBanner
       env <- liftIO $ getRuntimeEnv schemeRev
       runRepl env
     else do
         runOne (getRuntimeEnv schemeRev) nonOpts interactive

--
-- Command line options section
--

data Options = Options {
    optInter :: Bool,
    optSchemeRev :: String -- RxRS version
    }

-- |Default values for the command line options
defaultOptions :: Options
defaultOptions = Options {
    optInter = False,
    optSchemeRev = "5"
    }
options :: [OptDescr (Options -> IO Options)]
options = [
  Option ['i'] ["interactive"] (NoArg getInter) "load file and run REPL",
  Option ['r'] ["revision"] (ReqArg writeRxRSVersion "Scheme") "scheme RxRS version",
  Option ['h', '?'] ["help"] (NoArg showHelp) "show usage information"
  ]
 where
  getInter opt = return opt { optInter = True }
  writeRxRSVersion arg opt = return opt { optSchemeRev = arg }

showHelp :: Options -> IO Options
showHelp _ = do
  putStrLn "Usage: huski [options] [file]"
  putStrLn ""
  putStrLn "  huski is the husk scheme interpreter."
  putStrLn ""
  putStrLn "  File is a scheme source file to execute. If no file is specified"
  putStrLn "  the husk REPL will be started."
  putStrLn ""
  putStrLn "  Options may be any of the following:"
  putStrLn ""
  putStrLn "  -h, --help      Display this information"
  putStrLn "  -i              Start interactive REPL after file is executed. This"
  putStrLn "                  option has no effect if a file is not specified. "
--  putStrLn "  --revision rev   Specify the scheme revision to use:"
--  putStrLn ""
--  putStrLn "                     5 - r5rs (default)"
--  putStrLn "                     7 - r7rs small"
  putStrLn ""
  exitSuccess

--
-- REPL Section
--

flushStr :: String -> IO ()
flushStr str = putStr str >> hFlush stdout

getRuntimeEnv :: String -> IO Env
getRuntimeEnv "7" = LSC.r7rsEnv
getRuntimeEnv _ = LSC.r5rsEnv

-- |Execute a single scheme file from the command line
runOne :: IO Env -> [String] -> Bool -> IO ()
runOne initEnv args interactive = do
  env <- initEnv >>= flip LSV.extendEnv
                          [((LSV.varNamespace, "args"),
                           List $ map String $ drop 1 args)]

  result <- (LSC.runIOThrows $ liftM show $ 
             LSC.evalLisp env (List [Atom "load", String (head args)]))
  _ <- case result of
    Just errMsg -> putStrLn errMsg
    _  -> do 
      -- Call into (main) if it exists...
      alreadyDefined <- liftIO $ LSV.isBound env "main"
      let argv = List $ map String args
      when alreadyDefined (do 
        mainResult <- (LSC.runIOThrows $ liftM show $ 
                       LSC.evalLisp env (List [Atom "main", List [Atom "quote", argv]]))
        case mainResult of
          Just errMsg -> putStrLn errMsg
          _  -> return ())
  when interactive (do
    runRepl env)

-- |Start the REPL (interactive interpreter)
runRepl :: Env -> IO ()
runRepl env' = do
    let settings = HL.Settings (completeScheme env') Nothing True
    HL.runInputT settings (loop env')
    where
        -- Main REPL loop
        loop :: Env -> HL.InputT IO ()
        loop env = do
            minput <- HL.getInputLine "huski> "
            case minput of
                Nothing -> return ()
                Just i -> do 
                  case LSU.strip i of
                    "quit" -> return ()
                    "" -> loop env -- ignore inputs of just whitespace
                    input -> do
                        inputLines <- getMultiLine [input]
                        let input' = unlines inputLines
                        result <- liftIO (LSC.evalString env input')
                        if not (null result)
                           then do HL.outputStrLn result
                                   loop env
                           else loop env

        -- Read another input line, if necessary
        getMultiLine previous = do
          if test previous
            then do
              mb_input <- HL.getInputLine ""
              case mb_input of
                Nothing -> return previous
                Just input -> getMultiLine $ previous ++ [input]
            else return previous

        -- Check if we need another input line
        -- This just does a bare minimum, and could be more robust
        test ls = do
          let cOpen  = LSU.countAllLetters '(' ls
              cClose = LSU.countAllLetters ')' ls
          cOpen > cClose

-- |Auto-complete using scheme symbols
completeScheme :: Env -> (String, String) 
               -> IO (String, [HLC.Completion])
-- Right after a ')' it seems more useful to autocomplete next closed parenthesis
completeScheme _ (lnL@(')':_), _) = do
  let cOpen  = LSU.countLetters '(' lnL
      cClose = LSU.countLetters ')' lnL
  if cOpen > cClose
   then return (lnL, [HL.Completion ")" ")" False])
   else return (lnL, [])
completeScheme env (lnL, lnR) = do
   complete $ reverse $ readAtom lnL
 where
  complete ('"' : _) = do
    -- Special case, inside a string it seems more
    -- useful to autocomplete filenames
    liftIO $ HLC.completeFilename (lnL, lnR)


  complete pre = do
   -- Get list of possible completions from ENV
   xps <- LSV.recExportsFromEnv env
   let allDefs = xps ++ specialForms
   let allDefs' = filter (\ (Atom a) -> DL.isPrefixOf pre a) allDefs
   let comps = map (\ (Atom a) -> HL.Completion a a False) allDefs'

   -- Get unused portion of the left-hand string
   let unusedLnL = fromMaybe lnL (DL.stripPrefix (reverse pre) lnL)
   return (unusedLnL, comps)

  -- Not loaded into an env, so we need to list them here
  specialForms = map Atom [ 
       "define"  
     , "define-syntax" 
     , "expand"
     , "hash-table-delete!"
     , "hash-table-set!"
     , "if"
     , "lambda"
     , "let-syntax" 
     , "letrec-syntax" 
     , "quote"
     , "set!"
     , "set-car!"
     , "set-cdr!"
     , "string-set!"
     , "vector-set!"]

  -- Read until the end of the current symbol (atom), if there is one.
  -- There is also a special case for files if a double-quote is found.
  readAtom (c:cs)
    | c == '"' = ['"'] -- Save to indicate file completion to caller
    | c == '(' = []
    | c == '[' = []
    | DC.isSpace c = []
    | otherwise = (c : readAtom cs)
  readAtom [] = []