haskeem-0.7.4: haskeem_readline.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.24 2008-03-06 03:09:43 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.Readline
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 -> IO ()
evalAndPrint env print expr =
  do ret <- runErrorT (liftThrows (readExpr expr) >>= evalLisp env 0)
     case ret of
          Left err -> hPutStrLn stderr (show err)
          Right val -> if print then putStrLn (show val) else putStr ""

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

runInit :: Env -> IO ()
runInit env =
  (do ret <- CE.try (getEnv "HASKEEM_INIT")
      case ret of
           Left err -> return "(write-string \"no init file loaded\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, Boolean inter)]

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

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")

-- this readline and addHistory are for machines without gnu readline

readline :: String -> IO (Maybe String)
readline prompt =
  do putStr prompt
     hFlush stdout
     ret <- CE.try (getLine)
     case ret of
          Left err -> do hPutStrLn stderr "g'bye!"
                         exitWith (ExitFailure 1)
          Right val -> return (Just val)

addHistory :: String -> IO ()
addHistory foo = putStr ""

-- the actual REPL, combined with tasty gnu readline goodness

data MyInterrupt = MyInt deriving Typeable

catcher :: MyInterrupt -> IO ()
catcher e = hPutStrLn stderr "Interrupt!"

doREPL :: Env -> IO ()
doREPL env =
  do maybeLine <- readline "lisp> "
     case maybeLine of 
          Nothing -> putStrLn "g'bye!"
          Just "quit" -> return ()
          Just line -> if isBlank line
                          then doREPL env
                          else do addHistory line
                                  catchDyn (evalAndPrint env True line)
                                           (\e -> catcher e)
                                  doREPL env
  where isBlank [] = True
        isBlank _ = False

mysighandler tid = Catch (throwDynTo tid MyInt)

runREPL :: IO ()
runREPL =
  do getProgName >>= writeHdr
     env <- setupBindings [] True
     runInit env
     tid <- myThreadId
     installHandler sigINT (mysighandler tid) Nothing
     installHandler sigQUIT (mysighandler tid) Nothing
     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
     runInit env
     evalAndPrint env False ("(load \"" ++ (args !! 0) ++ "\")")

main =
  do args <- getArgs
     if null args then runREPL else runOne args