haskeem-0.7.0: haskeem.hs

{- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>
Portions of this were derived from Jonathan Tang's haskell
tutorial "Write yourself a scheme in 48 hours" and are thus
Copyright Jonathan Tang
(but I can't easily tell anymore who originally wrote what)

This file is part of haskeem.
haskeem is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

haskeem is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with haskeem; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

$Id: haskeem.hs,v 1.27 2009-06-06 20:40:08 uwe Exp $ -}

module Main where
import Prelude
import IO
import System
import Monad()
import Control.Monad.Error as CME
import Control.OldException as CE
import Data.Char
import System.Console.Haskeline
import System.Posix.Signals()
import Control.Concurrent()
import Data.Typeable()

import LispData
import Parser
import Evaluator
import Environment
import Library

-- haskeem version

version :: String
version = "0.7.0"

-- a variable under which any command-line arguments to a script are
-- made available; empty for interactive mode

scriptArgs :: String
scriptArgs = "args"

-- a variable which is initially set to #t for the REPL, #f for script mode

interactive :: String
interactive = "interactive?"

-- the "EP" of the REPL, but also used in non-interactive parts:
-- the boolean "print" arg controls whether results are printed
-- (but errors are always printed)

evalAndPrint :: Env -> Bool -> String -> InputT IO ()
evalAndPrint env pflag expr =
  do ret <- liftIO (runErrorT (liftThrows (readExpr expr) >>= evalLisp env 0))
     case ret of
          Left err -> outputStrLn (show err)
          Right val -> if pflag then outputStrLn (show val) else outputStr ""
     return ()

-- if the environment variable HASKEEM_INIT is set, try to load that file

runInit :: Env -> InputT IO ()
runInit env =
  (do ret <- liftIO (CE.try (getEnv "HASKEEM_INIT"))
      case ret of
           Left err -> return ("(write-string \"no init file loaded: " ++
                               show err ++ "\n\")")
           Right val -> return ("(load \"" ++ val ++ "\")")) >>=
    evalAndPrint env False

-- set up bindings: primitives plus additional variables determined here

setupBindings :: [LispVal] -> Bool -> IO Env
setupBindings args inter =
  primitiveBindings >>= flip bindVars [(scriptArgs, List args),
                                       (interactive, Bool inter)]

-- interactive mode: print header, run initialization, then dive into REPL

writeHdr :: String -> IO ()
writeHdr prog =
  hPutStrLn stderr
    ("This is " ++ prog ++ " " ++ version ++
     " -- scheme in haskell\n" ++
     "Derived from Jonathan Tang's tutorial \"scheme in 48\"\n" ++
     "Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>\n" ++
     "Available under GPL V2 or later. Share and enjoy!\n" ++
     "http://www.korgwal.com/haskeem/\n")

-- the actual REPL, combined with tasty haskeline goodness

doREPL :: Env -> InputT IO ()
doREPL env =
  do maybeLine <- getInputLine "lisp> "
     case maybeLine of 
          Nothing -> outputStrLn "g'bye!" >> return ()
          Just "quit" -> return ()
          Just line -> if isBlank line
                          then doREPL env
                          else evalAndPrint env True line >> doREPL env
  where isBlank [] = True
        isBlank _ = False

runREPL :: IO ()
runREPL =
  do getProgName >>= writeHdr
     env <- setupBindings [] True
     runInputT defaultSettings (runInit env >> doREPL env)

-- non-interactive mode: do initialization, then run a script
-- specified on the command line, with any extra args stored in the
-- top-level args variable defined above

runOne :: [String] -> IO ()
runOne args =
  do env <- setupBindings (map String (drop 1 args)) False
     runInputT defaultSettings
               (runInit env >>
                evalAndPrint env False ("(load \"" ++ (args !! 0) ++ "\")"))

main :: IO ()
main =
  do args <- getArgs
     if null args then runREPL else runOne args