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

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

This module contains support for compiling libraries of scheme code.

-}

module Language.Scheme.Compiler.Libraries
    ( 
      importAll
    )
where 
import Language.Scheme.Compiler.Types
import qualified Language.Scheme.Core as LSC 
    (evalLisp, findFileOrLib, meval, nullEnvWithImport)
import Language.Scheme.Primitives
import Language.Scheme.Types
import Language.Scheme.Variables
import Control.Monad.Except

-- |Import all given modules and generate code for them
importAll 
    :: Env 
    -- ^ Compilation environment
    -> Env 
    -- ^ Compilation meta environment, containing code from modules.scm
    -> [LispVal]
    -- ^ Modules to import
    -> CompLibOpts
    -- ^ Misc options required by compiler library functions
    -> CompOpts
    -- ^ Misc options required by compiler functions
    -> IOThrowsError [HaskAST]
    -- ^ Compiled code
importAll :: Env
-> Env
-> [LispVal]
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
importAll Env
env Env
metaEnv [LispVal
m] CompLibOpts
lopts 
          copts :: CompOpts
copts@(CompileOptions {}) = do
    Env
-> Env
-> LispVal
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
_importAll Env
env Env
metaEnv LispVal
m CompLibOpts
lopts CompOpts
copts
importAll Env
env Env
metaEnv (LispVal
m : [LispVal]
ms) CompLibOpts
lopts
          (CompileOptions String
thisFunc Bool
_ Bool
_ Maybe String
lastFunc) = do
    Atom String
nextFunc <- String -> IOThrowsError LispVal
_gensym String
"importAll"
    [HaskAST]
c <- Env
-> Env
-> LispVal
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
_importAll Env
env Env
metaEnv LispVal
m CompLibOpts
lopts (CompOpts -> IOThrowsError [HaskAST])
-> CompOpts -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ 
                    String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
thisFunc Bool
False Bool
False (String -> Maybe String
forall a. a -> Maybe a
Just String
nextFunc)
    [HaskAST]
rest <- Env
-> Env
-> [LispVal]
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
importAll Env
env Env
metaEnv [LispVal]
ms CompLibOpts
lopts (CompOpts -> IOThrowsError [HaskAST])
-> CompOpts -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$
                      String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
nextFunc Bool
False Bool
False Maybe String
lastFunc
    [HaskAST]
stub <- case [HaskAST]
rest of 
        [] -> [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> Maybe String -> HaskAST
createFunctionStub String
nextFunc Maybe String
lastFunc]
        [HaskAST]
_ -> [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    [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]
rest [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
stub
importAll Env
_ Env
_ [] CompLibOpts
_ CompOpts
_ = [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return []

_importAll :: Env
           -> Env
           -> LispVal
           -> CompLibOpts
           -> CompOpts
           -> ExceptT LispError IO [HaskAST]
_importAll :: Env
-> Env
-> LispVal
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
_importAll Env
env Env
metaEnv LispVal
m CompLibOpts
lopts CompOpts
copts = do
    -- Resolve import
    LispVal
resolved <- Env -> LispVal -> IOThrowsError LispVal
LSC.evalLisp Env
metaEnv (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ 
         [LispVal] -> LispVal
List [String -> LispVal
Atom  String
"resolve-import", [LispVal] -> LispVal
List [String -> LispVal
Atom String
"quote", LispVal
m]]
    case LispVal
resolved of
        List (LispVal
moduleName : [LispVal]
imports) -> do
            Env
-> Env
-> LispVal
-> [LispVal]
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
importModule Env
env Env
metaEnv LispVal
moduleName [LispVal]
imports CompLibOpts
lopts CompOpts
copts
        DottedList [List [LispVal]
moduleName] imports :: LispVal
imports@(Bool Bool
False) -> do
            Env
-> Env
-> LispVal
-> [LispVal]
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
importModule Env
env Env
metaEnv ([LispVal] -> LispVal
List [LispVal]
moduleName) [LispVal
imports] CompLibOpts
lopts CompOpts
copts
        LispVal
err -> 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
"module/import" LispVal
err

-- |Import a single module
importModule :: Env
             -> Env
             -> LispVal
             -> [LispVal]
             -> CompLibOpts
             -> CompOpts
             -> ExceptT LispError IO [HaskAST]
importModule :: Env
-> Env
-> LispVal
-> [LispVal]
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
importModule Env
env Env
metaEnv LispVal
moduleName [LispVal]
imports CompLibOpts
lopts 
             (CompileOptions String
thisFunc Bool
_ Bool
_ Maybe String
lastFunc) = do
    Atom String
symImport <- String -> IOThrowsError LispVal
_gensym String
"importFnc"

    -- Load module
    [HaskAST]
code <- Env
-> LispVal -> CompLibOpts -> CompOpts -> IOThrowsError [HaskAST]
loadModule Env
metaEnv LispVal
moduleName CompLibOpts
lopts (CompOpts -> IOThrowsError [HaskAST])
-> CompOpts -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ 
              String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
thisFunc Bool
False Bool
False (String -> Maybe String
forall a. a -> Maybe a
Just String
symImport)
    
    -- Get module env, and import module env into env
    LispEnv Env
modEnv <- Env -> LispVal -> IOThrowsError LispVal
LSC.evalLisp Env
metaEnv (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ 
       [LispVal] -> LispVal
List [String -> LispVal
Atom String
"module-env", [LispVal] -> LispVal
List [String -> LispVal
Atom String
"find-module", [LispVal] -> LispVal
List [String -> LispVal
Atom String
"quote", LispVal
moduleName]]]
    LispVal
_ <- Env -> LispVal -> IOThrowsError LispVal
eval Env
env (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [String -> LispVal
Atom String
"%import", 
                          Env -> LispVal
LispEnv Env
env, 
                          Env -> LispVal
LispEnv Env
modEnv, 
                          [LispVal] -> LispVal
List [String -> LispVal
Atom String
"quote", [LispVal] -> LispVal
List [LispVal]
imports], 
                          Bool -> LispVal
Bool Bool
False]
    
    [HaskAST]
importFunc <- [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
$ [
        -- fromEnv is a LispEnv passed in as the /value/ parameter.
        -- But the source of /value/ is different depending on the
        -- context, so we call into this function to figure it out
        LispVal -> [HaskAST] -> HaskAST
forall a. LispVal -> [a] -> HaskAST
codeToGetFromEnv LispVal
moduleName [HaskAST]
code,
        String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  _ <- evalLisp env $ List [Atom \"%import\", LispEnv env, value, List [Atom \"quote\", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                  (LispVal -> String
ast2Str (LispVal -> String) -> LispVal -> String
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
imports) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"], Bool False]",
        CompOpts -> String -> String -> HaskAST
createAstCont (String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
symImport Bool
False Bool
False Maybe String
lastFunc) String
"(value)" String
""]
    
    -- thisFunc MUST be defined, so include a stub if there was nothing to import
    [HaskAST]
stub <- case [HaskAST]
code of
        [] -> [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> Maybe String -> HaskAST
createFunctionStub String
thisFunc (String -> Maybe String
forall a. a -> Maybe a
Just String
symImport)]
        [HaskAST]
_ -> [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return []

    [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
symImport Bool
True Bool
False Maybe String
lastFunc) 
                             [HaskAST]
importFunc] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
code [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
stub
 where 
  --
  -- The import's from env can come from many places; this function
  -- figures that out and creates a new /value/ if necessary to send
  -- the proper value to %import in the above code
  --
  codeToGetFromEnv :: LispVal -> [a] -> HaskAST
codeToGetFromEnv (List [Atom String
"scheme", Atom String
"r5rs"]) [a]
_ = do
     -- This is a hack to compile-in a full environment for the (scheme r5rs) import.
     --
     -- TODO: This really should be handled by the add-module! that is executed during
     --  module initialization, instead of having a special case here
     String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  r5 <- liftIO $ r5rsEnv\n  let value = LispEnv r5"
  codeToGetFromEnv (List [Atom String
"scheme"]) [a]
_ = do
     -- hack to compile-in full env for the (scheme) import by r7rs
     String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  r7 <- liftIO $ r7rsEnv\n  let value = LispEnv r7"
  codeToGetFromEnv (List [Atom String
"scheme", Atom String
"time", Atom String
"posix"]) [a]
_ = do
     String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  e <- liftIO $ r7rsTimeEnv\n  let value = LispEnv e"
  codeToGetFromEnv LispVal
name [] = do
     -- No code was generated because module was loaded previously, so retrieve
     -- it from runtime memory
     String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  value <- evalLisp env $ List [Atom \"hash-table-ref\", Atom \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                String
moduleRuntimeVar String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\", List [Atom \"quote\", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
               (LispVal -> String
ast2Str LispVal
name) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]]" 

  codeToGetFromEnv LispVal
_ [a]
_ = String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
""

-- | Load module into memory and generate compiled code
loadModule
    :: Env 
    -- ^ Compilation meta environment, containing code from modules.scm
    -> LispVal
    -- ^ Name of the module to load
    -> CompLibOpts
    -- ^ Misc options required by compiler library functions
    -> CompOpts
    -- ^ Misc options required by compiler functions
    -> IOThrowsError [HaskAST]
    -- ^ Compiled code, or an empty list if the module was already compiled
    --   and loaded into memory
loadModule :: Env
-> LispVal -> CompLibOpts -> CompOpts -> IOThrowsError [HaskAST]
loadModule Env
metaEnv LispVal
name CompLibOpts
lopts copts :: CompOpts
copts@(CompileOptions {}) = do
    -- Get the module definition, or load it from file if necessary
    LispVal
_mod' <- Env -> LispVal -> IOThrowsError LispVal
eval Env
metaEnv (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [String -> LispVal
Atom String
"find-module", [LispVal] -> LispVal
List [String -> LispVal
Atom String
"quote", LispVal
name]]
    case LispVal
_mod' of
        Bool Bool
False -> [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [] -- Even possible to reach this line?
        LispVal
_ -> do
             LispVal
_mod <- LispVal -> IOThrowsError LispVal
recDerefPtrs LispVal
_mod'
             LispVal
modEnv <- Env -> LispVal -> IOThrowsError LispVal
LSC.evalLisp Env
metaEnv (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [String -> LispVal
Atom String
"module-env", LispVal
_mod]
             case LispVal
modEnv of
                Bool Bool
False -> do
                {-------------------------------------------
                    Control flow for compiled code:

                     - create new env
                     - call into func directly to load it
                     - return new env and save to memory
                     - continue on to lastFunc
                --------------------------------------------}
                    Atom String
symStartLoadNewEnv <- String -> IOThrowsError LispVal
_gensym String
"startLoadingNewEnvFnc"
                    Atom String
symEndLoadNewEnv <- String -> IOThrowsError LispVal
_gensym String
"doneLoadingNewEnvFnc"

                    [HaskAST]
newEnvFunc <- [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
"  newEnv <- liftIO $ nullEnvWithImport",
                        String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  _ <- defineVar newEnv \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
moduleRuntimeVar String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                                       String
"\" $ Pointer \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
moduleRuntimeVar String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" env",
                        String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  _ <- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
symStartLoadNewEnv String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                                   String
" newEnv (makeNullContinuation newEnv) (LispEnv env) (Just [])",
                        -- Save loaded module into runtime memory in case
                        -- it gets included somewhere else later on
                        String -> HaskAST
AstValue (String -> HaskAST) -> String -> HaskAST
forall a b. (a -> b) -> a -> b
$ String
"  _ <- evalLisp env $ List [Atom \"hash-table-set!\", Atom \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                                   String
moduleRuntimeVar String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\", List [Atom \"quote\", " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                  (LispVal -> String
ast2Str LispVal
name) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"], LispEnv newEnv]",
                        CompOpts -> String -> String -> HaskAST
createAstCont CompOpts
copts String
"(LispEnv newEnv)" String
""]
                    
                    -- Create new env for module, per eval-module
                    Env
newEnv <- IO Env -> ExceptT LispError IO Env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Env -> ExceptT LispError IO Env)
-> IO Env -> ExceptT LispError IO Env
forall a b. (a -> b) -> a -> b
$ IO Env
LSC.nullEnvWithImport
                    -- compile the module code, again per eval-module
                    [HaskAST]
result <- Env
-> Env
-> LispVal
-> LispVal
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
compileModule Env
newEnv Env
metaEnv LispVal
name LispVal
_mod CompLibOpts
lopts (CompOpts -> IOThrowsError [HaskAST])
-> CompOpts -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$
                        String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
symStartLoadNewEnv Bool
False Bool
False (String -> Maybe String
forall a. a -> Maybe a
Just String
symEndLoadNewEnv)
                    LispVal
modWEnv <- Env -> LispVal -> IOThrowsError LispVal
eval Env
metaEnv (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List (String -> LispVal
Atom String
"module-env-set!" LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: LispVal
_mod' LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [Env -> LispVal
LispEnv Env
newEnv]) 
                    -- Above does not update *modules* correctly, so we del/add below
                    LispVal
_ <- Env -> LispVal -> IOThrowsError LispVal
eval Env
metaEnv (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [String -> LispVal
Atom String
"delete-module!", [LispVal] -> LispVal
List [String -> LispVal
Atom String
"quote", LispVal
name]]
                    LispVal
_ <- Env -> LispVal -> IOThrowsError LispVal
eval Env
metaEnv (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [String -> LispVal
Atom String
"add-module!", [LispVal] -> LispVal
List [String -> LispVal
Atom String
"quote", LispVal
name], LispVal
modWEnv]

                    [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]
newEnvFunc] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++
                     [CompOpts -> [HaskAST] -> HaskAST
createAstFunc (String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
symEndLoadNewEnv Bool
False Bool
False Maybe String
forall a. Maybe a
Nothing)
                                    [String -> HaskAST
AstValue String
"  return $ Nil \"\""]] [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++
                     [HaskAST]
result
                LispVal
_ -> [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [] --_mod

-- |Compile the given module, using metadata loaded into memory.
--  This code is based off of eval-module from the meta language.
compileModule :: Env
              -> Env
              -> LispVal
              -> LispVal
              -> CompLibOpts
              -> CompOpts
              -> ExceptT LispError IO [HaskAST]
compileModule :: Env
-> Env
-> LispVal
-> LispVal
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
compileModule Env
env Env
metaEnv LispVal
name LispVal
_mod CompLibOpts
lopts 
              (CompileOptions String
thisFunc Bool
_ Bool
_ Maybe String
lastFunc) = do
    -- TODO: set mod meta-data to avoid cyclic references
    -- see modules.scm for how this is done by the interpreter
    Atom String
afterImportsFnc <- String -> IOThrowsError LispVal
_gensym String
"modAfterImport"
    --Atom afterDirFunc <- _gensym "modAfterDir"

    LispVal
metaData <- Env -> LispVal -> IOThrowsError LispVal
LSC.evalLisp Env
metaEnv (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ 
                  [LispVal] -> LispVal
List [String -> LispVal
Atom String
"module-meta-data", [LispVal] -> LispVal
List [String -> LispVal
Atom String
"quote", LispVal
_mod]]

    [HaskAST]
moduleImports <- Env
-> Env
-> LispVal
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
cmpSubMod Env
env Env
metaEnv LispVal
metaData CompLibOpts
lopts (CompOpts -> IOThrowsError [HaskAST])
-> CompOpts -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ 
        String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
thisFunc Bool
False Bool
False (String -> Maybe String
forall a. a -> Maybe a
Just String
afterImportsFnc)
    [HaskAST]
moduleDirectives <- Env
-> Env
-> LispVal
-> LispVal
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
cmpModExpr Env
env Env
metaEnv LispVal
name LispVal
metaData CompLibOpts
lopts (CompOpts -> IOThrowsError [HaskAST])
-> CompOpts -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$
        [HaskAST] -> String -> CompOpts
forall a. [a] -> String -> CompOpts
moduleDirsCopts [HaskAST]
moduleImports String
afterImportsFnc

    [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]
moduleImports [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ 
             [HaskAST]
moduleDirectives [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ 
            ([HaskAST] -> [HaskAST] -> String -> [HaskAST]
forall a a. [a] -> [a] -> String -> [HaskAST]
moduleStub [HaskAST]
moduleImports [HaskAST]
moduleDirectives String
afterImportsFnc)
 where 
  moduleDirsCopts :: [a] -> String -> CompOpts
moduleDirsCopts [a]
modImps String
afterImportsFnc = do
-- if moduleImports is [] then use same copts for moduleDir
-- else, use copts (afterImportsFunc, lastFunc)
    case [a]
modImps of
        [] -> String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
thisFunc Bool
False Bool
False (String -> Maybe String
forall a. a -> Maybe a
Just String
afterImportsFnc)
        [a]
_ -> String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
afterImportsFnc Bool
False Bool
False Maybe String
lastFunc
  moduleStub :: [a] -> [a] -> String -> [HaskAST]
moduleStub [a]
modImps [a]
modDir String
afterImportsFnc = do
-- if moduleDir == [] and moduleimports == [] then add stub (this, last)
-- else if modDir == [] then addstub (afterimports, last)
-- else, no stub required
    case ([a]
modImps, [a]
modDir) of
        ([], []) -> [String -> Maybe String -> HaskAST
createFunctionStub String
thisFunc Maybe String
lastFunc]
        ([], [a]
_) -> [String -> Maybe String -> HaskAST
createFunctionStub String
afterImportsFnc Maybe String
lastFunc]
        ([a]
_, []) -> [String -> Maybe String -> HaskAST
createFunctionStub String
afterImportsFnc Maybe String
lastFunc]
        ([a], [a])
_ -> [] -- Both have code, no stub needed

-- Helper function to create an empty continuation
--
-- TODO: ideally stubs would not be necessary,
--       should refactor out at some point
createFunctionStub :: String -> Maybe String -> HaskAST
createFunctionStub :: String -> Maybe String -> HaskAST
createFunctionStub String
thisFunc Maybe String
nextFunc = do
    CompOpts -> [HaskAST] -> HaskAST
createAstFunc (String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
thisFunc Bool
True Bool
False Maybe String
forall a. Maybe a
Nothing)
                  [CompOpts -> String -> String -> HaskAST
createAstCont (String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
"" Bool
True Bool
False Maybe String
nextFunc) 
                                 String
"value" String
""]

-- |Compile sub-modules. That is, modules that are imported by
--  another module in the (define-library) definition
cmpSubMod :: Env
          -> Env
          -> LispVal
          -> CompLibOpts
          -> CompOpts
          -> ExceptT LispError IO [HaskAST]
cmpSubMod :: Env
-> Env
-> LispVal
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
cmpSubMod Env
env Env
metaEnv (List ((List (Atom String
"import-immutable" : [LispVal]
modules)) : [LispVal]
ls)) 
    CompLibOpts
lopts CompOpts
copts = do
    -- Punt on this for now, although the meta-lang does the same thing
    Env
-> Env
-> LispVal
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
cmpSubMod Env
env Env
metaEnv 
              ([LispVal] -> LispVal
List (([LispVal] -> LispVal
List (String -> LispVal
Atom String
"import" LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
modules)) LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
ls)) 
              CompLibOpts
lopts CompOpts
copts
cmpSubMod Env
env Env
metaEnv (List ((List (Atom String
"import" : [LispVal]
modules)) : [LispVal]
ls)) CompLibOpts
lopts
    (CompileOptions String
thisFunc Bool
_ Bool
_ Maybe String
lastFunc) = do
    Atom String
nextFunc <- String -> IOThrowsError LispVal
_gensym String
"cmpSubMod"
    [HaskAST]
code <- Env
-> Env
-> [LispVal]
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
importAll Env
env Env
metaEnv [LispVal]
modules CompLibOpts
lopts (CompOpts -> IOThrowsError [HaskAST])
-> CompOpts -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ 
              String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
thisFunc Bool
False Bool
False (String -> Maybe String
forall a. a -> Maybe a
Just String
nextFunc)
    [HaskAST]
rest <- Env
-> Env
-> LispVal
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
cmpSubMod Env
env Env
metaEnv ([LispVal] -> LispVal
List [LispVal]
ls) CompLibOpts
lopts (CompOpts -> IOThrowsError [HaskAST])
-> CompOpts -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ 
              String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
nextFunc Bool
False Bool
False Maybe String
lastFunc 
    [HaskAST]
stub <- case [HaskAST]
rest of 
        [] -> [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> Maybe String -> HaskAST
createFunctionStub String
nextFunc Maybe String
lastFunc]
        [HaskAST]
_ -> [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    [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]
code [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
rest [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
stub
cmpSubMod Env
env Env
metaEnv (List (LispVal
_ : [LispVal]
ls)) CompLibOpts
lopts CompOpts
copts = 
    Env
-> Env
-> LispVal
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
cmpSubMod Env
env Env
metaEnv ([LispVal] -> LispVal
List [LispVal]
ls) CompLibOpts
lopts CompOpts
copts
cmpSubMod Env
_ Env
_ LispVal
_ CompLibOpts
_ (CompileOptions String
thisFunc Bool
_ Bool
_ Maybe String
lastFunc) = 
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> Maybe String -> HaskAST
createFunctionStub String
thisFunc Maybe String
lastFunc]

-- |Compile module directives (expressions) in a module definition
cmpModExpr :: Env
           -> Env
           -> LispVal
           -> LispVal
           -> CompLibOpts
           -> CompOpts
           -> ExceptT LispError IO [HaskAST]
cmpModExpr :: Env
-> Env
-> LispVal
-> LispVal
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
cmpModExpr Env
env Env
metaEnv LispVal
name (List ((List (Atom String
"include" : [LispVal]
files)) : [LispVal]
ls)) 
    lopts :: CompLibOpts
lopts@(CompileLibraryOptions String
-> Maybe String
-> Env
-> [HaskAST]
-> [LispVal]
-> IOThrowsError [HaskAST]
_ Env -> String -> String -> Maybe String -> IOThrowsError [HaskAST]
compileLisp)
    (CompileOptions String
thisFunc Bool
_ Bool
_ Maybe String
lastFunc) = do
    LispVal
dir <- Env -> LispVal -> IOThrowsError LispVal
LSC.evalLisp Env
metaEnv (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [String -> LispVal
Atom String
"module-name-prefix", 
                                        [LispVal] -> LispVal
List [String -> LispVal
Atom String
"quote", LispVal
name]]
-- TODO: this pattern is common with the one below in @begin@,
--       should consolidate (or at least consider doing so)
    Atom String
nextFunc <- String -> IOThrowsError LispVal
_gensym String
"includeNext"
    [HaskAST]
code <- Env
-> LispVal
-> [LispVal]
-> (LispVal
    -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST])
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
forall t t1 t2 t3.
t
-> t3
-> [t2]
-> (t3 -> t2 -> String -> Maybe String -> IOThrowsError [HaskAST])
-> t1
-> CompOpts
-> IOThrowsError [HaskAST]
includeAll Env
env LispVal
dir [LispVal]
files LispVal
-> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileInc CompLibOpts
lopts (CompOpts -> IOThrowsError [HaskAST])
-> CompOpts -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ 
                       String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
thisFunc Bool
False Bool
False (String -> Maybe String
forall a. a -> Maybe a
Just String
nextFunc)
    [HaskAST]
rest <- Env
-> Env
-> LispVal
-> LispVal
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
cmpModExpr Env
env Env
metaEnv LispVal
name ([LispVal] -> LispVal
List [LispVal]
ls) CompLibOpts
lopts (CompOpts -> IOThrowsError [HaskAST])
-> CompOpts -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ 
                String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
nextFunc Bool
False Bool
False Maybe String
lastFunc
    [HaskAST]
stub <- case [HaskAST]
rest of 
        [] -> [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> Maybe String -> HaskAST
createFunctionStub String
nextFunc Maybe String
lastFunc]
        [HaskAST]
_ -> [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    [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]
code [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
rest [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
stub
 where 
  compileInc :: LispVal
-> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
compileInc (String String
dir) (String String
filename) String
entry Maybe String
exit = do
    let path :: String
path = String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
filename
    String
path' <- String -> ExceptT LispError IO String
LSC.findFileOrLib String
path
    Env -> String -> String -> Maybe String -> IOThrowsError [HaskAST]
compileLisp Env
env String
path' String
entry Maybe String
exit
  compileInc LispVal
_ LispVal
_ String
_ Maybe String
_ = 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
""

cmpModExpr Env
env Env
metaEnv LispVal
name (List ((List (Atom String
"include-ci" : [LispVal]
code)) : [LispVal]
ls)) CompLibOpts
lopts CompOpts
copts = do
    -- NOTE: per r7rs, ci should insert a fold-case directive. But husk does
    -- not support that, so just do a regular include for now
    Env
-> Env
-> LispVal
-> LispVal
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
cmpModExpr Env
env Env
metaEnv LispVal
name
       ([LispVal] -> LispVal
List (([LispVal] -> LispVal
List (String -> LispVal
Atom String
"include" LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
code)) LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
ls)) CompLibOpts
lopts CompOpts
copts
cmpModExpr Env
env Env
metaEnv LispVal
name (List ((List (Atom String
"body" : [LispVal]
code)) : [LispVal]
ls)) CompLibOpts
lopts CompOpts
copts = do
    Env
-> Env
-> LispVal
-> LispVal
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
cmpModExpr Env
env Env
metaEnv LispVal
name
       ([LispVal] -> LispVal
List (([LispVal] -> LispVal
List (String -> LispVal
Atom String
"begin" LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
code)) LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
ls)) CompLibOpts
lopts CompOpts
copts

cmpModExpr Env
env Env
metaEnv LispVal
name
       (List ((List (Atom String
"begin" : [LispVal]
code')) : [LispVal]
ls)) 
        lopts :: CompLibOpts
lopts@(CompileLibraryOptions String
-> Maybe String
-> Env
-> [HaskAST]
-> [LispVal]
-> IOThrowsError [HaskAST]
compileBlock Env -> String -> String -> Maybe String -> IOThrowsError [HaskAST]
_)
        (CompileOptions String
thisFunc Bool
_ Bool
_ Maybe String
lastFunc) = do
    Atom String
nextFunc <- String -> IOThrowsError LispVal
_gensym String
"cmpSubModNext"
    [HaskAST]
code <- String
-> Maybe String
-> Env
-> [HaskAST]
-> [LispVal]
-> IOThrowsError [HaskAST]
compileBlock String
thisFunc (String -> Maybe String
forall a. a -> Maybe a
Just String
nextFunc) Env
env [] [LispVal]
code'
    [HaskAST]
rest <- Env
-> Env
-> LispVal
-> LispVal
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
cmpModExpr Env
env Env
metaEnv LispVal
name ([LispVal] -> LispVal
List [LispVal]
ls) CompLibOpts
lopts (CompOpts -> IOThrowsError [HaskAST])
-> CompOpts -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$ 
                String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
nextFunc Bool
False Bool
False Maybe String
lastFunc
    [HaskAST]
stub <- case [HaskAST]
rest of 
        [] -> [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> Maybe String -> HaskAST
createFunctionStub String
nextFunc Maybe String
lastFunc]
        [HaskAST]
_ -> [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    [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]
code [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
rest [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
stub
cmpModExpr Env
env Env
metaEnv LispVal
name (List (LispVal
_ : [LispVal]
ls)) CompLibOpts
lopts CompOpts
copts = 
    Env
-> Env
-> LispVal
-> LispVal
-> CompLibOpts
-> CompOpts
-> IOThrowsError [HaskAST]
cmpModExpr Env
env Env
metaEnv LispVal
name ([LispVal] -> LispVal
List [LispVal]
ls) CompLibOpts
lopts CompOpts
copts
cmpModExpr Env
_ Env
_ LispVal
_ LispVal
_ CompLibOpts
_ (CompileOptions String
thisFunc Bool
_ Bool
_ Maybe String
lastFunc) =
    [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> Maybe String -> HaskAST
createFunctionStub String
thisFunc Maybe String
lastFunc]

-- |Include one or more files for compilation
-- TODO: this pattern is used elsewhere (IE, importAll). could be generalized
includeAll :: forall t t1 t2 t3.
              t
              -> t3
              -> [t2]
              -> (t3
                  -> t2 -> String -> Maybe String -> ExceptT LispError IO [HaskAST])
              -> t1
              -> CompOpts
              -> ExceptT LispError IO [HaskAST]
includeAll :: t
-> t3
-> [t2]
-> (t3 -> t2 -> String -> Maybe String -> IOThrowsError [HaskAST])
-> t1
-> CompOpts
-> IOThrowsError [HaskAST]
includeAll t
_ t3
dir [t2
file] t3 -> t2 -> String -> Maybe String -> IOThrowsError [HaskAST]
include t1
_ --lopts
          (CompileOptions String
thisFunc Bool
_ Bool
_ Maybe String
lastFunc) = do
    t3 -> t2 -> String -> Maybe String -> IOThrowsError [HaskAST]
include t3
dir t2
file String
thisFunc Maybe String
lastFunc
includeAll t
env t3
dir (t2
f : [t2]
fs) t3 -> t2 -> String -> Maybe String -> IOThrowsError [HaskAST]
include t1
lopts
           (CompileOptions String
thisFunc Bool
_ Bool
_ Maybe String
lastFunc) = do
    Atom String
nextFunc <- String -> IOThrowsError LispVal
_gensym String
"includeAll"
    [HaskAST]
c <- t3 -> t2 -> String -> Maybe String -> IOThrowsError [HaskAST]
include t3
dir t2
f String
thisFunc (String -> Maybe String
forall a. a -> Maybe a
Just String
nextFunc)
    [HaskAST]
rest <- t
-> t3
-> [t2]
-> (t3 -> t2 -> String -> Maybe String -> IOThrowsError [HaskAST])
-> t1
-> CompOpts
-> IOThrowsError [HaskAST]
forall t t1 t2 t3.
t
-> t3
-> [t2]
-> (t3 -> t2 -> String -> Maybe String -> IOThrowsError [HaskAST])
-> t1
-> CompOpts
-> IOThrowsError [HaskAST]
includeAll t
env t3
dir [t2]
fs t3 -> t2 -> String -> Maybe String -> IOThrowsError [HaskAST]
include t1
lopts (CompOpts -> IOThrowsError [HaskAST])
-> CompOpts -> IOThrowsError [HaskAST]
forall a b. (a -> b) -> a -> b
$
                       String -> Bool -> Bool -> Maybe String -> CompOpts
CompileOptions String
nextFunc Bool
False Bool
False Maybe String
lastFunc
    [HaskAST]
stub <- case [HaskAST]
rest of 
        [] -> [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> Maybe String -> HaskAST
createFunctionStub String
nextFunc Maybe String
lastFunc]
        [HaskAST]
_ -> [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    [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]
rest [HaskAST] -> [HaskAST] -> [HaskAST]
forall a. [a] -> [a] -> [a]
++ [HaskAST]
stub
includeAll t
_ t3
_ [] t3 -> t2 -> String -> Maybe String -> IOThrowsError [HaskAST]
_ t1
_ CompOpts
_ = [HaskAST] -> IOThrowsError [HaskAST]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- |Like evalLisp, but preserve pointers in the output
eval :: Env -> LispVal -> IOThrowsError LispVal
eval :: Env -> LispVal -> IOThrowsError LispVal
eval Env
env LispVal
lisp = do
  Env -> LispVal -> LispVal -> IOThrowsError LispVal
LSC.meval Env
env (Env -> LispVal
makeNullContinuation Env
env) LispVal
lisp