{-# LANGUAGE FlexibleContexts #-}
{- |
Module      : Language.Scheme.Compiler
Copyright   : Justin Ethier
Licence     : MIT (see LICENSE in the distribution)

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

This module contains a Scheme to Haskell compiler which performs the following 
transformations:

> Scheme AST (LispVal) => Haskell AST (HaskAST) => Compiled Code (String)

The GHC compiler is then used to create a native executable. At present, the 
focus has just been on creating a compiler that will generate correct, working 
code. Many optimizations could and need to be made for time and space...

Note the following type is used for all functions generated by the compiler: 

> compiledFunc :: 
>   Env ->                  -- Runtime Environment
>   LispVal ->              -- Continuation
>   LispVal ->              -- Value
>   Maybe [LispVal] ->      -- Additional arguments
>   IOThrowsError LispVal   -- Result

-}

module Language.Scheme.Compiler 
    (
      compile
    , compileApply
    , compileBlock
    , compileDivertedVars 
    , compileExpr
    , compileLambdaList
    , compileLisp
    , compileScalar
    , compileSpecialForm
    , compileSpecialFormBody
    , compileSpecialFormEntryPoint
    , defineLambdaVars
    , defineTopLevelVars
    , divertVars 
    , initializeCompiler
    , isPrim
    , mcompile
    , mfunc
    )
where 
import Language.Scheme.Compiler.Libraries as LSCL
import Language.Scheme.Compiler.Types
import qualified Language.Scheme.Core as LSC 
    (apply, evalLisp, findFileOrLib)
import qualified Language.Scheme.Macro
import Language.Scheme.Primitives
import Language.Scheme.Types
import Language.Scheme.Variables
import Control.Monad.Except
import qualified Data.List
import Data.Maybe (fromMaybe)

-- |Perform one-time initialization of the compiler's environment
initializeCompiler :: Env -> IOThrowsError [HaskAST]
initializeCompiler :: Env -> IOThrowsError [HaskAST]
initializeCompiler Env
env = do
  -- Define imports var here as an empty list.
  -- This list is appended to by (load-ffi) instances,
  -- and the imports are explicitly added later on...
  LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
env Char
't' {-"internal"-} String
"imports" (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List []
  [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | Compile a file containing scheme code
compileLisp 
    :: Env  -- ^ Compiler environment 
    -> String -- ^ Filename
    -> String -- ^ Function entry point (code calls into this function)
    -> Maybe String -- ^ Function exit point, if any
    -> IOThrowsError [HaskAST]
compileLisp :: Env -> String -> String -> Maybe String -> IOThrowsError [HaskAST]
compileLisp Env
env String
filename String
entryPoint Maybe String
exitPoint = do
    String
filename' <- String -> ExceptT LispError IO String
LSC.findFileOrLib String
filename 
    [HaskAST]
ast <- String -> IOThrowsError [LispVal]
load String
filename' IOThrowsError [LispVal]
-> ([LispVal] -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String
-> Maybe String
-> Env
-> [HaskAST]
-> [LispVal]
-> IOThrowsError [HaskAST]
compileBlock String
entryPoint Maybe String
exitPoint Env
env []
    case [HaskAST]
ast of
        [] -> String -> CompOpts -> IOThrowsError [HaskAST]
compileScalar 
                String
" return $ Number 0" (CompOpts -> IOThrowsError [HaskAST])
-> CompOpts -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ 
                String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
entryPoint Bool
False Bool
False Maybe String
exitPoint
        [HaskAST]
_ -> [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST]
ast

-- |Compile a list (block) of Scheme code
compileBlock :: String -> Maybe String -> Env -> [HaskAST] -> [LispVal] 
             -> IOThrowsError [HaskAST]
compileBlock :: String
-> Maybe String
-> Env
-> [HaskAST]
-> [LispVal]
-> IOThrowsError [HaskAST]
compileBlock String
symThisFunc Maybe String
symLastFunc Env
env [HaskAST]
result [LispVal]
lisps = do
  LispVal
_ <- Env -> [LispVal] -> IOThrowsError LispVal
defineTopLevelVars Env
env [LispVal]
lisps
  String
-> Maybe String
-> Env
-> [HaskAST]
-> [LispVal]
-> IOThrowsError [HaskAST]
_compileBlock String
symThisFunc Maybe String
symLastFunc Env
env [HaskAST]
result [LispVal]
lisps

_compileBlock :: String -> Maybe String -> Env -> [HaskAST] -> [LispVal]
              -> IOThrowsError [HaskAST]
_compileBlock :: String
-> Maybe String
-> Env
-> [HaskAST]
-> [LispVal]
-> IOThrowsError [HaskAST]
_compileBlock String
symThisFunc Maybe String
symLastFunc Env
env [HaskAST]
result [LispVal
c] = do
  let copts :: CompOpts
copts = String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
symThisFunc Bool
False Bool
False Maybe String
symLastFunc 
  [HaskAST]
compiled <- Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
mcompile Env
env LispVal
c CompOpts
copts
  case [HaskAST]
compiled of
    [val :: HaskAST
val@(AstValue String
_)] -> do
      [HaskAST]
comp <- HaskAST -> CompOpts -> IOThrowsError [HaskAST]
compileScalar' HaskAST
val CompOpts
copts
      ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> [HaskAST] -> IOThrowsError [HaskAST]
_compileBlockDo [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST]
result [HaskAST]
comp
    [val :: HaskAST
val@(AstRef String
_)] -> do
      [HaskAST]
comp <- HaskAST -> CompOpts -> IOThrowsError [HaskAST]
compileScalar' HaskAST
val CompOpts
copts
      ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> [HaskAST] -> IOThrowsError [HaskAST]
_compileBlockDo [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST]
result [HaskAST]
comp
    [HaskAST]
_ -> ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> [HaskAST] -> IOThrowsError [HaskAST]
_compileBlockDo [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST]
result [HaskAST]
compiled
-- A special case to splice in definitions from a (begin)
_compileBlock String
symThisFunc Maybe String
symLastFunc Env
env [HaskAST]
result 
    (c :: LispVal
c@(List [Atom String
"%husk-switch-to-parent-environment"]) : [LispVal]
cs) = do
  let parEnv :: Env
parEnv = Env -> Maybe Env -> Env
forall a. a -> Maybe a -> a
fromMaybe Env
env (Env -> Maybe Env
parentEnv Env
env)
  LispVal
_ <- Env -> [LispVal] -> IOThrowsError LispVal
defineTopLevelVars Env
parEnv [LispVal]
cs
  Atom String
symNextFunc <- String -> IOThrowsError LispVal
_gensym String
"f"
  [HaskAST]
compiled <- Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
mcompile Env
env LispVal
c (CompOpts -> IOThrowsError [HaskAST])
-> CompOpts -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ 
                       String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
symThisFunc Bool
False Bool
False (String -> Maybe String
forall a. a -> Maybe a
Just String
symNextFunc)
  ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> [HaskAST] -> IOThrowsError [HaskAST]
_compileBlockDo 
    (\ [HaskAST]
result' ->
         String
-> Maybe String
-> Env
-> [HaskAST]
-> [LispVal]
-> IOThrowsError [HaskAST]
_compileBlock 
           (if [HaskAST] -> Bool
isSingleValue [HaskAST]
compiled
              then String
symThisFunc 
              else String
symNextFunc)
            Maybe String
symLastFunc 
            Env
parEnv [HaskAST]
result' [LispVal]
cs)
    [HaskAST]
result
    [HaskAST]
compiled
_compileBlock String
symThisFunc Maybe String
symLastFunc Env
env [HaskAST]
result (LispVal
c:[LispVal]
cs) = do
  Atom String
symNextFunc <- String -> IOThrowsError LispVal
_gensym String
"f"
  [HaskAST]
compiled <- Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
mcompile Env
env LispVal
c (CompOpts -> IOThrowsError [HaskAST])
-> CompOpts -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ 
                       String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
symThisFunc Bool
False Bool
False (String -> Maybe String
forall a. a -> Maybe a
Just String
symNextFunc)
  ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> [HaskAST] -> IOThrowsError [HaskAST]
_compileBlockDo
    (\ [HaskAST]
result' -> 
        String
-> Maybe String
-> Env
-> [HaskAST]
-> [LispVal]
-> IOThrowsError [HaskAST]
_compileBlock 
           (if [HaskAST] -> Bool
isSingleValue [HaskAST]
compiled
              then String
symThisFunc 
              else String
symNextFunc)
           Maybe String
symLastFunc 
           Env
env [HaskAST]
result' [LispVal]
cs)
    [HaskAST]
result
    [HaskAST]
compiled
_compileBlock String
_ Maybe String
_ Env
_ [HaskAST]
result [] = [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST]
result

_compileBlockDo :: ([HaskAST] -> IOThrowsError [HaskAST]) -> 
                   [HaskAST] -> [HaskAST] -> IOThrowsError [HaskAST]
_compileBlockDo :: ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> [HaskAST] -> IOThrowsError [HaskAST]
_compileBlockDo [HaskAST] -> IOThrowsError [HaskAST]
fnc [HaskAST]
result [HaskAST]
c =
  case [HaskAST]
c of
    -- Discard a value by itself
    [AstValue String
_] -> [HaskAST] -> IOThrowsError [HaskAST]
fnc [HaskAST]
result
    [AstRef String
_] -> [HaskAST] -> IOThrowsError [HaskAST]
fnc [HaskAST]
result
    [HaskAST]
_ -> [HaskAST] -> IOThrowsError [HaskAST]
fnc ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [HaskAST]
result [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
c

-- TODO: could everything just be regular function calls except when a continuation is 'added to the stack' via a makeCPS(makeCPSWArgs ...) ?? I think this could be made more efficient

-- |Helper function to compile expressions consisting of a scalar
compileScalar :: String -> CompOpts -> IOThrowsError [HaskAST]
compileScalar :: String -> CompOpts -> IOThrowsError [HaskAST]
compileScalar String
val CompOpts
copts = do 
  HaskAST
f <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> HaskAST -> HaskAST
AstAssignM String
"x1" (HaskAST -> HaskAST) -> HaskAST -> HaskAST
forall a b. (a -> b) -> a -> b
$ String -> HaskAST
AstValue String
val 
  HaskAST
c <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"x1" String
""
  [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [HaskAST
f, HaskAST
c]]

compileScalar' :: HaskAST -> CompOpts -> IOThrowsError [HaskAST]
compileScalar' :: HaskAST -> CompOpts -> IOThrowsError [HaskAST]
compileScalar' HaskAST
val CompOpts
copts = do 
  let fCode :: HaskAST
fCode = case HaskAST
val of
          AstValue String
v -> String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  let x1 = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v 
          AstRef String
r -> String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  x1 <- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
r
          HaskAST
_ -> String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"Unexpected compiler error in compileScalar' "
  -- TODO: _
  HaskAST
f <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ HaskAST
fCode
  HaskAST
c <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"x1" String
""
  [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [HaskAST
f, HaskAST
c]]

-- |Compile the list of arguments for a function
compileLambdaList :: [LispVal] -> IOThrowsError String
compileLambdaList :: [LispVal] -> ExceptT LispError IO String
compileLambdaList [LispVal]
l = do
  [String]
serialized <- (LispVal -> ExceptT LispError IO String)
-> [LispVal] -> ExceptT LispError IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LispVal -> ExceptT LispError IO String
forall (m :: * -> *). MonadError LispError m => LispVal -> m String
serialize [LispVal]
l 
  String -> ExceptT LispError IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ExceptT LispError IO String)
-> String -> ExceptT LispError IO String
forall a b. (a -> b) -> a -> b
$ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
Data.List.intercalate String
"," [String]
serialized String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
 where serialize :: LispVal -> m String
serialize (Atom String
a) = String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ (String -> String
forall a. Show a => a -> String
show String
a)
       serialize LispVal
a = LispError -> m String
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> m String) -> LispError -> m String
forall a b. (a -> b) -> a -> b
$ String -> LispError
Default (String -> LispError) -> String -> LispError
forall a b. (a -> b) -> a -> b
$ 
                         String
"invalid parameter to lambda list: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LispVal -> String
forall a. Show a => a -> String
show LispVal
a

-- |Add lambda variables to the compiler's environment
defineLambdaVars :: Env -> [LispVal] -> IOThrowsError LispVal
defineLambdaVars :: Env -> [LispVal] -> IOThrowsError LispVal
defineLambdaVars Env
env (Atom String
v : [LispVal]
vs) = do
    LispVal
_ <- Env -> String -> LispVal -> IOThrowsError LispVal
defineVar Env
env String
v (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> LispVal
Number Integer
0 -- For now, actual value does not matter
    Env -> [LispVal] -> IOThrowsError LispVal
defineLambdaVars Env
env [LispVal]
vs
defineLambdaVars Env
env (LispVal
_ : [LispVal]
vs) = Env -> [LispVal] -> IOThrowsError LispVal
defineLambdaVars Env
env [LispVal]
vs
defineLambdaVars 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
$ String -> LispVal
Nil String
""

-- |Find all variables defined at "this" level and load their symbols into
--  the environment. This allows the compiler validation to work even 
--  though a variable is used in a sub-form before it is defined further
--  on down in the program
defineTopLevelVars :: Env -> [LispVal] -> IOThrowsError LispVal
defineTopLevelVars :: Env -> [LispVal] -> IOThrowsError LispVal
defineTopLevelVars Env
env (List [Atom String
"define", Atom String
var, LispVal
_] : [LispVal]
ls) = do
    LispVal
_ <- Env -> String -> IOThrowsError LispVal
defineTopLevelVar Env
env String
var
    Env -> [LispVal] -> IOThrowsError LispVal
defineTopLevelVars Env
env [LispVal]
ls
defineTopLevelVars Env
env ((List (Atom String
"define" : List (Atom String
var : [LispVal]
_) : [LispVal]
_)) : [LispVal]
ls) = do
    LispVal
_ <- Env -> String -> IOThrowsError LispVal
defineTopLevelVar Env
env String
var
    Env -> [LispVal] -> IOThrowsError LispVal
defineTopLevelVars Env
env [LispVal]
ls
defineTopLevelVars Env
env ((List (Atom String
"define" : DottedList (Atom String
var : [LispVal]
_) LispVal
_ : [LispVal]
_)) : [LispVal]
ls) = do
    LispVal
_ <- Env -> String -> IOThrowsError LispVal
defineTopLevelVar Env
env String
var
    Env -> [LispVal] -> IOThrowsError LispVal
defineTopLevelVars Env
env [LispVal]
ls
defineTopLevelVars Env
env (LispVal
_ : [LispVal]
ls) = Env -> [LispVal] -> IOThrowsError LispVal
defineTopLevelVars Env
env [LispVal]
ls
defineTopLevelVars Env
_ [LispVal]
_ = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
nullLisp 

defineTopLevelVar :: Env -> String -> IOThrowsError LispVal
defineTopLevelVar :: Env -> String -> IOThrowsError LispVal
defineTopLevelVar Env
env String
var = do
  Env -> String -> LispVal -> IOThrowsError LispVal
defineVar Env
env String
var (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Integer -> LispVal
Number Integer
0 -- Actual value not loaded at the moment 

-- |Compile a Lisp expression to Haskell. Note this function does
--  not expand macros; mcompile should be used instead if macros
--  may appear in the expression.
compile :: Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
-- Experimenting with r7rs library support
compile :: Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
compile Env
env 
        (List (Atom String
"import" : [LispVal]
mods)) 
        copts :: CompOpts
copts@(CompileOptions {}) = do
    LispEnv Env
meta <- Env -> String -> IOThrowsError LispVal
getVar Env
env String
"*meta-env*"
    Env
-> Env
-> [LispVal]
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
LSCL.importAll Env
env 
                   Env
meta 
                   [LispVal]
mods 
                  ((String
 -> Maybe String
 -> Env
 -> [HaskAST]
 -> [LispVal]
 -> IOThrowsError [HaskAST])
-> (Env
    -> String -> String -> Maybe String -> IOThrowsError [HaskAST])
-> CompLibOpts
CompileLibraryOptions String
-> Maybe String
-> Env
-> [HaskAST]
-> [LispVal]
-> IOThrowsError [HaskAST]
compileBlock Env -> String -> String -> Maybe String -> IOThrowsError [HaskAST]
compileLisp) 
                   CompOpts
copts
compile Env
_ (Nil String
n) CompOpts
_              = [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"Nil " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
forall a. Show a => a -> String
show String
n)]
compile Env
_ v :: LispVal
v@(String String
_) CompOpts
_         = [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ LispVal -> String
ast2Str LispVal
v]
compile Env
_ v :: LispVal
v@(Char Char
_) CompOpts
_           = [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ LispVal -> String
ast2Str LispVal
v]
compile Env
_ v :: LispVal
v@(Complex Complex Double
_) CompOpts
_        = [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ LispVal -> String
ast2Str LispVal
v]
compile Env
_ v :: LispVal
v@(Float Double
_) CompOpts
_          = [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ LispVal -> String
ast2Str LispVal
v]
compile Env
_ v :: LispVal
v@(Rational Rational
_) CompOpts
_       = [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ LispVal -> String
ast2Str LispVal
v]
compile Env
_ v :: LispVal
v@(Number Integer
_) CompOpts
_         = [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ LispVal -> String
ast2Str LispVal
v]
compile Env
_ v :: LispVal
v@(Bool Bool
_) CompOpts
_           = [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ LispVal -> String
ast2Str LispVal
v]
compile Env
_ v :: LispVal
v@(Vector Array Int LispVal
_) CompOpts
_         = [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ LispVal -> String
ast2Str LispVal
v]
compile Env
_ v :: LispVal
v@(ByteVector ByteString
_) CompOpts
_     = [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ LispVal -> String
ast2Str LispVal
v]
compile Env
_ ht :: LispVal
ht@(HashTable Map LispVal LispVal
_) CompOpts
_     = [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ LispVal -> String
ast2Str LispVal
ht]
compile Env
env (Atom String
a) CompOpts
_ = do
 Bool
isDefined <- 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
a
 case Bool
isDefined of
   Bool
True -> do
-- TODO: this is not good enough, will probably have to 
--       return as a new type (AstGetVariable?)
     [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> HaskAST
AstRef (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"getRTVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""] 
   Bool
False -> LispError -> IOThrowsError [HaskAST]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError [HaskAST])
-> LispError -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ String -> String -> LispError
UnboundVar String
"Variable is not defined" String
a

compile Env
_ (List [Atom String
"quote", LispVal
val]) CompOpts
copts = 
  String -> CompOpts -> IOThrowsError [HaskAST]
compileScalar (String
" return $ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LispVal -> String
ast2Str LispVal
val) CompOpts
copts

compile Env
env ast :: LispVal
ast@(List [Atom String
"expand",  LispVal
_body]) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    LispVal
val <- 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
LSC.apply
    String -> CompOpts -> IOThrowsError [HaskAST]
compileScalar (String
" return $ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LispVal -> String
ast2Str LispVal
val) CompOpts
copts)

compile Env
env ast :: LispVal
ast@(List (Atom String
"let-syntax" : List [LispVal]
_bindings : [LispVal]
_body)) 
        copts :: CompOpts
copts@(CompileOptions String
thisFnc Bool
a Bool
b Maybe String
nextFnc) = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> 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
LSC.apply

    Atom String
loadMacroSym <- String -> IOThrowsError LispVal
_gensym String
"loadMacroStub"
    [HaskAST]
stub <- String -> CompOpts -> IOThrowsError [HaskAST]
compileScalar (String
" Language.Scheme.Macro.loadMacros env env Nothing False " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([LispVal] -> String
asts2Str [LispVal]
_bindings)) (String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
thisFnc Bool
False Bool
False (String -> Maybe String
forall a. a -> Maybe a
Just String
loadMacroSym))
    [HaskAST]
rest <- Env
-> LispVal
-> CompOpts
-> (Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
divertVars Env
bodyEnv LispVal
expanded (String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
loadMacroSym Bool
a Bool
b Maybe String
nextFnc) Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
compexp
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [HaskAST]
stub [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
rest)
 where 
     -- Pick up execution here after expansion
     compexp :: Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
compexp Env
bodyEnv' LispVal
expanded' CompOpts
copts' = do
       case LispVal
expanded' of
         List [LispVal]
e -> Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
compile Env
bodyEnv' ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
"begin" LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
e) CompOpts
copts'
         LispVal
e -> Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
compile Env
bodyEnv' LispVal
e CompOpts
copts'

compile Env
env ast :: LispVal
ast@(List (Atom String
"letrec-syntax" : List [LispVal]
_bindings : [LispVal]
_body))
        copts :: CompOpts
copts@(CompileOptions String
thisFnc Bool
a Bool
b Maybe String
nextFnc) = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> 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
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
LSC.apply

    Atom String
loadMacroSym <- String -> IOThrowsError LispVal
_gensym String
"loadMacroStub"
    [HaskAST]
stub <- String -> CompOpts -> IOThrowsError [HaskAST]
compileScalar (String
" Language.Scheme.Macro.loadMacros env env Nothing False " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([LispVal] -> String
asts2Str [LispVal]
_bindings)) (String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
thisFnc Bool
False Bool
False (String -> Maybe String
forall a. a -> Maybe a
Just String
loadMacroSym))
    [HaskAST]
rest <- Env
-> LispVal
-> CompOpts
-> (Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
divertVars Env
bodyEnv LispVal
expanded (String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
loadMacroSym Bool
a Bool
b Maybe String
nextFnc) Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
compexp
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [HaskAST]
stub [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
rest)
  where 
     -- Pick up execution here after expansion
     compexp :: Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
compexp Env
bodyEnv' LispVal
expanded' CompOpts
copts' = do
       case LispVal
expanded' of
         List [LispVal]
e -> Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
compile Env
bodyEnv' ([LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
"begin" LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
e) CompOpts
copts'
         LispVal
e -> Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
compile Env
bodyEnv' LispVal
e CompOpts
copts'

-- A non-standard way to rebind a macro to another keyword
compile Env
env 
        (List [Atom String
"define-syntax", 
                   Atom String
newKeyword,
                   Atom String
keyword]) 
        CompOpts
copts = 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
        [HaskAST]
compFunc <- [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [
          String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  bound <- getNamespacedVar' env macroNamespace \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                          String
keyword String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"",
          String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  case bound of ",
          String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"    Just m -> ",
          String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"      defineNamespacedVar env macroNamespace \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                              String
newKeyword String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" m",
          String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"    Nothing -> throwError $ TypeMismatch \"macro\" $ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                             String
"Atom \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
keyword String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"",
          CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"(Nil \"\")" String
""]
        [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [HaskAST]
compFunc]
    Maybe LispVal
Nothing -> LispError -> IOThrowsError [HaskAST]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError [HaskAST])
-> LispError -> IOThrowsError [HaskAST]
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

compile Env
env ast :: LispVal
ast@(List [Atom String
"define-syntax", Atom String
keyword,
  (List [Atom String
"er-macro-transformer", 
    (List (Atom String
"lambda" : List [LispVal]
fparams : [LispVal]
fbody))])])
  CompOpts
copts = do
  Bool
_ <- [LispVal] -> Maybe Integer -> ExceptT LispError IO Bool
validateFuncParams [LispVal]
fparams (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
3)
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    let fparamsStr :: String
fparamsStr = [LispVal] -> String
asts2Str [LispVal]
fparams
        fbodyStr :: String
fbodyStr = [LispVal] -> String
asts2Str [LispVal]
fbody
  
    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
  
    [HaskAST]
compFunc <- [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [
      String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  f <- makeNormalFunc env " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fparamsStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fbodyStr, 
      String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  defineNamespacedVar env macroNamespace \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
keyword String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                      String
"\" $ SyntaxExplicitRenaming f",
      CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"(Nil \"\")" String
""]
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [HaskAST]
compFunc])

compile Env
env lisp :: LispVal
lisp@(List [Atom String
"define-syntax", Atom String
keyword, 
    (List (Atom String
"syntax-rules" : Atom String
ellipsis : (List [LispVal]
identifiers : [LispVal]
rules)))]) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
lisp CompOpts
copts (\ Maybe String
_ -> do
    let idStr :: String
idStr = [LispVal] -> String
asts2Str [LispVal]
identifiers
        ruleStr :: String
ruleStr = [LispVal] -> String
asts2Str [LispVal]
rules
  
    -- Make macro available at compile time
    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
  
    -- And load it at runtime as well
    -- Env should be identical to the one loaded at compile time...
    String -> CompOpts -> IOThrowsError [HaskAST]
compileScalar 
      (String
"  defineNamespacedVar env macroNamespace \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
keyword String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
       String
"\" $ Syntax (Just env) Nothing False \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ellipsis String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
idStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ruleStr) CompOpts
copts)

compile Env
env lisp :: LispVal
lisp@(List [Atom String
"define-syntax", Atom String
keyword, 
    (List (Atom String
"syntax-rules" : (List [LispVal]
identifiers : [LispVal]
rules)))]) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
lisp CompOpts
copts (\ Maybe String
_ -> do
    let idStr :: String
idStr = [LispVal] -> String
asts2Str [LispVal]
identifiers
        ruleStr :: String
ruleStr = [LispVal] -> String
asts2Str [LispVal]
rules
  
    -- Make macro available at compile time
    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
  
    -- And load it at runtime as well
    -- Env should be identical to the one loaded at compile time...
    String -> CompOpts -> IOThrowsError [HaskAST]
compileScalar 
      (String
"  defineNamespacedVar env macroNamespace \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
keyword String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
       String
"\" $ Syntax (Just env) Nothing False \"...\" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
idStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ruleStr) CompOpts
copts)

compile Env
env ast :: LispVal
ast@(List [Atom String
"if", LispVal
predic, LispVal
conseq]) CompOpts
copts = 
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
compile Env
env ([LispVal] -> LispVal
List [String -> LispVal
Atom String
"if", LispVal
predic, LispVal
conseq, String -> LispVal
Nil String
""]) CompOpts
copts)

compile Env
env ast :: LispVal
ast@(List [Atom String
"if", LispVal
predic, LispVal
conseq, LispVal
alt]) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
nextFunc -> do
    Atom String
symPredicate <- String -> IOThrowsError LispVal
_gensym String
"ifPredic"
    Atom String
symCheckPredicate <- String -> IOThrowsError LispVal
_gensym String
"compiledIfPredicate"
    Atom String
symConsequence <- String -> IOThrowsError LispVal
_gensym String
"compiledConsequence"
    Atom String
symAlternate <- String -> IOThrowsError LispVal
_gensym String
"compiledAlternative"

    -- Entry point; ensure if is not rebound
    [HaskAST]
f <- [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symPredicate String -> String -> String
forall a. [a] -> [a] -> [a]
++
                            String
" env (makeCPSWArgs env cont " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symCheckPredicate String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" []) " String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                            String
" (Nil \"\") (Just []) "]
    -- Compile expression for if's args
    [HaskAST]
compPredicate <- String -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
wrapObject String
symPredicate Maybe String
forall a. Maybe a
Nothing ([HaskAST] -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
      Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr 
        Env
env LispVal
predic String
symPredicate 
        Maybe String
forall a. Maybe a
Nothing -- Do not want to call into nextFunc in the middle of (if)
    [HaskAST]
compConsequence <- String -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
wrapObject String
symConsequence Maybe String
nextFunc ([HaskAST] -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
      Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr 
        Env
env LispVal
conseq String
symConsequence 
        Maybe String
nextFunc -- pick up at nextFunc after consequence
    [HaskAST]
compAlternate <- String -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
wrapObject String
symAlternate Maybe String
nextFunc ([HaskAST] -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
      Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr 
        Env
env LispVal
alt String
symAlternate 
        Maybe String
nextFunc -- or... pick up at nextFunc after alternate
    -- Special case because we need to check the predicate's value
-- FUTURE: could call a runtime function to do this, and save some code ??
    HaskAST
compCheckPredicate <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> String -> [HaskAST] -> HaskAST
AstFunction String
symCheckPredicate String
" env cont result _ " [
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  case result of ",
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"    Bool False -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symAlternate String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env cont (Nil \"\") (Just []) ",
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"    _ -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symConsequence String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env cont (Nil \"\") (Just []) "]
    
    -- Join compiled code together
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [HaskAST]
f] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
compPredicate [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST
compCheckPredicate] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ 
              [HaskAST]
compConsequence [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
compAlternate)

compile Env
env ast :: LispVal
ast@(List [Atom String
"set!", Atom String
var, LispVal
form]) copts :: CompOpts
copts@(CompileOptions {}) = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    Atom String
symDefine <- String -> IOThrowsError LispVal
_gensym String
"setFunc"
    Atom String
symMakeDefine <- String -> IOThrowsError LispVal
_gensym String
"setFuncMakeSet"

    -- Store var in huskc's env for macro processing
    LispVal
_ <- Env -> String -> LispVal -> IOThrowsError LispVal
setVar Env
env String
var LispVal
form

    [HaskAST]
compDefine <- Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr Env
env LispVal
form String
symDefine (Maybe String -> IOThrowsError [HaskAST])
-> Maybe String -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
symMakeDefine
    case [HaskAST]
compDefine of
      [(AstValue String
val)] -> do
        [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [
            String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  result <- setVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" $ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val,
            CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
""]]
      [(AstRef String
val)] -> do
        [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [
            String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  result <- setVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" =<< " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val,
            CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
""]]
      [HaskAST]
_ -> do
        HaskAST
entryPt <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialFormEntryPoint String
"set!" String
symDefine CompOpts
copts
        HaskAST
compMakeDefine <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> String -> [HaskAST] -> HaskAST
AstFunction String
symMakeDefine String
" env cont result _ " [
           String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  _ <- setVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" result",
           CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
""]
        [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [HaskAST
entryPt] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
compDefine [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST
compMakeDefine])

compile Env
env ast :: LispVal
ast@(List [Atom String
"set!", LispVal
nonvar, LispVal
_]) CompOpts
copts = do 
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    HaskAST
f <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialForm String
"set!" (String
"throwError $ TypeMismatch \"variable\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                            String
" $ String \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (LispVal -> String
forall a. Show a => a -> String
show LispVal
nonvar) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"")  CompOpts
copts
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST
f])
compile Env
env ast :: LispVal
ast@(List (Atom String
"set!" : [LispVal]
args)) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    HaskAST
f <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialForm String
"set!" (String
"throwError $ NumArgs 2 $ [String \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
            ([LispVal] -> String
forall a. Show a => a -> String
show [LispVal]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"]") CompOpts
copts -- Cheesy to use a string, but fine for now...
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST
f])

compile Env
env ast :: LispVal
ast@(List [Atom String
"define", Atom String
var, LispVal
form]) copts :: CompOpts
copts@(CompileOptions {}) = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    Atom String
symDefine <- String -> IOThrowsError LispVal
_gensym String
"defineFuncDefine"
    Atom String
symMakeDefine <- String -> IOThrowsError LispVal
_gensym String
"defineFuncMakeDef"
   
    -- Store var in huskc's env for macro processing (and same for other vers of define)
    LispVal
_ <- Env -> String -> LispVal -> IOThrowsError LispVal
defineVar Env
env String
var LispVal
form


    -- WORKAROUND #1
    -- Special case to support require-extension
    LispVal
_ <- case LispVal
form of
        List [Atom String
"current-environment"] -> 
            Env -> String -> LispVal -> IOThrowsError LispVal
defineVar Env
env String
var (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Env -> LispVal
LispEnv Env
env
        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
$ String -> LispVal
Nil String
"" 
    -- End special case

   
    -- Entry point; ensure var is not rebound
    [HaskAST]
compDefine <- Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr Env
env LispVal
form String
symDefine (Maybe String -> IOThrowsError [HaskAST])
-> Maybe String -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
symMakeDefine

    case [HaskAST]
compDefine of
      [(AstValue String
val)] -> do
        [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [
            String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  result <- defineVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" $ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val,
            CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
""]]
      [(AstRef String
val)] -> do
        [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [
            String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  result <- defineVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" =<< " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val,
            CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
""]]
      [HaskAST]
_ -> do
        [HaskAST]
f <- [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [
              String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symDefine String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env cont (Nil \"\") (Just [])" ]
        HaskAST
compMakeDefine <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> String -> [HaskAST] -> HaskAST
AstFunction String
symMakeDefine String
" env cont result _ " [
           String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  _ <- defineVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" result",
           CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
""]
        [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [HaskAST]
f] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
compDefine [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST
compMakeDefine])

compile Env
env ast :: LispVal
ast@(List (Atom String
"define" : List (Atom String
var : [LispVal]
fparams) : [LispVal]
fbody)) 
        copts :: CompOpts
copts@(CompileOptions {}) = do
  Bool
_ <- [LispVal] -> Maybe Integer -> ExceptT LispError IO Bool
validateFuncParams [LispVal]
fparams Maybe Integer
forall a. Maybe a
Nothing
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> 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 []
    -- bind lambda params in the extended env
    LispVal
_ <- Env -> [LispVal] -> IOThrowsError LispVal
defineLambdaVars Env
bodyEnv (String -> LispVal
Atom String
var LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
fparams)
   
    Atom String
symCallfunc <- String -> IOThrowsError LispVal
_gensym String
"defineFuncEntryPt"
    String
compiledParams <- [LispVal] -> ExceptT LispError IO String
compileLambdaList [LispVal]
fparams
    [HaskAST]
compiledBody <- String
-> Maybe String
-> Env
-> [HaskAST]
-> [LispVal]
-> IOThrowsError [HaskAST]
compileBlock String
symCallfunc Maybe String
forall a. Maybe a
Nothing Env
bodyEnv [] [LispVal]
fbody
   
    -- Cache macro expansions within function body
    [LispVal]
ebody <- (LispVal -> IOThrowsError LispVal)
-> [LispVal] -> IOThrowsError [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
LSC.apply) [LispVal]
fbody
    -- Store var in huskc's env for macro processing (and same for other vers of define)
    LispVal
_ <- 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
   
    -- Entry point; ensure var is not rebound
    [HaskAST]
f <- [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [
          String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  result <- makeNormalHFunc env (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
compiledParams String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                     String
") " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symCallfunc,
          String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  _ <- defineVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" result ",
          CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
""
          ]
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ (CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [HaskAST]
f) HaskAST -> [HaskAST] -> [HaskAST]
forall a. a -> [a] -> [a]
: [HaskAST]
compiledBody)

compile Env
env 
        ast :: LispVal
ast@(List (Atom String
"define" : DottedList (Atom String
var : [LispVal]
fparams) LispVal
varargs : [LispVal]
fbody)) 
        copts :: CompOpts
copts@(CompileOptions {}) = 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
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> 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 []
    -- bind lambda params in the extended env
    LispVal
_ <- Env -> [LispVal] -> IOThrowsError LispVal
defineLambdaVars Env
bodyEnv ([LispVal] -> IOThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ (String -> LispVal
Atom String
var LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
fparams) [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
varargs]
   
    Atom String
symCallfunc <- String -> IOThrowsError LispVal
_gensym String
"defineFuncEntryPt"
    String
compiledParams <- [LispVal] -> ExceptT LispError IO String
compileLambdaList [LispVal]
fparams
    [HaskAST]
compiledBody <- String
-> Maybe String
-> Env
-> [HaskAST]
-> [LispVal]
-> IOThrowsError [HaskAST]
compileBlock String
symCallfunc Maybe String
forall a. Maybe a
Nothing Env
bodyEnv [] [LispVal]
fbody
   
    -- Store var in huskc's env for macro processing (and same for other vers of define)
    [LispVal]
ebody <- (LispVal -> IOThrowsError LispVal)
-> [LispVal] -> IOThrowsError [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
LSC.apply) [LispVal]
fbody
    LispVal
_ <- 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
   
    -- Entry point; ensure var is not rebound
    [HaskAST]
f <- [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [
      String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  result <- makeHVarargs (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ LispVal -> String
ast2Str LispVal
varargs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") env (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                       String
compiledParams String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symCallfunc,
      String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  _ <- defineVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" result ",
      CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
"" ]
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ (CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [HaskAST]
f) HaskAST -> [HaskAST] -> [HaskAST]
forall a. a -> [a] -> [a]
: [HaskAST]
compiledBody)

compile Env
env ast :: LispVal
ast@(List (Atom String
"lambda" : List [LispVal]
fparams : [LispVal]
fbody)) 
        copts :: CompOpts
copts@(CompileOptions {}) = do
  Bool
_ <- [LispVal] -> Maybe Integer -> ExceptT LispError IO Bool
validateFuncParams [LispVal]
fparams Maybe Integer
forall a. Maybe a
Nothing
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    Atom String
symCallfunc <- String -> IOThrowsError LispVal
_gensym String
"lambdaFuncEntryPt"
    String
compiledParams <- [LispVal] -> ExceptT LispError IO String
compileLambdaList [LispVal]
fparams
   
    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 []
    -- bind lambda params in the extended env
    LispVal
_ <- Env -> [LispVal] -> IOThrowsError LispVal
defineLambdaVars Env
bodyEnv [LispVal]
fparams
   
    [HaskAST]
compiledBody <- String
-> Maybe String
-> Env
-> [HaskAST]
-> [LispVal]
-> IOThrowsError [HaskAST]
compileBlock String
symCallfunc Maybe String
forall a. Maybe a
Nothing Env
bodyEnv [] [LispVal]
fbody
   
    -- Entry point; ensure var is not rebound
    [HaskAST]
f <- [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [
          String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  result <- makeNormalHFunc env (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
compiledParams String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                     String
") " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symCallfunc,
          CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
""
          ]
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ (CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [HaskAST]
f) HaskAST -> [HaskAST] -> [HaskAST]
forall a. a -> [a] -> [a]
: [HaskAST]
compiledBody)

compile Env
env ast :: LispVal
ast@(List (Atom String
"lambda" : DottedList [LispVal]
fparams LispVal
varargs : [LispVal]
fbody)) 
        copts :: CompOpts
copts@(CompileOptions {}) = 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
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    Atom String
symCallfunc <- String -> IOThrowsError LispVal
_gensym String
"lambdaFuncEntryPt"
    String
compiledParams <- [LispVal] -> ExceptT LispError IO String
compileLambdaList [LispVal]
fparams
   
    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 []
    -- bind lambda params in the extended env
    LispVal
_ <- Env -> [LispVal] -> IOThrowsError LispVal
defineLambdaVars Env
bodyEnv ([LispVal] -> IOThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
fparams [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
varargs]
   
    [HaskAST]
compiledBody <- String
-> Maybe String
-> Env
-> [HaskAST]
-> [LispVal]
-> IOThrowsError [HaskAST]
compileBlock String
symCallfunc Maybe String
forall a. Maybe a
Nothing Env
bodyEnv [] [LispVal]
fbody
   
    -- Entry point; ensure var is not rebound
    [HaskAST]
f <- [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [
      String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  result <- makeHVarargs (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ LispVal -> String
ast2Str LispVal
varargs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") env (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
         String
compiledParams String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symCallfunc,
      CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
"" ]
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ (CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [HaskAST]
f) HaskAST -> [HaskAST] -> [HaskAST]
forall a. a -> [a] -> [a]
: [HaskAST]
compiledBody)

compile Env
env ast :: LispVal
ast@(List (Atom String
"lambda" : varargs :: LispVal
varargs@(Atom String
_) : [LispVal]
fbody)) 
        copts :: CompOpts
copts@(CompileOptions {}) = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    Atom String
symCallfunc <- String -> IOThrowsError LispVal
_gensym String
"lambdaFuncEntryPt"
   
    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 []
    -- bind lambda params in the extended env
    LispVal
_ <- Env -> [LispVal] -> IOThrowsError LispVal
defineLambdaVars Env
bodyEnv [LispVal
varargs]
   
    [HaskAST]
compiledBody <- String
-> Maybe String
-> Env
-> [HaskAST]
-> [LispVal]
-> IOThrowsError [HaskAST]
compileBlock String
symCallfunc Maybe String
forall a. Maybe a
Nothing Env
bodyEnv [] [LispVal]
fbody
   
    -- Entry point; ensure var is not rebound
    [HaskAST]
f <- [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [
          String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  result <- makeHVarargs (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ LispVal -> String
ast2Str LispVal
varargs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") env [] " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symCallfunc,
          CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
""
          ]
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ (CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [HaskAST]
f) HaskAST -> [HaskAST] -> [HaskAST]
forall a. a -> [a] -> [a]
: [HaskAST]
compiledBody)

compile Env
env ast :: LispVal
ast@(List [Atom String
"string-set!", Atom String
var, LispVal
i, LispVal
character]) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    Atom String
symDefine <- String -> IOThrowsError LispVal
_gensym String
"stringSetFunc"
    Atom String
symMakeDefine <- String -> IOThrowsError LispVal
_gensym String
"stringSetFuncMakeSet"
    Atom String
symChr <- String -> IOThrowsError LispVal
_gensym String
"stringSetChar"
    Atom String
symCompiledI <- String -> IOThrowsError LispVal
_gensym String
"stringI"
   
    HaskAST
entryPt <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialFormEntryPoint String
"string-set!" String
symChr CompOpts
copts
    [HaskAST]
compChr <- String -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
wrapObject String
symChr (String -> Maybe String
forall a. a -> Maybe a
Just String
symDefine) ([HaskAST] -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr Env
env LispVal
character String
symChr (String -> Maybe String
forall a. a -> Maybe a
Just String
symDefine)
    HaskAST
compDefine <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> String -> [HaskAST] -> HaskAST
AstFunction String
symDefine String
" env cont chr _ " [
        String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symCompiledI String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env (makeCPSWArgs env cont " String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
          String
symMakeDefine String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [chr]) (Nil \"\") (Just []) " ]
    [HaskAST]
compI <- String -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
wrapObject String
symCompiledI Maybe String
forall a. Maybe a
Nothing ([HaskAST] -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr Env
env LispVal
i String
symCompiledI Maybe String
forall a. Maybe a
Nothing
    HaskAST
compMakeDefine <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> String -> [HaskAST] -> HaskAST
AstFunction String
symMakeDefine String
" env cont idx (Just [chr]) " [
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  tmp <- getVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"",
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  derefValue <- recDerefPtrs tmp",
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  result <- substr (derefValue, chr, idx)",
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  _ <- updateObject env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" result",
       CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
""]
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [HaskAST
entryPt, HaskAST
compDefine, HaskAST
compMakeDefine] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
compI [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
compChr)

compile Env
env ast :: LispVal
ast@(List [Atom String
"string-set!", LispVal
nonvar, LispVal
_, LispVal
_]) CompOpts
copts = do 
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    HaskAST
f <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialForm String
"string-set!" (String
"throwError $ TypeMismatch \"variable\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                            String
" $ String \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (LispVal -> String
forall a. Show a => a -> String
show LispVal
nonvar) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"")  CompOpts
copts
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST
f])
compile Env
env ast :: LispVal
ast@(List (Atom String
"string-set!" : [LispVal]
args)) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    HaskAST
f <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialForm String
"string-set!" (String
"throwError $ NumArgs 3 $ [String \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
            ([LispVal] -> String
forall a. Show a => a -> String
show [LispVal]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"]") CompOpts
copts
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST
f])

compile Env
env ast :: LispVal
ast@(List [Atom String
"set-car!", Atom String
var, LispVal
argObj]) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    Atom String
symGetVar <- String -> IOThrowsError LispVal
_gensym String
"setCarGetVar"
    Atom String
symCompiledObj <- String -> IOThrowsError LispVal
_gensym String
"setCarCompiledObj"
    Atom String
symObj <- String -> IOThrowsError LispVal
_gensym String
"setCarObj"
    Atom String
symDoSet <- String -> IOThrowsError LispVal
_gensym String
"setCarDoSet"
   
    -- Code to all into next continuation from copts, if one exists
    let finalContinuation :: String
finalContinuation = case CompOpts
copts of
          (CompileOptions String
_ Bool
_ Bool
_ (Just String
nextFunc)) -> String
"continueEval' e (makeCPSWArgs e c " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nextFunc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [])\n"
          CompOpts
_ -> String
"continueEval' e c\n"
   
    -- Entry point that allows set-car! to be redefined
    HaskAST
entryPt <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialFormEntryPoint String
"set-car!" String
symGetVar CompOpts
copts
   
    -- Function to read existing var
    HaskAST
compGetVar <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> String -> [HaskAST] -> HaskAST
AstFunction String
symGetVar String
" env cont idx _ " [
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  result <- getVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"",
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  derefValue <- recDerefPtrs result",
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symObj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env cont derefValue (Just []) "]
   
    -- Compiled version of argObj
    [HaskAST]
compiledObj <- String -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
wrapObject String
symCompiledObj Maybe String
forall a. Maybe a
Nothing ([HaskAST] -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr Env
env LispVal
argObj String
symCompiledObj Maybe String
forall a. Maybe a
Nothing 
   
    -- Function to check looked-up var and call into appropriate handlers; 
    -- based on code from Core
    --
    -- This is so verbose because we need to have overloads of symObj to 
    -- deal with many possible inputs.
    -- FUTURE: consider making these functions part of the runtime.
    HaskAST
compObj <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
symObj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
symObj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" _ _ obj@(List []) _ = throwError $ TypeMismatch \"pair\" obj\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
symObj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" e c obj@(List (_ : _)) _ = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symCompiledObj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" e (makeCPSWArgs e c " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symDoSet String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [obj]) (Nil \"\") Nothing\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
symObj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" e c obj@(DottedList _ _) _ = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symCompiledObj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" e (makeCPSWArgs e c " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symDoSet String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [obj]) (Nil \"\") Nothing\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
symObj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" _ _ obj _ = throwError $ TypeMismatch \"pair\" obj\n"
   
    -- Function to do the actual (set!), based on code from Core
    --
    -- This is so verbose because we need to have overloads of symObj to deal 
    -- with many possible inputs.
    -- FUTURE: consider making these functions part of the runtime.
    HaskAST
compDoSet <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
symDoSet String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
symDoSet String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" e c obj (Just [List (_ : ls)]) = updateObject e \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" (List (obj : ls)) >>= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
finalContinuation String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
symDoSet String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" e c obj (Just [DottedList (_ : ls) l]) = updateObject e \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" (DottedList (obj : ls) l) >>= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
finalContinuation String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
symDoSet String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" _ _ _ _ = throwError $ InternalError \"Unexpected argument to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symDoSet String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"\n"
   
    -- Return a list of all the compiled code
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [HaskAST
entryPt, HaskAST
compGetVar, HaskAST
compObj, HaskAST
compDoSet] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
compiledObj)

compile Env
env ast :: LispVal
ast@(List [Atom String
"set-car!", LispVal
nonvar, LispVal
_]) CompOpts
copts = do 
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    HaskAST
f <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialForm String
"set-car!" (String
"throwError $ TypeMismatch \"variable\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                            String
" $ String \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (LispVal -> String
forall a. Show a => a -> String
show LispVal
nonvar) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"")  CompOpts
copts
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST
f])
compile Env
env ast :: LispVal
ast@(List (Atom String
"set-car!" : [LispVal]
args)) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    HaskAST
f <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialForm String
"set-car!" (String
"throwError $ NumArgs 2 $ [String \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
            ([LispVal] -> String
forall a. Show a => a -> String
show [LispVal]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"]") CompOpts
copts
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST
f])

compile Env
env ast :: LispVal
ast@(List [Atom String
"set-cdr!", Atom String
var, LispVal
argObj]) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    Atom String
symGetVar <- String -> IOThrowsError LispVal
_gensym String
"setCdrGetVar"
    Atom String
symCompiledObj <- String -> IOThrowsError LispVal
_gensym String
"setCdrCompiledObj"
    Atom String
symObj <- String -> IOThrowsError LispVal
_gensym String
"setCdrObj"
    Atom String
symDoSet <- String -> IOThrowsError LispVal
_gensym String
"setCdrDoSet"
   
    -- Code to all into next continuation from copts, if one exists
    let finalContinuation :: String
finalContinuation = case CompOpts
copts of
          (CompileOptions String
_ Bool
_ Bool
_ (Just String
nextFunc)) -> String
"continueEval' e (makeCPSWArgs e c " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nextFunc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [])\n"
          CompOpts
_ -> String
"continueEval' e c\n"
   
    -- Entry point that allows set-car! to be redefined
    HaskAST
entryPt <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialFormEntryPoint String
"set-car!" String
symGetVar CompOpts
copts
   
    -- Function to read existing var
    HaskAST
compGetVar <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> String -> [HaskAST] -> HaskAST
AstFunction String
symGetVar String
" env cont idx _ " [
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  result <- getVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"",
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  derefValue <- recDerefPtrs result",
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symObj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env cont derefValue (Just []) "]
   
    -- Compiled version of argObj
    [HaskAST]
compiledObj <- String -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
wrapObject String
symCompiledObj Maybe String
forall a. Maybe a
Nothing ([HaskAST] -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr Env
env LispVal
argObj String
symCompiledObj Maybe String
forall a. Maybe a
Nothing 
   
    -- Function to check looked-up var and call into appropriate handlers; based on code from Core
    --
    -- This is so verbose because we need to have overloads of symObj to deal with many possible inputs.
    -- FUTURE: consider making these functions part of the runtime.
    HaskAST
compObj <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
symObj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
symObj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" _ _ obj@(List []) _ = throwError $ TypeMismatch \"pair\" obj\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
   -- TODO: below, we want to make sure obj is of the right type. if so, 
   -- compile obj and call into the "set" 
   --       function below to do the actual set-car
      String
symObj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" e c obj@(List (_ : _)) _ = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symCompiledObj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" e (makeCPSWArgs e c " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symDoSet String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [obj]) (Nil \"\") Nothing\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
symObj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" e c obj@(DottedList _ _) _ = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symCompiledObj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" e (makeCPSWArgs e c " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symDoSet String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [obj]) (Nil \"\") Nothing\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
symObj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" _ _ obj _ = throwError $ TypeMismatch \"pair\" obj\n"
   
    -- Function to do the actual (set!), based on code from Core
    --
    -- This is so verbose because we need to have overloads of symObj 
    -- to deal with many possible inputs.
    -- FUTURE: consider making these functions part of the runtime.
    HaskAST
compDoSet <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
symDoSet String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
symDoSet String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" e c obj (Just [List (l : _)]) = do\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"   l' <- recDerefPtrs l\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"   obj' <- recDerefPtrs obj\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"   (cons [l', obj']) >>= updateObject e \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" >>= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
finalContinuation String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
symDoSet String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" e c obj (Just [DottedList (l : _) _]) = do\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"   l' <- recDerefPtrs l\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"   obj' <- recDerefPtrs obj\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String
"   (cons [l', obj']) >>= updateObject e \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" >>= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
finalContinuation String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
symDoSet String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" _ _ _ _ = throwError $ InternalError \"Unexpected argument to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symDoSet String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"\n"
   
    -- Return a list of all the compiled code
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [HaskAST
entryPt, HaskAST
compGetVar, HaskAST
compObj, HaskAST
compDoSet] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
compiledObj)

compile Env
env ast :: LispVal
ast@(List [Atom String
"set-cdr!", LispVal
nonvar, LispVal
_]) CompOpts
copts = do 
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    HaskAST
f <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialForm String
"set-cdr!" (String
"throwError $ TypeMismatch \"variable\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                            String
" $ String \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (LispVal -> String
forall a. Show a => a -> String
show LispVal
nonvar) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"")  CompOpts
copts
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST
f])
compile Env
env ast :: LispVal
ast@(List (Atom String
"set-cdr!" : [LispVal]
args)) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    HaskAST
f <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialForm String
"set-cdr!" (String
"throwError $ NumArgs 2 $ [String \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
            ([LispVal] -> String
forall a. Show a => a -> String
show [LispVal]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"]") CompOpts
copts
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST
f])

compile Env
env ast :: LispVal
ast@(List [Atom String
"list-set!", Atom String
var, LispVal
i, LispVal
object]) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    Atom String
symCompiledIdx <- String -> IOThrowsError LispVal
_gensym String
"listSetIdx"
    Atom String
symCompiledObj <- String -> IOThrowsError LispVal
_gensym String
"listSetObj"
    Atom String
symUpdateVec <- String -> IOThrowsError LispVal
_gensym String
"listSetUpdate"
    Atom String
symIdxWrapper <- String -> IOThrowsError LispVal
_gensym String
"listSetIdxWrapper"
   
    -- Entry point that allows this form to be redefined
    HaskAST
entryPt <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialFormEntryPoint String
"list-set!" String
symCompiledIdx CompOpts
copts
    -- Compile index, then use a wrapper to pass it as an arg while compiling obj
    [HaskAST]
compiledIdx <- String -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
wrapObject String
symCompiledIdx (String -> Maybe String
forall a. a -> Maybe a
Just String
symIdxWrapper) ([HaskAST] -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr Env
env LispVal
i String
symCompiledIdx (String -> Maybe String
forall a. a -> Maybe a
Just String
symIdxWrapper) 
    HaskAST
compiledIdxWrapper <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> String -> [HaskAST] -> HaskAST
AstFunction String
symIdxWrapper String
" env cont idx _ " [
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symCompiledObj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env (makeCPSWArgs env cont " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symUpdateVec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [idx]) (Nil \"\") (Just []) " ]
    [HaskAST]
compiledObj <- String -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
wrapObject String
symCompiledObj Maybe String
forall a. Maybe a
Nothing ([HaskAST] -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr Env
env LispVal
object String
symCompiledObj Maybe String
forall a. Maybe a
Nothing
    -- Do actual update
    HaskAST
compiledUpdate <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> String -> [HaskAST] -> HaskAST
AstFunction String
symUpdateVec String
" env cont obj (Just [idx]) " [
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  vec <- getVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"",
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  result <- updateList vec idx obj >>= updateObject env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"",
       CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
""]
   
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [HaskAST
entryPt, HaskAST
compiledIdxWrapper, HaskAST
compiledUpdate] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
compiledIdx [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
compiledObj)

compile Env
env ast :: LispVal
ast@(List [Atom String
"list-set!", LispVal
nonvar, LispVal
_, LispVal
_]) CompOpts
copts = do 
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    HaskAST
f <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialForm String
"list-set!" (String
"throwError $ TypeMismatch \"variable\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                            String
" $ String \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (LispVal -> String
forall a. Show a => a -> String
show LispVal
nonvar) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"")  CompOpts
copts
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST
f])
compile Env
env ast :: LispVal
ast@(List (Atom String
"list-set!" : [LispVal]
args)) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    HaskAST
f <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialForm String
"list-set!" (String
"throwError $ NumArgs 3 $ [String \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
            ([LispVal] -> String
forall a. Show a => a -> String
show [LispVal]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"]") CompOpts
copts
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST
f])

compile Env
env ast :: LispVal
ast@(List [Atom String
"vector-set!", Atom String
var, LispVal
i, LispVal
object]) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    Atom String
symCompiledIdx <- String -> IOThrowsError LispVal
_gensym String
"vectorSetIdx"
    Atom String
symCompiledObj <- String -> IOThrowsError LispVal
_gensym String
"vectorSetObj"
    Atom String
symUpdateVec <- String -> IOThrowsError LispVal
_gensym String
"vectorSetUpdate"
    Atom String
symIdxWrapper <- String -> IOThrowsError LispVal
_gensym String
"vectorSetIdxWrapper"
   
    -- Entry point that allows this form to be redefined
    HaskAST
entryPt <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialFormEntryPoint String
"vector-set!" String
symCompiledIdx CompOpts
copts
    -- Compile index, then use a wrapper to pass it as an arg while compiling obj
    [HaskAST]
compiledIdx <- String -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
wrapObject String
symCompiledIdx (String -> Maybe String
forall a. a -> Maybe a
Just String
symIdxWrapper) ([HaskAST] -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr Env
env LispVal
i String
symCompiledIdx (String -> Maybe String
forall a. a -> Maybe a
Just String
symIdxWrapper) 
    HaskAST
compiledIdxWrapper <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> String -> [HaskAST] -> HaskAST
AstFunction String
symIdxWrapper String
" env cont idx _ " [
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symCompiledObj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env (makeCPSWArgs env cont " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symUpdateVec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [idx]) (Nil \"\") (Just []) " ]
    [HaskAST]
compiledObj <- String -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
wrapObject String
symCompiledObj Maybe String
forall a. Maybe a
Nothing ([HaskAST] -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr Env
env LispVal
object String
symCompiledObj Maybe String
forall a. Maybe a
Nothing
    -- Do actual update
    HaskAST
compiledUpdate <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> String -> [HaskAST] -> HaskAST
AstFunction String
symUpdateVec String
" env cont obj (Just [idx]) " [
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  vec <- getVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"",
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  result <- updateVector vec idx obj >>= updateObject env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"",
       CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
""]
   
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [HaskAST
entryPt, HaskAST
compiledIdxWrapper, HaskAST
compiledUpdate] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
compiledIdx [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
compiledObj)

compile Env
env ast :: LispVal
ast@(List [Atom String
"vector-set!", LispVal
nonvar, LispVal
_, LispVal
_]) CompOpts
copts = do 
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    HaskAST
f <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialForm String
"vector-set!" (String
"throwError $ TypeMismatch \"variable\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                            String
" $ String \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (LispVal -> String
forall a. Show a => a -> String
show LispVal
nonvar) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"")  CompOpts
copts
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST
f])
compile Env
env ast :: LispVal
ast@(List (Atom String
"vector-set!" : [LispVal]
args)) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    HaskAST
f <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialForm String
"vector-set!" (String
"throwError $ NumArgs 3 $ [String \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
            ([LispVal] -> String
forall a. Show a => a -> String
show [LispVal]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"]") CompOpts
copts
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST
f])


compile Env
env ast :: LispVal
ast@(List [Atom String
"bytevector-u8-set!", Atom String
var, LispVal
i, LispVal
object]) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    Atom String
symCompiledIdx <- String -> IOThrowsError LispVal
_gensym String
"bytevectorSetIdx"
    Atom String
symCompiledObj <- String -> IOThrowsError LispVal
_gensym String
"bytevectorSetObj"
    Atom String
symUpdateVec <- String -> IOThrowsError LispVal
_gensym String
"bytevectorSetUpdate"
    Atom String
symIdxWrapper <- String -> IOThrowsError LispVal
_gensym String
"bytevectorSetIdxWrapper"
   
    -- Entry point that allows this form to be redefined
    HaskAST
entryPt <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialFormEntryPoint String
"bytevector-u8-set!" String
symCompiledIdx CompOpts
copts
    -- Compile index, then use a wrapper to pass it as an arg while compiling obj
    [HaskAST]
compiledIdx <- String -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
wrapObject String
symCompiledIdx (String -> Maybe String
forall a. a -> Maybe a
Just String
symIdxWrapper) ([HaskAST] -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr Env
env LispVal
i String
symCompiledIdx (String -> Maybe String
forall a. a -> Maybe a
Just String
symIdxWrapper) 
    HaskAST
compiledIdxWrapper <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> String -> [HaskAST] -> HaskAST
AstFunction String
symIdxWrapper String
" env cont idx _ " [
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symCompiledObj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env (makeCPSWArgs env cont " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symUpdateVec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [idx]) (Nil \"\") (Just []) " ]
    [HaskAST]
compiledObj <- String -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
wrapObject String
symCompiledObj Maybe String
forall a. Maybe a
Nothing ([HaskAST] -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr Env
env LispVal
object String
symCompiledObj Maybe String
forall a. Maybe a
Nothing
    -- Do actual update
    HaskAST
compiledUpdate <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> String -> [HaskAST] -> HaskAST
AstFunction String
symUpdateVec String
" env cont obj (Just [idx]) " [
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  vec <- getVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"",
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  result <- updateByteVector vec idx obj >>= updateObject env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"",
       CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
""]
   
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [HaskAST
entryPt, HaskAST
compiledIdxWrapper, HaskAST
compiledUpdate] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
compiledIdx [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
compiledObj)

compile Env
env ast :: LispVal
ast@(List [Atom String
"bytevector-u8-set!", LispVal
nonvar, LispVal
_, LispVal
_]) CompOpts
copts = do 
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    HaskAST
f <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialForm String
"bytevector-u8-set!" (String
"throwError $ TypeMismatch \"variable\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                            String
" $ String \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (LispVal -> String
forall a. Show a => a -> String
show LispVal
nonvar) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"")  CompOpts
copts
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST
f])
compile Env
env ast :: LispVal
ast@(List (Atom String
"bytevector-u8-set!" : [LispVal]
args)) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    HaskAST
f <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialForm String
"bytevector-u8-set!" (String
"throwError $ NumArgs 3 $ [String \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
            ([LispVal] -> String
forall a. Show a => a -> String
show [LispVal]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"]") CompOpts
copts
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST
f])

compile Env
env ast :: LispVal
ast@(List [Atom String
"hash-table-set!", Atom String
var, LispVal
rkey, LispVal
rvalue]) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    Atom String
symCompiledIdx <- String -> IOThrowsError LispVal
_gensym String
"hashTableSetIdx"
    Atom String
symCompiledObj <- String -> IOThrowsError LispVal
_gensym String
"hashTableSetObj"
    Atom String
symUpdateVec <- String -> IOThrowsError LispVal
_gensym String
"hashTableSetUpdate"
    Atom String
symIdxWrapper <- String -> IOThrowsError LispVal
_gensym String
"hashTableSetIdxWrapper"
   
    -- Entry point that allows this form to be redefined
    HaskAST
entryPt <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialFormEntryPoint String
"hash-table-set!" String
symCompiledIdx CompOpts
copts
    -- Compile index, then use a wrapper to pass it as an arg while compiling obj
    [HaskAST]
compiledIdx <- String -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
wrapObject String
symCompiledIdx (String -> Maybe String
forall a. a -> Maybe a
Just String
symIdxWrapper) ([HaskAST] -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
       Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr Env
env LispVal
rkey String
symCompiledIdx (String -> Maybe String
forall a. a -> Maybe a
Just String
symIdxWrapper) 
    HaskAST
compiledIdxWrapper <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> String -> [HaskAST] -> HaskAST
AstFunction String
symIdxWrapper String
" env cont idx _ " [
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symCompiledObj String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env (makeCPSWArgs env cont " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symUpdateVec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [idx]) (Nil \"\") (Just []) " ]
    [HaskAST]
compiledObj <- String -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
wrapObject String
symCompiledObj Maybe String
forall a. Maybe a
Nothing ([HaskAST] -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
       Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr Env
env LispVal
rvalue String
symCompiledObj Maybe String
forall a. Maybe a
Nothing
    -- Do actual update
    HaskAST
compiledUpdate <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> String -> [HaskAST] -> HaskAST
AstFunction String
symUpdateVec String
" env cont obj (Just [rkey]) " [
       -- TODO: this should be more robust, than just assuming ht is a HashTable
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  HashTable ht <- getVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"",
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  HashTable ht' <- recDerefPtrs $ HashTable ht",
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  result <- updateObject env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" (HashTable $ Data.Map.insert rkey obj ht') ",
       CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
""]
   
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [HaskAST
entryPt, HaskAST
compiledIdxWrapper, HaskAST
compiledUpdate] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
compiledIdx [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
compiledObj)

compile Env
env ast :: LispVal
ast@(List [Atom String
"hash-table-set!", LispVal
nonvar, LispVal
_, LispVal
_]) CompOpts
copts = do 
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    HaskAST
f <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialForm String
"hash-table-set!" (String
"throwError $ TypeMismatch \"variable\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                            String
" $ String \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (LispVal -> String
forall a. Show a => a -> String
show LispVal
nonvar) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"")  CompOpts
copts
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST
f])
compile Env
env ast :: LispVal
ast@(List (Atom String
"hash-table-set!" : [LispVal]
args)) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    HaskAST
f <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialForm String
"hash-table-set!" (String
"throwError $ NumArgs 3 $ [String \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
            ([LispVal] -> String
forall a. Show a => a -> String
show [LispVal]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"]") CompOpts
copts
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST
f])

compile Env
env ast :: LispVal
ast@(List [Atom String
"hash-table-delete!", Atom String
var, LispVal
rkey]) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    Atom String
symCompiledIdx <- String -> IOThrowsError LispVal
_gensym String
"hashTableDeleteIdx"
    Atom String
symDoDelete <- String -> IOThrowsError LispVal
_gensym String
"hashTableDelete"
   
    -- Entry point that allows this form to be redefined
    HaskAST
entryPt <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialFormEntryPoint String
"hash-table-delete!" String
symCompiledIdx CompOpts
copts
    -- Compile index, then use a wrapper to pass it as an arg while compiling obj
    [HaskAST]
compiledIdx <- String -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
wrapObject String
symCompiledIdx (String -> Maybe String
forall a. a -> Maybe a
Just String
symDoDelete) ([HaskAST] -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
       Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr Env
env LispVal
rkey String
symCompiledIdx (String -> Maybe String
forall a. a -> Maybe a
Just String
symDoDelete) 
    -- Do actual update
    HaskAST
compiledUpdate <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> String -> [HaskAST] -> HaskAST
AstFunction String
symDoDelete String
" env cont rkey _ " [
       -- TODO: this should be more robust, than just assuming ht is a HashTable
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  HashTable ht <- getVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"",
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  HashTable ht' <- recDerefPtrs $ HashTable ht",
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  result <- updateObject env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" (HashTable $ Data.Map.delete rkey ht') ",
       CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
""]
   
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [HaskAST
entryPt, HaskAST
compiledUpdate] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
compiledIdx)

compile Env
env ast :: LispVal
ast@(List [Atom String
"hash-table-delete!", LispVal
nonvar, LispVal
_]) CompOpts
copts = do 
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    HaskAST
f <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialForm String
"hash-table-delete!" (String
"throwError $ TypeMismatch \"variable\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                            String
" $ String \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (LispVal -> String
forall a. Show a => a -> String
show LispVal
nonvar) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"")  CompOpts
copts
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST
f])
compile Env
env ast :: LispVal
ast@(List (Atom String
"hash-table-delete!" : [LispVal]
args)) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    HaskAST
f <- String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialForm String
"hash-table-delete!" (String
"throwError $ NumArgs 2 $ [String \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
            ([LispVal] -> String
forall a. Show a => a -> String
show [LispVal]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"]") CompOpts
copts
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST
f])

compile Env
env ast :: LispVal
ast@(List (Atom String
"%import" : [LispVal]
args)) CompOpts
copts = do
  Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env LispVal
ast CompOpts
copts (\ Maybe String
_ -> do
    LispError -> IOThrowsError [HaskAST]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError [HaskAST])
-> LispError -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ String -> LispError
NotImplemented (String -> LispError) -> String -> LispError
forall a b. (a -> b) -> a -> b
$ String
"%import, with args: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [LispVal] -> String
forall a. Show a => a -> String
show [LispVal]
args)

compile Env
env (List [a :: LispVal
a@(Atom String
"husk-interpreter?")]) CompOpts
copts = do
    Env
-> LispVal
-> (Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST])
-> CompOpts
-> IOThrowsError [HaskAST]
mfunc Env
env ([LispVal] -> LispVal
List [LispVal
a, Bool -> LispVal
Bool Bool
True]) Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
compile CompOpts
copts 

compile Env
env args :: LispVal
args@(List [Atom String
"load", LispVal
filename, LispVal
envSpec]) CompOpts
copts = do
  -- Explicitly do NOT call compileSpecialFormBody here, since load is not normally a special form

  -- F*ck it, just run the evaluator here since filename is req'd at compile time
  LispVal
fname <- Env -> LispVal -> IOThrowsError LispVal
LSC.evalLisp Env
env LispVal
filename
  case LispVal
fname of
    -- Compile contents of the file
    String String
fn -> String -> IOThrowsError [HaskAST]
compileFile String
fn

    -- Unable to get filename at compile time, fall back to loading at runtime
    LispVal
_ -> Env
-> LispVal
-> (Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST])
-> CompOpts
-> IOThrowsError [HaskAST]
mfunc Env
env LispVal
args Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
compileApply CompOpts
copts

 where 
 compileFile :: String -> IOThrowsError [HaskAST]
compileFile String
filename' = do
  Atom String
symEnv <- String -> IOThrowsError LispVal
_gensym String
"loadEnv"
  Atom String
symLoad <- String -> IOThrowsError LispVal
_gensym String
"load"
  [HaskAST]
compEnv <- String -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
wrapObject String
symEnv Maybe String
forall a. Maybe a
Nothing ([HaskAST] -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr Env
env LispVal
envSpec String
symEnv
                            Maybe String
forall a. Maybe a
Nothing -- Return env to our custom func

  -- WORKAROUND #1
  -- Special case to support require-extension
  Env
env' <- case LispVal
envSpec of
               Atom String
a -> do
                   LispVal
v <- Env -> String -> IOThrowsError LispVal
getVar Env
env String
a
                   case LispVal
v of
                       LispEnv Env
e -> Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. Monad m => a -> m a
return Env
e
                       LispVal
_ -> Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. Monad m => a -> m a
return Env
env
               LispVal
_ -> Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. Monad m => a -> m a
return Env
env
  -- End special case

  [HaskAST]
compLoad <- Env -> String -> String -> Maybe String -> IOThrowsError [HaskAST]
compileLisp Env
env' String
filename' String
symLoad Maybe String
forall a. Maybe a
Nothing
 
  -- Entry point
  [HaskAST]
f <- [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [
    -- TODO: should do runtime error checking if something else
    --       besides a LispEnv is returned
    String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  LispEnv e <- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symEnv String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env (makeNullContinuation env) (Nil \"\") (Just []) ",
    String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  result <- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symLoad String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" e (makeNullContinuation e) (Nil \"\") Nothing",
    CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
""]
  -- Join compiled code together
  [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [HaskAST]
f] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
compEnv [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
compLoad

compile Env
env (List [Atom String
"load", LispVal
filename]) CompOpts
copts = do -- TODO: allow filename from a var, support env optional arg
 -- TODO: error handling for string below
 String String
filename' <- Env -> LispVal -> IOThrowsError LispVal
LSC.evalLisp Env
env LispVal
filename
 Atom String
symEntryPt <- String -> IOThrowsError LispVal
_gensym String
"load"
 [HaskAST]
result <- Env -> String -> String -> Maybe String -> IOThrowsError [HaskAST]
compileLisp Env
env String
filename' String
symEntryPt Maybe String
forall a. Maybe a
Nothing
 [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [HaskAST]
result [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ 
   [CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [
    String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  result <- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symEntryPt String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
               String
" env (makeNullContinuation env) (Nil \"\") Nothing",
    CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
""]]

-- FUTURE: eventually it should be possible to evaluate the args instead of assuming
-- that they are all strings, but lets keep it simple for now
compile Env
env (List [Atom String
"load-ffi", 
                        String String
moduleName, 
                        String String
externalFuncName, 
                        String String
internalFuncName]) CompOpts
copts = do
--  Atom symLoadFFI <- _gensym "loadFFI"

  -- Only append module again if it is not already in the list
  List [LispVal]
l <- Env -> Char -> String -> IOThrowsError LispVal
getNamespacedVar Env
env Char
't' {-"internal"-} String
"imports"
  LispVal
_ <- if String -> LispVal
String String
moduleName LispVal -> [LispVal] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [LispVal]
l
          then Env -> Char -> String -> LispVal -> IOThrowsError LispVal
setNamespacedVar Env
env Char
't' {-"internal"-} String
"imports" (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
$ [LispVal]
l [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [String -> LispVal
String String
moduleName]
          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
String String
""

  -- Pass along moduleName as another top-level import
  [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [
    String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  result <- defineVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
        String
internalFuncName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" $ IOFunc " String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
        String
moduleName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
externalFuncName,
    CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
""]]

compile Env
env args :: LispVal
args@(List (LispVal
_ : [LispVal]
_)) CompOpts
copts = Env
-> LispVal
-> (Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST])
-> CompOpts
-> IOThrowsError [HaskAST]
mfunc Env
env LispVal
args Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
compileApply CompOpts
copts 
compile Env
_ LispVal
badForm CompOpts
_ = LispError -> IOThrowsError [HaskAST]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError [HaskAST])
-> LispError -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
BadSpecialForm String
"Unrecognized special form" LispVal
badForm

-- |Expand macros and compile the resulting code
mcompile :: Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
mcompile :: Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
mcompile Env
env LispVal
lisp = Env
-> LispVal
-> (Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST])
-> CompOpts
-> IOThrowsError [HaskAST]
mfunc Env
env LispVal
lisp Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
compile

-- |Expand macros and then pass control to the given function 
mfunc :: Env
      -> LispVal 
      -> (Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]) 
      -> CompOpts 
      -> IOThrowsError [HaskAST] 
mfunc :: Env
-> LispVal
-> (Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST])
-> CompOpts
-> IOThrowsError [HaskAST]
mfunc Env
env LispVal
lisp Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
func CompOpts
copts = do
  LispVal
expanded <- Env
-> LispVal
-> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal)
-> IOThrowsError LispVal
Language.Scheme.Macro.macroEval Env
env LispVal
lisp LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
LSC.apply
  Env
-> LispVal
-> CompOpts
-> (Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
divertVars Env
env LispVal
expanded CompOpts
copts Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
func

-- |Do the actual insertion of diverted variables back to the 
--  compiled program.
divertVars 
    :: Env 
    -- ^ Current compile Environment
    -> LispVal
    -- ^ Lisp code after macro expansion
    -> CompOpts
    -- ^ Compiler options
    -> (Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST])
    -- ^ Continuation to call into after vars are diverted
    -> IOThrowsError [HaskAST]
    -- ^ Code generated by the continuation, along with the code
    --   added to divert vars to the compiled program
divertVars :: Env
-> LispVal
-> CompOpts
-> (Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
divertVars Env
env LispVal
expanded copts :: CompOpts
copts@(CompileOptions String
_ Bool
uvar Bool
uargs Maybe String
nfnc) Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
func = do
  [LispVal]
vars <- Env -> IOThrowsError [LispVal]
Language.Scheme.Macro.getDivertedVars Env
env
  case [LispVal]
vars of 
    [] -> Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
func Env
env LispVal
expanded CompOpts
copts
    [LispVal]
_ -> do 
      Atom String
symNext <- String -> IOThrowsError LispVal
_gensym String
"afterDivert"
      HaskAST
diverted <- String
-> Env -> [LispVal] -> CompOpts -> ExceptT LispError IO HaskAST
compileDivertedVars String
symNext Env
env [LispVal]
vars CompOpts
copts
      [HaskAST]
rest <- String -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
wrapObject String
symNext Maybe String
nfnc ([HaskAST] -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
func Env
env LispVal
expanded (String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
symNext Bool
uvar Bool
uargs Maybe String
nfnc)
      [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ HaskAST
diverted HaskAST -> [HaskAST] -> [HaskAST]
forall a. a -> [a] -> [a]
: [HaskAST]
rest

-- |Take a list of variables diverted into env at compile time, and
--  divert them into the env at runtime
compileDivertedVars :: String -> Env -> [LispVal] -> CompOpts -> IOThrowsError HaskAST
compileDivertedVars :: String
-> Env -> [LispVal] -> CompOpts -> ExceptT LispError IO HaskAST
compileDivertedVars 
  String
formNext Env
_ [LispVal]
vars 
  copts :: CompOpts
copts@(CompileOptions String
_ Bool
useVal Bool
useArgs Maybe String
_) = do
  let val :: String
val = case Bool
useVal of
        Bool
True -> String
"value"
        Bool
_ -> String
"Nil \"\""
      args :: String
args = case Bool
useArgs of
        Bool
True -> String
"(Just args)"
        Bool
_ -> String
"(Just [])"
      comp :: LispVal -> [HaskAST]
comp (List [Atom String
renamed, Atom String
orig]) = do
        [String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  v <- getVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
orig String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"",
         String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  _ <- defineVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
renamed String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" v"]
      comp LispVal
_ = []
      cvars :: [[HaskAST]]
cvars = (LispVal -> [HaskAST]) -> [LispVal] -> [[HaskAST]]
forall a b. (a -> b) -> [a] -> [b]
map LispVal -> [HaskAST]
comp [LispVal]
vars 
      f :: [HaskAST]
f = ([[HaskAST]] -> [HaskAST]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[HaskAST]]
cvars) [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ 
          [String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
formNext String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env cont (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
args]
  HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [HaskAST]
f

-- |Create the function entry point for a special form
compileSpecialFormEntryPoint :: String -> String -> CompOpts -> IOThrowsError HaskAST
compileSpecialFormEntryPoint :: String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialFormEntryPoint String
formName String
formSym CompOpts
copts = do
 String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialForm String
formName (String
"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
formSym String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env cont (Nil \"\") (Just [])") CompOpts
copts

-- | Helper function for compiling a special form
compileSpecialForm :: String -> String -> CompOpts -> IOThrowsError HaskAST
compileSpecialForm :: String -> String -> CompOpts -> ExceptT LispError IO HaskAST
compileSpecialForm String
_ String
formCode CompOpts
copts = do
 [HaskAST]
f <- [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [
       String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
formCode]
 HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [HaskAST]
f

-- |A wrapper for each special form that allows the form variable 
--  (EG: "if") to be redefined at compile time
compileSpecialFormBody :: Env
                       -> LispVal
                       -> CompOpts
                       -> (Maybe String -> ExceptT LispError IO [HaskAST])
                       -> ExceptT LispError IO [HaskAST]
compileSpecialFormBody :: Env
-> LispVal
-> CompOpts
-> (Maybe String -> IOThrowsError [HaskAST])
-> IOThrowsError [HaskAST]
compileSpecialFormBody Env
env 
                       ast :: LispVal
ast@(List (Atom String
fnc : [LispVal]
_)) 
                       copts :: CompOpts
copts@(CompileOptions String
_ Bool
_ Bool
_ Maybe String
nextFunc) 
                       Maybe String -> IOThrowsError [HaskAST]
spForm = do
  Bool
isDefined <- 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
fnc
  case Bool
isDefined of
    Bool
True -> Env
-> LispVal
-> (Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST])
-> CompOpts
-> IOThrowsError [HaskAST]
mfunc Env
env LispVal
ast Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
compileApply CompOpts
copts 
    Bool
False -> Maybe String -> IOThrowsError [HaskAST]
spForm Maybe String
nextFunc
compileSpecialFormBody Env
_ LispVal
_ CompOpts
_ Maybe String -> IOThrowsError [HaskAST]
_ = LispError -> IOThrowsError [HaskAST]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError [HaskAST])
-> LispError -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError String
"compileSpecialFormBody"

-- | Compile an intermediate expression (such as an arg to if) and 
--   call into the next continuation with it's value
compileExpr :: Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr :: Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileExpr Env
env LispVal
expr String
symThisFunc Maybe String
fForNextExpr = do
  Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
mcompile Env
env LispVal
expr (String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
symThisFunc Bool
False Bool
False Maybe String
fForNextExpr) 

-- |Compile a function call
compileApply :: Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
compileApply :: Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
compileApply Env
env (List (LispVal
func : [LispVal]
fparams)) copts :: CompOpts
copts@(CompileOptions String
coptsThis Bool
_ Bool
_ Maybe String
coptsNext) = do

--
-- TODO: it is probably possible to mix creating conts and not when there are func and non-func args.
--  
--  _ <- case (trace ("calling compileApply: " ++ show (List (func : fparams))) func) of
  LispVal
_ <- case LispVal
func of
    List [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
$ String -> LispVal
Nil String
""
    Atom String
_ -> 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
"" 
    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
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]
fparams)

  Maybe LispVal
primitive <- Env -> LispVal -> IOThrowsError (Maybe LispVal)
isPrim Env
env LispVal
func
  let literals :: Maybe [LispVal]
literals = [LispVal] -> Maybe [LispVal]
collectLiterals [LispVal]
fparams 
      nonFunctionCalls :: Maybe [LispVal]
nonFunctionCalls = [LispVal] -> Maybe [LispVal]
collectLiteralsAndVars [LispVal]
fparams

  case (Maybe LispVal
primitive, Maybe [LispVal]
literals, Maybe [LispVal]
nonFunctionCalls) of
     -- Primitive (non-I/O) function with literal args, 
     -- evaluate at compile time
     (Just LispVal
primFunc, Just [LispVal]
ls, Maybe [LispVal]
_) -> do
       LispVal
result <- LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal
LSC.apply 
        (Env -> LispVal
makeNullContinuation Env
env)
        LispVal
primFunc
        [LispVal]
ls

       [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [CompOpts -> [HaskAST] -> HaskAST
createAstFunc CompOpts
copts [
         String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  let result = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (LispVal -> String
ast2Str LispVal
result),
         CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"result" String
""]]

     -- Other function with literal args, no need to create a
     -- continuation chain. But this case may include I/O funcs and
     -- variables, so everything must be executed at runtime
     (Maybe LispVal
_, Maybe [LispVal]
_, Just [LispVal]
ls) -> [LispVal] -> IOThrowsError [HaskAST]
compileFuncLitArgs [LispVal]
ls
     
     -- Any other function, do it the hard way...
     --
     -- Compile the function and each argument as a link in
     -- a chain of continuations.
     (Maybe LispVal, Maybe [LispVal], Maybe [LispVal])
_ -> LispVal -> IOThrowsError [HaskAST]
compileAllArgs LispVal
func

 where 
  -- |Compile a function call that contains arguments that are not
  --  function calls executed at runtime.
  compileFuncLitArgs :: [LispVal] -> IOThrowsError [HaskAST]
compileFuncLitArgs [LispVal]
args = do
       -- Keep track of any variables since we need to do a
       -- 'getRtVar' lookup for each of them prior to apply
       let pack :: [LispVal]
-> [String]
-> [(String, String)]
-> a
-> ([String], [(String, String)])
pack (Atom String
p : [LispVal]
ps) [String]
strs [(String, String)]
vars a
i = do
             let varName :: String
varName = Char
'v' Char -> String -> String
forall a. a -> [a] -> [a]
: a -> String
forall a. Show a => a -> String
show a
i
             [LispVal]
-> [String]
-> [(String, String)]
-> a
-> ([String], [(String, String)])
pack [LispVal]
ps 
                  ([String]
strs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
varName]) 
                  ([(String, String)]
vars [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String
p, String
varName)]) 
                  (a
i a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)
           pack (LispVal
p : [LispVal]
ps) [String]
strs [(String, String)]
vars a
i = 
             [LispVal]
-> [String]
-> [(String, String)]
-> a
-> ([String], [(String, String)])
pack [LispVal]
ps 
                  ([String]
strs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [LispVal -> String
ast2Str LispVal
p]) 
                  [(String, String)]
vars 
                  a
i
           pack [] [String]
strs [(String, String)]
vars a
_ = ([String]
strs, [(String, String)]
vars)
       let ([String]
paramStrs, [(String, String)]
vars) = [LispVal]
-> [String]
-> [(String, String)]
-> Int
-> ([String], [(String, String)])
forall a.
(Num a, Show a) =>
[LispVal]
-> [String]
-> [(String, String)]
-> a
-> ([String], [(String, String)])
pack [LispVal]
args [] [] (Int
0::Int)
       LispVal -> [(String, String)] -> String -> IOThrowsError [HaskAST]
_compileFuncLitArgs LispVal
func [(String, String)]
vars (String -> IOThrowsError [HaskAST])
-> String -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String -> String
forall a. [[a]] -> [a] -> [a]
joinL [String]
paramStrs String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"

  _compileFuncLitArgs :: LispVal -> [(String, String)] -> String -> IOThrowsError [HaskAST]
_compileFuncLitArgs LispVal
fnc [(String, String)]
vars String
args = do
    Atom String
stubFunc <- String -> IOThrowsError LispVal
_gensym String
"applyStubF"
    Atom String
nextFunc <- String -> IOThrowsError LispVal
_gensym String
"applyNextF"

    -- Haskell variables must be used to retrieve each atom from the env
    let varLines :: [HaskAST]
varLines = 
          ((String, String) -> HaskAST) -> [(String, String)] -> [HaskAST]
forall a b. (a -> b) -> [a] -> [b]
map (\ (String
rt, String
cp) -> 
                  String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" <- getRTVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"")
              [(String, String)]
vars

    [HaskAST]
rest <- case Maybe String
coptsNext of
             Maybe String
Nothing -> [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [
               String -> String -> [HaskAST] -> HaskAST
AstFunction String
nextFunc
                String
" env cont value _ " ([HaskAST] -> HaskAST) -> [HaskAST] -> HaskAST
forall a b. (a -> b) -> a -> b
$ [HaskAST]
varLines [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ 
                [String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  apply cont value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
args]]
             Just String
fnextExpr -> [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [
               String -> String -> [HaskAST] -> HaskAST
AstFunction String
nextFunc 
                String
" env cont value _ " ([HaskAST] -> HaskAST) -> [HaskAST] -> HaskAST
forall a b. (a -> b) -> a -> b
$ [HaskAST]
varLines [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ 
                [String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  apply (makeCPSWArgs env cont " String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                            String
fnextExpr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" []) value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
args]]

    [HaskAST]
_comp <- Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
mcompile Env
env LispVal
fnc (CompOpts -> IOThrowsError [HaskAST])
-> CompOpts -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
stubFunc Bool
False Bool
False Maybe String
forall a. Maybe a
Nothing
    case [HaskAST]
_comp of
        [(AstValue String
val)] -> do
          [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [CompOpts -> [HaskAST] -> HaskAST
createAstFunc 
                    (String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
coptsThis Bool
False Bool
False Maybe String
forall a. Maybe a
Nothing) [
                     String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  let var = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val,
                     String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nextFunc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env cont var Nothing"]] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
rest
        [(AstRef String
val)] -> do
          [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [CompOpts -> [HaskAST] -> HaskAST
createAstFunc 
                    (String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
coptsThis Bool
False Bool
False Maybe String
forall a. Maybe a
Nothing) [
                     String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  var <- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val,
                     String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nextFunc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env cont var Nothing"]] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
rest
        [HaskAST]
_ -> do
          HaskAST
c <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ 
            String -> String -> [HaskAST] -> HaskAST
AstFunction String
coptsThis String
" env cont _ _ " [
              String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stubFunc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env (makeCPSWArgs env cont " String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                         String
nextFunc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" []) (Nil \"\") (Just [])"]  
      
          [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [HaskAST
c] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
_comp [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
rest

  -- |Compile function and args as a chain of continuations
-- TODO:
  compileAllArgs :: LispVal -> IOThrowsError [HaskAST]
compileAllArgs (Atom String
fncName) = do
    [HaskAST]
rest <- case [LispVal]
fparams of
    --rest <- case (trace "fncName" fparams) of
              [] -> do
                  LispError -> IOThrowsError [HaskAST]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError [HaskAST])
-> LispError -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ String -> LispError
Default (String -> LispError) -> String -> LispError
forall a b. (a -> b) -> a -> b
$ String
" unreachable code in compileAllArgs for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fncName
--                fnc <- compileInlineVar env fncName "fnc"
--                return [AstFunction 
--                          coptsThis
--                          " env cont (Nil _) (Just (a:as)) "
--                          [fnc,
--                           AstValue $ "  apply " ++ applyCont ++ " fnc (a:as) "],
--                        AstFunction 
--                          coptsThis
--                          " env cont value (Just (a:as)) " 
--                          [fnc,
--                           AstValue $ "  apply " ++ applyCont ++ " fnc $ (a:as) ++ [value] "]]
              [LispVal]
_ -> String
-> Bool -> Maybe String -> [LispVal] -> IOThrowsError [HaskAST]
compileArgs String
coptsThis Bool
True (String -> Maybe String
forall a. a -> Maybe a
Just String
fncName) [LispVal]
fparams -- True, passing fnc as value
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [HaskAST]
rest
    --return $ [c, wrapper ] ++ _comp ++ rest
  compileAllArgs LispVal
func' = do
    Atom String
stubFunc <- String -> IOThrowsError LispVal
_gensym String
"applyStubF"
    Atom String
wrapperFunc <- String -> IOThrowsError LispVal
_gensym String
"applyWrapper"
    Atom String
nextFunc <- String -> IOThrowsError LispVal
_gensym String
"applyNextF"

    -- Use wrapper to pass high-order function (func) as an argument to apply
    HaskAST
wrapper <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ 
      String -> String -> [HaskAST] -> HaskAST
AstFunction String
wrapperFunc String
" env cont value _ " [
          String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nextFunc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env cont " String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                     String
" (Nil \"\") (Just [value]) "]
    --rest <- case (trace ("func' = " ++ (show func') ++ ", fparams = " ++ (show fparams)) fparams) of
    [HaskAST]
rest <- case [LispVal]
fparams of
              [] -> do
                [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> String -> [HaskAST] -> HaskAST
AstFunction 
                          String
nextFunc 
                          String
" env cont (Nil _) (Just (a:as)) "
                          [String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  apply " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
applyCont String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" a as "],
                        String -> String -> [HaskAST] -> HaskAST
AstFunction 
                          String
nextFunc 
                          String
" env cont value (Just (a:as)) " 
                          [String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  apply " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
applyCont String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" a $ as ++ [value] "]]
              [LispVal]
_ -> String
-> Bool -> Maybe String -> [LispVal] -> IOThrowsError [HaskAST]
compileArgs String
nextFunc Bool
False Maybe String
forall a. Maybe a
Nothing [LispVal]
fparams -- False since no value passed in this time

    [HaskAST]
_comp <- Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
mcompile Env
env LispVal
func' (CompOpts -> IOThrowsError [HaskAST])
-> CompOpts -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
stubFunc Bool
False Bool
False Maybe String
forall a. Maybe a
Nothing
    case [HaskAST]
_comp of
        [(AstValue String
val)] -> do
          [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [CompOpts -> [HaskAST] -> HaskAST
createAstFunc 
                    (String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
coptsThis Bool
False Bool
False Maybe String
forall a. Maybe a
Nothing) [
                     String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  let var = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val,
                     String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
wrapperFunc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env cont var Nothing"]] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
rest
        [(AstRef String
val)] -> do
          [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [CompOpts -> [HaskAST] -> HaskAST
createAstFunc 
                    (String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
coptsThis Bool
False Bool
False Maybe String
forall a. Maybe a
Nothing) [
                     String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  var <- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val,
                     String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
wrapperFunc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env cont var Nothing"]] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
rest
        [HaskAST]
_ -> do
          HaskAST
c <- HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ 
            String -> String -> [HaskAST] -> HaskAST
AstFunction String
coptsThis String
" env cont _ _ " [
              String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stubFunc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env (makeCPSWArgs env cont " String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                         String
wrapperFunc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" []) (Nil \"\") (Just [])"]  
          [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [HaskAST
c, HaskAST
wrapper ] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
_comp [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
rest

  applyCont :: String
  applyCont :: String
applyCont = case Maybe String
coptsNext of
                Maybe String
Nothing -> String
"cont"
                Just String
fnextExpr -> String
"(makeCPSWArgs env cont " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fnextExpr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [])"

  -- |Compile each argument as its own continuation (lambda), and then
  --  call the function using @applyWrapper@
  compileArgs :: String -> Bool -> (Maybe String) -> [LispVal] -> IOThrowsError [HaskAST]
  compileArgs :: String
-> Bool -> Maybe String -> [LispVal] -> IOThrowsError [HaskAST]
compileArgs String
thisFunc Bool
thisFuncUseValue Maybe String
maybeFnc [LispVal]
args = do
    case [LispVal]
args of
      (LispVal
a:[LispVal]
as) -> do
        let ([LispVal]
asRest, [a]
asLiterals) = ([LispVal]
as, [])
--        let (asRest, asLiterals) = takeLiterals a as
        let lastArg :: Bool
lastArg = [LispVal] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LispVal]
asRest
        Atom String
stubFunc <- String -> IOThrowsError LispVal
_gensym String
"applyFirstArg" -- Call into compiled stub
        Atom String
nextFunc <- do
            case Bool
lastArg of
                Bool
True -> 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
Atom String
"applyWrapper" -- Use wrapper to call into /apply/
                Bool
_ -> String -> IOThrowsError LispVal
_gensym String
"applyNextArg" -- Next func argument to execute...

        -- inline function?
        [HaskAST]
fnc <- case Maybe String
maybeFnc of
                 Just String
fncName -> do
                    HaskAST
var <- Env -> String -> String -> ExceptT LispError IO HaskAST
compileInlineVar Env
env String
fncName String
"value"
                    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST
var]
                 Maybe String
_ -> [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return []

        -- Flag below means that the expression's value matters, add it to args
        let fargs :: String
fargs = if Bool
thisFuncUseValue
                       then String
" env cont value (Just args) "
                       else String
" env cont _ (Just args) "
        [HaskAST]
rest <- case Bool
lastArg of
                     Bool
True -> [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [] -- Using apply wrapper, so no more code
                     Bool
_ -> String
-> Bool -> Maybe String -> [LispVal] -> IOThrowsError [HaskAST]
compileArgs String
nextFunc Bool
True Maybe String
forall a. Maybe a
Nothing [LispVal]
asRest -- True indicates nextFunc needs to use value arg passed into it
        let nextCont' :: String
nextCont' = case (Bool
lastArg, Maybe String
coptsNext) of
                            (Bool
True, Just String
fnextExpr) -> String
"(makeCPSWArgs env cont " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fnextExpr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [])"
                            (Bool, Maybe String)
_ -> String
"cont"
        let literalArgs :: String
literalArgs = [LispVal] -> String
asts2Str [LispVal]
forall a. [a]
asLiterals
        let argsCode :: String
argsCode = case Bool
thisFuncUseValue of
                         Bool
True -> String
" $ args ++ [value] ++ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
literalArgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") " 
                         Bool
False -> String
" $ args ++ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
literalArgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") "

        [HaskAST]
_comp <- Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
mcompile Env
env LispVal
a (CompOpts -> IOThrowsError [HaskAST])
-> CompOpts -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
stubFunc Bool
thisFuncUseValue Bool
False Maybe String
forall a. Maybe a
Nothing
        case [HaskAST]
_comp of
            [(AstValue String
val)] -> do
              [HaskAST]
c <- do
                   [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  let var = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val,
                           String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nextFunc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nextCont' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" var (Just " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
argsCode]
              [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [String -> String -> [HaskAST] -> HaskAST
AstFunction String
thisFunc String
fargs ([HaskAST]
fnc [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
c)] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
rest
            [(AstRef String
val)] -> do
              [HaskAST]
c <- do
                   [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  var <- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val,
                           String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nextFunc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" env " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nextCont' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" var (Just " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
argsCode]
              [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [String -> String -> [HaskAST] -> HaskAST
AstFunction String
thisFunc String
fargs ([HaskAST]
fnc [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
c)] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
rest
            [HaskAST]
_ -> do
              let c :: HaskAST
c = String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$
                        String
"  continueEval' env (makeCPSWArgs env (makeCPSWArgs env " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                        String
nextCont' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nextFunc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
argsCode String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stubFunc String -> String -> String
forall a. [a] -> [a] -> [a]
++
                        String
" []) $ Nil\"\""
-- TODO: not good enough, generated functions assume args come from continuation and not parameter
--              let c = AstValue $ "  " ++ stubFunc ++ " env (makeCPS env " ++ nextCont' ++ " " ++ nextFunc ++ " ) " ++
--                                 " (Nil \"\") (Just " ++ argsCode
              [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return ([HaskAST] -> IOThrowsError [HaskAST])
-> [HaskAST] -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ [String -> String -> [HaskAST] -> HaskAST
AstFunction String
thisFunc String
fargs ([HaskAST]
fnc [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST
c])] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
_comp [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
rest

      [LispVal]
_ -> LispError -> IOThrowsError [HaskAST]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError [HaskAST])
-> LispError -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ String -> LispVal -> LispError
TypeMismatch String
"nonempty list" (LispVal -> LispError) -> LispVal -> LispError
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
args

compileApply Env
_ LispVal
err CompOpts
_ = do
    LispError -> IOThrowsError [HaskAST]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError [HaskAST])
-> LispError -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ String -> LispError
Default (String -> LispError) -> String -> LispError
forall a b. (a -> b) -> a -> b
$ String
"compileApply - Unexpected argument: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LispVal -> String
forall a. Show a => a -> String
show LispVal
err

-- |Determines if the given lispval is a primitive function
isPrim :: Env -> LispVal -> IOThrowsError (Maybe LispVal)
isPrim :: Env -> LispVal -> IOThrowsError (Maybe LispVal)
isPrim Env
env (Atom String
func) = do
  LispVal
val <- Env -> String -> IOThrowsError LispVal
getVar Env
env String
func IOThrowsError LispVal
-> (LispVal -> IOThrowsError LispVal) -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LispVal -> IOThrowsError LispVal
recDerefPtrs
  case LispVal
val of
      p :: LispVal
p@(PrimitiveFunc [LispVal] -> ThrowsError LispVal
_) -> Maybe LispVal -> IOThrowsError (Maybe LispVal)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe LispVal -> IOThrowsError (Maybe LispVal))
-> Maybe LispVal -> IOThrowsError (Maybe LispVal)
forall a b. (a -> b) -> a -> b
$ LispVal -> Maybe LispVal
forall a. a -> Maybe a
Just LispVal
p
      LispVal
_ -> Maybe LispVal -> IOThrowsError (Maybe LispVal)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LispVal
forall a. Maybe a
Nothing
isPrim Env
_ p :: LispVal
p@(PrimitiveFunc [LispVal] -> ThrowsError LispVal
_) = Maybe LispVal -> IOThrowsError (Maybe LispVal)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe LispVal -> IOThrowsError (Maybe LispVal))
-> Maybe LispVal -> IOThrowsError (Maybe LispVal)
forall a b. (a -> b) -> a -> b
$ LispVal -> Maybe LispVal
forall a. a -> Maybe a
Just LispVal
p
isPrim Env
_ LispVal
_ = Maybe LispVal -> IOThrowsError (Maybe LispVal)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LispVal
forall a. Maybe a
Nothing

-- |Determine if the given list of expressions contains only literal identifiers
--  EG: 1, "2", etc. And return them if that is all that is found.
--
-- Atoms are a special case since they denote variables that will only be
-- available at runtime, so a flag is used to selectively include them.
--
_collectLiterals :: [LispVal] -> [LispVal] -> Bool -> (Maybe [LispVal])
_collectLiterals :: [LispVal] -> [LispVal] -> Bool -> Maybe [LispVal]
_collectLiterals (List [LispVal]
_ : [LispVal]
_) [LispVal]
_ Bool
_ = Maybe [LispVal]
forall a. Maybe a
Nothing
_collectLiterals (Atom String
_ : [LispVal]
_) [LispVal]
_ Bool
False = Maybe [LispVal]
forall a. Maybe a
Nothing
_collectLiterals (LispVal
a : [LispVal]
as) [LispVal]
nfs Bool
varFlag = [LispVal] -> [LispVal] -> Bool -> Maybe [LispVal]
_collectLiterals [LispVal]
as (LispVal
a LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
nfs) Bool
varFlag
_collectLiterals [] [LispVal]
nfs Bool
_ = [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]
reverse [LispVal]
nfs

-- Wrappers for the above function
collectLiterals, collectLiteralsAndVars :: [LispVal] -> (Maybe [LispVal])
collectLiteralsAndVars :: [LispVal] -> Maybe [LispVal]
collectLiteralsAndVars [LispVal]
args = [LispVal] -> [LispVal] -> Bool -> Maybe [LispVal]
_collectLiterals [LispVal]
args [] Bool
True
collectLiterals :: [LispVal] -> Maybe [LispVal]
collectLiterals [LispVal]
args = [LispVal] -> [LispVal] -> Bool -> Maybe [LispVal]
_collectLiterals [LispVal]
args [] Bool
False

-- Experimental:
-- -- Take as many literals as possible from the given list, and
-- -- return those literals and the rest of the list
-- takeLiterals :: LispVal -> [LispVal] -> ([LispVal], [LispVal])
-- takeLiterals (List _) ls = (ls, [])
-- takeLiterals _ ls' = do
--   loop ls' []
--  where
--   loop (l : ls) acc = do
--     if isLiteral l
--        then loop ls (l : acc)
--        else ((l:ls), Data.List.reverse acc)
--   loop [] acc = ([], Data.List.reverse acc)
-- 
--   isLiteral (List _) = False
--   isLiteral (Atom _) = False
--   isLiteral _ = True

-- Compile variable as a stand-alone line of code
compileInlineVar :: Env -> String -> String -> IOThrowsError HaskAST
compileInlineVar :: Env -> String -> String -> ExceptT LispError IO HaskAST
compileInlineVar Env
env String
a String
hsName = do
 Bool
isDefined <- 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
a
 case Bool
isDefined of
   Bool
True -> HaskAST -> ExceptT LispError IO HaskAST
forall (m :: * -> *) a. Monad m => a -> m a
return (HaskAST -> ExceptT LispError IO HaskAST)
-> HaskAST -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hsName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" <- getRTVar env \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
   Bool
False -> LispError -> ExceptT LispError IO HaskAST
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> ExceptT LispError IO HaskAST)
-> LispError -> ExceptT LispError IO HaskAST
forall a b. (a -> b) -> a -> b
$ String -> String -> LispError
UnboundVar String
"Variable is not defined" String
a

-- Helper function to determine if a value/ref was received
isSingleValue :: [HaskAST] -> Bool
isSingleValue :: [HaskAST] -> Bool
isSingleValue [(AstValue String
_)] = Bool
True
isSingleValue [(AstRef String
_)] = Bool
True
isSingleValue [HaskAST]
_ = Bool
False

wrapObject :: String
              -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
wrapObject :: String -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
wrapObject String
thisF Maybe String
nextF [HaskAST]
es = do
 case [HaskAST]
es of
  [val :: HaskAST
val@(AstValue String
_)] -> HaskAST -> CompOpts -> IOThrowsError [HaskAST]
compileScalar' HaskAST
val (CompOpts -> IOThrowsError [HaskAST])
-> CompOpts -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
thisF Bool
False Bool
False Maybe String
nextF
  [val :: HaskAST
val@(AstRef String
_)] -> HaskAST -> CompOpts -> IOThrowsError [HaskAST]
compileScalar' HaskAST
val (CompOpts -> IOThrowsError [HaskAST])
-> CompOpts -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
thisF Bool
False Bool
False Maybe String
nextF
  [HaskAST]
_ -> [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [HaskAST]
es