haskeem-0.7.16: Evaluator.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 there isn't much of his stuff left).

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: evaluator.hs,v 1.51 2010-01-18 00:08:49 uwe Exp $ -}

{-# LANGUAGE FlexibleContexts #-}

module Evaluator (evalLisp, evalPP) where
import Prelude
import IO
import Control.Exception as CE()
import Control.Monad.Error as CME
import Data.IORef()
import qualified Data.IntMap as DIM

import LispData
import Environment
import Library

errNumArgs :: MonadError LispError m =>
  String -> Integer -> [LispVal] -> m a
errNumArgs name want = throwError . NumArgs name want

errTypeMismatch :: MonadError LispError m =>
  String -> String -> LispVal -> m a
errTypeMismatch name want = throwError . TypeMismatch name want

errBadForm :: MonadError LispError m => String -> [LispVal] -> m a
errBadForm name =
  throwError . BadSpecial ("bad " ++ name ++ " form") . List

-- Debugging output: either inside haskeem while tracing something,
-- or inside haskeem while debugging haskeem

remark :: MonadIO m => String -> m ()
remark = liftIO . hPutStrLn stderr

mapML :: Monad m => (a -> m LispVal) -> [a] -> m LispVal
mapML fn lst = mapMLA (List []) fn lst
  where mapMLA r _ [] = return r
        mapMLA _ f (x:xs) =
           do rn <- f x
              mapMLA rn f xs

isTrue :: LispVal -> Bool
isTrue (Boolean False) = False
isTrue _ = True

-- Check that a variable is unique in a list,
-- for the various forms of "let" and for "do"

uniqCheck :: String -> [LispVal] -> Bool
uniqCheck _ [] = True
uniqCheck name ((List (Symbol var : _)) : rest) =
  if name == var then False else uniqCheck name rest
uniqCheck _ _ = progError "uniqCheck"

-- Check the variable bindings in the various forms of "let".
-- The "uniq" boolean argument specifies whether or not multiple
-- instances of the same name are allowed.

letCheck :: Bool -> [LispVal] -> Bool
letCheck _ [] = True
letCheck uniq ((List [Symbol var, _]) : rest) =
  letCheck uniq rest && (not uniq || (uniq && uniqCheck var rest))
letCheck _ _ = False

-- Ditto for "do", except that we have two kinds of syntax:
-- (var-name init-expr step-expr) and (var-name init-expr)

doCheck :: [LispVal] -> Bool
doCheck [] = True
doCheck ((List [Symbol var, _]) : rest) =
  doCheck rest && uniqCheck var rest
doCheck ((List [Symbol var, _, _]) : rest) =
  doCheck rest && uniqCheck var rest
doCheck _ = False

-- Ditto for "define", "defmacro", and "lambda" params lists and dotted-lists

paramsCheck :: [LispVal] -> Bool
paramsCheck [] = True
paramsCheck (Symbol var : rest) =
  paramsCheck rest && uC var rest
  where uC _ [] = True
        uC name (Symbol var2 : rmdr) =
           if name == var2 then False else uC name rmdr
        uC _ _ = progError "paramsCheck"
paramsCheck _ = False

-- This is the apply function, the generic
-- omnipotent thing that does all the work

doApply :: Bool -> String -> [String] -> (Maybe String) -> [LispVal]
           -> Env -> EEnv -> [LispVal] -> Bool -> IOThrowsError LispVal
doApply trace name params varargs body closure eenv args cflag =
  if num params /= num args && varargs == Nothing
     then errNumArgs (show body) (num params) args
     else do let app = zip params args
                 ca = head app
             prtTrace
             envn <- liftIO (bindVars closure app) >>= bindVarArgs varargs
             let een = eeNewE eenv envn
                 eenc = eeNewPE een (ca : eePE een)
             evalBody (if cflag then eenc else een)
  where remainingArgs = drop (length params) args
        num = toInteger . length
        evalBody ee = mapML (evalLisp ee) body
        bindVarArgs arg env =
          case arg of
               Just argName ->
                    liftIO (bindVars env [(argName, List remainingArgs)])
               Nothing -> return env
        prtTrace =
          if trace
             then remark ("trace: " ++ name ++ " <- " ++ show (List args))
                  >> return True
             else return False

apply :: EEnv -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply _ (Prim func) args = liftThrows (func args)
apply _ (IOPrim func) args = func args
apply eenv (Func params varargs body closure Nothing _ cflag) args =
  doApply False "" params varargs body closure eenv args cflag
apply eenv (Func params varargs body closure (Just name) _ cflag) args =
  doApply True name params varargs body closure eenv args cflag
apply _ func _ = throwError (NotFunction "apply got non-function" func)

makeFunc, makeMacro ::
  Monad m => Maybe String -> Env -> [LispVal] -> [LispVal] -> m LispVal

makeFunc varargs env params body =
  return (Func (map show params) varargs body env Nothing False False)
makeMacro varargs env params body =
  return (Func (map show params) varargs body env Nothing True False)

makeNormalFunc, makeNormalMacro ::
  Monad m => Env -> [LispVal] -> [LispVal] -> m LispVal

makeNormalFunc = makeFunc Nothing
makeNormalMacro = makeMacro Nothing

makeVarargsFunc, makeVarargsMacro ::
  Monad m => LispVal -> Env -> [LispVal] -> [LispVal] -> m LispVal

makeVarargsFunc = makeFunc . Just . show
makeVarargsMacro = makeMacro . Just . show

makeContFunc :: Monad m => Env -> [LispVal] -> [LispVal] -> m LispVal
makeContFunc env params body =
  return (Func (map show params) Nothing body env Nothing False True)

specialForms :: [String]
specialForms = ["and", "apply", "begin", "case", "cond", "define",
                "defmacro", "delay", "do", "eval", "force", "gensym",
                "guard", "if", "lambda", "let", "let*", "letrec",
                "letrec*", "load", "or", "quasiquote", "quote", "set!",
                "unquote", "unquote-splicing", "vector-fill!",
                "vector-set!", "reset", "shift ",
                "trace", "dump-bindings"]

isSpecialForm, isInt, isStr, isList, isDL, isVec :: LispVal -> Bool

isSpecialForm (Symbol sym) = seek sym specialForms
  where seek _ [] = False
        seek s (sf:sfs) = (s == sf) || seek s sfs
isSpecialForm _ = False

isInt (IntNumber _) = True
isInt _ = False

getInt :: LispVal -> Integer
getInt (IntNumber n) = n
getInt _ = progError "getInt"

isStr (String _) = True
isStr _ = False

getStr :: LispVal -> String
getStr (String s) = s
getStr _ = progError "getStr"

isList (List _) = True
isList _ = False

getList :: LispVal -> [LispVal]
getList (List l) = l
getList _ = progError "getList"

isDL (DottedList _ _) = True
isDL _ = False

getDLh :: LispVal -> [LispVal]
getDLh (DottedList h _) = h
getDLh _ = progError "getDLh"

getDLt :: LispVal -> LispVal
getDLt (DottedList _ t) = t
getDLt _ = progError "getDLt"

isVec (Vector _ _) = True
isVec _ = False

getVecL :: LispVal -> Integer
getVecL (Vector l _) = l
getVecL _ = progError "getVecL"

getVecV :: LispVal -> DIM.IntMap LispVal
getVecV (Vector _ v) = v
getVecV _ = progError "getVecV"

-- This is an internal symbol which temporarily replaces "unquote" and
-- "unquote-splicing" after these have evaluated the expression(s): evalQQ
-- looks for this marker and lifts the remainder of the list up by one
-- level, turning (1 2 (' unq' 7)) into (1 2 7): this makes `(1 2 ,(+ 3 4))
-- come out right (otherwise it turns into (1 2 (7)). Notice that this
-- begins with a space: that's necessary to guarantee there will be no
-- collisions with user-generated symbols.

unq :: String
unq = " unq"

-- This is the list-context unquote-lifting function:

liftLUnq :: [LispVal] -> [LispVal]
liftLUnq lst = lunq [] lst
  where lunq acc [] = acc
        lunq acc (l@(List ((Symbol sym):vals)):ls) =
          if sym == unq
             then lunq (acc ++ vals) ls
             else lunq (acc ++ [l]) ls
        lunq acc (l:ls) = lunq (acc ++ [l]) ls

-- and the scalar-context equivalent

liftSUnq :: LispVal -> IOThrowsError LispVal
liftSUnq l@(List ((Symbol sym):vals)) =
  if sym == unq
     then if length vals == 1
             then return (head vals)
             else throwError (Default "list unquote form in scalar context")
     else return l
liftSUnq v = return v

-- evalQQ is more or less a specialized version of evalLisp: It just walks
-- the tree, returning everything unevaluated, except if it finds an unquote
-- or an unquote-splicing at the right quote level; these it evaluates via
-- evalLisp and patches into the tree

evalQQ :: EEnv -> LispVal -> IOThrowsError LispVal

-- "quasiquote", "unquote", and "unquote-splicing" might get evaluated,
-- depending on quote level

evalQQ eenv (List [Symbol "quasiquote", arg]) =
  do val <- evalQQ (eeQLIncr eenv) arg >>= liftSUnq
     return (List [Symbol "quasiquote", val])

evalQQ eenv (List (Symbol "unquote" : args)) =
  let een = eeQLDecr eenv
  in if eeQL eenv == 1
        then do vals <- mapM (evalLisp een) args
                return (List (Symbol unq : vals))
        else do vals <- mapM (evalQQ een) args
                return (List (Symbol "unquote" : liftLUnq vals))

evalQQ eenv (List (Symbol "unquote-splicing" : args)) =
  let een = eeQLDecr eenv
  in if eeQL eenv == 1
        then do vals <- mapM (evalLisp een) args
                if isLL vals
                   then return (List (Symbol unq : peel vals))
                   else throwError (Default ("bad unquote-splicing form: " ++
                                   show args))
        else do vals <- mapM (evalQQ een) args
                return (List (Symbol "unquote-splicing" : liftLUnq vals))
  where isLL [] = True
        isLL ((List _):ls) = isLL ls
        isLL _ = False
        peel [] = []
        peel ((List l):ls) = l ++ peel ls
        peel _ = progError "evalQQ/unquote-splicing"

-- lists, dotted-lists, and vectors get traversed

evalQQ eenv (List con) = mapM (evalQQ eenv) con >>= return . List . liftLUnq

evalQQ eenv (DottedList con cab) =
  do vals <- mapM (evalQQ eenv) con
     vcab <- evalQQ eenv cab >>= liftSUnq
     let h = liftLUnq vals
     if isList vcab
        then return (List (h ++ getList vcab))
        else if isDL vcab
                then return (DottedList (h ++ getDLh vcab) (getDLt vcab))
                else return (DottedList h vcab)

evalQQ eenv (Vector _ con) =
  do vals <- mapM (evalQQ eenv) (remkey (DIM.toAscList con))
     let new = DIM.fromAscList (addkey 0 (liftLUnq vals))
     return (Vector (toInteger (DIM.size new)) new)
  where remkey [] = []
        remkey ((_, v) : vs) = v : remkey vs
        addkey _ [] = []
        addkey n (v:vs) = (n, v) : addkey (n+1) vs

-- anything else gets returned unchanged

evalQQ _ val@_ = return val

-- evalPP is another specialized version of evalLisp: it also walks
-- the tree and turns the del-cont operators into their internal form,
-- which has a unique identifier attached. The unique identifier is to
-- be able to identify which is the current hole in an expression if
-- there are several interior operators enclosed within the scope of
-- an exterior operator.

-- TODO: check shift operators for syntactic correctness here?
-- ie, check that the first arg is a symbol and not something else?
-- probably a good idea...

evalPP :: EEnv -> LispVal -> IOThrowsError LispVal

evalPP eenv (List (Symbol "shift" : arg)) =
  do let env = eeE eenv
     argn <- mapM (evalPP eenv) arg
     cval <- getVar env contCounter
     let count = getInt cval
         csym = " cont." ++ show count
     setVar env contCounter (IntNumber (count + 1))
     return (List (Symbol "shift " : Symbol csym : argn))

evalPP eenv (List args) = mapM (evalPP eenv) args >>= return . List

-- everything else gets returned unchanged

evalPP _ val = return val

-- This is the main evaluator

evalLisp :: EEnv -> LispVal -> IOThrowsError LispVal

-- various simple things which evaluate to themselves

evalLisp _ val@(String _) = return val
evalLisp _ val@(IntNumber _) = return val
evalLisp _ val@(RatNumber _) = return val
evalLisp _ val@(FltNumber _) = return val
evalLisp _ val@(Boolean _) = return val
evalLisp _ val@(Char _) = return val
evalLisp _ (List []) = return (List [])
evalLisp eenv (Symbol ident) = getVar (eeE eenv) ident

-- Special forms must go here, before the generic (function : args) stuff

-- TODO: implement set-car! and set-cdr! (but how?)

-- (apply) doesn't strictly need to be a special form, but it's far more
-- convenient to have it here; otherwise, we have to do all sorts of
-- twisting to make it all work.

evalLisp eenv (List (Symbol "apply" : fn : args)) =
  do func <- evalLisp eenv fn
     argVals <- mapM (evalLisp eenv) args
     appp (func:argVals)
  where appp [f, List as] = apply eenv f as
        appp (f : as) = apply eenv f as
        appp _ = progError "evalLisp/apply"

-- TODO: this is not a special form according to R6RS; the only reason
-- I put it here is because evalLisp wants an environment, and that's
-- provided here more conveniently than in library.hs. In order to
-- make stuff like "(map eval (list 'foo 'bar 'baz))" work in addition
-- to "(eval 'foo)", there is a hack "(define (eval x) (eval x))" in
-- stdlib.scm. Hmmm... reading R6RS more closely, it seems that they
-- do not make eval work in the current environment; it's some
-- sanitized top-level environment. That would make it possible to
-- move this into the libraries... I'd just have to provide access to
-- the (or a) top-level environment.

evalLisp eenv (List (Symbol "eval" : args)) =
  mapM (evalPP eenv) args >>= mapM (evalLisp eenv) >>= mapML (evalLisp eenv)

-- TODO: This is also not a special form according to R6RS; I think I
-- could also make it a regular function, but it has the same issues
-- as "eval".  It would most likely be safe to just provide access to
-- the top-level environment here; it's really unlikely that anyone
-- wants to (or should be able to) call (load) from within some
-- function and modify the environment seen within that function.

evalLisp eenv (List [Symbol "load", arg]) =
  do fname <- evalLisp eenv arg
     if isStr fname
        then loadFile (getStr fname) >>=
             mapM (evalPP eenv) >>= mapML (evalLisp eenv)
        else throwError (Default ("bad load form: " ++
                                  show fname ++ " is not a string"))

evalLisp eenv (List (Symbol "begin" : args)) = mapML (evalLisp eenv) args

evalLisp _ (List [Symbol "quote", val]) = return val

evalLisp eenv (List [Symbol "quasiquote", val]) =
  evalQQ (eeQLIncr eenv) val >>= liftSUnq

evalLisp _ (List (Symbol "unquote" : args)) =
  throwError (Default ("naked unquote form: " ++ show args))

evalLisp _ (List (Symbol "unquote-splicing" : args)) =
  throwError (Default ("naked unquote-splicing form: " ++ show args))

evalLisp eenv (List [Symbol "set!", Symbol var, val]) =
  evalLisp eenv val >>= setVar (eeE eenv) var

evalLisp eenv (List [Symbol "vector-set!", Symbol var, indx, obj]) =
  do vec <- evalLisp eenv (Symbol var)
     if isVec vec
        then do lk <- evalLisp eenv indx
                let l = getVecL vec
                    k = getInt lk
                if isInt lk && k >= 0 && k < l
                   then do val <- evalLisp eenv obj
                           setVar (eeE eenv) var (Vector l
                             (DIM.insert (fromInteger k) val (getVecV vec)))
                   else throwError (VectorBounds l lk)
        else throwError (Default ("bad vector-set! form: " ++
                                  show var ++ " is not a vector"))

evalLisp eenv (List [Symbol "vector-fill!", Symbol var, obj]) =
  do vec <- evalLisp eenv (Symbol var)
     if isVec vec
        then do val <- evalLisp eenv obj
                let n = getVecL vec
                setVar (eeE eenv) var (Vector n (DIM.fromAscList
                  (addkey val (fromInteger n))))
        else throwError (Default ("bad vector-fill! form: " ++
                                  show var ++ " is not a vector"))
  where addkey _ 0 = []
        addkey v n = ((n-1), v) : addkey v (n-1)

evalLisp eenv (List [Symbol "vector-resize!", Symbol var, obj]) =
  do vec <- evalLisp eenv (Symbol var)
     if isVec vec
        then do lk <- evalLisp eenv obj
                let l = getVecL vec
                    k = getInt lk
                if isInt lk && k > 0
                   then do let new = if k < l
                                        then rmv (getVecV vec) l k
                                        else add (getVecV vec) k l
                           setVar (eeE eenv) var (Vector k new)
                   else throwError (Default ("bad vector-resize! size: " ++
                                             show k))
        else throwError (Default ("bad vector-resize! form: " ++
                                  show var ++ " is not a vector"))
  where rmv vec h l =
          if h == l
             then vec
             else rmv (DIM.delete (fromInteger l) vec) h (l + 1)
        add vec h l =
          if h == l
             then vec
             else add (DIM.insert (fromInteger l) lispFalse vec) h (l + 1)

evalLisp eenv (List [Symbol "define", Symbol var, val]) =
  do let env = eeE eenv
     defineVar env var lispFalse
     evalLisp eenv val >>= setVar env var
evalLisp eenv (List [Symbol "define", Symbol var]) =
  defineVar (eeE eenv) var lispFalse
evalLisp (EEnv env _ _ _)
    (List (Symbol "define" : List (Symbol var : params) : body)) =
  if paramsCheck params
     then do defineVar env var lispFalse
             makeNormalFunc env params body >>= setVar env var
     else errBadForm "define" params
evalLisp (EEnv env _ _ _) (List (Symbol "define" :
    DottedList (Symbol var : params) varargs : body)) =
  if paramsCheck (params ++ [varargs])
     then do defineVar env var lispFalse
             makeVarargsFunc varargs env params body >>= setVar env var
     else errBadForm "define" [DottedList params varargs]

evalLisp (EEnv env _ _ _)
    (List (Symbol "defmacro" : List (Symbol var : params) : body)) =
  if paramsCheck params
     then do defineVar env var lispFalse
             makeNormalMacro env params body >>= setVar env var
     else errBadForm "defmacro" params
evalLisp (EEnv env _ _ _) (List (Symbol "defmacro" :
    DottedList (Symbol var : params) varargs : body)) =
  if paramsCheck (params ++ [varargs])
     then do defineVar env var lispFalse
             makeVarargsMacro varargs env params body >>= setVar env var
     else errBadForm "defmacro" [DottedList params varargs]

evalLisp eenv (List (Symbol "lambda" : List params : body)) =
  if paramsCheck params
     then makeNormalFunc (eeE eenv) params body
     else errBadForm "lambda" params
evalLisp eenv
    (List (Symbol "lambda" : DottedList params varargs : body)) =
  if paramsCheck (params ++ [varargs])
     then makeVarargsFunc varargs (eeE eenv) params body
     else errBadForm "lambda" [DottedList params varargs]
evalLisp eenv (List (Symbol "lambda" : varargs@(Symbol _) : body)) =
  makeVarargsFunc varargs (eeE eenv) [] body

evalLisp eenv (List [Symbol "if", pr, tcase, fcase]) =
  do result <- evalLisp eenv pr
     case result of
          Boolean False -> evalLisp eenv fcase
          _ -> evalLisp eenv tcase
evalLisp eenv (List [Symbol "if", pr, tcase]) =
  do result <- evalLisp eenv pr
     case result of
          Boolean False -> return lispFalse
          _ -> evalLisp eenv tcase

evalLisp eenv (List (Symbol "and" : args)) = eva (eeE eenv) args lispTrue
  where eva _ [] ret = return ret
        eva env (t:ts) _ =
          do result <- evalLisp eenv t
             case result of
                  Boolean False -> return lispFalse
                  _ -> eva env ts result

evalLisp eenv (List (Symbol "or" : args)) = evo (eeE eenv) args lispFalse
  where evo _ [] ret = return ret
        evo env (t:ts) _ =
          do result <- evalLisp eenv t
             case result of
                  Boolean False -> evo env ts result
                  _ -> return result

evalLisp _ (List [Symbol "cond"]) = return lispFalse
evalLisp eenv (List (Symbol "cond" : args)) =
  if all isList args
     then evc (eeE eenv) args
     else errTypeMismatch "cond" "cond-clauses" (String (show args))
  where evc _ [] = return lispFalse
        evc env (cl:cls) = do (tst,val) <- evc_clause env cl
                              if tst then return val else evc env cls
        evc_clause _ (List (Symbol "else" : as)) =
          do ret <- mapML (evalLisp eenv) as
             return (True, ret)
        evc_clause env (List (pr : as)) =
          do tst <- evalLisp eenv pr
             case tst of
                  Boolean False -> return (False, lispFalse)
                  _ -> do ret <- if isArrow as
                                    then evcArrow env as tst
                                    else mapML (evalLisp eenv) as
                          return (True, ret)
        evc_clause _ _ = return (False, lispFalse)
        isArrow [Symbol "=>", _] = True
        isArrow _ = False
        evcArrow env [Symbol "=>", proc] val =
          let een = eeNewE eenv env
          in evalLisp een proc >>= flip (apply een) [val]
        evcArrow _ _ _ = progError "evalLisp/cond/evcArrow"

evalLisp eenv (List (Symbol "let" : List params : body)) =
  if letCheck True params
     then do func <- makeNormalFunc (eeE eenv) (map exn params) body
             mapM (evalLisp eenv . exv) params >>= apply eenv func
     else errBadForm "let" params
  where exn (List [Symbol var, _]) = Symbol var
        exn _ = progError "evalLisp/let/exn1"
        exv (List [Symbol _, val]) = val
        exv _ = progError "evalLisp/let/exv1"

evalLisp eenv
    (List (Symbol "let" : Symbol lname : List params : body)) =
  if letCheck True params
     then do envn <- liftIO (bindVars (eeE eenv) [(lname, lispFalse)])
             func <- makeNormalFunc envn (map exn params) body
             setVar envn lname func
             mapM (evalLisp eenv . exv) params >>= apply eenv func
     else errBadForm "named-let" params
  where exn (List [Symbol var, _]) = Symbol var
        exn _ = progError "evalLisp/let/exn2"
        exv (List [Symbol _, val]) = val
        exv _ = progError "evalLisp/let/exv2"

evalLisp eenv (List (Symbol "let*" : List params : body)) =
  if letCheck False params
     then dols params body (eeE eenv)
     else errBadForm "let*" params
  where dols [] b env = mapML (evalLisp (eeNewE eenv env)) b
        dols (p:ps) b env =
             do val <- evalLisp (eeNewE eenv env) (exv p)
                liftIO (bindVars env [(exn p, val)]) >>= dols ps b
        exn (List [Symbol var, _]) = var
        exn _ = progError "evalLisp/let*/exn"
        exv (List [Symbol _, val]) = val
        exv _ = progError "evalLisp/let*/exv"

evalLisp eenv (List (Symbol "letrec" : List params : body)) =
  if letCheck True params
     then dolr params body (eeE eenv)
     else errBadForm "letrec" params
  where dolr ps b env =
          do let varn = map exn ps
             envn <- liftIO (bindVars env varn)
             let een = eeNewE eenv envn
             varv <- mapM (evalLisp een . exv) ps
             mapM_ (doSet envn) (repl varn varv) >> mapML (evalLisp een) b
        exn (List [Symbol var, _]) = (var, lispFalse)
        exn _ = progError "evalLisp/letrec/exn"
        exv (List [Symbol _, val]) = val
        exv _ = progError "evalLisp/letrec/exv"
        repl [] [] = []
-- TODO: fix this! it's infelicitous... would prefer to not know
-- what lispFalse looks like on the inside
        repl ((n, Boolean False):ns) (v:vs) = (n, v) : repl ns vs
        repl _ _ = progError "evalLisp/letrec/repl"
        doSet env (n,v) = setVar env n v

evalLisp eenv (List (Symbol "letrec*" : List params : body)) =
  if letCheck False params
     then dolr params body (eeE eenv)
     else errBadForm "letrec*" params
  where dolr ps b env =
          do let varn = map exn ps
             envn <- liftIO (bindVars env varn)
             mapM_ (evSet envn) ps >>
                  mapML (evalLisp (eeNewE eenv envn)) b
        exn (List [Symbol var, _]) = (var, lispFalse)
        exn _ = progError "evalLisp/letrec*/exn"
        evSet env (List [Symbol var, val]) =
              evalLisp (eeNewE eenv env) val >>= setVar env var
        evSet _ _ = progError "evalLisp/letrec*/evSet"

evalLisp _ (List [Symbol "case"]) = return lispFalse
evalLisp eenv (List (Symbol "case" : k : as)) =
  if null as || not (all isLL as)
     then errTypeMismatch "case" "case-clauses" (String (show as))
     else evalLisp eenv k >>= evc (eeE eenv) as
  where isLL (List (List _ : _)) = True
        isLL (List (Symbol "else" : _)) = True
        isLL _ = False
        evc _ [] _ = return lispFalse
        evc env (cl:cls) k1 = do (tst,val) <- evc_clause env cl k1
                                 if tst then return val else evc env cls k1
        evc_clause env (List (Symbol "else" : args)) _ =
          do ret <- mapML (evalLisp (eeNewE eenv env)) args
             return (True, ret)
        evc_clause env (List (List vals : args)) k1 =
          if valMatch k1 vals
             then do ret <- mapML (evalLisp (eeNewE eenv env)) args
                     return (True, ret)
             else return (False, lispFalse)
        evc_clause _ _ _ = return (False, lispFalse)
        valMatch k1 (v:vs) = Library.eqv [k1, v] || valMatch k1 vs
        valMatch _ [] = False

evalLisp eenv
    (List (Symbol "guard" : List (Symbol var : clauses) : body)) =
  if all isList clauses
     then catchError (mapML (evalLisp eenv) body)
                     (\err -> do let errval = unpackErr err
                                 liftIO (bindVars (eeE eenv) [(var, errval)])
                                   >>= evc err clauses)
     else errTypeMismatch "guard" "error-clauses" (String (show clauses))
  where unpackErr (UserException val) = val
        unpackErr err = String (show err)
        evc err [] _ = throwError err
        evc err (cl:cls) env = do (tst,val) <- evc_clause env cl
                                  if tst then return val else evc err cls env
        evc_clause env (List (Symbol "else" : args)) =
          do ret <- mapML (evalLisp (eeNewE eenv env)) args
             return (True, ret)
        evc_clause env (List (pr : args)) =
          do let een = eeNewE eenv env
             tst <- evalLisp een pr
             case tst of
                  Boolean False -> return (False, lispFalse)
                  _ -> do ret <- if isArrow args
                                    then evcArrow env args tst
                                    else mapML (evalLisp een) args
                          return (True, ret)
        evc_clause _ _ = return (False, lispFalse)
        isArrow [Symbol "=>", _] = True
        isArrow _ = False
        evcArrow env [Symbol "=>", proc] val =
          let een = eeNewE eenv env
          in evalLisp een proc >>= flip (apply een) [val]
        evcArrow _ _ _ = progError "evalLisp/guard/evcArrow"

-- This creates an internal variable for each delay object where its value
-- will be stored once it is forced. We avoid collisions with any symbols
-- that the user might define by simply beginning the variable name with a
-- space: the parser won't let such strings through as symbols, so we are
-- never in the situation where something might clash.

evalLisp eenv (List [Symbol "delay", val]) =
  do let env = eeE eenv
     dval <- getVar env delayCounter
     let count = getInt dval
     do setVar env delayCounter (IntNumber (count + 1))
        return (Delay val env (" delay." ++ show count))

evalLisp eenv (List [Symbol "force", val]) =
  do vali <- evalLisp eenv val
     if isDelay vali
        then do let (env, tag) = getTag vali
                alreadyDef <- liftIO (isBound env tag)
                if alreadyDef
                   then getVar env tag
                   else forceEval vali >>= defineVar env tag
        else return vali
  where isDelay (Delay _ _ _) = True
        isDelay _ = False
        getTag (Delay _ env tag) = (env, tag)
        getTag _ = progError "evalLisp/getTag"
        forceEval (Delay obj env _) = evalLisp (eeNewE eenv env) obj
        forceEval _ = progError "evalLisp/forceEval"

evalLisp eenv (List (Symbol "do" : List params : List test : body)) =
  if doCheck params
     then do let names = map exn params
                 steps = map exs params
             inits <- mapM (evalLisp eenv . exi) params
             envn <- liftIO (bindVars (eeE eenv) (zip names inits))
             doloop envn names test steps
     else errBadForm "do" params
  where exn (List [Symbol var, _]) = var
        exn (List [Symbol var, _, _]) = var
        exn _ = progError "evalLisp/do/exn"
        exi (List [Symbol _, ini]) = ini
        exi (List [Symbol _, ini, _]) = ini
        exi _ = progError "evalLisp/do/exi"
        exs (List [Symbol var, _]) = Symbol var
        exs (List [Symbol _, _, step]) = step
        exs _ = progError "evalLisp/do/exs"
        doSet env (n,v) = setVar env n v
        doloop env names (tst:rets) steps =
          do let een = eeNewE eenv env
             tval <- evalLisp een tst
             if isTrue tval
                then mapML (evalLisp een) rets
                else do mapM_ (evalLisp een) body
                        svals <- mapM (evalLisp een) steps
                        mapM_ (doSet env) (zip names svals)
                        doloop env names (tst:rets) steps
        doloop _ _ [] _ = progError "evalLisp/do/doloop"

-- This creates a new guaranteed-never-before-used symbol (and one which
-- the user can't enter, so guaranteed no past present or future clashes).

evalLisp (EEnv env _ _ _) (List [Symbol "gensym"]) =
  do sval <- getVar env symbolCounter
     let count = getInt sval
     do setVar env symbolCounter (IntNumber (count + 1))
        return (Symbol (" symbol." ++ show count))

-- Delimited continuations -- two new special forms: (reset expr ...)
-- and (shift  id fname expr ...) which is the translation of shift

-- NOTE! 'shift ' is a single symbol, with a space at the end; this makes it
-- harder for the user to enter it directly (but not impossible: generate a
-- quoted expression like '(reset (shift f #t)), then take the result apart
-- to get the desired symbols... if you do this, you deserve what you get).

evalLisp eenv@(EEnv _ _ dcs _) (List (Symbol "reset" : as)) =
  catchError (mapML (evalLisp (eeNewDC eenv (as:dcs))) as) getVal
  where getVal (DelCont val) = return val
        getVal err = throwError err

evalLisp (EEnv _ _ [] _)
    a@(List (Symbol "shift " : Symbol _ : Symbol _ : _)) =
  throwError (BadSpecial "naked internal delcont form" a)

-- TODO: does the isCont test need to be made more discriminating?
-- check if it could perhaps fail with nested or multiple calls to the
-- continuation function

evalLisp eenv (List (Symbol "shift " : Symbol cid : Symbol fn : as)) =
  do let env = eeE eenv
         isCont = lookup cid (eePE eenv)
     case isCont of
          Just val -> return val
          Nothing -> do let cbody = [List (Symbol "reset" :
                                           head (eeDC eenv))]
                            ebody = [List (Symbol "reset" : as)]
                        func <- makeContFunc env [Symbol cid] cbody
                        envn <- liftIO (bindVars env [(fn, func)])
                        mapML (evalLisp (eeNewE eenv envn)) ebody
                          >>= throwError . DelCont

{-
     if isCont
        then (getVar env cid) >>= return
        else do let cbody = [List ([Symbol "reset"] ++ (head (eeDC eenv)))]
                    ebody = [List ([Symbol "reset"] ++ as)]
                func <- makeContFunc env [Symbol cid] cbody
                envn <- liftIO (bindVars env [(fn, func)])
                mapML (evalLisp (eeNewE eenv envn)) ebody
                  >>= throwError . DelCont
-}

-- This is not an R6RS special form, but it is a haskeem one: it needs
-- to be, because we don't want to evaluate the function name, and we
-- do want to be able to do stuff in the current environment, so that
-- we can trace just sub-functions which are defined within a function
-- but which are not visible in the top-level environment. Evaluating
-- the function name is pretty trivial, we could just require writing
-- (trace 'function #t), but tracing sub-functions needs a special
-- form, because it needs access to the current environment rather than
-- the top-level environment.
-- We require the literal form '(trace name #t/f), rather than some
-- expression which evaluates to the symbol to trace, because we want
-- to have a name: var is what gets used. Consider relaxing this?

evalLisp eenv (List [Symbol "trace", Symbol var, sw]) =
  if isSpecialForm (Symbol var)
     then throwError (Default "can't trace special forms")
     else do val <- evalLisp eenv (Symbol var)
             swval <- evalLisp eenv sw
             let env = eeE eenv
             if isPr val
                then throwError (Default "can't trace primitives")
                else if isF val
-- TODO: this can be cleaned up a bit more... doit!
                        then if isTrue swval
                                then remark ("trace " ++ var ++ " on") >>
                                     setVar env var (trOn var val) >>
                                     return lispTrue
                                else remark ("trace " ++ var ++ " off") >>
                                     setVar env var (trOff val) >>
                                     return lispFalse
                        else errBadForm "trace" (Symbol var : [sw])
  where isPr (Prim _) = True
        isPr (IOPrim _) = True
        isPr _ = False
        isF (Func _ _ _ _ _ _ _) = True
        isF _ = False
        trOn name (Func params varargs body closure _ mac cont) =
              Func params varargs body closure (Just name) mac cont
        trOn _ _ = progError "evalLisp/trace/trOn"
        trOff (Func params varargs body closure _ mac cont) =
              Func params varargs body closure Nothing mac cont
        trOff _ = progError "evalLisp/trace/trOff"

-- This is also not an R6RS special form, but a haskeem one: it needs
-- to be, because we want the ability to show the current environment
-- rather than just the top-level one

evalLisp eenv (List [Symbol "dump-bindings"]) = dumpEnv (eeE eenv) stderr []
evalLisp eenv (List [Symbol "dump-bindings", val]) =
  do vali <- evalLisp eenv val
     if isPort vali
        then dumpEnv (eeE eenv) (getPort vali) []
        else errBadForm "dump-bindings" [val]
  where isPort (Port _) = True
        isPort _ = False
        getPort (Port p) = p
        getPort _ = progError "evalLisp/dump-bindings"

-- The generic (function : as) stuff; also macro expansion stuff
-- For macro expansion, we evaluate once to get syntax back from the
-- macro, that's the "evalLisp env dcs ql function", but then we change
-- the environment to evaluate that syntax in the caller's environment.

evalLisp eenv (List (function : as)) =
  if isSpecialForm function
     then throwError (BadSpecial "bad syntax for special form" function)
     else do func <- evalLisp eenv function
             if isM func
                then apply eenv (chEnv func (eeE eenv)) as >>=
                     prtTrace (isT func) >>= evalPP eenv >>= evalLisp eenv
                else mapM (evalLisp eenv) as >>= apply eenv func
  where isM (Func _ _ _ _ _ mac _) = mac
        isM _ = False
        isT (Func _ _ _ _ (Just _) _ _) = True
        isT _ = False
        chEnv (Func pars vars bod _ name mac cont) envn =
          Func pars vars bod envn name mac cont
        chEnv _ _ = progError "evalLisp/generic-function"
        prtTrace trace vals =
          if trace
             then remark ("   ->  " ++ show vals) >> return vals
             else return vals

evalLisp _ badForm =
  throwError (BadSpecial "Unrecognized special form" badForm)