{-# LANGUAGE CPP #-}

{- |
Module      : Language.Scheme.Core
Copyright   : Justin Ethier
Licence     : MIT (see LICENSE in the distribution)

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

This module contains Core functionality, primarily Scheme expression evaluation.
-}

module Language.Scheme.Core
    (
    -- * Scheme code evaluation
      evalLisp
    , evalLisp'
    , evalString
    , evalAndPrint
    , apply
    , continueEval
    , runIOThrows 
    , runIOThrowsREPL 
    -- * Core data
    , nullEnvWithImport
    , primitiveBindings
    , r5rsEnv
    , r5rsEnv'
    , r7rsEnv
    , r7rsEnv'
    , r7rsTimeEnv
    , version
    -- * Utility functions
    , findFileOrLib
    , getDataFileFullPath
    , replaceAtIndex
    , registerExtensions
    , showBanner
    , showLispError
    , substr
    , updateList
    , updateVector
    , updateByteVector
    , hashTblRef
    -- * Error handling
    , addToCallHistory
    , throwErrorWithCallHistory
    -- * Internal use only
    , meval
    ) where
import qualified Paths_husk_scheme as PHS (getDataFileName, version)
#ifdef UseFfi
import qualified Language.Scheme.FFI
#endif
import Language.Scheme.Environments
import Language.Scheme.Libraries
import qualified Language.Scheme.Macro
import Language.Scheme.Parser
import Language.Scheme.Primitives
import Language.Scheme.Types
import Language.Scheme.Util
import Language.Scheme.Variables
import Control.Monad.Except
import Data.Array
import qualified Data.ByteString as BS
import qualified Data.Map
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Version as DV
import Data.Word
import qualified System.Exit
import qualified System.Info as SysInfo
-- import Debug.Trace

-- |Husk version number
version :: String
version :: String
version = Version -> String
DV.showVersion Version
PHS.version

-- |A utility function to display the husk console banner
showBanner :: IO ()
showBanner :: IO ()
showBanner = do
  String -> IO ()
putStrLn String
"  _               _        __                 _                          "
  String -> IO ()
putStrLn String
" | |             | |       \\\\\\               | |                         "
  String -> IO ()
putStrLn String
" | |__  _   _ ___| | __     \\\\\\      ___  ___| |__   ___ _ __ ___   ___  "
  String -> IO ()
putStrLn String
" | '_ \\| | | / __| |/ /    //\\\\\\    / __|/ __| '_ \\ / _ \\ '_ ` _ \\ / _ \\ "
  String -> IO ()
putStrLn String
" | | | | |_| \\__ \\   <    /// \\\\\\   \\__ \\ (__| | | |  __/ | | | | |  __/ "
  String -> IO ()
putStrLn String
" |_| |_|\\__,_|___/_|\\_\\  ///   \\\\\\  |___/\\___|_| |_|\\___|_| |_| |_|\\___| "
  String -> IO ()
putStrLn String
"                                                                         "
  String -> IO ()
putStrLn String
" http://justinethier.github.io/husk-scheme                              "
  String -> IO ()
putStrLn String
" (c) 2010-2021 Justin Ethier                                             "
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" Version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Version -> String
DV.showVersion Version
PHS.version) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
  String -> IO ()
putStrLn String
"                                                                         "

getHuskFeatures :: IO [LispVal]
getHuskFeatures :: IO [LispVal]
getHuskFeatures = do
    -- TODO: windows posix
    [LispVal] -> IO [LispVal]
forall (m :: * -> *) a. Monad m => a -> m a
return [ String -> LispVal
Atom String
"r7rs"
           , String -> LispVal
Atom String
"husk"
           , String -> LispVal
Atom (String -> LispVal) -> String -> LispVal
forall a b. (a -> b) -> a -> b
$ String
"husk-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Version -> String
DV.showVersion Version
PHS.version)
           , String -> LispVal
Atom String
SysInfo.arch
           , String -> LispVal
Atom String
SysInfo.os
           , String -> LispVal
Atom String
"full-unicode"
           , String -> LispVal
Atom String
"complex"
           , String -> LispVal
Atom String
"ratios"
           ]

-- |Get the full path to a data file installed for husk
getDataFileFullPath :: String -> IO String
getDataFileFullPath :: String -> IO String
getDataFileFullPath = String -> IO String
PHS.getDataFileName

-- Future use:
-- getDataFileFullPath' :: [LispVal] -> IOThrowsError LispVal
-- getDataFileFullPath' [String s] = do
--     path <- liftIO $ PHS.getDataFileName s
--     return $ String path
-- getDataFileFullPath' [] = throwError $ NumArgs (Just 1) []
-- getDataFileFullPath' args = throwError $ TypeMismatch "string" $ List args

-- |Attempts to find the file both in the current directory and in the husk
--  libraries. If the file is not found in the current directory but exists
--  as a husk library, return the full path to the file in the library.
--  Otherwise just return the given filename.
findFileOrLib :: String -> ExceptT LispError IO String
findFileOrLib :: String -> ExceptT LispError IO String
findFileOrLib String
filename = do
    String
fileAsLib <- IO String -> ExceptT LispError IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT LispError IO String)
-> IO String -> ExceptT LispError IO String
forall a b. (a -> b) -> a -> b
$ String -> IO String
getDataFileFullPath (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"lib/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
filename
    LispVal
exists <- [LispVal] -> IOThrowsError LispVal
fileExists [String -> LispVal
String String
filename]
    LispVal
existsLib <- [LispVal] -> IOThrowsError LispVal
fileExists [String -> LispVal
String String
fileAsLib]
    case (LispVal
exists, LispVal
existsLib) of
        (Bool Bool
False, Bool Bool
True) -> String -> ExceptT LispError IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
fileAsLib
        (LispVal, LispVal)
_ -> String -> ExceptT LispError IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
filename

libraryExists :: [LispVal] -> IOThrowsError LispVal
libraryExists :: [LispVal] -> IOThrowsError LispVal
libraryExists [p :: LispVal
p@(Pointer String
_ Env
_)] = do
    LispVal
p' <- LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
p
    [LispVal] -> IOThrowsError LispVal
libraryExists [LispVal
p']
libraryExists [(String String
filename)] = do
    String
fileAsLib <- IO String -> ExceptT LispError IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT LispError IO String)
-> IO String -> ExceptT LispError IO String
forall a b. (a -> b) -> a -> b
$ String -> IO String
getDataFileFullPath (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"lib/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
filename
    Bool Bool
exists <- [LispVal] -> IOThrowsError LispVal
fileExists [String -> LispVal
String String
filename]
    Bool Bool
existsLib <- [LispVal] -> IOThrowsError LispVal
fileExists [String -> LispVal
String String
fileAsLib]
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool (Bool -> LispVal) -> Bool -> LispVal
forall a b. (a -> b) -> a -> b
$ Bool
exists Bool -> Bool -> Bool
|| Bool
existsLib
libraryExists [LispVal]
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Bool -> LispVal
Bool Bool
False

-- |Register optional SRFI extensions
registerExtensions :: Env -> (FilePath -> IO FilePath) -> IO ()
registerExtensions :: Env -> (String -> IO String) -> IO ()
registerExtensions Env
env String -> IO String
getDataFileName = do
  ()
_ <- Env -> (String -> IO String) -> Integer -> IO ()
registerSRFI Env
env String -> IO String
getDataFileName Integer
1
  ()
_ <- Env -> (String -> IO String) -> Integer -> IO ()
registerSRFI Env
env String -> IO String
getDataFileName Integer
2
  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- |Register the given SRFI
registerSRFI :: Env -> (FilePath -> IO FilePath) -> Integer -> IO ()
registerSRFI :: Env -> (String -> IO String) -> Integer -> IO ()
registerSRFI Env
env String -> IO String
getDataFileName Integer
num = do
 String
filename <- String -> IO String
getDataFileName (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"lib/srfi/srfi-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
num String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".scm"
 String
_ <- Env -> String -> IO String
evalString Env
env (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"(register-extension '(srfi " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
num String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
  (String -> String
escapeBackslashes String
filename) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\")"
 () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- TODO: good news is I think this can be completely implemented in husk, no changes necessary to third party code. the bad news is that this guy needs to be called from the runIOThrows* code instead of show which means that code needs to be relocated (maybe to this module, if that is appropriate (not sure it is)...

-- |This is the recommended function to use to display a lisp error, instead
--  of just using show directly.
showLispError :: LispError -> IO String
showLispError :: LispError -> IO String
showLispError (NumArgs Maybe Integer
n [LispVal]
lvs) = do
  Either LispError [LispVal]
lvs' <- ExceptT LispError IO [LispVal] -> IO (Either LispError [LispVal])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT LispError IO [LispVal] -> IO (Either LispError [LispVal]))
-> ExceptT LispError IO [LispVal]
-> IO (Either LispError [LispVal])
forall a b. (a -> b) -> a -> b
$ (LispVal -> IOThrowsError LispVal)
-> [LispVal] -> ExceptT LispError IO [LispVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LispVal -> IOThrowsError LispVal
recDerefPtrs [LispVal]
lvs
  case Either LispError [LispVal]
lvs' of
    Left LispError
_ -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ LispError -> String
forall a. Show a => a -> String
show (LispError -> String) -> LispError -> String
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs Maybe Integer
n [LispVal]
lvs
    Right [LispVal]
vals -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ LispError -> String
forall a. Show a => a -> String
show (LispError -> String) -> LispError -> String
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs Maybe Integer
n [LispVal]
vals
showLispError (TypeMismatch String
str p :: LispVal
p@(Pointer String
_ Env
e)) = do
  ThrowsError LispVal
lv' <- Env -> LispVal -> IO (ThrowsError LispVal)
evalLisp' Env
e LispVal
p 
  case ThrowsError LispVal
lv' of
    Left LispError
_ -> LispError -> IO String
showLispError (LispError -> IO String) -> LispError -> IO String
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
str (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom (String -> LispVal) -> String -> LispVal
forall a b. (a -> b) -> a -> b
$ LispVal -> String
forall a. Show a => a -> String
show LispVal
p
    Right LispVal
val -> LispError -> IO String
showLispError (LispError -> IO String) -> LispError -> IO String
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
str LispVal
val
showLispError (BadSpecialForm String
str p :: LispVal
p@(Pointer String
_ Env
e)) = do
  ThrowsError LispVal
lv' <- Env -> LispVal -> IO (ThrowsError LispVal)
evalLisp' Env
e LispVal
p 
  case ThrowsError LispVal
lv' of
    Left LispError
_ -> LispError -> IO String
showLispError (LispError -> IO String) -> LispError -> IO String
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
BadSpecialForm String
str (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom (String -> LispVal) -> String -> LispVal
forall a b. (a -> b) -> a -> b
$ LispVal -> String
forall a. Show a => a -> String
show LispVal
p
    Right LispVal
val -> LispError -> IO String
showLispError (LispError -> IO String) -> LispError -> IO String
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
BadSpecialForm String
str LispVal
val
showLispError (ErrorWithCallHist LispError
err [LispVal]
hist) = do
  String
err' <- LispError -> IO String
showLispError LispError
err
  Either LispError [LispVal]
hist' <- ExceptT LispError IO [LispVal] -> IO (Either LispError [LispVal])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT LispError IO [LispVal] -> IO (Either LispError [LispVal]))
-> ExceptT LispError IO [LispVal]
-> IO (Either LispError [LispVal])
forall a b. (a -> b) -> a -> b
$ (LispVal -> IOThrowsError LispVal)
-> [LispVal] -> ExceptT LispError IO [LispVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LispVal -> IOThrowsError LispVal
recDerefPtrs [LispVal]
hist
  case Either LispError [LispVal]
hist' of
    Left LispError
_ -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> [LispVal] -> String
showCallHistory String
err' [LispVal]
hist
    Right [LispVal]
vals -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> [LispVal] -> String
showCallHistory String
err' [LispVal]
vals
showLispError LispError
err = String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ LispError -> String
forall a. Show a => a -> String
show LispError
err

-- |Execute an IO action and return result or an error message.
--  This is intended for use by a REPL, where a result is always
--  needed regardless of type.
runIOThrowsREPL :: IOThrowsError String -> IO String
runIOThrowsREPL :: ExceptT LispError IO String -> IO String
runIOThrowsREPL ExceptT LispError IO String
action = do
    Either LispError String
runState <- ExceptT LispError IO String -> IO (Either LispError String)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT LispError IO String
action
    case Either LispError String
runState of
        Left LispError
err -> LispError -> IO String
showLispError LispError
err
        Right String
val -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
val

-- |Execute an IO action and return error or Nothing if no error was thrown.
runIOThrows :: IOThrowsError String -> IO (Maybe String)
runIOThrows :: ExceptT LispError IO String -> IO (Maybe String)
runIOThrows ExceptT LispError IO String
action = do
    Either LispError String
runState <- ExceptT LispError IO String -> IO (Either LispError String)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT LispError IO String
action
    case Either LispError String
runState of
        Left LispError
err -> do
            String
disp <- LispError -> IO String
showLispError LispError
err
            Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
disp
        Right String
_ -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing

{- |Evaluate a string containing Scheme code

@
env <- primitiveBindings

evalString env "(+ x x x)"
"3"

evalString env "(+ x x x (* 3 9))"
"30"

evalString env "(* 3 9)"
"27"
@
-}
evalString :: Env -> String -> IO String
evalString :: Env -> String -> IO String
evalString Env
env String
expr = do
  ExceptT LispError IO String -> IO String
runIOThrowsREPL (ExceptT LispError IO String -> IO String)
-> ExceptT LispError IO String -> IO String
forall a b. (a -> b) -> a -> b
$ (LispVal -> String)
-> IOThrowsError LispVal -> ExceptT LispError IO String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM LispVal -> String
forall a. Show a => a -> String
show (IOThrowsError LispVal -> ExceptT LispError IO String)
-> IOThrowsError LispVal -> ExceptT LispError IO String
forall a b. (a -> b) -> a -> b
$ ThrowsError LispVal -> IOThrowsError LispVal
forall a. ThrowsError a -> IOThrowsError a
liftThrows (String -> ThrowsError LispVal
readExpr String
expr) IOThrowsError LispVal
-> (LispVal -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Env -> LispVal -> IOThrowsError LispVal
evalLisp Env
env

-- |Evaluate a string and print results to console
evalAndPrint :: Env -> String -> IO ()
evalAndPrint :: Env -> String -> IO ()
evalAndPrint Env
env String
expr = Env -> String -> IO String
evalString Env
env String
expr IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
putStrLn

-- |Evaluate a lisp data structure and return a value for use by husk
evalLisp :: Env -> LispVal -> IOThrowsError LispVal
evalLisp :: Env -> LispVal -> IOThrowsError LispVal
evalLisp Env
env LispVal
lisp = do
  LispVal
v <- Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
env (Env -> LispVal
makeNullContinuation Env
env) LispVal
lisp
  [LispVal] -> LispVal -> IOThrowsError LispVal
safeRecDerefPtrs [] LispVal
v

-- |Evaluate a lisp data structure and return the LispVal or LispError
--  result directly
-- 
-- @
--  result <- evalLisp' env $ List [Atom "/", Number 1, Number 0]
--  case result of
--    Left err -> putStrLn $ "Error: " ++ (show err)
--    Right val -> putStrLn $ show val
-- @
evalLisp' :: Env -> LispVal -> IO (ThrowsError LispVal)
evalLisp' :: Env -> LispVal -> IO (ThrowsError LispVal)
evalLisp' Env
env LispVal
lisp = IOThrowsError LispVal -> IO (ThrowsError LispVal)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (Env -> LispVal -> IOThrowsError LispVal
evalLisp Env
env LispVal
lisp)

-- |A wrapper for macroEval and eval
meval, mprepareApply :: Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval :: Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
env LispVal
cont LispVal
lisp = Env
-> LispVal
-> LispVal
-> (Env -> LispVal -> LispVal -> IOThrowsError LispVal)
-> IOThrowsError LispVal
mfunc Env
env LispVal
cont LispVal
lisp Env -> LispVal -> LispVal -> IOThrowsError LispVal
eval
mprepareApply :: Env -> LispVal -> LispVal -> IOThrowsError LispVal
mprepareApply Env
env LispVal
cont LispVal
lisp = Env
-> LispVal
-> LispVal
-> (Env -> LispVal -> LispVal -> IOThrowsError LispVal)
-> IOThrowsError LispVal
mfunc Env
env LispVal
cont LispVal
lisp Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply
mfunc :: Env -> LispVal -> LispVal -> (Env -> LispVal -> LispVal -> IOThrowsError LispVal) -> IOThrowsError LispVal
mfunc :: Env
-> LispVal
-> LispVal
-> (Env -> LispVal -> LispVal -> IOThrowsError LispVal)
-> IOThrowsError LispVal
mfunc Env
env LispVal
cont LispVal
lisp Env -> LispVal -> LispVal -> IOThrowsError LispVal
func = do
  Env
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
Language.Scheme.Macro.macroEval Env
env LispVal
lisp LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply IOThrowsError LispVal
-> (LispVal -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Env -> LispVal -> LispVal -> IOThrowsError LispVal
func Env
env LispVal
cont) 
{- OBSOLETE:
 old code for updating env's in the continuation chain (see below)
  if False --needToExtendEnv lisp
     then do
       expanded <- macroEval env lisp
       exEnv <- liftIO $ extendEnv env []
       -- Recursively replace env of nextCont with the extended env
       -- This is more expensive than I would like, but I think it should be straightforward enough...
       exCont <- updateContEnv exEnv cont
       func exEnv (trace ("extending Env") exCont) expanded
     else macroEval env lisp >>= (func env cont) 
-}
{- EXPERIMENTAL CODE FOR REPLACING ENV's in the continuation chain
   
   This is a difficult problem to solve and this code will likely just
   end up going away because we are not going with this approach...

updateContEnv :: Env -> LispVal -> IOThrowsError LispVal
updateContEnv env (Continuation _ curC (Just nextC) dwind) = do
    next <- updateContEnv env nextC
    return $ Continuation env curC (Just next) dwind
updateContEnv env (Continuation _ curC Nothing dwind) = do
    return $ Continuation env curC Nothing dwind
updateContEnv _ val = do
    return val
-}

{- |A support function for eval; eval calls into this function instead of 
    returning values directly. continueEval then uses the continuation 
    argument to manage program control flow.
 -}
continueEval :: Env     -- ^ Current environment
             -> LispVal -- ^ Current continuation
             -> LispVal -- ^ Value of previous computation
             -> Maybe [LispVal] -- ^ Extra arguments from previous computation
             -> IOThrowsError LispVal -- ^ Final value of computation

{- Passing a higher-order function as the continuation; just evaluate it. This is
 - done to enable an 'eval' function to be broken up into multiple sub-functions,
 - so that any of the sub-functions can be passed around as a continuation. 
 -
 - Carry extra args from the current continuation into the next, to support (call-with-values)
 -}
continueEval :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
_
            (Continuation 
                Env
cEnv 
                (Just (HaskellBody Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
func Maybe [LispVal]
funcArgs))
                (Just nCont :: LispVal
nCont@(Continuation {}))
                Maybe [DynamicWinders]
_ [LispVal]
_)
             LispVal
val 
             Maybe [LispVal]
xargs = do
    let args :: Maybe [LispVal]
args = case Maybe [LispVal]
funcArgs of
                    Maybe [LispVal]
Nothing -> Maybe [LispVal]
xargs
                    Maybe [LispVal]
_ -> Maybe [LispVal]
funcArgs
    Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
func Env
cEnv LispVal
nCont LispVal
val Maybe [LispVal]
args
{-
 - No higher order function, so:
 -
 - If there is Scheme code to evaluate in the function body, we continue to evaluate it.
 -
 - Otherwise, if all code in the function has been executed, we 'unwind' to an outer
 - continuation (if there is one), or we just return the result. Yes technically with
 - CPS you are supposed to keep calling into functions and never return, but in this case
 - when the computation is complete, you have to return something. 
 -
 - NOTE: We use 'eval' below instead of 'meval' because macros are already expanded when
 -       a function is loaded the first time, so there is no need to test for this again here.
 -}
continueEval Env
_ (Continuation Env
cEnv (Just (SchemeBody [LispVal]
cBody)) (Just LispVal
cCont) Maybe [DynamicWinders]
dynWind [LispVal]
callHist) LispVal
val Maybe [LispVal]
extraArgs = do
--    case (trace ("cBody = " ++ show cBody) cBody) of
    case [LispVal]
cBody of
        [] -> do
          case LispVal
cCont of
            Continuation {contClosure :: LispVal -> Env
contClosure = Env
nEnv} -> 
              -- Pass extra args along if last expression of a function, to support (call-with-values)
              Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
nEnv LispVal
cCont LispVal
val Maybe [LispVal]
extraArgs 
            LispVal
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
val
        (LispVal
lv : [LispVal]
lvs) -> Env -> LispVal -> LispVal -> IOThrowsError LispVal
eval Env
cEnv (Env
-> Maybe DeferredCode
-> Maybe LispVal
-> Maybe [DynamicWinders]
-> [LispVal]
-> LispVal
Continuation Env
cEnv (DeferredCode -> Maybe DeferredCode
forall a. a -> Maybe a
Just ([LispVal] -> DeferredCode
SchemeBody [LispVal]
lvs)) (LispVal -> Maybe LispVal
forall a. a -> Maybe a
Just LispVal
cCont) Maybe [DynamicWinders]
dynWind [LispVal]
callHist) LispVal
lv

-- No current continuation, but a next cont is available; call into it
continueEval Env
_ (Continuation Env
cEnv Maybe DeferredCode
Nothing (Just LispVal
cCont) Maybe [DynamicWinders]
_ [LispVal]
_) LispVal
val Maybe [LispVal]
xargs = Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
cEnv LispVal
cCont LispVal
val Maybe [LispVal]
xargs

-- There is no continuation code, just return value
continueEval Env
_ (Continuation Env
_ Maybe DeferredCode
Nothing Maybe LispVal
Nothing Maybe [DynamicWinders]
_ [LispVal]
_) LispVal
val Maybe [LispVal]
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
val
continueEval Env
_ LispVal
_ LispVal
_ Maybe [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
Default String
"Internal error in continueEval"

{- |Core eval function
Evaluate a scheme expression.
NOTE:  This function does not include macro support and should not be called directly. Instead, use 'evalLisp' -}
--
--
-- Implementation Notes:
--
-- Internally, this function is written in continuation passing style (CPS) to allow the Scheme language
-- itself to support first-class continuations. That is, at any point in the evaluation, call/cc may
-- be used to capture the current continuation. Thus this code must call into the next continuation point, eg: 
--
--  eval ... (makeCPS ...)
--
-- Instead of calling eval directly from within the same function, eg:
--
--  eval ...
--  eval ...
--
-- This can make the code harder to follow, however some coding conventions have been established to make the
-- code easier to follow. Whenever a single function has been broken into multiple ones for the purpose of CPS,
-- those additional functions are defined locally using @where@, and each has been given a /cps/ prefix.
--
eval :: Env -> LispVal -> LispVal -> IOThrowsError LispVal
eval :: Env -> LispVal -> LispVal -> IOThrowsError LispVal
eval Env
env LispVal
cont val :: LispVal
val@(Nil String
_) = Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
val Maybe [LispVal]
forall a. Maybe a
Nothing
eval Env
env LispVal
cont val :: LispVal
val@(String String
_) = Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
val Maybe [LispVal]
forall a. Maybe a
Nothing
eval Env
env LispVal
cont val :: LispVal
val@(Char Char
_) = Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
val Maybe [LispVal]
forall a. Maybe a
Nothing
eval Env
env LispVal
cont val :: LispVal
val@(Complex Complex Double
_) = Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
val Maybe [LispVal]
forall a. Maybe a
Nothing
eval Env
env LispVal
cont val :: LispVal
val@(Float Double
_) = Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
val Maybe [LispVal]
forall a. Maybe a
Nothing
eval Env
env LispVal
cont val :: LispVal
val@(Rational Rational
_) = Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
val Maybe [LispVal]
forall a. Maybe a
Nothing
eval Env
env LispVal
cont val :: LispVal
val@(Number Integer
_) = Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
val Maybe [LispVal]
forall a. Maybe a
Nothing
eval Env
env LispVal
cont val :: LispVal
val@(Bool Bool
_) = Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
val Maybe [LispVal]
forall a. Maybe a
Nothing
eval Env
env LispVal
cont val :: LispVal
val@(HashTable Map LispVal LispVal
_) = Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
val Maybe [LispVal]
forall a. Maybe a
Nothing
eval Env
env LispVal
cont val :: LispVal
val@(Vector Array Int LispVal
_) = Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
val Maybe [LispVal]
forall a. Maybe a
Nothing
eval Env
env LispVal
cont val :: LispVal
val@(ByteVector ByteString
_) = Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
val Maybe [LispVal]
forall a. Maybe a
Nothing
eval Env
env LispVal
cont val :: LispVal
val@(LispEnv Env
_) = Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
val Maybe [LispVal]
forall a. Maybe a
Nothing
eval Env
env LispVal
cont val :: LispVal
val@(Pointer String
_ Env
_) = Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
val Maybe [LispVal]
forall a. Maybe a
Nothing
eval Env
env LispVal
cont (Atom String
a) = do
  LispVal
v <- Env -> String -> IOThrowsError LispVal
getVar Env
env String
a
  let val :: LispVal
val = case LispVal
v of
-- TODO: this flag may go away on this branch; it may
--       not be practical with Pointer used everywhere now
#ifdef UsePointers
              List [LispVal]
_ -> String -> Env -> LispVal
Pointer String
a Env
env
              DottedList [LispVal]
_ LispVal
_ -> String -> Env -> LispVal
Pointer String
a Env
env
              String String
_ -> String -> Env -> LispVal
Pointer String
a Env
env
              Vector Array Int LispVal
_ -> String -> Env -> LispVal
Pointer String
a Env
env
              ByteVector ByteString
_ -> String -> Env -> LispVal
Pointer String
a Env
env
              HashTable Map LispVal LispVal
_ -> String -> Env -> LispVal
Pointer String
a Env
env
#endif
              LispVal
_ -> LispVal
v
  Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
val Maybe [LispVal]
forall a. Maybe a
Nothing

-- Quote an expression by simply passing along the value
eval Env
env LispVal
cont (List [Atom String
"quote", LispVal
val]) = Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
val Maybe [LispVal]
forall a. Maybe a
Nothing

-- A special form to assist with debugging macros
eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"expand" , LispVal
_body]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"expand"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if bound to a variable in this scope; call into it
  else do
      LispVal
value <- Env
-> Bool
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
Language.Scheme.Macro.expand Env
env Bool
False LispVal
_body LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply 
      Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
value Maybe [LispVal]
forall a. Maybe a
Nothing
 
-- A rudimentary implementation of let-syntax
eval Env
env LispVal
cont args :: LispVal
args@(List (Atom String
"let-syntax" : List [LispVal]
_bindings : [LispVal]
_body)) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"let-syntax"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if bound to a variable in this scope; call into it
  else do 
   Env
bodyEnv <- IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> ExceptT LispError IO Env)
-> IO Env -> ExceptT LispError IO Env
forall a b. (a -> b) -> a -> b
$ Env -> [((Char, String), LispVal)] -> IO Env
extendEnv Env
env []
   LispVal
_ <- Env
-> Env -> Maybe Env -> Bool -> [LispVal] -> IOThrowsError LispVal
Language.Scheme.Macro.loadMacros Env
env Env
bodyEnv Maybe Env
forall a. Maybe a
Nothing Bool
False [LispVal]
_bindings
   -- Expand whole body as a single continuous macro, to ensure hygiene
   LispVal
expanded <- Env
-> Bool
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
Language.Scheme.Macro.expand Env
bodyEnv Bool
False ([LispVal] -> LispVal
List [LispVal]
_body) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
   case LispVal
expanded of
     List [LispVal]
e -> Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
bodyEnv (Env
-> Maybe DeferredCode
-> Maybe LispVal
-> Maybe [DynamicWinders]
-> [LispVal]
-> LispVal
Continuation Env
bodyEnv (DeferredCode -> Maybe DeferredCode
forall a. a -> Maybe a
Just (DeferredCode -> Maybe DeferredCode)
-> DeferredCode -> Maybe DeferredCode
forall a b. (a -> b) -> a -> b
$ [LispVal] -> DeferredCode
SchemeBody [LispVal]
e) (LispVal -> Maybe LispVal
forall a. a -> Maybe a
Just LispVal
cont) Maybe [DynamicWinders]
forall a. Maybe a
Nothing []) (String -> LispVal
Nil String
"") Maybe [LispVal]
forall a. Maybe a
Nothing 
     LispVal
e -> Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
bodyEnv LispVal
cont LispVal
e Maybe [LispVal]
forall a. Maybe a
Nothing

eval Env
env LispVal
cont args :: LispVal
args@(List (Atom String
"letrec-syntax" : List [LispVal]
_bindings : [LispVal]
_body)) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"letrec-syntax"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if bound to a variable in this scope; call into it
  else do 
   Env
bodyEnv <- IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> ExceptT LispError IO Env)
-> IO Env -> ExceptT LispError IO Env
forall a b. (a -> b) -> a -> b
$ Env -> [((Char, String), LispVal)] -> IO Env
extendEnv Env
env []
   -- A primitive means of implementing letrec, by simply assuming that each macro is defined in
   -- the letrec's environment, instead of the parent env. Not sure if this is 100% correct but it
   -- is good enough to pass the R5RS test case so it will be used as a rudimentary implementation 
   -- for now...
   LispVal
_ <- Env
-> Env -> Maybe Env -> Bool -> [LispVal] -> IOThrowsError LispVal
Language.Scheme.Macro.loadMacros Env
bodyEnv Env
bodyEnv Maybe Env
forall a. Maybe a
Nothing Bool
False [LispVal]
_bindings
   -- Expand whole body as a single continuous macro, to ensure hygiene
   LispVal
expanded <- Env
-> Bool
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
Language.Scheme.Macro.expand Env
bodyEnv Bool
False ([LispVal] -> LispVal
List [LispVal]
_body) LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply
   case LispVal
expanded of
     List [LispVal]
e -> Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
bodyEnv (Env
-> Maybe DeferredCode
-> Maybe LispVal
-> Maybe [DynamicWinders]
-> [LispVal]
-> LispVal
Continuation Env
bodyEnv (DeferredCode -> Maybe DeferredCode
forall a. a -> Maybe a
Just (DeferredCode -> Maybe DeferredCode)
-> DeferredCode -> Maybe DeferredCode
forall a b. (a -> b) -> a -> b
$ [LispVal] -> DeferredCode
SchemeBody [LispVal]
e) (LispVal -> Maybe LispVal
forall a. a -> Maybe a
Just LispVal
cont) Maybe [DynamicWinders]
forall a. Maybe a
Nothing []) (String -> LispVal
Nil String
"") Maybe [LispVal]
forall a. Maybe a
Nothing
     LispVal
e -> Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
bodyEnv LispVal
cont LispVal
e Maybe [LispVal]
forall a. Maybe a
Nothing

-- A non-standard way to rebind a macro to another keyword
eval Env
env LispVal
cont (List [Atom String
"define-syntax", 
                     Atom String
newKeyword,
                     Atom String
keyword]) = do
  Maybe LispVal
bound <- Env -> Char -> String -> IOThrowsError (Maybe LispVal)
getNamespacedVar' Env
env Char
macroNamespace String
keyword
  case Maybe LispVal
bound of
    Just LispVal
m -> do
        LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
env Char
macroNamespace String
newKeyword LispVal
m
        Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont (String -> LispVal
Nil String
"") Maybe [LispVal]
forall a. Maybe a
Nothing
    Maybe LispVal
Nothing -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"macro" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
keyword

eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"define-syntax", Atom String
keyword,
  (List [Atom String
"er-macro-transformer", 
    (List (Atom String
"lambda" : List [LispVal]
fparams : [LispVal]
fbody))])]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"define-syntax"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if bound to var in this scope; call it
  else do 
    -- TODO: ensure fparams is 3 atoms
    -- TODO: now just need to figure out initial entry point to the ER func
    --       for now can ignore complications of an ER found during syn-rules transformation
    Bool
_ <- [LispVal] -> Maybe Integer -> ExceptT LispError IO Bool
validateFuncParams [LispVal]
fparams (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
3)
    LispVal
f <- Env -> [LispVal] -> [LispVal] -> IOThrowsError LispVal
forall (m :: * -> *).
Monad m =>
Env -> [LispVal] -> [LispVal] -> m LispVal
makeNormalFunc Env
env [LispVal]
fparams [LispVal]
fbody 
    LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
env Char
macroNamespace String
keyword (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ LispVal -> LispVal
SyntaxExplicitRenaming LispVal
f
    Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont (String -> LispVal
Nil String
"") Maybe [LispVal]
forall a. Maybe a
Nothing 

eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"define-syntax", Atom String
keyword, 
    (List (Atom String
"syntax-rules" : Atom String
ellipsis : (List [LispVal]
identifiers : [LispVal]
rules)))]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"define-syntax"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if bound to a variable in this scope; call into it
  else do 
    LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
env Char
macroNamespace String
keyword (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ 
            Maybe Env
-> Maybe Env -> Bool -> String -> [LispVal] -> [LispVal] -> LispVal
Syntax (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
env) Maybe Env
forall a. Maybe a
Nothing Bool
False String
ellipsis [LispVal]
identifiers [LispVal]
rules
    Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont (String -> LispVal
Nil String
"") Maybe [LispVal]
forall a. Maybe a
Nothing

eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"define-syntax", Atom String
keyword, 
    (List (Atom String
"syntax-rules" : (List [LispVal]
identifiers : [LispVal]
rules)))]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"define-syntax"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if bound to a variable in this scope; call into it
  else do 
  {-
   - FUTURE: Issue #15: there really ought to be some error checking of the syntax rules, 
   -                    since they could be malformed...
   - As it stands now, there is no checking until the code attempts to perform a macro transformation.
   - At a minimum, should check identifiers to make sure each is an atom (see findAtom) 
   -}
    -- 
    -- I think it seems to be a better solution to use this defEnv, but
    -- that causes problems when a var is changed via (define) or (set!) since most
    -- schemes interpret allow this change to propagate back to the point of definition
    -- (or at least, when modules are not in play). See:
    --
    -- http://stackoverflow.com/questions/7999084/scheme-syntax-rules-difference-in-variable-bindings-between-let-anddefine
    --
    -- Anyway, this may come back. But not using it for now...
    --
    --    defEnv <- liftIO $ copyEnv env
    LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
env Char
macroNamespace String
keyword (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Env
-> Maybe Env -> Bool -> String -> [LispVal] -> [LispVal] -> LispVal
Syntax (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
env) Maybe Env
forall a. Maybe a
Nothing Bool
False String
"..." [LispVal]
identifiers [LispVal]
rules
    Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont (String -> LispVal
Nil String
"") Maybe [LispVal]
forall a. Maybe a
Nothing 

eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"if", LispVal
predic, LispVal
conseq, LispVal
alt]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"if"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
env (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> LispVal
makeCPS Env
env LispVal
cont Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cps) LispVal
predic
 where cps :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
       cps :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cps Env
e LispVal
c LispVal
result Maybe [LispVal]
_ =
            case LispVal
result of
              Bool Bool
False -> Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
e LispVal
c LispVal
alt
              LispVal
_ -> Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
e LispVal
c LispVal
conseq

eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"if", LispVal
predic, LispVal
conseq]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"if"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
env (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> LispVal
makeCPS Env
env LispVal
cont Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsResult) LispVal
predic
 where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
       cpsResult :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsResult Env
e LispVal
c LispVal
result Maybe [LispVal]
_ =
            case LispVal
result of
              Bool Bool
False -> Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
e LispVal
c (String -> LispVal
Nil String
"") Maybe [LispVal]
forall a. Maybe a
Nothing -- Unspecified return value per R5RS
              LispVal
_ -> Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
e LispVal
c LispVal
conseq

eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"set!", Atom String
var, LispVal
form]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"set!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
env (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> LispVal
makeCPS Env
env LispVal
cont Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsResult) LispVal
form
 where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
       cpsResult :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsResult Env
e LispVal
c LispVal
result Maybe [LispVal]
_ = do
        LispVal
value <- Env -> String -> LispVal -> IOThrowsError LispVal
setVar Env
e String
var LispVal
result 
        Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
e LispVal
c LispVal
value Maybe [LispVal]
forall a. Maybe a
Nothing
eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"set!", LispVal
nonvar, LispVal
_]) = do 
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"set!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"variable" LispVal
nonvar
eval Env
env LispVal
cont fargs :: LispVal
fargs@(List (Atom String
"set!" : [LispVal]
args)) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"set!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
fargs -- if is bound to a variable in this scope; call into it
  else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
args

eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"define", Atom String
var, LispVal
form]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"define"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
env (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> LispVal
makeCPS Env
env LispVal
cont Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsResult) LispVal
form
 where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
       cpsResult :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsResult Env
e LispVal
c LispVal
result Maybe [LispVal]
_ = do
        LispVal
value <- Env -> String -> LispVal -> IOThrowsError LispVal
defineVar Env
e String
var LispVal
result 
        Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
e LispVal
c LispVal
value Maybe [LispVal]
forall a. Maybe a
Nothing

eval Env
env LispVal
cont args :: LispVal
args@(List (Atom String
"define" : List (Atom String
var : [LispVal]
fparams) : [LispVal]
fbody )) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"define"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else do 
      Bool
_ <- [LispVal] -> Maybe Integer -> ExceptT LispError IO Bool
validateFuncParams [LispVal]
fparams Maybe Integer
forall a. Maybe a
Nothing
      -- Cache macro expansions within function body
      [LispVal]
ebody <- (LispVal -> IOThrowsError LispVal)
-> [LispVal] -> ExceptT LispError IO [LispVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ LispVal
lisp -> Env
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
Language.Scheme.Macro.macroEval Env
env LispVal
lisp LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply) [LispVal]
fbody
      LispVal
result <- (Env -> [LispVal] -> [LispVal] -> IOThrowsError LispVal
forall (m :: * -> *).
Monad m =>
Env -> [LispVal] -> [LispVal] -> m LispVal
makeNormalFunc Env
env [LispVal]
fparams [LispVal]
ebody IOThrowsError LispVal
-> (LispVal -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Env -> String -> LispVal -> IOThrowsError LispVal
defineVar Env
env String
var)
      Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
result Maybe [LispVal]
forall a. Maybe a
Nothing

eval Env
env LispVal
cont args :: LispVal
args@(List (Atom String
"define" : DottedList (Atom String
var : [LispVal]
fparams) LispVal
varargs : [LispVal]
fbody)) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"define"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else do 
      Bool
_ <- [LispVal] -> Maybe Integer -> ExceptT LispError IO Bool
validateFuncParams ([LispVal]
fparams [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
varargs]) Maybe Integer
forall a. Maybe a
Nothing
      [LispVal]
ebody <- (LispVal -> IOThrowsError LispVal)
-> [LispVal] -> ExceptT LispError IO [LispVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ LispVal
lisp -> Env
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
Language.Scheme.Macro.macroEval Env
env LispVal
lisp LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply) [LispVal]
fbody
      LispVal
result <- (LispVal -> Env -> [LispVal] -> [LispVal] -> IOThrowsError LispVal
forall (m :: * -> *).
Monad m =>
LispVal -> Env -> [LispVal] -> [LispVal] -> m LispVal
makeVarargs LispVal
varargs Env
env [LispVal]
fparams [LispVal]
ebody IOThrowsError LispVal
-> (LispVal -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Env -> String -> LispVal -> IOThrowsError LispVal
defineVar Env
env String
var)
      Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
result Maybe [LispVal]
forall a. Maybe a
Nothing

eval Env
env LispVal
cont args :: LispVal
args@(List (Atom String
"lambda" : List [LispVal]
fparams : [LispVal]
fbody)) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"lambda"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else do 
      Bool
_ <- [LispVal] -> Maybe Integer -> ExceptT LispError IO Bool
validateFuncParams [LispVal]
fparams Maybe Integer
forall a. Maybe a
Nothing
      [LispVal]
ebody <- (LispVal -> IOThrowsError LispVal)
-> [LispVal] -> ExceptT LispError IO [LispVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ LispVal
lisp -> Env
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
Language.Scheme.Macro.macroEval Env
env LispVal
lisp LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply) [LispVal]
fbody
      LispVal
result <- Env -> [LispVal] -> [LispVal] -> IOThrowsError LispVal
forall (m :: * -> *).
Monad m =>
Env -> [LispVal] -> [LispVal] -> m LispVal
makeNormalFunc Env
env [LispVal]
fparams [LispVal]
ebody
      Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
result Maybe [LispVal]
forall a. Maybe a
Nothing

eval Env
env LispVal
cont args :: LispVal
args@(List (Atom String
"lambda" : DottedList [LispVal]
fparams LispVal
varargs : [LispVal]
fbody)) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"lambda"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else do 
      Bool
_ <- [LispVal] -> Maybe Integer -> ExceptT LispError IO Bool
validateFuncParams ([LispVal]
fparams [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
varargs]) Maybe Integer
forall a. Maybe a
Nothing
      [LispVal]
ebody <- (LispVal -> IOThrowsError LispVal)
-> [LispVal] -> ExceptT LispError IO [LispVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ LispVal
lisp -> Env
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
Language.Scheme.Macro.macroEval Env
env LispVal
lisp LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply) [LispVal]
fbody
      LispVal
result <- LispVal -> Env -> [LispVal] -> [LispVal] -> IOThrowsError LispVal
forall (m :: * -> *).
Monad m =>
LispVal -> Env -> [LispVal] -> [LispVal] -> m LispVal
makeVarargs LispVal
varargs Env
env [LispVal]
fparams [LispVal]
ebody
      Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
result Maybe [LispVal]
forall a. Maybe a
Nothing

eval Env
env LispVal
cont args :: LispVal
args@(List (Atom String
"lambda" : varargs :: LispVal
varargs@(Atom String
_) : [LispVal]
fbody)) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"lambda"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else do 
      [LispVal]
ebody <- (LispVal -> IOThrowsError LispVal)
-> [LispVal] -> ExceptT LispError IO [LispVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ LispVal
lisp -> Env
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
Language.Scheme.Macro.macroEval Env
env LispVal
lisp LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply) [LispVal]
fbody
      LispVal
result <- LispVal -> Env -> [LispVal] -> [LispVal] -> IOThrowsError LispVal
forall (m :: * -> *).
Monad m =>
LispVal -> Env -> [LispVal] -> [LispVal] -> m LispVal
makeVarargs LispVal
varargs Env
env [] [LispVal]
ebody
      Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
result Maybe [LispVal]
forall a. Maybe a
Nothing

eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"string-set!", Atom String
var, LispVal
i, LispVal
character]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"string-set!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
env (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> LispVal
makeCPS Env
env LispVal
cont Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsChar) LispVal
character
 where
        cpsChar :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
        cpsChar :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsChar Env
e LispVal
c LispVal
chr Maybe [LispVal]
_ = do
            Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
e (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> [LispVal]
-> LispVal
makeCPSWArgs Env
e LispVal
c Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsStr [LispVal
chr]) LispVal
i

        cpsStr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
        cpsStr :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsStr Env
e LispVal
c LispVal
idx (Just [LispVal
chr]) = do
            LispVal
value <- Env -> String -> IOThrowsError LispVal
getVar Env
env String
var
            LispVal
derefValue <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
value
            Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
e (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> [LispVal]
-> LispVal
makeCPSWArgs Env
e LispVal
c Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsSubStr [LispVal
idx, LispVal
chr]) LispVal
derefValue
        cpsStr Env
_ LispVal
_ LispVal
_ Maybe [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError String
"Unexpected case in cpsStr"

        cpsSubStr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
        cpsSubStr :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsSubStr Env
e LispVal
c LispVal
str (Just [LispVal
idx, LispVal
chr]) = do
            LispVal
value <- (LispVal, LispVal, LispVal) -> IOThrowsError LispVal
substr (LispVal
str, LispVal
chr, LispVal
idx) IOThrowsError LispVal
-> (LispVal -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Env -> String -> LispVal -> IOThrowsError LispVal
updateObject Env
e String
var 
            Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
e LispVal
c LispVal
value Maybe [LispVal]
forall a. Maybe a
Nothing
        cpsSubStr Env
_ LispVal
_ LispVal
_ Maybe [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError String
"Invalid argument to cpsSubStr"

eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"string-set!" , LispVal
nonvar , LispVal
_ , LispVal
_ ]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"string-set!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"variable" LispVal
nonvar
eval Env
env LispVal
cont fargs :: LispVal
fargs@(List (Atom String
"string-set!" : [LispVal]
args)) = do 
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"string-set!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
fargs -- if is bound to a variable in this scope; call into it
  else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
3) [LispVal]
args

eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"set-car!", Atom String
var, LispVal
argObj]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"set-car!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else do
      LispVal
value <- Env -> String -> IOThrowsError LispVal
getVar Env
env String
var
      Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> LispVal
makeCPS Env
env LispVal
cont Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsObj) LispVal
value Maybe [LispVal]
forall a. Maybe a
Nothing
 where
        cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
        cpsObj :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsObj Env
e LispVal
c obj :: LispVal
obj@(Pointer String
_ Env
_) Maybe [LispVal]
x = do
          LispVal
o <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
obj
          Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsObj Env
e LispVal
c LispVal
o Maybe [LispVal]
x
        cpsObj Env
_ LispVal
_ obj :: LispVal
obj@(List []) Maybe [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"pair" LispVal
obj
        cpsObj Env
e LispVal
c obj :: LispVal
obj@(List (LispVal
_ : [LispVal]
_)) Maybe [LispVal]
_ = Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
e (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> [LispVal]
-> LispVal
makeCPSWArgs Env
e LispVal
c Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsSet [LispVal
obj]) LispVal
argObj
        cpsObj Env
e LispVal
c obj :: LispVal
obj@(DottedList [LispVal]
_ LispVal
_) Maybe [LispVal]
_ =  Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
e (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> [LispVal]
-> LispVal
makeCPSWArgs Env
e LispVal
c Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsSet [LispVal
obj]) LispVal
argObj
        cpsObj Env
_ LispVal
_ LispVal
obj Maybe [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"pair" LispVal
obj

        cpsSet :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
        cpsSet :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsSet Env
e LispVal
c LispVal
obj (Just [List (LispVal
_ : [LispVal]
ls)]) = do
            LispVal
value <- Env -> String -> LispVal -> IOThrowsError LispVal
updateObject Env
e String
var ([LispVal] -> LispVal
List (LispVal
obj LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
ls)) 
            Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
e LispVal
c LispVal
value Maybe [LispVal]
forall a. Maybe a
Nothing
        cpsSet Env
e LispVal
c LispVal
obj (Just [DottedList (LispVal
_ : [LispVal]
ls) LispVal
l]) = do
            LispVal
value <- Env -> String -> LispVal -> IOThrowsError LispVal
updateObject Env
e String
var ([LispVal] -> LispVal -> LispVal
DottedList (LispVal
obj LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
ls) LispVal
l) 
            Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
e LispVal
c LispVal
value Maybe [LispVal]
forall a. Maybe a
Nothing
        cpsSet Env
_ LispVal
_ LispVal
_ Maybe [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError String
"Unexpected argument to cpsSet"
eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"set-car!" , LispVal
nonvar , LispVal
_ ]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"set-car!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"variable" LispVal
nonvar
eval Env
env LispVal
cont fargs :: LispVal
fargs@(List (Atom String
"set-car!" : [LispVal]
args)) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"set-car!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
fargs -- if is bound to a variable in this scope; call into it
  else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
args

eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"set-cdr!", Atom String
var, LispVal
argObj]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"set-cdr!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else do
      LispVal
value <- Env -> String -> IOThrowsError LispVal
getVar Env
env String
var
      LispVal
derefValue <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
value
      Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> LispVal
makeCPS Env
env LispVal
cont Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsObj) LispVal
derefValue Maybe [LispVal]
forall a. Maybe a
Nothing
 where
        cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
        cpsObj :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsObj Env
_ LispVal
_ pair :: LispVal
pair@(List []) Maybe [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"pair" LispVal
pair
        cpsObj Env
e LispVal
c pair :: LispVal
pair@(List (LispVal
_ : [LispVal]
_)) Maybe [LispVal]
_ = Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
e (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> [LispVal]
-> LispVal
makeCPSWArgs Env
e LispVal
c Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsSet [LispVal
pair]) LispVal
argObj
        cpsObj Env
e LispVal
c pair :: LispVal
pair@(DottedList [LispVal]
_ LispVal
_) Maybe [LispVal]
_ = Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
e (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> [LispVal]
-> LispVal
makeCPSWArgs Env
e LispVal
c Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsSet [LispVal
pair]) LispVal
argObj
        cpsObj Env
_ LispVal
_ LispVal
pair Maybe [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"pair" LispVal
pair

        updateCdr :: Env -> LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateCdr Env
e LispVal
c LispVal
obj LispVal
l = do
            LispVal
l' <- LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
l
            LispVal
obj' <- LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
obj
            LispVal
value <- ([LispVal] -> IOThrowsError LispVal
cons [LispVal
l', LispVal
obj']) IOThrowsError LispVal
-> (LispVal -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Env -> String -> LispVal -> IOThrowsError LispVal
updateObject Env
e String
var 
            Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
e LispVal
c LispVal
value Maybe [LispVal]
forall a. Maybe a
Nothing

        cpsSet :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
        cpsSet :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsSet Env
e LispVal
c LispVal
obj (Just [List (LispVal
l : [LispVal]
_)]) = Env -> LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateCdr Env
e LispVal
c LispVal
obj LispVal
l
        cpsSet Env
e LispVal
c LispVal
obj (Just [DottedList (LispVal
l : [LispVal]
_) LispVal
_]) = Env -> LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateCdr Env
e LispVal
c LispVal
obj LispVal
l
        cpsSet Env
_ LispVal
_ LispVal
_ Maybe [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError String
"Unexpected argument to cpsSet"
eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"set-cdr!" , LispVal
nonvar , LispVal
_ ]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"set-cdr!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else do
      -- TODO: eval nonvar, then can process it if we get a list
      LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"variable" LispVal
nonvar
eval Env
env LispVal
cont fargs :: LispVal
fargs@(List (Atom String
"set-cdr!" : [LispVal]
args)) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"set-cdr!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
fargs -- if is bound to a variable in this scope; call into it
  else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
args

eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"list-set!", Atom String
var, LispVal
i, LispVal
object]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"list-set!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
env (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> LispVal
makeCPS Env
env LispVal
cont ((Env
  -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
 -> LispVal)
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> LispVal
forall a b. (a -> b) -> a -> b
$ String
-> LispVal
-> (LispVal -> LispVal -> LispVal -> IOThrowsError LispVal)
-> Env
-> LispVal
-> LispVal
-> Maybe [LispVal]
-> IOThrowsError LispVal
createObjSetCPS String
var LispVal
object LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateList) LispVal
i

eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"list-set!" , LispVal
nonvar , LispVal
_ , LispVal
_]) = do 
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"list-set!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"variable" LispVal
nonvar
eval Env
env LispVal
cont fargs :: LispVal
fargs@(List (Atom String
"list-set!" : [LispVal]
args)) = do 
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"list-set!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
fargs -- if is bound to a variable in this scope; call into it
  else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
3) [LispVal]
args

eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"vector-set!", Atom String
var, LispVal
i, LispVal
object]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"vector-set!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
env (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> LispVal
makeCPS Env
env LispVal
cont ((Env
  -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
 -> LispVal)
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> LispVal
forall a b. (a -> b) -> a -> b
$ String
-> LispVal
-> (LispVal -> LispVal -> LispVal -> IOThrowsError LispVal)
-> Env
-> LispVal
-> LispVal
-> Maybe [LispVal]
-> IOThrowsError LispVal
createObjSetCPS String
var LispVal
object LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateVector) LispVal
i
eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"vector-set!" , LispVal
nonvar , LispVal
_ , LispVal
_]) = do 
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"vector-set!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"variable" LispVal
nonvar
eval Env
env LispVal
cont fargs :: LispVal
fargs@(List (Atom String
"vector-set!" : [LispVal]
args)) = do 
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"vector-set!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
fargs -- if is bound to a variable in this scope; call into it
  else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
3) [LispVal]
args

eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"bytevector-u8-set!", Atom String
var, LispVal
i, LispVal
object]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"bytevector-u8-set!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
env (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> LispVal
makeCPS Env
env LispVal
cont ((Env
  -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
 -> LispVal)
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> LispVal
forall a b. (a -> b) -> a -> b
$ String
-> LispVal
-> (LispVal -> LispVal -> LispVal -> IOThrowsError LispVal)
-> Env
-> LispVal
-> LispVal
-> Maybe [LispVal]
-> IOThrowsError LispVal
createObjSetCPS String
var LispVal
object LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateByteVector) LispVal
i

eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"bytevector-u8-set!" , LispVal
nonvar , LispVal
_ , LispVal
_]) = do 
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"bytevector-u8-set!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"variable" LispVal
nonvar
eval Env
env LispVal
cont fargs :: LispVal
fargs@(List (Atom String
"bytevector-u8-set!" : [LispVal]
args)) = do 
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"bytevector-u8-set!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
fargs -- if is bound to a variable in this scope; call into it
  else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
3) [LispVal]
args

eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"hash-table-set!", Atom String
var, LispVal
rkey, LispVal
rvalue]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"hash-table-set!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
env (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> LispVal
makeCPS Env
env LispVal
cont Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsValue) LispVal
rkey
 where
        cpsValue :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
        cpsValue :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsValue Env
e LispVal
c LispVal
key Maybe [LispVal]
_ = Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
e (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> [LispVal]
-> LispVal
makeCPSWArgs Env
e LispVal
c Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsH [LispVal
key]) LispVal
rvalue

        cpsH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
        cpsH :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsH Env
e LispVal
c LispVal
value (Just [LispVal
key]) = do
          LispVal
v <- Env -> String -> IOThrowsError LispVal
getVar Env
e String
var
          LispVal
derefVar <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
v
          Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
e (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> [LispVal]
-> LispVal
makeCPSWArgs Env
e LispVal
c Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsEvalH [LispVal
key, LispVal
value]) LispVal
derefVar
        cpsH Env
_ LispVal
_ LispVal
_ Maybe [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError String
"Invalid argument to cpsH"

        cpsEvalH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
        cpsEvalH :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsEvalH Env
e LispVal
c LispVal
h (Just [LispVal
key, LispVal
value]) = do
            case LispVal
h of
                HashTable Map LispVal LispVal
ht -> do
                  Env -> String -> LispVal -> IOThrowsError LispVal
updateObject Env
env String
var (Map LispVal LispVal -> LispVal
HashTable (Map LispVal LispVal -> LispVal) -> Map LispVal LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ LispVal -> LispVal -> Map LispVal LispVal -> Map LispVal LispVal
forall k a. Ord k => k -> a -> Map k a -> Map k a
Data.Map.insert LispVal
key LispVal
value Map LispVal LispVal
ht) IOThrowsError LispVal
-> (LispVal -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
e LispVal
c
                LispVal
other -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"hash-table" LispVal
other
        cpsEvalH Env
_ LispVal
_ LispVal
_ Maybe [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError String
"Invalid argument to cpsEvalH"
eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"hash-table-set!" , LispVal
nonvar , LispVal
_ , LispVal
_]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"hash-table-set!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"variable" LispVal
nonvar
eval Env
env LispVal
cont fargs :: LispVal
fargs@(List (Atom String
"hash-table-set!" : [LispVal]
args)) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"hash-table-set!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
fargs -- if is bound to a variable in this scope; call into it
  else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
3) [LispVal]
args

eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"hash-table-delete!", Atom String
var, LispVal
rkey]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"hash-table-delete!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
env (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> LispVal
makeCPS Env
env LispVal
cont Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsH) LispVal
rkey
 where
        cpsH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
        cpsH :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsH Env
e LispVal
c LispVal
key Maybe [LispVal]
_ = do
            LispVal
value <- Env -> String -> IOThrowsError LispVal
getVar Env
e String
var
            LispVal
derefValue <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
value
            Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
e (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> [LispVal]
-> LispVal
makeCPSWArgs Env
e LispVal
c Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsEvalH ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal
key]) LispVal
derefValue

        cpsEvalH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
        cpsEvalH :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsEvalH Env
e LispVal
c LispVal
h (Just [LispVal
key]) = do
            case LispVal
h of
                HashTable Map LispVal LispVal
ht -> do
                  Env -> String -> LispVal -> IOThrowsError LispVal
updateObject Env
env String
var (Map LispVal LispVal -> LispVal
HashTable (Map LispVal LispVal -> LispVal) -> Map LispVal LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ LispVal -> Map LispVal LispVal -> Map LispVal LispVal
forall k a. Ord k => k -> Map k a -> Map k a
Data.Map.delete LispVal
key Map LispVal LispVal
ht) IOThrowsError LispVal
-> (LispVal -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
e LispVal
c
                LispVal
other -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"hash-table" LispVal
other
        cpsEvalH Env
_ LispVal
_ LispVal
_ Maybe [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError String
"Invalid argument to cpsEvalH"
eval Env
env LispVal
cont args :: LispVal
args@(List [Atom String
"hash-table-delete!" , LispVal
nonvar , LispVal
_]) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"hash-table-delete!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
args -- if is bound to a variable in this scope; call into it
  else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"variable" LispVal
nonvar
eval Env
env LispVal
cont fargs :: LispVal
fargs@(List (Atom String
"hash-table-delete!" : [LispVal]
args)) = do
 Bool
bound <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> String -> IO Bool
isRecBound Env
env String
"hash-table-delete!"
 if Bool
bound
  then Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env LispVal
cont LispVal
fargs -- if is bound to a variable in this scope; call into it
  else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
args

eval Env
env LispVal
cont args :: LispVal
args@(List (LispVal
_ : [LispVal]
_)) = Env -> LispVal -> LispVal -> IOThrowsError LispVal
mprepareApply Env
env LispVal
cont LispVal
args
eval Env
_ LispVal
_ LispVal
badForm = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
BadSpecialForm String
"Unrecognized special form" LispVal
badForm

-- |A helper function for the special form /(string-set!)/
substr :: (LispVal, LispVal, LispVal) -> IOThrowsError LispVal 
substr :: (LispVal, LispVal, LispVal) -> IOThrowsError LispVal
substr (String String
str, Char Char
char, Number Integer
ii) = do
                      LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
String (String -> LispVal) -> String -> LispVal
forall a b. (a -> b) -> a -> b
$ (Int -> String -> String
forall a. Int -> [a] -> [a]
take (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
ii) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
0) String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++
                               [Char
char] String -> String -> String
forall a. [a] -> [a] -> [a]
++
                               (Int -> String -> String
forall a. Int -> [a] -> [a]
take (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
ii Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) String
str
substr (String String
_, Char Char
_, LispVal
n) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"number" LispVal
n
substr (String String
_, LispVal
c, LispVal
_) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"character" LispVal
c
substr (LispVal
s, LispVal
_, LispVal
_) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"string" LispVal
s

-- |Replace a list element, by index. Taken from:
--  http://stackoverflow.com/questions/10133361/haskell-replace-element-in-list
replaceAtIndex :: forall a. Int -> a -> [a] -> [a]
replaceAtIndex :: Int -> a -> [a] -> [a]
replaceAtIndex Int
n a
item [a]
ls = [a]
a [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ (a
itema -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
b) where ([a]
a, (a
_:[a]
b)) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
ls

-- |A helper function for /(list-set!)/
updateList :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateList :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateList (List [LispVal]
list) (Number Integer
idx) LispVal
obj = do
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ Int -> LispVal -> [LispVal] -> [LispVal]
forall a. Int -> a -> [a] -> [a]
replaceAtIndex (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
idx) LispVal
obj [LispVal]
list
updateList ptr :: LispVal
ptr@(Pointer String
_ Env
_) LispVal
i LispVal
obj = do
  LispVal
list <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
ptr
  LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateList LispVal
list LispVal
i LispVal
obj
updateList LispVal
l LispVal
_ LispVal
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"list" LispVal
l

-- |A helper function for the special form /(vector-set!)/
updateVector :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateVector :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateVector (Vector Array Int LispVal
vec) (Number Integer
idx) LispVal
obj = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Array Int LispVal -> LispVal
Vector (Array Int LispVal -> LispVal) -> Array Int LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ Array Int LispVal
vec Array Int LispVal -> [(Int, LispVal)] -> Array Int LispVal
forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
// [(Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
idx, LispVal
obj)]
updateVector ptr :: LispVal
ptr@(Pointer String
_ Env
_) LispVal
i LispVal
obj = do
  LispVal
vec <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
ptr
  LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateVector LispVal
vec LispVal
i LispVal
obj
updateVector LispVal
v LispVal
_ LispVal
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"vector" LispVal
v

-- |A helper function for the special form /(bytevector-u8-set!)/
updateByteVector :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateByteVector :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateByteVector (ByteVector ByteString
vec) (Number Integer
idx) LispVal
obj = 
    case LispVal
obj of
        Number Integer
byte -> do
-- TODO: error checking
           let (ByteString
h, ByteString
t) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
idx) ByteString
vec
           LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ ByteString -> LispVal
ByteVector (ByteString -> LispVal) -> ByteString -> LispVal
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BS.concat [ByteString
h, [Word8] -> ByteString
BS.pack [Integer -> Word8
forall a. Num a => Integer -> a
fromInteger Integer
byte :: Word8], ByteString -> ByteString
BS.tail ByteString
t]
        LispVal
badType -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"byte" LispVal
badType
updateByteVector ptr :: LispVal
ptr@(Pointer String
_ Env
_) LispVal
i LispVal
obj = do
  LispVal
vec <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
ptr
  LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateByteVector LispVal
vec LispVal
i LispVal
obj
updateByteVector LispVal
v LispVal
_ LispVal
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"bytevector" LispVal
v

-- |Helper function to perform CPS for vector-set! and similar forms
createObjSetCPS :: String
                   -> LispVal
                   -> (LispVal -> LispVal -> LispVal -> ExceptT LispError IO LispVal)
                   -> Env
                   -> LispVal
                   -> LispVal
                   -> Maybe [LispVal]
                   -> IOThrowsError LispVal
createObjSetCPS :: String
-> LispVal
-> (LispVal -> LispVal -> LispVal -> IOThrowsError LispVal)
-> Env
-> LispVal
-> LispVal
-> Maybe [LispVal]
-> IOThrowsError LispVal
createObjSetCPS String
var LispVal
object LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateFnc = Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsIndex
  where
    -- Update data structure at given index, with given object
    cpsUpdateStruct :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
    cpsUpdateStruct :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsUpdateStruct Env
e LispVal
c LispVal
struct (Just [LispVal
idx, LispVal
obj]) = do
        LispVal
value <- LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
updateFnc LispVal
struct LispVal
idx LispVal
obj IOThrowsError LispVal
-> (LispVal -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Env -> String -> LispVal -> IOThrowsError LispVal
updateObject Env
e String
var
        Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
e LispVal
c LispVal
value Maybe [LispVal]
forall a. Maybe a
Nothing
    cpsUpdateStruct Env
_ LispVal
_ LispVal
_ Maybe [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError String
"Invalid argument to cpsUpdateStruct"

    -- Receive index/object, retrieve variable containing data structure
    cpsGetVar :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
    cpsGetVar :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsGetVar Env
e LispVal
c LispVal
obj (Just [LispVal
idx]) = (Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
e (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> [LispVal]
-> LispVal
makeCPSWArgs Env
e LispVal
c Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsUpdateStruct [LispVal
idx, LispVal
obj]) (LispVal -> IOThrowsError LispVal)
-> IOThrowsError LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env -> String -> IOThrowsError LispVal
getVar Env
e String
var)
    cpsGetVar Env
_ LispVal
_ LispVal
_ Maybe [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError String
"Invalid argument to cpsGetVar"

    -- Receive and pass index
    cpsIndex :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
    cpsIndex :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsIndex Env
e LispVal
c LispVal
idx Maybe [LispVal]
_ = Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
e (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> [LispVal]
-> LispVal
makeCPSWArgs Env
e LispVal
c Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsGetVar [LispVal
idx]) LispVal
object

{- Prepare for apply by evaluating each function argument,
   and then execute the function via 'apply' -}
prepareApply :: Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply :: Env -> LispVal -> LispVal -> IOThrowsError LispVal
prepareApply Env
env (Continuation Env
clo Maybe DeferredCode
cc Maybe LispVal
nc Maybe [DynamicWinders]
dw [LispVal]
cstk) fnc :: LispVal
fnc@(List (LispVal
function : [LispVal]
functionArgs)) = do
  Env -> LispVal -> LispVal -> IOThrowsError LispVal
eval Env
env 
       (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> [LispVal]
-> LispVal
makeCPSWArgs Env
env (Env
-> Maybe DeferredCode
-> Maybe LispVal
-> Maybe [DynamicWinders]
-> [LispVal]
-> LispVal
Continuation Env
clo Maybe DeferredCode
cc Maybe LispVal
nc Maybe [DynamicWinders]
dw ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$! LispVal -> [LispVal] -> [LispVal]
addToCallHistory LispVal
fnc [LispVal]
cstk) 
                     Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsPrepArgs [LispVal]
functionArgs) 
       LispVal
function
 where
       cpsPrepArgs :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
       cpsPrepArgs :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsPrepArgs Env
e LispVal
c LispVal
func Maybe [LispVal]
args' = do
-- case (trace ("prep eval of args: " ++ show args) args) of
          let args :: [LispVal]
args = case Maybe [LispVal]
args' of
                          Just [LispVal]
as -> [LispVal]
as
                          Maybe [LispVal]
Nothing -> []
          --case (trace ("stack: " ++ (show fnc) ++ " " ++ (show cstk)) args) of
          case [LispVal]
args of
            [] -> LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply LispVal
c LispVal
func [] -- No args, immediately apply the function
            [LispVal
a] -> Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
env (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> [LispVal]
-> LispVal
makeCPSWArgs Env
e LispVal
c Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsEvalArgs [LispVal
func, [LispVal] -> LispVal
List [], [LispVal] -> LispVal
List []]) LispVal
a
            (LispVal
a : [LispVal]
as) -> Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
env (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> [LispVal]
-> LispVal
makeCPSWArgs Env
e LispVal
c Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsEvalArgs [LispVal
func, [LispVal] -> LispVal
List [], [LispVal] -> LispVal
List [LispVal]
as]) LispVal
a
        {- Store value of previous argument, evaluate the next arg until all are done
        parg - Previous argument that has now been evaluated
        state - List containing the following, in order:
        - Function to apply when args are ready
        - List of evaluated parameters
        - List of parameters awaiting evaluation -}
       cpsEvalArgs :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
       cpsEvalArgs :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsEvalArgs Env
e LispVal
c LispVal
evaledArg (Just [LispVal
func, List [LispVal]
argsEvaled, List [LispVal]
argsRemaining]) =
          case [LispVal]
argsRemaining of
            [] -> LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply LispVal
c LispVal
func ([LispVal]
argsEvaled [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
evaledArg])
            [LispVal
a] -> Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
e (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> [LispVal]
-> LispVal
makeCPSWArgs Env
e LispVal
c Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsEvalArgs [LispVal
func, [LispVal] -> LispVal
List ([LispVal]
argsEvaled [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
evaledArg]), [LispVal] -> LispVal
List []]) LispVal
a
            (LispVal
a : [LispVal]
as) -> Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
e (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> [LispVal]
-> LispVal
makeCPSWArgs Env
e LispVal
c Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsEvalArgs [LispVal
func, [LispVal] -> LispVal
List ([LispVal]
argsEvaled [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
evaledArg]), [LispVal] -> LispVal
List [LispVal]
as]) LispVal
a

       cpsEvalArgs Env
_ LispVal
_ LispVal
_ (Just [LispVal]
a) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
Default (String -> LispError) -> String -> LispError
forall a b. (a -> b) -> a -> b
$ String
"Unexpected error in function application (1) " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [LispVal] -> String
forall a. Show a => a -> String
show [LispVal]
a
       cpsEvalArgs Env
_ LispVal
_ LispVal
_ Maybe [LispVal]
Nothing = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
Default String
"Unexpected error in function application (2)"
prepareApply Env
_ LispVal
_ LispVal
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
Default String
"Unexpected error in prepareApply"

-- |Call into a Scheme function
apply :: LispVal  -- ^ Current continuation
      -> LispVal  -- ^ Function or continuation to execute
      -> [LispVal] -- ^ Arguments
      -> IOThrowsError LispVal -- ^ Final value of computation
apply :: LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply LispVal
_ cont :: LispVal
cont@(Continuation Env
env Maybe DeferredCode
_ Maybe LispVal
_ Maybe [DynamicWinders]
ndynwind [LispVal]
_) [LispVal]
args = do
-- case (trace ("calling into continuation. dynWind = " ++ show ndynwind) ndynwind) of
  case Maybe [DynamicWinders]
ndynwind of
    -- Call into dynWind.before if it exists...
    Just [DynamicWinders LispVal
beforeFunc LispVal
_] -> LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> LispVal
makeCPS Env
env LispVal
cont Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsApply) LispVal
beforeFunc []
    Maybe [DynamicWinders]
_ -> Env -> LispVal -> IOThrowsError LispVal
doApply Env
env LispVal
cont
 where
   cpsApply :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
   cpsApply :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsApply Env
e LispVal
c LispVal
_ Maybe [LispVal]
_ = Env -> LispVal -> IOThrowsError LispVal
doApply Env
e LispVal
c
   doApply :: Env -> LispVal -> IOThrowsError LispVal
doApply Env
e LispVal
c = do
      case (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
args) of
        Integer
0 -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) []
        Integer
1 -> Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
e LispVal
c ([LispVal] -> LispVal
forall a. [a] -> a
head [LispVal]
args) Maybe [LispVal]
forall a. Maybe a
Nothing
        Integer
_ ->  -- Pass along additional arguments, so they are available to (call-with-values)
             Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
e LispVal
cont ([LispVal] -> LispVal
forall a. [a] -> a
head [LispVal]
args) ([LispVal] -> Maybe [LispVal]
forall a. a -> Maybe a
Just ([LispVal] -> Maybe [LispVal]) -> [LispVal] -> Maybe [LispVal]
forall a b. (a -> b) -> a -> b
$ [LispVal] -> [LispVal]
forall a. [a] -> [a]
tail [LispVal]
args)
apply LispVal
cont (IOFunc [LispVal] -> IOThrowsError LispVal
f) [LispVal]
args = do
  LispVal
result <- ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
exec [LispVal] -> IOThrowsError LispVal
f
  case LispVal
cont of
    Continuation {contClosure :: LispVal -> Env
contClosure = Env
cEnv} -> Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
cEnv LispVal
cont LispVal
result Maybe [LispVal]
forall a. Maybe a
Nothing
    LispVal
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
result
 where
  exec :: ([LispVal] -> IOThrowsError LispVal) -> IOThrowsError LispVal
exec [LispVal] -> IOThrowsError LispVal
func = do
    [LispVal] -> IOThrowsError LispVal
func [LispVal]
args
    IOThrowsError LispVal
-> (LispError -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` LispVal -> LispError -> IOThrowsError LispVal
throwErrorWithCallHistory LispVal
cont
apply LispVal
cont (CustFunc [LispVal] -> IOThrowsError LispVal
f) [LispVal]
args = do
  List [LispVal]
dargs <- LispVal -> IOThrowsError LispVal
recDerefPtrs (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
args -- Deref any pointers
  LispVal
result <- ([LispVal] -> IOThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
forall t.
(t -> IOThrowsError LispVal) -> t -> IOThrowsError LispVal
exec [LispVal] -> IOThrowsError LispVal
f [LispVal]
dargs
  case LispVal
cont of
    Continuation {contClosure :: LispVal -> Env
contClosure = Env
cEnv} -> Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
cEnv LispVal
cont LispVal
result Maybe [LispVal]
forall a. Maybe a
Nothing
    LispVal
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
result
 where
  exec :: (t -> IOThrowsError LispVal) -> t -> IOThrowsError LispVal
exec t -> IOThrowsError LispVal
func t
fargs = do
    t -> IOThrowsError LispVal
func t
fargs
    IOThrowsError LispVal
-> (LispError -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` LispVal -> LispError -> IOThrowsError LispVal
throwErrorWithCallHistory LispVal
cont
apply LispVal
cont (EvalFunc [LispVal] -> IOThrowsError LispVal
func) [LispVal]
args = do
    -- An EvalFunc extends the evaluator so it needs access to the current 
    -- continuation, so pass it as the first argument.
  [LispVal] -> IOThrowsError LispVal
func (LispVal
cont LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
args)
apply LispVal
cont (PrimitiveFunc [LispVal] -> ThrowsError LispVal
func) [LispVal]
args = do
  -- OK not to deref ptrs here because primitives only operate on
  -- non-objects, and the error handler execs in the I/O monad and
  -- handles ptrs just fine
  LispVal
result <- [LispVal] -> IOThrowsError LispVal
exec [LispVal]
args
  case LispVal
cont of
    Continuation {contClosure :: LispVal -> Env
contClosure = Env
cEnv} -> Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
cEnv LispVal
cont LispVal
result Maybe [LispVal]
forall a. Maybe a
Nothing
    LispVal
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
result
 where
  exec :: [LispVal] -> IOThrowsError LispVal
exec [LispVal]
fargs = do
    ThrowsError LispVal -> IOThrowsError LispVal
forall a. ThrowsError a -> IOThrowsError a
liftThrows (ThrowsError LispVal -> IOThrowsError LispVal)
-> ThrowsError LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> ThrowsError LispVal
func [LispVal]
fargs
    IOThrowsError LispVal
-> (LispError -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` LispVal -> LispError -> IOThrowsError LispVal
throwErrorWithCallHistory LispVal
cont
apply LispVal
cont (Func [String]
aparams Maybe String
avarargs [LispVal]
abody Env
aclosure) [LispVal]
args =
  if ([String] -> Integer
forall a. [a] -> Integer
num [String]
aparams Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= [LispVal] -> Integer
forall a. [a] -> Integer
num [LispVal]
args Bool -> Bool -> Bool
&& Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing Maybe String
avarargs) Bool -> Bool -> Bool
||
     ([String] -> Integer
forall a. [a] -> Integer
num [String]
aparams Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> [LispVal] -> Integer
forall a. [a] -> Integer
num [LispVal]
args Bool -> Bool -> Bool
&& Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
avarargs)
     then LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just ([String] -> Integer
forall a. [a] -> Integer
num [String]
aparams)) [LispVal]
args
     else IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Env -> [((Char, String), LispVal)] -> IO Env
extendEnv Env
aclosure ([((Char, String), LispVal)] -> IO Env)
-> [((Char, String), LispVal)] -> IO Env
forall a b. (a -> b) -> a -> b
$ [(Char, String)] -> [LispVal] -> [((Char, String), LispVal)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((String -> (Char, String)) -> [String] -> [(Char, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((,) Char
varNamespace) [String]
aparams) [LispVal]
args) ExceptT LispError IO Env
-> (Env -> ExceptT LispError IO Env) -> ExceptT LispError IO Env
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe String -> Env -> ExceptT LispError IO Env
forall (m :: * -> *). MonadIO m => Maybe String -> Env -> m Env
bindVarArgs Maybe String
avarargs ExceptT LispError IO Env
-> (Env -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([LispVal] -> Env -> IOThrowsError LispVal
evalBody [LispVal]
abody)
  where remainingArgs :: [LispVal]
remainingArgs = Int -> [LispVal] -> [LispVal]
forall a. Int -> [a] -> [a]
drop ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
aparams) [LispVal]
args
        num :: [a] -> Integer
num = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> ([a] -> Int) -> [a] -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
        --
        -- Continue evaluation within the body, preserving the outer continuation.
        --
        {- This link was helpful for implementing this, and has a *lot* of other useful information:
        http://icem-www.folkwang-hochschule.de/~finnendahl/cm_kurse/doc/schintro/schintro_73.html#SEC80 -}
        --
        {- What we are doing now is simply not saving a continuation for tail calls. For now this may
        be good enough, although it may need to be enhanced in the future in order to properly
        detect all tail calls. -}
        --
        -- See: http://icem-www.folkwang-hochschule.de/~finnendahl/cm_kurse/doc/schintro/schintro_142.html#SEC294
        --
        evalBody :: [LispVal] -> Env -> IOThrowsError LispVal
evalBody [LispVal]
evBody Env
env = case LispVal
cont of
            Continuation Env
_ (Just (SchemeBody [LispVal]
cBody)) (Just LispVal
cCont) Maybe [DynamicWinders]
cDynWind [LispVal]
cStack -> if [LispVal] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LispVal]
cBody
                then Env
-> [LispVal]
-> LispVal
-> Maybe [DynamicWinders]
-> [LispVal]
-> IOThrowsError LispVal
continueWCont Env
env [LispVal]
evBody LispVal
cCont Maybe [DynamicWinders]
cDynWind [LispVal]
cStack
-- else continueWCont env (evBody) cont (trace ("cDynWind = " ++ show cDynWind) cDynWind) -- Might be a problem, not fully optimizing
                else Env
-> [LispVal]
-> LispVal
-> Maybe [DynamicWinders]
-> [LispVal]
-> IOThrowsError LispVal
continueWCont Env
env [LispVal]
evBody LispVal
cont Maybe [DynamicWinders]
cDynWind [LispVal]
cStack -- Might be a problem, not fully optimizing
            Continuation Env
_ Maybe DeferredCode
_ Maybe LispVal
_ Maybe [DynamicWinders]
cDynWind [LispVal]
cStack -> Env
-> [LispVal]
-> LispVal
-> Maybe [DynamicWinders]
-> [LispVal]
-> IOThrowsError LispVal
continueWCont Env
env [LispVal]
evBody LispVal
cont Maybe [DynamicWinders]
cDynWind [LispVal]
cStack
            LispVal
_ -> Env
-> [LispVal]
-> LispVal
-> Maybe [DynamicWinders]
-> [LispVal]
-> IOThrowsError LispVal
continueWCont Env
env [LispVal]
evBody LispVal
cont Maybe [DynamicWinders]
forall a. Maybe a
Nothing []

        -- Shortcut for calling continueEval
        continueWCont :: Env
-> [LispVal]
-> LispVal
-> Maybe [DynamicWinders]
-> [LispVal]
-> IOThrowsError LispVal
continueWCont Env
cwcEnv [LispVal]
cwcBody LispVal
cwcCont Maybe [DynamicWinders]
cwcDynWind [LispVal]
cStack =
            Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
cwcEnv (Env
-> Maybe DeferredCode
-> Maybe LispVal
-> Maybe [DynamicWinders]
-> [LispVal]
-> LispVal
Continuation Env
cwcEnv (DeferredCode -> Maybe DeferredCode
forall a. a -> Maybe a
Just ([LispVal] -> DeferredCode
SchemeBody [LispVal]
cwcBody)) (LispVal -> Maybe LispVal
forall a. a -> Maybe a
Just LispVal
cwcCont) Maybe [DynamicWinders]
cwcDynWind [LispVal]
cStack) (String -> LispVal
Nil String
"") Maybe [LispVal]
forall a. Maybe a
Nothing

        bindVarArgs :: Maybe String -> Env -> m Env
bindVarArgs Maybe String
arg Env
env = case Maybe String
arg of
          Just String
argName -> IO Env -> m Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> m Env) -> IO Env -> m Env
forall a b. (a -> b) -> a -> b
$ Env -> [((Char, String), LispVal)] -> IO Env
extendEnv Env
env [((Char
varNamespace, String
argName), [LispVal] -> LispVal
List [LispVal]
remainingArgs)]
          Maybe String
Nothing -> Env -> m Env
forall (m :: * -> *) a. Monad m => a -> m a
return Env
env
apply LispVal
cont (HFunc [String]
aparams Maybe String
avarargs Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
abody Env
aclosure) [LispVal]
args =
  if ([String] -> Integer
forall a. [a] -> Integer
num [String]
aparams Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= [LispVal] -> Integer
forall a. [a] -> Integer
num [LispVal]
args Bool -> Bool -> Bool
&& Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing Maybe String
avarargs) Bool -> Bool -> Bool
||
     ([String] -> Integer
forall a. [a] -> Integer
num [String]
aparams Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> [LispVal] -> Integer
forall a. [a] -> Integer
num [LispVal]
args Bool -> Bool -> Bool
&& Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
avarargs)
     then LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just ([String] -> Integer
forall a. [a] -> Integer
num [String]
aparams)) [LispVal]
args
     else IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Env -> [((Char, String), LispVal)] -> IO Env
extendEnv Env
aclosure ([((Char, String), LispVal)] -> IO Env)
-> [((Char, String), LispVal)] -> IO Env
forall a b. (a -> b) -> a -> b
$ [(Char, String)] -> [LispVal] -> [((Char, String), LispVal)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((String -> (Char, String)) -> [String] -> [(Char, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((,) Char
varNamespace) [String]
aparams) [LispVal]
args) ExceptT LispError IO Env
-> (Env -> ExceptT LispError IO Env) -> ExceptT LispError IO Env
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe String -> Env -> ExceptT LispError IO Env
forall (m :: * -> *). MonadIO m => Maybe String -> Env -> m Env
bindVarArgs Maybe String
avarargs ExceptT LispError IO Env
-> (Env -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Env
 -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> Env -> IOThrowsError LispVal
forall t a t. (t -> LispVal -> LispVal -> Maybe [a] -> t) -> t -> t
evalBody Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
abody)
  where remainingArgs :: [LispVal]
remainingArgs = Int -> [LispVal] -> [LispVal]
forall a. Int -> [a] -> [a]
drop ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
aparams) [LispVal]
args
        num :: [a] -> Integer
num = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> ([a] -> Int) -> [a] -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
        evalBody :: (t -> LispVal -> LispVal -> Maybe [a] -> t) -> t -> t
evalBody t -> LispVal -> LispVal -> Maybe [a] -> t
evBody t
env = t -> LispVal -> LispVal -> Maybe [a] -> t
evBody t
env LispVal
cont (String -> LispVal
Nil String
"") ([a] -> Maybe [a]
forall a. a -> Maybe a
Just [])
{- TODO: may need to handle cases from Func, such as dynamic winders
        case cont of
            Continuation _ (Just (SchemeBody cBody)) (Just cCont) _ cDynWind -> if length cBody == 0
                then continueWCont env (evBody) cCont cDynWind
                else continueWCont env (evBody) cont cDynWind -- Might be a problem, not fully optimizing
            Continuation _ _ _ _ cDynWind -> continueWCont env (evBody) cont cDynWind
            _ -> continueWCont env (evBody) cont Nothing

        -- Shortcut for calling continueEval
        continueWCont cwcEnv cwcBody cwcCont cwcDynWind =
            continueEval cwcEnv (Continuation cwcEnv (Just (SchemeBody cwcBody)) (Just cwcCont) Nothing cwcDynWind) $ Nil ""-}

        bindVarArgs :: Maybe String -> Env -> m Env
bindVarArgs Maybe String
arg Env
env = case Maybe String
arg of
          Just String
argName -> IO Env -> m Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> m Env) -> IO Env -> m Env
forall a b. (a -> b) -> a -> b
$ Env -> [((Char, String), LispVal)] -> IO Env
extendEnv Env
env [((Char
varNamespace, String
argName), [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
remainingArgs)]
          Maybe String
Nothing -> Env -> m Env
forall (m :: * -> *) a. Monad m => a -> m a
return Env
env
apply LispVal
_ LispVal
func [LispVal]
args = do
  List [LispVal
func'] <- LispVal -> IOThrowsError LispVal
recDerefPtrs (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal
func] -- Deref any pointers
  List [LispVal]
args' <- LispVal -> IOThrowsError LispVal
recDerefPtrs (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
args
  LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
BadSpecialForm String
"Unable to evaluate form" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List (LispVal
func' LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
args')

-- |Environment containing the primitive forms that are built into the Scheme 
--  language. This function only includes forms that are implemented in Haskell; 
--  derived forms implemented in Scheme (such as let, list, etc) are available
--  in the standard library which must be pulled into the environment using /(load)/
--
--  For the purposes of using husk as an extension language, /r5rsEnv/ will
--  probably be more useful.
primitiveBindings :: IO Env
primitiveBindings :: IO Env
primitiveBindings = IO Env
nullEnv IO Env -> (Env -> IO Env) -> IO Env
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 
    (Env -> [((Char, String), LispVal)] -> IO Env)
-> [((Char, String), LispVal)] -> Env -> IO Env
forall a b c. (a -> b -> c) -> b -> a -> c
flip Env -> [((Char, String), LispVal)] -> IO Env
extendEnv  ( ((String, [LispVal] -> IOThrowsError LispVal)
 -> ((Char, String), LispVal))
-> [(String, [LispVal] -> IOThrowsError LispVal)]
-> [((Char, String), LispVal)]
forall a b. (a -> b) -> [a] -> [b]
map ((([LispVal] -> IOThrowsError LispVal) -> LispVal)
-> (String, [LispVal] -> IOThrowsError LispVal)
-> ((Char, String), LispVal)
forall t b b. (t -> b) -> (b, t) -> ((Char, b), b)
domakeFunc ([LispVal] -> IOThrowsError LispVal) -> LispVal
IOFunc) [(String, [LispVal] -> IOThrowsError LispVal)]
ioPrimitives
                   [((Char, String), LispVal)]
-> [((Char, String), LispVal)] -> [((Char, String), LispVal)]
forall a. [a] -> [a] -> [a]
++ ((String, [LispVal] -> IOThrowsError LispVal)
 -> ((Char, String), LispVal))
-> [(String, [LispVal] -> IOThrowsError LispVal)]
-> [((Char, String), LispVal)]
forall a b. (a -> b) -> [a] -> [b]
map ((([LispVal] -> IOThrowsError LispVal) -> LispVal)
-> (String, [LispVal] -> IOThrowsError LispVal)
-> ((Char, String), LispVal)
forall t b b. (t -> b) -> (b, t) -> ((Char, b), b)
domakeFunc ([LispVal] -> IOThrowsError LispVal) -> LispVal
EvalFunc) [(String, [LispVal] -> IOThrowsError LispVal)]
evalFunctions
                   [((Char, String), LispVal)]
-> [((Char, String), LispVal)] -> [((Char, String), LispVal)]
forall a. [a] -> [a] -> [a]
++ ((String, [LispVal] -> ThrowsError LispVal)
 -> ((Char, String), LispVal))
-> [(String, [LispVal] -> ThrowsError LispVal)]
-> [((Char, String), LispVal)]
forall a b. (a -> b) -> [a] -> [b]
map ((([LispVal] -> ThrowsError LispVal) -> LispVal)
-> (String, [LispVal] -> ThrowsError LispVal)
-> ((Char, String), LispVal)
forall t b b. (t -> b) -> (b, t) -> ((Char, b), b)
domakeFunc ([LispVal] -> ThrowsError LispVal) -> LispVal
PrimitiveFunc) [(String, [LispVal] -> ThrowsError LispVal)]
primitives)
  where domakeFunc :: (t -> b) -> (b, t) -> ((Char, b), b)
domakeFunc t -> b
constructor (b
var, t
func) = 
            ((Char
varNamespace, b
var), t -> b
constructor t
func)

--baseBindings :: IO Env
--baseBindings = nullEnv >>= 
--    (flip extendEnv $ map (domakeFunc EvalFunc) evalFunctions)
--  where domakeFunc constructor (var, func) = 
--            ((varNamespace, var), constructor func)

-- |An empty environment with the %import function. This is presently
--  just intended for internal use by the compiler.
nullEnvWithImport :: IO Env
nullEnvWithImport :: IO Env
nullEnvWithImport = IO Env
nullEnv IO Env -> (Env -> IO Env) -> IO Env
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 
  ((Env -> [((Char, String), LispVal)] -> IO Env)
-> [((Char, String), LispVal)] -> Env -> IO Env
forall a b c. (a -> b -> c) -> b -> a -> c
flip Env -> [((Char, String), LispVal)] -> IO Env
extendEnv [
    ((Char
varNamespace, String
"%import"), ([LispVal] -> IOThrowsError LispVal) -> LispVal
EvalFunc [LispVal] -> IOThrowsError LispVal
evalfuncImport),
    ((Char
varNamespace, String
"hash-table-ref"), ([LispVal] -> IOThrowsError LispVal) -> LispVal
EvalFunc [LispVal] -> IOThrowsError LispVal
hashTblRef)])

-- |Load the standard r5rs environment, including libraries
r5rsEnv :: IO Env
r5rsEnv :: IO Env
r5rsEnv = do
  Env
env <- IO Env
r5rsEnv'
  -- Bit of a hack to load (import)
  ThrowsError LispVal
_ <- Env -> LispVal -> IO (ThrowsError LispVal)
evalLisp' Env
env (LispVal -> IO (ThrowsError LispVal))
-> LispVal -> IO (ThrowsError LispVal)
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [String -> LispVal
Atom String
"%bootstrap-import"]

  Env -> IO Env
forall (m :: * -> *) a. Monad m => a -> m a
return Env
env

-- |Load the standard r5rs environment, including libraries,
--  but do not create the (import) binding
r5rsEnv' :: IO Env
r5rsEnv' :: IO Env
r5rsEnv' = do
  Env
env <- IO Env
primitiveBindings
  String
stdlib <- String -> IO String
PHS.getDataFileName String
"lib/stdlib.scm"
  String
srfi55 <- String -> IO String
PHS.getDataFileName String
"lib/srfi/srfi-55.scm" -- (require-extension)
  
  -- Load standard library
  [LispVal]
features <- IO [LispVal]
getHuskFeatures
  String
_ <- Env -> String -> IO String
evalString Env
env (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"(define *features* '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ LispVal -> String
forall a. Show a => a -> String
show ([LispVal] -> LispVal
List [LispVal]
features) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  String
_ <- Env -> String -> IO String
evalString Env
env (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"(load \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
escapeBackslashes String
stdlib) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\")" 

  -- Load (require-extension), which can be used to load other SRFI's
  String
_ <- Env -> String -> IO String
evalString Env
env (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"(load \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
escapeBackslashes String
srfi55) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\")"
  Env -> (String -> IO String) -> IO ()
registerExtensions Env
env String -> IO String
PHS.getDataFileName

#ifdef UseLibraries
  -- Load module meta-language 
  String
metalib <- String -> IO String
PHS.getDataFileName String
"lib/modules.scm"
  Env
metaEnv <- Env -> IO Env
nullEnvWithParent Env
env -- Load env as parent of metaenv
  String
_ <- Env -> String -> IO String
evalString Env
metaEnv (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"(load \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
escapeBackslashes String
metalib) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\")"
  -- Load meta-env so we can find it later
  ThrowsError LispVal
_ <- Env -> LispVal -> IO (ThrowsError LispVal)
evalLisp' Env
env (LispVal -> IO (ThrowsError LispVal))
-> LispVal -> IO (ThrowsError LispVal)
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [String -> LispVal
Atom String
"define", String -> LispVal
Atom String
"*meta-env*", Env -> LispVal
LispEnv Env
metaEnv]
  -- Load base primitives
  ThrowsError LispVal
_ <- Env -> LispVal -> IO (ThrowsError LispVal)
evalLisp' Env
metaEnv (LispVal -> IO (ThrowsError LispVal))
-> LispVal -> IO (ThrowsError LispVal)
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [String -> LispVal
Atom String
"add-module!", [LispVal] -> LispVal
List [String -> LispVal
Atom String
"quote", [LispVal] -> LispVal
List [String -> LispVal
Atom String
"scheme"]], [LispVal] -> LispVal
List [String -> LispVal
Atom String
"make-module", Bool -> LispVal
Bool Bool
False, Env -> LispVal
LispEnv Env
env {-baseEnv-}, [LispVal] -> LispVal
List [String -> LispVal
Atom String
"quote", [LispVal] -> LispVal
List []]]]
--  _ <- evalString metaEnv
--         "(add-module! '(scheme r5rs) (make-module #f (interaction-environment) '()))"
  Env
timeEnv <- IO Env -> IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> IO Env) -> IO Env -> IO Env
forall a b. (a -> b) -> a -> b
$ IO Env
r7rsTimeEnv
  ThrowsError LispVal
_ <- Env -> LispVal -> IO (ThrowsError LispVal)
evalLisp' Env
metaEnv (LispVal -> IO (ThrowsError LispVal))
-> LispVal -> IO (ThrowsError LispVal)
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [String -> LispVal
Atom String
"add-module!", [LispVal] -> LispVal
List [String -> LispVal
Atom String
"quote", [LispVal] -> LispVal
List [String -> LispVal
Atom String
"scheme", String -> LispVal
Atom String
"time", String -> LispVal
Atom String
"posix"]], [LispVal] -> LispVal
List [String -> LispVal
Atom String
"make-module", Bool -> LispVal
Bool Bool
False, Env -> LispVal
LispEnv Env
timeEnv, [LispVal] -> LispVal
List [String -> LispVal
Atom String
"quote", [LispVal] -> LispVal
List []]]]

  ThrowsError LispVal
_ <- Env -> LispVal -> IO (ThrowsError LispVal)
evalLisp' Env
metaEnv (LispVal -> IO (ThrowsError LispVal))
-> LispVal -> IO (ThrowsError LispVal)
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [
    String -> LispVal
Atom String
"define", 
    String -> LispVal
Atom String
"library-exists?",
    [LispVal] -> LispVal
List [String -> LispVal
Atom String
"quote", 
          ([LispVal] -> IOThrowsError LispVal) -> LispVal
IOFunc [LispVal] -> IOThrowsError LispVal
libraryExists]]
#endif

  Env -> IO Env
forall (m :: * -> *) a. Monad m => a -> m a
return Env
env

-- |Load the standard r7rs environment, including libraries
--
--  Note that the only difference between this and the r5rs equivalent is that
--  slightly less Scheme code is loaded initially.
r7rsEnv :: IO Env
r7rsEnv :: IO Env
r7rsEnv = do
  Env
env <- IO Env
r7rsEnv'
  -- Bit of a hack to load (import)
  ThrowsError LispVal
_ <- Env -> LispVal -> IO (ThrowsError LispVal)
evalLisp' Env
env (LispVal -> IO (ThrowsError LispVal))
-> LispVal -> IO (ThrowsError LispVal)
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [String -> LispVal
Atom String
"%bootstrap-import"]

  Env -> IO Env
forall (m :: * -> *) a. Monad m => a -> m a
return Env
env
-- |Load the standard r7rs environment
--
r7rsEnv' :: IO Env
r7rsEnv' :: IO Env
r7rsEnv' = do
  -- TODO: longer term, will need r7rs bindings instead of these
  -- basically want to limit the base bindings to the absolute minimum, but
  -- need enough to get the meta language working
  Env
env <- IO Env
primitiveBindings --baseBindings
--  baseEnv <- primitiveBindings

  -- Load necessary libraries
  -- Unfortunately this adds them in the top-level environment (!!)
  [LispVal]
features <- IO [LispVal]
getHuskFeatures
  String
_ <- Env -> String -> IO String
evalString Env
env (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"(define *features* '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ LispVal -> String
forall a. Show a => a -> String
show ([LispVal] -> LispVal
List [LispVal]
features) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  String
cxr <- String -> IO String
PHS.getDataFileName String
"lib/cxr.scm"
  String
_ <- Env -> String -> IO String
evalString Env
env {-baseEnv-} (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"(load \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
escapeBackslashes String
cxr) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\")" 
  String
core <- String -> IO String
PHS.getDataFileName String
"lib/core.scm"
  String
_ <- Env -> String -> IO String
evalString Env
env {-baseEnv-} (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"(load \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
escapeBackslashes String
core) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\")" 

-- TODO: probably will have to load some scheme libraries for modules.scm to work
--  maybe the /base/ libraries from (scheme base) would be good enough?

#ifdef UseLibraries
  -- Load module meta-language 
  String
metalib <- String -> IO String
PHS.getDataFileName String
"lib/modules.scm"
  Env
metaEnv <- Env -> IO Env
nullEnvWithParent Env
env -- Load env as parent of metaenv
  String
_ <- Env -> String -> IO String
evalString Env
metaEnv (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"(load \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
escapeBackslashes String
metalib) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\")"
  -- Load meta-env so we can find it later
  ThrowsError LispVal
_ <- Env -> LispVal -> IO (ThrowsError LispVal)
evalLisp' Env
env (LispVal -> IO (ThrowsError LispVal))
-> LispVal -> IO (ThrowsError LispVal)
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [String -> LispVal
Atom String
"define", String -> LispVal
Atom String
"*meta-env*", Env -> LispVal
LispEnv Env
metaEnv]
  -- Load base primitives
  ThrowsError LispVal
_ <- Env -> LispVal -> IO (ThrowsError LispVal)
evalLisp' Env
metaEnv (LispVal -> IO (ThrowsError LispVal))
-> LispVal -> IO (ThrowsError LispVal)
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [String -> LispVal
Atom String
"add-module!", [LispVal] -> LispVal
List [String -> LispVal
Atom String
"quote", [LispVal] -> LispVal
List [String -> LispVal
Atom String
"scheme"]], [LispVal] -> LispVal
List [String -> LispVal
Atom String
"make-module", Bool -> LispVal
Bool Bool
False, Env -> LispVal
LispEnv Env
env {-baseEnv-}, [LispVal] -> LispVal
List [String -> LispVal
Atom String
"quote", [LispVal] -> LispVal
List []]]]

  Env
timeEnv <- IO Env -> IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> IO Env) -> IO Env -> IO Env
forall a b. (a -> b) -> a -> b
$ IO Env
r7rsTimeEnv
  ThrowsError LispVal
_ <- Env -> LispVal -> IO (ThrowsError LispVal)
evalLisp' Env
metaEnv (LispVal -> IO (ThrowsError LispVal))
-> LispVal -> IO (ThrowsError LispVal)
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [String -> LispVal
Atom String
"add-module!", [LispVal] -> LispVal
List [String -> LispVal
Atom String
"quote", [LispVal] -> LispVal
List [String -> LispVal
Atom String
"scheme", String -> LispVal
Atom String
"time", String -> LispVal
Atom String
"posix"]], [LispVal] -> LispVal
List [String -> LispVal
Atom String
"make-module", Bool -> LispVal
Bool Bool
False, Env -> LispVal
LispEnv Env
timeEnv, [LispVal] -> LispVal
List [String -> LispVal
Atom String
"quote", [LispVal] -> LispVal
List []]]]

  ThrowsError LispVal
_ <- Env -> LispVal -> IO (ThrowsError LispVal)
evalLisp' Env
metaEnv (LispVal -> IO (ThrowsError LispVal))
-> LispVal -> IO (ThrowsError LispVal)
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [
    String -> LispVal
Atom String
"define", 
    String -> LispVal
Atom String
"library-exists?",
    [LispVal] -> LispVal
List [String -> LispVal
Atom String
"quote", 
          ([LispVal] -> IOThrowsError LispVal) -> LispVal
IOFunc [LispVal] -> IOThrowsError LispVal
libraryExists]]
#endif

  Env -> IO Env
forall (m :: * -> *) a. Monad m => a -> m a
return Env
env

-- | Load haskell bindings used for the r7rs time library
r7rsTimeEnv :: IO Env
r7rsTimeEnv :: IO Env
r7rsTimeEnv = do
    IO Env
nullEnv IO Env -> (Env -> IO Env) -> IO Env
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 
     ((Env -> [((Char, String), LispVal)] -> IO Env)
-> [((Char, String), LispVal)] -> Env -> IO Env
forall a b c. (a -> b -> c) -> b -> a -> c
flip Env -> [((Char, String), LispVal)] -> IO Env
extendEnv 
           [ ((Char
varNamespace, String
"current-second"), ([LispVal] -> IOThrowsError LispVal) -> LispVal
IOFunc [LispVal] -> IOThrowsError LispVal
currentTimestamp)])

-- Functions that extend the core evaluator, but that can be defined separately.
--
{- These functions have access to the current environment via the
current continuation, which is passed as the first LispVal argument. -}
--
evalfuncExitSuccess, evalfuncExitFail, evalfuncApply, evalfuncDynamicWind,
  evalfuncEval, evalfuncLoad, evalfuncCallCC, evalfuncCallWValues,
  evalfuncMakeEnv, evalfuncNullEnv, evalfuncUseParentEnv, evalfuncExit,
  evalfuncInteractionEnv, evalfuncImport :: [LispVal] -> IOThrowsError LispVal

{-
 - A (somewhat) simplified implementation of dynamic-wind
 -
 - The implementation must obey these 4 rules:
 -
 - 1) The dynamic extent is entered when execution of the body of the called procedure begins.
 - 2) The dynamic extent is also entered when execution is not within the dynamic extent and a continuation is invoked that was captured (using call-with-current-continuation) during the dynamic extent.
 - 3) It is exited when the called procedure returns.
 - 4) It is also exited when execution is within the dynamic extent and a continuation is invoked that was captured while not within the dynamic extent.
 -
 - Basically (before) must be called either when thunk is called into, or when a continuation captured
 - during (thunk) is called into.
 - And (after) must be called either when thunk returns *or* a continuation is called into during (thunk).
 - FUTURE:
 -   At this point dynamic-wind works well enough now to pass all tests, although I am not convinced the implementation
 -   is 100% correct since a stack is not directly used to hold the winders. I think there must still be edge
 -   cases that are not handled properly...
 -}
evalfuncDynamicWind :: [LispVal] -> IOThrowsError LispVal
evalfuncDynamicWind [cont :: LispVal
cont@(Continuation {contClosure :: LispVal -> Env
contClosure = Env
env}), LispVal
beforeFunc, LispVal
thunkFunc, LispVal
afterFunc] = do
  LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> LispVal
makeCPS Env
env LispVal
cont Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsThunk) LispVal
beforeFunc []
 where
   cpsThunk, cpsAfter :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
   cpsThunk :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsThunk Env
e (Continuation Env
ce Maybe DeferredCode
cc Maybe LispVal
cnc Maybe [DynamicWinders]
_ [LispVal]
cs) LispVal
_ Maybe [LispVal]
_ = 
     LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply (Env
-> Maybe DeferredCode
-> Maybe LispVal
-> Maybe [DynamicWinders]
-> [LispVal]
-> LispVal
Continuation Env
e (DeferredCode -> Maybe DeferredCode
forall a. a -> Maybe a
Just ((Env
 -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> Maybe [LispVal] -> DeferredCode
HaskellBody Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsAfter Maybe [LispVal]
forall a. Maybe a
Nothing))
                           (LispVal -> Maybe LispVal
forall a. a -> Maybe a
Just (Env
-> Maybe DeferredCode
-> Maybe LispVal
-> Maybe [DynamicWinders]
-> [LispVal]
-> LispVal
Continuation Env
ce Maybe DeferredCode
cc Maybe LispVal
cnc Maybe [DynamicWinders]
forall a. Maybe a
Nothing [LispVal]
cs))
                           ([DynamicWinders] -> Maybe [DynamicWinders]
forall a. a -> Maybe a
Just [LispVal -> LispVal -> DynamicWinders
DynamicWinders LispVal
beforeFunc LispVal
afterFunc]) 
                           []) -- FUTURE: append if existing winders
           LispVal
thunkFunc []
   cpsThunk Env
_ LispVal
_ LispVal
_ Maybe [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
Default String
"Unexpected error in cpsThunk during (dynamic-wind)"
   cpsAfter :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsAfter Env
_ LispVal
c LispVal
value Maybe [LispVal]
_ = do
    let cpsRetVals :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
        cpsRetVals :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsRetVals Env
e LispVal
cc LispVal
_ Maybe [LispVal]
xargs = Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
e LispVal
cc LispVal
value Maybe [LispVal]
xargs
    LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> LispVal
makeCPS Env
env LispVal
c Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsRetVals) LispVal
afterFunc [] -- FUTURE: remove dynamicWinder from above from the list before calling after
evalfuncDynamicWind (LispVal
_ : [LispVal]
args) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
3) [LispVal]
args -- Skip over continuation argument
evalfuncDynamicWind [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
3) []

-- |Evaluate all outstanding dynamic wind /after/ procedures, and exit program
evalfuncExit :: [LispVal] -> IOThrowsError LispVal
evalfuncExit args :: [LispVal]
args@(LispVal
cont : [LispVal]
rest) = do
  [LispVal]
_ <- LispVal -> ExceptT LispError IO [LispVal]
unchain LispVal
cont
  case [LispVal]
rest of
    [Bool Bool
False] -> [LispVal] -> IOThrowsError LispVal
evalfuncExitFail [LispVal]
args
    [LispVal]
_ -> [LispVal] -> IOThrowsError LispVal
evalfuncExitSuccess [LispVal]
args
 where
  unchain :: LispVal -> ExceptT LispError IO [LispVal]
unchain c :: LispVal
c@(Continuation {nextCont :: LispVal -> Maybe LispVal
nextCont = Maybe LispVal
cn}) = do
    case Maybe LispVal
cn of
      (Just c' :: LispVal
c'@(Continuation {})) -> do
        [LispVal]
_ <- LispVal -> ExceptT LispError IO [LispVal]
execAfters LispVal
c
        LispVal -> ExceptT LispError IO [LispVal]
unchain LispVal
c'
      Maybe LispVal
_ -> LispVal -> ExceptT LispError IO [LispVal]
execAfters LispVal
c
  unchain LispVal
_ = [LispVal] -> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  execAfters :: LispVal -> ExceptT LispError IO [LispVal]
execAfters (Continuation Env
e Maybe DeferredCode
_ Maybe LispVal
_ (Just [DynamicWinders]
dynamicWinders) [LispVal]
_) = do
    (DynamicWinders -> IOThrowsError LispVal)
-> [DynamicWinders] -> ExceptT LispError IO [LispVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ (DynamicWinders LispVal
_ LispVal
afterFunc) -> 
            LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply (Env -> LispVal
makeNullContinuation Env
e) LispVal
afterFunc []) 
         [DynamicWinders]
dynamicWinders
  execAfters LispVal
_ = [LispVal] -> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a. Monad m => a -> m a
return []
evalfuncExit [LispVal]
args = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError (String -> LispError) -> String -> LispError
forall a b. (a -> b) -> a -> b
$ String
"Invalid arguments to exit: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [LispVal] -> String
forall a. Show a => a -> String
show [LispVal]
args

evalfuncCallWValues :: [LispVal] -> IOThrowsError LispVal
evalfuncCallWValues [cont :: LispVal
cont@(Continuation {contClosure :: LispVal -> Env
contClosure = Env
env}), LispVal
producer, LispVal
consumer] = do
  LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply (Env
-> LispVal
-> (Env
    -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
-> LispVal
makeCPS Env
env LispVal
cont Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsEval) LispVal
producer [] -- Call into prod to get values
 where
   cpsEval :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
   cpsEval :: Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
cpsEval Env
_ c :: LispVal
c@(Continuation {}) LispVal
value (Just [LispVal]
xargs) = LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply LispVal
c LispVal
consumer (LispVal
value LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
xargs)
   cpsEval Env
_ LispVal
c LispVal
value Maybe [LispVal]
_ = LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply LispVal
c LispVal
consumer [LispVal
value]
evalfuncCallWValues (LispVal
_ : [LispVal]
args) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
args -- Skip over continuation argument
evalfuncCallWValues [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) []

--evalfuncApply [cont@(Continuation _ _ _ _ _), func, List args] = apply cont func args
evalfuncApply :: [LispVal] -> IOThrowsError LispVal
evalfuncApply (cont :: LispVal
cont@(Continuation {}) : LispVal
func : [LispVal]
args) = do
  let aRev :: [LispVal]
aRev = [LispVal] -> [LispVal]
forall a. [a] -> [a]
reverse [LispVal]
args

  if [LispVal] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LispVal]
args
     then LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
args
     else LispVal -> IOThrowsError LispVal
applyArgs (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
forall a. [a] -> a
head [LispVal]
aRev
 where 
  applyArgs :: LispVal -> IOThrowsError LispVal
applyArgs LispVal
aRev = do
    case LispVal
aRev of
      List [LispVal]
aLastElems -> do
        LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply LispVal
cont LispVal
func ([LispVal] -> IOThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ ([LispVal] -> [LispVal]
forall a. [a] -> [a]
init [LispVal]
args) [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal]
aLastElems
      Pointer String
_ Env
_ -> do
        LispVal -> IOThrowsError LispVal
derefPtr LispVal
aRev IOThrowsError LispVal
-> (LispVal -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> IOThrowsError LispVal
applyArgs
      LispVal
other -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"List" LispVal
other
evalfuncApply (LispVal
_ : [LispVal]
args) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) [LispVal]
args -- Skip over continuation argument
evalfuncApply [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) []


evalfuncMakeEnv :: [LispVal] -> IOThrowsError LispVal
evalfuncMakeEnv (cont :: LispVal
cont@(Continuation {contClosure :: LispVal -> Env
contClosure = Env
env}) : [LispVal]
_) = do
    Env
e <- IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Env
nullEnv
    Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont (Env -> LispVal
LispEnv Env
e) Maybe [LispVal]
forall a. Maybe a
Nothing
evalfuncMakeEnv [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) []

evalfuncNullEnv :: [LispVal] -> IOThrowsError LispVal
evalfuncNullEnv [cont :: LispVal
cont@(Continuation {contClosure :: LispVal -> Env
contClosure = Env
env}), Number Integer
_] = do
    Env
nilEnv <- IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Env
primitiveBindings
    Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont (Env -> LispVal
LispEnv Env
nilEnv) Maybe [LispVal]
forall a. Maybe a
Nothing
evalfuncNullEnv (LispVal
_ : [LispVal]
args) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args -- Skip over continuation argument
evalfuncNullEnv [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) []

evalfuncInteractionEnv :: [LispVal] -> IOThrowsError LispVal
evalfuncInteractionEnv (cont :: LispVal
cont@(Continuation {contClosure :: LispVal -> Env
contClosure = Env
env}) : [LispVal]
_) = do
    Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont (Env -> LispVal
LispEnv Env
env) Maybe [LispVal]
forall a. Maybe a
Nothing
evalfuncInteractionEnv [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError String
""

evalfuncUseParentEnv :: [LispVal] -> IOThrowsError LispVal
evalfuncUseParentEnv ((Continuation Env
env Maybe DeferredCode
a Maybe LispVal
b Maybe [DynamicWinders]
c [LispVal]
d) : [LispVal]
_) = do
    let parEnv :: Env
parEnv = Env -> Maybe Env -> Env
forall a. a -> Maybe a -> a
fromMaybe Env
env (Env -> Maybe Env
parentEnv Env
env)
    Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
parEnv (Env
-> Maybe DeferredCode
-> Maybe LispVal
-> Maybe [DynamicWinders]
-> [LispVal]
-> LispVal
Continuation Env
parEnv Maybe DeferredCode
a Maybe LispVal
b Maybe [DynamicWinders]
c [LispVal]
d) (Env -> LispVal
LispEnv Env
parEnv) Maybe [LispVal]
forall a. Maybe a
Nothing
evalfuncUseParentEnv [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError String
""

evalfuncImport :: [LispVal] -> IOThrowsError LispVal
evalfuncImport [
    cont :: LispVal
cont@(Continuation Env
env Maybe DeferredCode
a Maybe LispVal
b Maybe [DynamicWinders]
c [LispVal]
d), 
    LispVal
toEnv,
    LispEnv Env
fromEnv, 
    LispVal
imports,
    LispVal
_] = do
    LispEnv Env
toEnv' <- 
        case LispVal
toEnv of
            LispEnv Env
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
toEnv
            Bool Bool
False -> do
                -- A hack to load imports into the main env, which
                -- in modules.scm is the parent env
                case Env -> Maybe Env
parentEnv Env
env of
                    Just Env
env' -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Env -> LispVal
LispEnv Env
env'
                    Maybe Env
Nothing -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError String
"import into empty env"
            LispVal
_ -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError String
""
    case LispVal
imports of
        List [Bool Bool
False] -> do -- Export everything
            Env -> IOThrowsError LispVal
exportAll Env
toEnv'
        Bool Bool
False -> do -- Export everything
            Env -> IOThrowsError LispVal
exportAll Env
toEnv'
        p :: LispVal
p@(Pointer String
_ Env
_) -> do
            -- TODO: need to do this in a safer way
            List [LispVal]
i <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
p -- Dangerous, but list is only expected obj
            LispVal
result <- Env -> Env -> [LispVal] -> IOThrowsError LispVal
moduleImport Env
toEnv' Env
fromEnv [LispVal]
i
            Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
result Maybe [LispVal]
forall a. Maybe a
Nothing
        List [LispVal]
i -> do
            LispVal
result <- Env -> Env -> [LispVal] -> IOThrowsError LispVal
moduleImport Env
toEnv' Env
fromEnv [LispVal]
i
            Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
result Maybe [LispVal]
forall a. Maybe a
Nothing
        LispVal
_ -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError String
""
 where 
   exportAll :: Env -> IOThrowsError LispVal
exportAll Env
toEnv' = do
     Env
newEnv <- IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> ExceptT LispError IO Env)
-> IO Env -> ExceptT LispError IO Env
forall a b. (a -> b) -> a -> b
$ Env -> Env -> IO Env
importEnv Env
toEnv' Env
fromEnv
     Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval
         Env
env 
        (Env
-> Maybe DeferredCode
-> Maybe LispVal
-> Maybe [DynamicWinders]
-> [LispVal]
-> LispVal
Continuation Env
env Maybe DeferredCode
a Maybe LispVal
b Maybe [DynamicWinders]
c [LispVal]
d) 
        (Env -> LispVal
LispEnv Env
newEnv)
        Maybe [LispVal]
forall a. Maybe a
Nothing

-- This is just for debugging purposes:
evalfuncImport ((Continuation {} ) : [LispVal]
cs) = do
    LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"import fields" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
cs
evalfuncImport [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError String
""

-- |Load import into the main environment
bootstrapImport :: [LispVal] -> ExceptT LispError IO LispVal
bootstrapImport :: [LispVal] -> IOThrowsError LispVal
bootstrapImport [cont :: LispVal
cont@(Continuation {contClosure :: LispVal -> Env
contClosure = Env
env})] = do
    LispEnv Env
me <- Env -> String -> IOThrowsError LispVal
getVar Env
env String
"*meta-env*"
    LispVal
ri <- Env -> Char -> String -> IOThrowsError LispVal
getNamespacedVar Env
me Char
macroNamespace String
"repl-import"
    LispVal
renv <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
env Char
macroNamespace String
"import" LispVal
ri
    Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
renv Maybe [LispVal]
forall a. Maybe a
Nothing
bootstrapImport [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError String
""

evalfuncLoad :: [LispVal] -> IOThrowsError LispVal
evalfuncLoad (LispVal
cont : p :: LispVal
p@(Pointer String
_ Env
_) : [LispVal]
lvs) = do
    LispVal
lv <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
p
    [LispVal] -> IOThrowsError LispVal
evalfuncLoad (LispVal
cont LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: LispVal
lv LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
lvs)

evalfuncLoad [(Continuation Env
_ Maybe DeferredCode
a Maybe LispVal
b Maybe [DynamicWinders]
c [LispVal]
d), String String
filename, LispEnv Env
env] = do
    [LispVal] -> IOThrowsError LispVal
evalfuncLoad [Env
-> Maybe DeferredCode
-> Maybe LispVal
-> Maybe [DynamicWinders]
-> [LispVal]
-> LispVal
Continuation Env
env Maybe DeferredCode
a Maybe LispVal
b Maybe [DynamicWinders]
c [LispVal]
d, String -> LispVal
String String
filename]

evalfuncLoad [cont :: LispVal
cont@(Continuation {contClosure :: LispVal -> Env
contClosure = Env
env}), String String
filename] = do
    String
filename' <- String -> ExceptT LispError IO String
findFileOrLib String
filename
    [LispVal]
results <- String -> ExceptT LispError IO [LispVal]
load String
filename' ExceptT LispError IO [LispVal]
-> ([LispVal] -> ExceptT LispError IO [LispVal])
-> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (LispVal -> IOThrowsError LispVal)
-> [LispVal] -> ExceptT LispError IO [LispVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
env (Env -> LispVal
makeNullContinuation Env
env))
    if Bool -> Bool
not ([LispVal] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LispVal]
results)
       then do LispVal
result <- LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> ([LispVal] -> LispVal) -> [LispVal] -> IOThrowsError LispVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LispVal] -> LispVal
forall a. [a] -> a
last ([LispVal] -> IOThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
results
               Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
env LispVal
cont LispVal
result Maybe [LispVal]
forall a. Maybe a
Nothing
       else LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Nil String
"" -- Empty, unspecified value

evalfuncLoad (LispVal
_ : [LispVal]
args) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args -- Skip over continuation argument
evalfuncLoad [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) []

-- |Evaluate an expression.
evalfuncEval :: [LispVal] -> IOThrowsError LispVal
evalfuncEval [cont :: LispVal
cont@(Continuation {contClosure :: LispVal -> Env
contClosure = Env
env}), LispVal
val] = do -- Current env
    LispVal
v <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
val -- Must deref ptrs for macro subsystem
    Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
env LispVal
cont LispVal
v
evalfuncEval [cont :: LispVal
cont@(Continuation {}), LispVal
val, LispEnv Env
env] = do -- Env parameter
    LispVal
v <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
val -- Must deref ptrs for macro subsystem
    Env -> LispVal -> LispVal -> IOThrowsError LispVal
meval Env
env LispVal
cont LispVal
v
evalfuncEval (LispVal
_ : [LispVal]
args) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args -- Skip over continuation argument
evalfuncEval [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) []

evalfuncCallCC :: [LispVal] -> IOThrowsError LispVal
evalfuncCallCC [cont :: LispVal
cont@(Continuation {}), LispVal
func] = do
   case LispVal
func of
     Continuation {} -> LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply LispVal
cont LispVal
func [LispVal
cont] 
     PrimitiveFunc [LispVal] -> ThrowsError LispVal
f -> do
         LispVal
result <- ThrowsError LispVal -> IOThrowsError LispVal
forall a. ThrowsError a -> IOThrowsError a
liftThrows (ThrowsError LispVal -> IOThrowsError LispVal)
-> ThrowsError LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> ThrowsError LispVal
f [LispVal
cont]
         case LispVal
cont of
             Continuation {contClosure :: LispVal -> Env
contClosure = Env
cEnv} -> Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
continueEval Env
cEnv LispVal
cont LispVal
result Maybe [LispVal]
forall a. Maybe a
Nothing
             LispVal
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
result
     Func [String]
_ (Just String
_) [LispVal]
_ Env
_ -> LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply LispVal
cont LispVal
func [LispVal
cont] -- Variable # of args (pair). Just call into cont
     Func [String]
aparams Maybe String
_ [LispVal]
_ Env
_ ->
       if Int -> Integer
forall a. Integral a => a -> Integer
toInteger ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
aparams) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1
         then LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply LispVal
cont LispVal
func [LispVal
cont]
         else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
aparams)) [LispVal
cont]
     HFunc [String]
_ (Just String
_) Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
_ Env
_ -> LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply LispVal
cont LispVal
func [LispVal
cont] -- Variable # of args (pair). Just call into cont  
     HFunc [String]
aparams Maybe String
_ Env
-> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal
_ Env
_ ->
       if Int -> Integer
forall a. Integral a => a -> Integer
toInteger ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
aparams) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1
         then LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply LispVal
cont LispVal
func [LispVal
cont]
         else LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
aparams)) [LispVal
cont]
     LispVal
other -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"procedure" LispVal
other
evalfuncCallCC (LispVal
_ : [LispVal]
args) = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) [LispVal]
args -- Skip over continuation argument
evalfuncCallCC [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1) []

evalfuncExitFail :: [LispVal] -> IOThrowsError LispVal
evalfuncExitFail [LispVal]
_ = do
  Any
_ <- IO Any -> ExceptT LispError IO Any
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Any
forall a. IO a
System.Exit.exitFailure
  LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Nil String
""
evalfuncExitSuccess :: [LispVal] -> IOThrowsError LispVal
evalfuncExitSuccess [LispVal]
_ = do
  Any
_ <- IO Any -> ExceptT LispError IO Any
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Any
forall a. IO a
System.Exit.exitSuccess
  LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Nil String
""

{- Primitive functions that extend the core evaluator -}
evalFunctions :: [(String, [LispVal] -> IOThrowsError LispVal)]
evalFunctions :: [(String, [LispVal] -> IOThrowsError LispVal)]
evalFunctions =  [  (String
"apply", [LispVal] -> IOThrowsError LispVal
evalfuncApply)
                  , (String
"call-with-current-continuation", [LispVal] -> IOThrowsError LispVal
evalfuncCallCC)
                  , (String
"call-with-values", [LispVal] -> IOThrowsError LispVal
evalfuncCallWValues)
                  , (String
"dynamic-wind", [LispVal] -> IOThrowsError LispVal
evalfuncDynamicWind)
                  , (String
"exit", [LispVal] -> IOThrowsError LispVal
evalfuncExit)
                  , (String
"eval", [LispVal] -> IOThrowsError LispVal
evalfuncEval)
                  , (String
"load", [LispVal] -> IOThrowsError LispVal
evalfuncLoad)
                  , (String
"null-environment", [LispVal] -> IOThrowsError LispVal
evalfuncNullEnv)
                  , (String
"current-environment", [LispVal] -> IOThrowsError LispVal
evalfuncInteractionEnv)
                  , (String
"interaction-environment", [LispVal] -> IOThrowsError LispVal
evalfuncInteractionEnv)
                  , (String
"make-environment", [LispVal] -> IOThrowsError LispVal
evalfuncMakeEnv)
                  , (String
"hash-table-ref", [LispVal] -> IOThrowsError LispVal
hashTblRef)

               -- Non-standard extensions
#ifdef UseFfi
                  , ("load-ffi", Language.Scheme.FFI.evalfuncLoadFFI)
#endif
#ifdef UseLibraries
                  , (String
"%import", [LispVal] -> IOThrowsError LispVal
evalfuncImport)
                  , (String
"%bootstrap-import", [LispVal] -> IOThrowsError LispVal
bootstrapImport)
#endif
                  , (String
"%husk-switch-to-parent-environment", [LispVal] -> IOThrowsError LispVal
evalfuncUseParentEnv)

                  , (String
"exit-fail", [LispVal] -> IOThrowsError LispVal
evalfuncExitFail)
                  , (String
"exit-success", [LispVal] -> IOThrowsError LispVal
evalfuncExitSuccess)
                ]

-- | Rethrow given error with call history, if available
throwErrorWithCallHistory :: LispVal -> LispError -> IOThrowsError LispVal
throwErrorWithCallHistory :: LispVal -> LispError -> IOThrowsError LispVal
throwErrorWithCallHistory (Continuation {contCallHist :: LispVal -> [LispVal]
contCallHist=[LispVal]
cstk}) LispError
e = do
    LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ LispError -> [LispVal] -> LispError
ErrorWithCallHist LispError
e [LispVal]
cstk
throwErrorWithCallHistory LispVal
_ LispError
e = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError LispError
e

-- | Add a function to the call history
addToCallHistory :: LispVal -> [LispVal] -> [LispVal]
addToCallHistory :: LispVal -> [LispVal] -> [LispVal]
addToCallHistory LispVal
f [LispVal]
history 
  | [LispVal] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LispVal]
history = [LispVal
f]
  | Bool
otherwise = (Int -> [LispVal] -> [LispVal]
forall a. Int -> [a] -> [a]
lastN' Int
9 [LispVal]
history) [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
f]

-- | Retrieve the value from the hashtable for the given key.
--   An error is thrown if the key is not found.
--
--   Note this had to be made an EvalFunc because a thunk
--   can be passed as an optional argument to be executed 
--   if the key is not found.
--
--   Arguments:
--
--   * Current continuation
--   * HashTable to copy
--   * Object that is the key to query the table for
--
--   Returns: Object containing the key's value
--
hashTblRef :: [LispVal] -> IOThrowsError LispVal
hashTblRef :: [LispVal] -> IOThrowsError LispVal
hashTblRef [LispVal
_, (HashTable Map LispVal LispVal
ht), LispVal
key] = do
  case LispVal -> Map LispVal LispVal -> Maybe LispVal
forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup LispVal
key Map LispVal LispVal
ht of
    Just LispVal
val -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
val
    Maybe LispVal
Nothing -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
BadSpecialForm String
"Hash table does not contain key" LispVal
key
hashTblRef [LispVal
cont, (HashTable Map LispVal LispVal
ht), LispVal
key, LispVal
thunk] = do
  case LispVal -> Map LispVal LispVal -> Maybe LispVal
forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup LispVal
key Map LispVal LispVal
ht of
    Just LispVal
val -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ LispVal
val
    Maybe LispVal
Nothing -> LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply LispVal
cont LispVal
thunk []
hashTblRef (LispVal
cont : p :: LispVal
p@(Pointer String
_ Env
_) : [LispVal]
args) = do
  LispVal
ht <- LispVal -> IOThrowsError LispVal
derefPtr LispVal
p
  [LispVal] -> IOThrowsError LispVal
hashTblRef (LispVal
cont LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: LispVal
ht LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
args)
hashTblRef [LispVal
_, LispVal
badType] = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"hash-table" LispVal
badType
hashTblRef [LispVal]
badArgList = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> [LispVal] -> LispError
NumArgs (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
2) ([LispVal] -> [LispVal]
forall a. [a] -> [a]
tail [LispVal]
badArgList)