carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-09-11 05:25:28 +03:00
Code Issues Projects Releases Wiki Activity

interim

Browse Source
This commit is contained in:
hellerve 2020-03-28 14:32:41 +01:00
parent b6f045f992
commit 6185099044
11 changed files with 930 additions and 1019 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
app/Main.hs
View File

@ -69,6 +69,7 @@ main = do setLocaleEncoding utf8
projectWithCustomPrompt = setCustomPromptFromOptions projectWithCarpDir otherOptions
startingContext = Context
(startingGlobalEnv noArray)
Nothing
(TypeEnv startingTypeEnv)
[]
projectWithCustomPrompt

2
core/Core.carp
View File

@ -23,8 +23,8 @@
(load "Interfaces.carp")
(load "Bool.carp")
(load "Generics.carp")
(load "Macros.carp")
(load "Generics.carp")
(load "Maybe.carp")
(load "Result.carp")
(load "Dynamic.carp")

10
core/Macros.carp
View File

@ -114,8 +114,8 @@
acc
(collect-into-internal (cdr xs) (append acc (f (car xs))) f)))
(doc collect-into
"Transforms a dynamic data literal into another, preserving order")
; (doc collect-into
; "Transforms a dynamic data literal into another, preserving order")
(defndynamic collect-into [xs f]
(list 'quote
(collect-into-internal xs (f) f)))
@ -296,10 +296,10 @@
(case-internal name forms))
(defmacro and [x y]
(list 'if x y false))
(list 'quote (list 'if x y false)))
(defmacro or [x y]
(list 'if x true y))
(list 'quote (list 'if x true y)))
(defndynamic build-vararg [func forms]
(if (= (length forms) 0)
@ -360,7 +360,9 @@ The expression must be evaluable at compile time.")
(doc gensym-with "generates symbols dynamically, based on a symbol name.")
(defndynamic gensym-with [x]
(do
(macro-log *gensym-counter*)
(set! *gensym-counter* (inc *gensym-counter*))
(macro-log *gensym-counter*)
(Symbol.join [x (Symbol.from *gensym-counter*)])))
(doc gensym "generates symbols dynamically as needed.")

691
src/Commands.hs
View File

File diff suppressed because it is too large Load Diff

638
src/Eval.hs
View File

@ -33,77 +33,88 @@ import Concretize
import Path
import Primitives
import Debug.Trace
-- | Dynamic (REPL) evaluation of XObj:s (s-expressions)
eval :: Env -> XObj -> StateT Context IO (Either EvalError XObj)
eval env xobj@(XObj o i t) = do
ctx <- get
eval :: Context -> XObj -> IO (Context, Either EvalError XObj)
eval ctx xobj@(XObj o i t) =
case o of
Lst body -> eval' body
Sym path@(SymPath p n) _ -> do
let fppl = projectFilePathPrintLength (contextProj ctx)
case lookupInEnv (SymPath ("Dynamic" : p) n) env of
Just (_, Binder _ found) -> return (Right (resolveDef found))
Sym path@(SymPath p n) _ ->
case lookupInEnv (SymPath ("Dynamic" : p) n) (contextGlobalEnv ctx) of
Just (_, Binder _ found) -> return (ctx, Right (resolveDef found))
Nothing ->
case lookupInEnv path env of
Just (_, Binder _ found) -> return (Right (resolveDef found))
Nothing ->
return (evalError ctx ("Can't find symbol '" ++ show path ++ "'") i)
if null p
then
case tryInternalLookup path of
Just v -> return v
Nothing -> tryLookup path
else tryLookup path
where tryInternalLookup path =
case contextInternalEnv ctx of
Nothing -> Nothing
Just e ->
case lookupInEnv path e of
Just (_ , Binder _ found) -> Just (ctx, Right (resolveDef found))
Nothing -> Nothing
tryLookup path =
case lookupInEnv path (contextGlobalEnv ctx) of
Just (_, Binder _ found) -> return (ctx, Right (resolveDef found))
Nothing ->
return (evalError ctx ("Can't find symbol '" ++ show path ++ "'") i)
Arr objs -> do
evaled <- fmap sequence (mapM (eval env) objs)
return $ do ok <- evaled
Right (XObj (Arr ok) i t)
_ -> return (Right xobj)
(newCtx, evaled) <- foldlM successiveEval (ctx, Right []) objs
return (newCtx, do ok <- evaled
Right (XObj (Arr ok) i t))
_ -> return (ctx, Right xobj)
where
resolveDef (XObj (Lst [XObj DefDynamic _ _, _, value]) _ _) = value
resolveDef x = x
eval' form = do
ctx <- get
eval' form =
case form of
[XObj (Sym (SymPath ["Dynamic"] "and") _) _ _, a, b] -> do
evaledA <- eval env a
evaledB <- eval env b
return $ do okA <- evaledA
case okA of
XObj (Bol ab) _ _ ->
if ab
then do okB <- evaledB
case okB of
XObj (Bol bb) _ _ ->
if bb then Right trueXObj else Right falseXObj
_ ->
evalError ctx ("Can’t perform call `and` on " ++ pretty okB) (info okB)
else Right falseXObj
_ ->
evalError ctx ("Can’t call `and` on " ++ pretty okA) (info okA)
(newCtx, evaledA) <- eval ctx a
case evaledA of
Left e -> return (ctx, Left e)
Right (XObj (Bol ab) _ _) ->
if ab
then do
(newCtx', evaledB) <- eval newCtx b
case evaledB of
Left e -> return (newCtx, Left e)
Right (XObj (Bol bb) _ _) ->
return (newCtx', if bb then Right trueXObj else Right falseXObj)
Right b -> return (evalError ctx ("Can’t call `or` on " ++ pretty b) (info b))
else return (newCtx, Right falseXObj)
Right a -> return (evalError ctx ("Can’t call `or` on " ++ pretty a) (info a))
[XObj (Sym (SymPath ["Dynamic"] "or") _) _ _, a, b] -> do
evaledA <- eval env a
evaledB <- eval env b
return $ do okA <- evaledA
case okA of
XObj (Bol ab) _ _ ->
if ab
then Right trueXObj
else do okB <- evaledB
case okB of
XObj (Bol bb) _ _ ->
if bb then Right trueXObj else Right falseXObj
_ ->
evalError ctx ("Can’t call `or` on " ++ pretty okB) (info okB)
_ ->
evalError ctx ("Can’t call `or` on " ++ pretty okA) (info okA)
(newCtx, evaledA) <- eval ctx a
case evaledA of
Left e -> return (ctx, Left e)
Right (XObj (Bol ab) _ _) ->
if ab
then return (newCtx, Right trueXObj)
else do
(newCtx', evaledB) <- eval newCtx b
case evaledB of
Left e -> return (newCtx, Left e)
Right (XObj (Bol bb) _ _) ->
return (newCtx', if bb then Right trueXObj else Right falseXObj)
Right b -> return (evalError ctx ("Can’t call `or` on " ++ pretty b) (info b))
Right a -> return (evalError ctx ("Can’t call `or` on " ++ pretty a) (info a))
[XObj If _ _, mcond, mtrue, mfalse] -> do
evd <- eval env mcond
(newCtx, evd) <- eval ctx mcond
case evd of
Right cond ->
case obj cond of
Bol b -> eval env (if b then mtrue else mfalse)
Bol b -> eval newCtx (if b then mtrue else mfalse)
_ ->
return (evalError ctx
("This `if` condition contains the non-boolean value `" ++
pretty cond ++ "`") (info cond))
Left e -> return (Left e)
Left e -> return (newCtx, Left e)
XObj If _ _:_ ->
return (evalError ctx
@ -114,7 +125,7 @@ eval env xobj@(XObj o i t) = do
case obj name of
(Sym (SymPath [] _) _) ->
if all isUnqualifiedSym a
then specialCommandDefine xobj
then specialCommandDefine ctx xobj
else return (evalError ctx
("`defn` requires all arguments to be unqualified symbols, but it got `" ++
pretty args ++ "`") (info xobj))
@ -136,15 +147,15 @@ eval env xobj@(XObj o i t) = do
[def@(XObj Def _ _), name, expr] ->
if isUnqualifiedSym name
then specialCommandDefine xobj
then specialCommandDefine ctx xobj
else return (evalError ctx
("`def` identifiers must be unqualified symbols, but it got `" ++
pretty name ++ "`") (info xobj))
[the@(XObj The _ _), ty, value] ->
do evaledValue <- expandAll eval env value -- TODO: Why expand all here?
return $ do okValue <- evaledValue
Right (XObj (Lst [the, ty, okValue]) i t)
do (newCtx, evaledValue) <- expandAll eval ctx value -- TODO: Why expand all here?
return (newCtx, do okValue <- evaledValue
Right (XObj (Lst [the, ty, okValue]) i t))
(XObj The _ _: _) ->
return (evalError ctx
@ -161,140 +172,111 @@ eval env xobj@(XObj o i t) = do
("`let` identifiers must be symbols, but it got `" ++
joinWithSpace (map pretty bindings) ++ "`") (info xobj))
| otherwise ->
do let innerEnv = Env Map.empty (Just env) (Just "LET") [] InternalEnv 0
pathStrings = contextPath ctx
mod = XObj (Mod innerEnv) (info xobj) (Just ModuleTy)
globalEnvWithModuleAdded = envInsertAt (contextGlobalEnv ctx) (SymPath pathStrings "LET") (Binder emptyMeta mod)
ctx' = ctx {
contextGlobalEnv=globalEnvWithModuleAdded,
contextPath=pathStrings ++ ["LET"]}
put ctx'
let binds = unwrapVar (pairwise bindings) []
eitherEnv <- foldrM successiveEval (Right innerEnv) binds
case eitherEnv of
Left err -> return $ Left err
Right envWithBindings -> do
evaledBody <- eval envWithBindings body
put (popModulePath ctx')
return $ do okBody <- evaledBody
Right okBody
do let binds = unwrapVar (pairwise bindings) []
eitherCtx <- foldrM successiveEval (Right ctx) binds
case eitherCtx of
Left err -> return (ctx, Left err)
Right newCtx -> do
(_, evaledBody) <- eval newCtx body
return (ctx, do okBody <- evaledBody
Right okBody)
where unwrapVar [] acc = acc
unwrapVar ((XObj (Sym (SymPath [] x) _) _ _,y):xs) acc = unwrapVar xs ((x,y):acc)
successiveEval (n, x) =
\case
err@(Left _) -> return err
Right e ->
eval e x >>= \case
Right okX -> return $ Right $ extendEnv e n okX
Right ctx -> do
(newCtx, res) <- eval ctx x
case res of
Right okX -> do
let name = SymPath (contextPath newCtx) n
binder = Binder emptyMeta okX
return $ Right (newCtx {contextGlobalEnv=envInsertAt (contextGlobalEnv ctx) name binder})
Left err -> return $ Left err
l@[XObj Fn{} _ _, args@(XObj (Arr a) _ _), f] ->
if all isUnqualifiedSym a
then return (Right (XObj (Closure (XObj (Lst l) i t) (CEnv env)) i t))
then return (ctx, Right (XObj (Closure (XObj (Lst l) i t) (CCtx ctx)) i t))
else return (evalError ctx ("`fn` requires all arguments to be unqualified symbols, but it got `" ++ pretty args ++ "`") (info args))
XObj (Closure (XObj (Lst [XObj (Fn _ _) _ _, XObj (Arr params) _ _, body]) _ _) (CEnv e)) i _:args ->
XObj (Closure (XObj (Lst [XObj (Fn _ _) _ _, XObj (Arr params) _ _, body]) _ _) (CCtx c)) i _:args ->
case checkArity params args of
Left err ->
return (evalError ctx err (info xobj))
Left err -> return (evalError ctx err (info xobj))
Right () ->
do evaledArgs <- fmap sequence (mapM (eval env) args)
do (newCtx, evaledArgs) <- foldlM successiveEval (ctx, Right []) args
case evaledArgs of
Right okArgs -> apply e body params okArgs
Left err -> return (Left err)
Right okArgs -> do
(_, res) <- apply c body params okArgs
return (newCtx, res)
Left err -> return (newCtx, Left err)
XObj (Lst [XObj Dynamic _ _, _, XObj (Arr params) _ _, body]) i _:args ->
case checkArity params args of
Left err ->
return (evalError ctx err i)
Right () ->
do evaledArgs <- fmap sequence (mapM (eval env) args)
do (newCtx, evaledArgs) <- foldlM successiveEval (ctx, Right []) args
case evaledArgs of
Right okArgs -> apply env body params okArgs
Left err -> return (Left err)
Right okArgs -> do
(newCtx', res) <- apply (pushFrame newCtx xobj) body params okArgs
case res of
Right xobj -> return (popFrame newCtx', res)
Left err -> return (newCtx', res)
Left err -> return (newCtx, Left err)
XObj (Lst [XObj Macro _ _, _, XObj (Arr params) _ _, body]) i _:args -> do
put (pushFrame ctx xobj)
XObj (Lst [XObj Macro _ _, _, XObj (Arr params) _ _, body]) i _:args ->
case checkArity params args of
Left err -> do
put ctx
return (evalError ctx err i)
Left err -> return (evalError ctx err i)
Right () -> do
-- Replace info so that the macro which is called gets the source location info of the expansion site.
--let replacedBody = replaceSourceInfoOnXObj (info xobj) body
res <- apply env body params args
(ctx', res) <- apply (pushFrame ctx xobj) body params args
case res of
Right xobj -> do
_ <- eval env xobj
newCtx <- get
put (popFrame newCtx)
return res
Left err -> do
put ctx
return (Left err)
(newCtx, res) <- eval ctx' xobj
return (popFrame newCtx, res)
Left err -> return (ctx, res)
XObj (Lst [XObj (Command callback) _ _, _]) _ _:args ->
do evaledArgs <- fmap sequence (mapM (eval env) args)
do (newCtx, evaledArgs) <- foldlM successiveEval (ctx, Right []) args
case evaledArgs of
Right okArgs -> getCommand callback okArgs
Left err -> return (Left err)
Right okArgs -> getCommand callback ctx okArgs
Left err -> return (ctx, Left err)
XObj (Lst (XObj (Defn _) _ _:_)) _ _:_ -> return (Right xobj)
XObj (Lst (XObj (Defn _) _ _:_)) _ _:_ -> return (ctx, Right xobj)
l@(XObj (Lst _) i t):args -> do
put (pushFrame ctx xobj)
f <- eval env l
(newCtx, f) <- eval ctx l
case f of
Right fun -> do
res <- eval env (XObj (Lst (fun:args)) i t)
newCtx <- get
put (popFrame newCtx)
return res
x -> do
put ctx
return x
(newCtx', res) <- eval (pushFrame newCtx xobj) (XObj (Lst (fun:args)) i t)
return (popFrame newCtx', res)
x -> return (newCtx, x)
x@(XObj sym@(Sym s _) i _):args -> do
put (pushFrame ctx xobj)
x@(XObj sym@(Sym s _) i _):args ->
case Map.lookup s primitives of
Just prim -> do
res <- prim x env args
newCtx <- get
put (popFrame newCtx)
return res
(newCtx, res) <- prim x (pushFrame ctx xobj) args
return (popFrame newCtx, res)
Nothing -> do
f <- eval env x
(newCtx, f) <- eval ctx x
case f of
Right fun -> do
res <- eval env (XObj (Lst (fun:args)) i t)
newCtx <- get
put (popFrame newCtx)
return res
Left err -> do
put ctx
return (Left err)
(newCtx', res) <- eval ctx (XObj (Lst (fun:args)) i t)
return (popFrame newCtx', res)
Left err -> return (newCtx, Left err)
XObj With _ _ : xobj@(XObj (Sym path _) _ _) : forms ->
specialCommandWith xobj path forms
specialCommandWith ctx xobj path forms
XObj With _ _ : _ ->
return (evalError ctx ("Invalid arguments to `with`: " ++ pretty xobj) (info xobj))
XObj SetBang _ _ :args -> specialCommandSet args
XObj SetBang _ _ :args -> specialCommandSet ctx args
[XObj Do _ _] ->
return (evalError ctx "No forms in do" (info xobj))
XObj Do _ _ : rest -> do
(evaled, _) <- foldlM successiveEval (dynamicNil, env) rest
case evaled of
Left e -> return (Left e)
Right evald -> return (Right evald)
where successiveEval (acc, e) x =
case acc of
err@(Left _) -> return (err, e)
Right _ -> do
res <- eval e x
ctx <- get
let pathStrings = contextPath ctx
globalEnv = contextGlobalEnv ctx
env = getEnv globalEnv pathStrings
return (res, env)
[] -> return dynamicNil
XObj Do _ _ : rest -> foldlM successiveEval (ctx, dynamicNil) rest
where successiveEval (ctx, acc) x =
case acc of
err@(Left _) -> return (ctx, err)
Right _ -> eval ctx x
[] -> return (ctx, dynamicNil)
x -> do
return (evalError ctx ("I did not understand the form `" ++ pretty xobj ++ "`") (info xobj))
checkArity params args =
@ -313,20 +295,28 @@ eval env xobj@(XObj o i t) = do
show la ++ ".\n\nThe arguments " ++
intercalate ", " (map pretty (drop lp args)) ++
" are not needed.")
successiveEval (ctx, acc) x =
case acc of
err@(Left _) -> return (ctx, err)
Right l -> do
(newCtx, evald) <- eval ctx x
case evald of
Right res -> return (newCtx, Right (l ++ [res]))
Left err -> return (newCtx, Left err)
apply :: Env -> XObj -> [XObj] -> [XObj] -> StateT Context IO (Either EvalError XObj)
apply env body params args =
let allParams = map getName params
apply :: Context -> XObj -> [XObj] -> [XObj] -> IO (Context, Either EvalError XObj)
apply ctx body params args =
let env = contextEnv ctx
allParams = map getName params
in case splitWhen (":rest" ==) allParams of
[a, b] -> callWith a b
[a] -> callWith a []
_ -> do
ctx <- get
[a, b] -> callWith env a b
[a] -> callWith env a []
_ ->
return (evalError ctx
("I didn’t understand this macro’s argument split, got `" ++
joinWith "," allParams ++
"`, but expected exactly one `:rest` separator.") Nothing)
where callWith proper rest =
where callWith env proper rest = do
let n = length proper
insideEnv = Env Map.empty (Just env) Nothing [] InternalEnv 0
insideEnv' = foldl' (\e (p, x) -> extendEnv e p x) insideEnv
@ -336,9 +326,8 @@ apply env body params args =
else extendEnv insideEnv'
(head rest)
(XObj (Lst (drop n args)) Nothing Nothing)
in eval insideEnv'' body
-- LEGACY STUFF
(nctx, res) <- eval (ctx {contextInternalEnv=Just insideEnv''}) body
return (nctx {contextInternalEnv=Nothing}, res)
-- | Parses a string and then converts the resulting forms to commands, which are evaluated in order.
executeString :: Bool -> Bool -> Context -> String -> String -> IO Context
@ -383,17 +372,17 @@ executeCommand ctx s@(XObj (Sym _ _) _ _) =
executeCommand ctx
(XObj (Lst [ (XObj (Sym (SymPath [] "info") Symbol) (Just dummyInfo) Nothing)
, s]) (Just dummyInfo) Nothing)
executeCommand ctx@(Context env typeEnv pathStrings proj lastInput execMode _) xobj =
executeCommand ctx@(Context env _ typeEnv pathStrings proj lastInput execMode _) xobj =
do when (isJust (envModuleName env)) $
error ("Global env module name is " ++ fromJust (envModuleName env) ++ " (should be Nothing).")
(result, newCtx) <- runStateT (eval env xobj) ctx
(newCtx, result) <- eval ctx xobj
case result of
Left e -> do
reportExecutionError newCtx (show e)
return (xobj, newCtx)
-- special case: calling a function at the repl
Right (XObj (Lst (XObj (Lst (XObj (Defn _) _ _:name:_)) _ _:args)) i _) -> do
(r, nc) <- runStateT (annotateWithinContext False (XObj (Lst (name:args)) i Nothing)) newCtx
(nc, r) <- annotateWithinContext False newCtx (XObj (Lst (name:args)) i Nothing)
case r of
Right (ann, _) -> executeCommand nc (withBuildAndRun (buildMainFunction ann))
Left err -> do
@ -437,33 +426,29 @@ catcher ctx exception =
BuildAndRun -> exitWith (ExitFailure returnCode)
Check -> exitSuccess
specialCommandWith :: XObj -> SymPath -> [XObj] -> StateT Context IO (Either EvalError XObj)
specialCommandWith xobj path forms =
do ctx <- get
let pathStrings = contextPath ctx
env = contextGlobalEnv ctx
typeEnv = contextTypeEnv ctx
useThese = envUseModules env
env' = if path `elem` useThese then env else env { envUseModules = path : useThese }
ctx' = ctx { contextGlobalEnv = env' }
ctxAfter <- liftIO $ foldM folder ctx' forms
let envAfter = contextGlobalEnv ctxAfter
ctxAfter' = ctx { contextGlobalEnv = envAfter { envUseModules = useThese } } -- This will undo ALL use:s made inside the 'with'.
put ctxAfter'
return dynamicNil
specialCommandWith :: Context -> XObj -> SymPath -> [XObj] -> IO (Context, Either EvalError XObj)
specialCommandWith ctx xobj path forms = do
let pathStrings = contextPath ctx
env = contextEnv ctx
typeEnv = contextTypeEnv ctx
useThese = envUseModules env
env' = if path `elem` useThese then env else env { envUseModules = path : useThese }
ctx' = ctx { contextGlobalEnv = env' }
ctxAfter <- liftIO $ foldM folder ctx' forms
let envAfter = contextEnv ctxAfter
ctxAfter' = ctx { contextGlobalEnv = envAfter { envUseModules = useThese } } -- This will undo ALL use:s made inside the 'with'.
return (ctxAfter', dynamicNil)
specialCommandDefine :: XObj -> StateT Context IO (Either EvalError XObj)
specialCommandDefine xobj =
do result <- annotateWithinContext True xobj
specialCommandDefine :: Context -> XObj -> IO (Context, Either EvalError XObj)
specialCommandDefine ctx xobj =
do (newCtx, result) <- annotateWithinContext True ctx xobj
case result of
Right (annXObj, annDeps) ->
do ctxAfterExpansion <- get
ctxWithDeps <- liftIO $ foldM (define True) ctxAfterExpansion annDeps
do ctxWithDeps <- liftIO $ foldM (define True) newCtx annDeps
ctxWithDef <- liftIO $ define False ctxWithDeps annXObj
put ctxWithDef
return dynamicNil
return (ctxWithDef, dynamicNil)
Left err ->
return (Left err)
return (ctx, Left err)
getSigFromDefnOrDef :: Context -> Env -> FilePathPrintLength -> XObj -> StateT Context IO (Either EvalError (Maybe (Ty, XObj)))
getSigFromDefnOrDef ctx globalEnv fppl xobj =
@ -478,17 +463,15 @@ getSigFromDefnOrDef ctx globalEnv fppl xobj =
Nothing -> return (evalError ctx ("Can't use '" ++ pretty foundSignature ++ "' as a type signature") (info xobj))
Nothing -> return (Right Nothing)
annotateWithinContext :: Bool -> XObj -> StateT Context IO (Either EvalError (XObj, [XObj]))
annotateWithinContext qualifyDefn xobj =
do ctx <- get
annotateWithinContext :: Bool -> Context -> XObj -> IO (Context, Either EvalError (XObj, [XObj]))
annotateWithinContext qualifyDefn ctx xobj = do
let pathStrings = contextPath ctx
fppl = projectFilePathPrintLength (contextProj ctx)
globalEnv = contextGlobalEnv ctx
typeEnv = contextTypeEnv ctx
innerEnv = getEnv globalEnv pathStrings
sig <- getSigFromDefnOrDef ctx globalEnv fppl xobj
expansionResult <- expandAll eval globalEnv xobj
ctxAfterExpansion <- get
(ctxAfterExpansion, expansionResult) <- expandAll eval ctx xobj
case expansionResult of
Left err -> return (evalError ctx (show err) Nothing)
Right expanded ->
@ -503,93 +486,90 @@ annotateWithinContext qualifyDefn xobj =
_ ->
return (evalError ctx (show err) (info xobj))
Right ok ->
return (Right ok)
return (ctx, Right ok)
primitiveDefmodule :: Primitive
primitiveDefmodule xobj env (XObj (Sym (SymPath [] moduleName) _) _ _:innerExpressions) = do
ctx@(Context _ typeEnv pathStrings proj lastInput execMode history) <- get
primitiveDefmodule xobj ctx@(Context env i typeEnv pathStrings proj lastInput execMode history) (XObj (Sym (SymPath [] moduleName) _) _ _:innerExpressions) = do
let fppl = projectFilePathPrintLength proj
defineIt :: MetaData -> StateT Context IO (Either EvalError XObj)
defineIt meta = do let parentEnv = getEnv env pathStrings
innerEnv = Env (Map.fromList []) (Just parentEnv) (Just moduleName) [] ExternalEnv 0
newModule = XObj (Mod innerEnv) (info xobj) (Just ModuleTy)
globalEnvWithModuleAdded = envInsertAt env (SymPath pathStrings moduleName) (Binder meta newModule)
ctx' = Context globalEnvWithModuleAdded typeEnv (pathStrings ++ [moduleName]) proj lastInput execMode history
ctxAfterModuleDef <- liftIO $ foldM folder ctx' innerExpressions
put (popModulePath ctxAfterModuleDef)
return dynamicNil
defineIt :: MetaData -> IO (Context, Either EvalError XObj)
defineIt meta = do
let parentEnv = getEnv env pathStrings
innerEnv = Env (Map.fromList []) (Just parentEnv) (Just moduleName) [] ExternalEnv 0
newModule = XObj (Mod innerEnv) (info xobj) (Just ModuleTy)
globalEnvWithModuleAdded = envInsertAt env (SymPath pathStrings moduleName) (Binder meta newModule)
ctx' = Context globalEnvWithModuleAdded i typeEnv (pathStrings ++ [moduleName]) proj lastInput execMode history
ctxAfterModuleDef <- liftIO $ foldM folder ctx' innerExpressions
return (popModulePath ctxAfterModuleDef, dynamicNil)
result <- case lookupInEnv (SymPath pathStrings moduleName) env of
Just (_, Binder _ (XObj (Mod _) _ _)) ->
do let ctx' = Context env typeEnv (pathStrings ++ [moduleName]) proj lastInput execMode history -- use { = } syntax instead
ctxAfterModuleAdditions <- liftIO $ foldM folder ctx' innerExpressions
put (popModulePath ctxAfterModuleAdditions)
return dynamicNil -- TODO: propagate errors...
Just (_, Binder existingMeta (XObj (Lst [XObj DocStub _ _, _]) _ _)) ->
defineIt existingMeta
Just (_, Binder _ x) ->
return (evalError ctx ("Can't redefine '" ++ moduleName ++ "' as module") (info xobj))
Nothing ->
defineIt emptyMeta
(newCtx, result) <-
case lookupInEnv (SymPath pathStrings moduleName) env of
Just (_, Binder _ (XObj (Mod _) _ _)) -> do
let ctx' = Context env i typeEnv (pathStrings ++ [moduleName]) proj lastInput execMode history -- TODO: use { = } syntax instead
ctxAfterModuleAdditions <- liftIO $ foldM folder ctx' innerExpressions
return (popModulePath ctxAfterModuleAdditions, dynamicNil) -- TODO: propagate errors...
Just (_, Binder existingMeta (XObj (Lst [XObj DocStub _ _, _]) _ _)) ->
defineIt existingMeta
Just (_, Binder _ x) ->
return (evalError ctx ("Can't redefine '" ++ moduleName ++ "' as module") (info xobj))
Nothing ->
defineIt emptyMeta
case result of
Left err -> return (Left err)
Right _ -> return dynamicNil
Left err -> return (newCtx, Left err)
Right _ -> return (newCtx, dynamicNil)
-- | "NORMAL" COMMANDS (just like the ones in Command.hs, but these need access to 'eval', etc.)
-- | Command for loading a Carp file.
commandLoad :: CommandCallback
commandLoad [xobj@(XObj (Str path) i _)] =
do ctx <- get
let proj = contextProj ctx
libDir <- liftIO $ cachePath $ projectLibDir proj
let relativeTo = case i of
Just ii ->
case infoFile ii of
"REPL" -> "."
file -> takeDirectory file
Nothing -> "."
carpDir = projectCarpDir proj
fullSearchPaths =
path :
(relativeTo </> path) : -- the path from the file that contains the '(load)', or the current directory if not loading from a file (e.g. the repl)
map (</> path) (projectCarpSearchPaths proj) ++ -- user defined search paths
[carpDir </> "core" </> path] ++
[libDir </> path]
firstM _ [] = return Nothing
firstM p (x:xs) = do
q <- p x
if q
then return $ Just x
else firstM p xs
existingPath <- liftIO $ firstM doesFileExist fullSearchPaths
case existingPath of
Nothing ->
if '@' `elem` path
then tryInstall path
else return $ invalidPath ctx path
Just firstPathFound ->
do canonicalPath <- liftIO (canonicalizePath firstPathFound)
fileThatLoads <- liftIO (canonicalizePath (case i of
Just ii -> infoFile ii
Nothing -> ""))
if canonicalPath == fileThatLoads
then return $ cantLoadSelf ctx path
else do let alreadyLoaded = projectAlreadyLoaded proj
if canonicalPath `elem` alreadyLoaded
then
return ()
else do contents <- liftIO $ slurp canonicalPath
let files = projectFiles proj
files' = if canonicalPath `elem` files
then files
else files ++ [canonicalPath]
proj' = proj { projectFiles = files', projectAlreadyLoaded = canonicalPath : alreadyLoaded }
newCtx <- liftIO $ executeString True False (ctx { contextProj = proj' }) contents canonicalPath
put newCtx
return dynamicNil
commandLoad ctx [xobj@(XObj (Str path) i _)] = do
let proj = contextProj ctx
libDir <- liftIO $ cachePath $ projectLibDir proj
let relativeTo = case i of
Just ii ->
case infoFile ii of
"REPL" -> "."
file -> takeDirectory file
Nothing -> "."
carpDir = projectCarpDir proj
fullSearchPaths =
path :
(relativeTo </> path) : -- the path from the file that contains the '(load)', or the current directory if not loading from a file (e.g. the repl)
map (</> path) (projectCarpSearchPaths proj) ++ -- user defined search paths
[carpDir </> "core" </> path] ++
[libDir </> path]
firstM _ [] = return Nothing
firstM p (x:xs) = do
q <- p x
if q
then return $ Just x
else firstM p xs
existingPath <- liftIO $ firstM doesFileExist fullSearchPaths
case existingPath of
Nothing ->
if '@' `elem` path
then tryInstall path
else return $ invalidPath ctx path
Just firstPathFound ->
do canonicalPath <- liftIO (canonicalizePath firstPathFound)
fileThatLoads <- liftIO (canonicalizePath (case i of
Just ii -> infoFile ii
Nothing -> ""))
if canonicalPath == fileThatLoads
then return $ cantLoadSelf ctx path
else do let alreadyLoaded = projectAlreadyLoaded proj
if canonicalPath `elem` alreadyLoaded
then return (ctx, dynamicNil)
else do
contents <- liftIO $ slurp canonicalPath
let files = projectFiles proj
files' = if canonicalPath `elem` files
then files
else files ++ [canonicalPath]
proj' = proj { projectFiles = files', projectAlreadyLoaded = canonicalPath : alreadyLoaded }
newCtx <- liftIO $ executeString True False (ctx { contextProj = proj' }) contents canonicalPath
return (newCtx, dynamicNil)
where
fppl ctx =
projectFilePathPrintLength (contextProj ctx)
@ -630,7 +610,6 @@ commandLoad [xobj@(XObj (Str path) i _)] =
then joinWith "/" (joinWith "@" (tail (splitOn "@" fst)) : tail split)
else url
tryInstallWithCheckout path toCheckout = do
ctx <- get
let proj = contextProj ctx
fpath <- liftIO $ cachePath $ projectLibDir proj </> fromURL path </> toCheckout
cur <- liftIO getCurrentDirectory
@ -668,12 +647,11 @@ commandLoad [xobj@(XObj (Str path) i _)] =
fileToLoad = fpath </> realName
mainToLoad = fpath </> "main.carp"
in do
res <- commandLoad [XObj (Str fileToLoad) Nothing Nothing]
(newCtx, res) <- commandLoad ctx [XObj (Str fileToLoad) Nothing Nothing]
case res of
ret@(Right _) -> return ret
Left _ -> commandLoad [XObj (Str mainToLoad) Nothing Nothing]
commandLoad [x] = do
ctx <- get
ret@(Right _) -> return (newCtx, ret)
Left _ -> commandLoad ctx [XObj (Str mainToLoad) Nothing Nothing]
commandLoad ctx [x] =
return $ evalError ctx ("Invalid args to `load`: " ++ pretty x) (info x)
-- | Load several files in order.
@ -681,7 +659,7 @@ loadFiles :: Context -> [FilePath] -> IO Context
loadFiles ctxStart filesToLoad = foldM folder ctxStart filesToLoad
where folder :: Context -> FilePath -> IO Context
folder ctx file = do
(ret, newCtx) <- runStateT (commandLoad [XObj (Str file) Nothing Nothing]) ctx
(newCtx, ret) <- commandLoad ctx [XObj (Str file) Nothing Nothing]
let fppl = projectFilePathPrintLength (contextProj newCtx)
case ret of
Left err -> throw (EvalException err)
@ -689,53 +667,49 @@ loadFiles ctxStart filesToLoad = foldM folder ctxStart filesToLoad
-- | Command for reloading all files in the project (= the files that has been loaded before).
commandReload :: CommandCallback
commandReload args =
do ctx <- get
let paths = projectFiles (contextProj ctx)
f :: Context -> FilePath -> IO Context
f context filepath = do let proj = contextProj context
alreadyLoaded = projectAlreadyLoaded proj
if filepath `elem` alreadyLoaded
then
return context
else do
contents <- slurp filepath
let proj' = proj { projectAlreadyLoaded = filepath : alreadyLoaded }
executeString False False (context { contextProj = proj' }) contents filepath
newCtx <- liftIO (foldM f ctx paths)
put newCtx
return dynamicNil
commandReload ctx args = do
let paths = projectFiles (contextProj ctx)
f :: Context -> FilePath -> IO Context
f context filepath = do let proj = contextProj context
alreadyLoaded = projectAlreadyLoaded proj
if filepath `elem` alreadyLoaded
then
return context
else do
contents <- slurp filepath
let proj' = proj { projectAlreadyLoaded = filepath : alreadyLoaded }
executeString False False (context { contextProj = proj' }) contents filepath
newCtx <- liftIO (foldM f ctx paths)
return (newCtx, dynamicNil)
-- | Command for expanding a form and its macros.
commandExpand :: CommandCallback
commandExpand [xobj] =
do ctx <- get
result <- expandAll eval (contextGlobalEnv ctx) xobj
case result of
Left e -> return (Left e)
Right expanded ->
liftIO $ do putStrLnWithColor Yellow (pretty expanded)
return dynamicNil
commandExpand ctx [xobj] = do
(newCtx, result) <- expandAll eval ctx xobj
case result of
Left e -> return (newCtx, Left e)
Right expanded ->
liftIO $ do putStrLnWithColor Yellow (pretty expanded)
return (newCtx, dynamicNil)
-- | This function will show the resulting C code from an expression.
-- | i.e. (Int.+ 2 3) => "_0 = 2 + 3"
commandC :: CommandCallback
commandC [xobj] =
do ctx <- get
let globalEnv = contextGlobalEnv ctx
typeEnv = contextTypeEnv ctx
result <- expandAll eval globalEnv xobj
case result of
Left err -> return $ Left err
Right expanded ->
case annotate typeEnv globalEnv (setFullyQualifiedSymbols typeEnv globalEnv globalEnv expanded) Nothing of
Left err -> return $ evalError ctx (show err) (info xobj)
Right (annXObj, annDeps) ->
do let cXObj = printC annXObj
cDeps = concatMap printC annDeps
c = cDeps ++ cXObj
liftIO (putStr c)
return dynamicNil
commandC ctx [xobj] = do
let globalEnv = contextGlobalEnv ctx
typeEnv = contextTypeEnv ctx
(newCtx, result) <- expandAll eval ctx xobj
case result of
Left err -> return (newCtx, Left err)
Right expanded ->
case annotate typeEnv globalEnv (setFullyQualifiedSymbols typeEnv globalEnv globalEnv expanded) of
Left err -> return $ evalError newCtx (show err) (info xobj)
Right (annXObj, annDeps) ->
do let cXObj = printC annXObj
cDeps = concatMap printC annDeps
c = cDeps ++ cXObj
liftIO (putStr c)
return (newCtx, dynamicNil)
-- | Helper function for commandC
printC :: XObj -> String
@ -762,46 +736,40 @@ buildMainFunction xobj =
]) (Just dummyInfo) (Just (FuncTy [] UnitTy StaticLifetimeTy))
primitiveDefdynamic :: Primitive
primitiveDefdynamic _ _ [XObj (Sym (SymPath [] name) _) _ _, value] =
do env <- gets contextGlobalEnv
result <- eval env value
case result of
Left err -> return (Left err)
Right evaledBody ->
dynamicOrMacroWith (\path -> [XObj DefDynamic Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing, evaledBody]) DynamicTy name value
primitiveDefdynamic _ _ [notName, body] = do
ctx <- get
primitiveDefdynamic _ ctx [XObj (Sym (SymPath [] name) _) _ _, value] = do
(newCtx, result) <- eval ctx value
case result of
Left err -> return (newCtx, Left err)
Right evaledBody ->
dynamicOrMacroWith newCtx (\path -> [XObj DefDynamic Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing, evaledBody]) DynamicTy name value
primitiveDefdynamic _ ctx [notName, body] =
return (evalError ctx ("`defndynamic` expected a name as first argument, but got " ++ pretty notName) (info notName))
specialCommandSet :: [XObj] -> StateT Context IO (Either EvalError XObj)
specialCommandSet [XObj (Sym (SymPath [] name) _) _ _, value] =
do env <- gets contextGlobalEnv
result <- eval env value
case result of
Left err -> return (Left err)
Right evald -> do
ctx <- get
let nenv = extendEnv env name evald
put (ctx {contextGlobalEnv = seq nenv nenv})
return dynamicNil
specialCommandSet [notName, body] = do
ctx <- get
specialCommandSet :: Context -> [XObj] -> IO (Context, Either EvalError XObj)
specialCommandSet ctx [x@(XObj (Sym path _) _ _), value] = do
(newCtx, result) <- eval ctx value
case result of
Left err -> return (newCtx, Left (trace (show err) err))
Right evald -> do
let globalEnv = contextGlobalEnv ctx
nenv = newCtx { contextGlobalEnv=envInsertAt globalEnv path (Binder emptyMeta (trace (show evald) evald)) }
return (nenv, dynamicNil)
specialCommandSet ctx [notName, body] =
return (evalError ctx ("`set!` expected a name as first argument, but got " ++ pretty notName) (info notName))
specialCommandSet args = do
ctx <- get
specialCommandSet ctx args =
return (evalError ctx ("`set!` takes a name and a value, but got `" ++ intercalate " " (map pretty args)) (if null args then Nothing else info (head args)))
primitiveEval :: Primitive
primitiveEval _ env [val] = do
primitiveEval _ ctx [val] = do
-- primitives don’t evaluate their arguments, so this needs to double-evaluate
arg <- eval env val
(newCtx, arg) <- eval ctx val
case arg of
Left err -> return (Left err)
Right ok -> eval env ok
Left err -> return (newCtx, Left err)
Right ok -> eval newCtx ok
primitives :: Map.Map SymPath Primitive
primitives = Map.fromList
[ makePrim "quote" 1 "(quote x) ; where x is an actual symbol" (\_ _ [x] -> return (Right x))
[ makePrim "quote" 1 "(quote x) ; where x is an actual symbol" (\_ ctx [x] -> return (ctx, Right x))
, makeVarPrim "file" "(file mysymbol)" primitiveFile
, makeVarPrim "line" "(line mysymbol)" primitiveLine
, makeVarPrim "column" "(column mysymbol)" primitiveColumn

223
src/Expand.hs
View File

@ -1,7 +1,7 @@
module Expand (expandAll, replaceSourceInfoOnXObj) where
import Control.Monad.State.Lazy (StateT(..), runStateT, liftIO, modify, get, put)
import Control.Monad.State
import Control.Monad.State (evalState, get, put, State)
import Data.Foldable (foldlM)
import Debug.Trace
import Types
@ -11,116 +11,125 @@ import Lookup
import TypeError
-- | Used for calling back to the 'eval' function in Eval.hs
type DynamicEvaluator = Env -> XObj -> StateT Context IO (Either EvalError XObj)
type DynamicEvaluator = Context -> XObj -> IO (Context, Either EvalError XObj)
-- | Keep expanding the form until it doesn't change anymore.
-- | Note: comparing environments is tricky! Make sure they *can* be equal, otherwise this won't work at all!
expandAll :: DynamicEvaluator -> Env -> XObj -> StateT Context IO (Either EvalError XObj)
expandAll eval env root =
do fullyExpanded <- expandAllInternal root
return (fmap setNewIdentifiers fullyExpanded)
expandAll :: DynamicEvaluator -> Context -> XObj -> IO (Context, Either EvalError XObj)
expandAll eval ctx root =
do (ctx, fullyExpanded) <- expandAllInternal root
return (ctx, fmap setNewIdentifiers fullyExpanded)
where expandAllInternal xobj =
do expansionResult <- expand eval env xobj
do (newCtx, expansionResult) <- expand eval ctx xobj
case expansionResult of
Right expanded -> if expanded == xobj
then return (Right expanded)
else expandAll eval env expanded
err -> return err
then return (ctx, Right expanded)
else expandAll eval newCtx expanded
err -> return (newCtx, err)
-- | Macro expansion of a single form
expand :: DynamicEvaluator -> Env -> XObj -> StateT Context IO (Either EvalError XObj)
expand eval env xobj =
expand :: DynamicEvaluator -> Context -> XObj -> IO (Context, Either EvalError XObj)
expand eval ctx xobj =
case obj xobj of
--case obj (trace ("Expand: " ++ pretty xobj) xobj) of
Lst _ -> expandList xobj
Arr _ -> expandArray xobj
Sym _ _ -> expandSymbol xobj
_ -> return (Right xobj)
Sym _ _ -> return (ctx, expandSymbol xobj)
_ -> return (ctx, Right xobj)
where
expandList :: XObj -> StateT Context IO (Either EvalError XObj)
expandList :: XObj -> IO (Context, Either EvalError XObj)
expandList (XObj (Lst xobjs) i t) = do
ctx <- get
let fppl = projectFilePathPrintLength (contextProj ctx)
case xobjs of
[] -> return (Right xobj)
XObj (External _) _ _ : _ -> return (Right xobj)
XObj (Instantiate _) _ _ : _ -> return (Right xobj)
XObj (Deftemplate _) _ _ : _ -> return (Right xobj)
XObj (Defalias _) _ _ : _ -> return (Right xobj)
[] -> return (ctx, Right xobj)
XObj (External _) _ _ : _ -> return (ctx, Right xobj)
XObj (Instantiate _) _ _ : _ -> return (ctx, Right xobj)
XObj (Deftemplate _) _ _ : _ -> return (ctx, Right xobj)
XObj (Defalias _) _ _ : _ -> return (ctx, Right xobj)
[defnExpr@(XObj (Defn _) _ _), name, args, body] ->
do expandedBody <- expand eval env body
return $ do okBody <- expandedBody
Right (XObj (Lst [defnExpr, name, args, okBody]) i t)
do (ctx, expandedBody) <- expand eval ctx body
return (ctx, do okBody <- expandedBody
Right (XObj (Lst [defnExpr, name, args, okBody]) i t))
[defExpr@(XObj Def _ _), name, expr] ->
do expandedExpr <- expand eval env expr
return $ do okExpr <- expandedExpr
Right (XObj (Lst [defExpr, name, okExpr]) i t)
do (ctx, expandedExpr) <- expand eval ctx expr
return (ctx, do okExpr <- expandedExpr
Right (XObj (Lst [defExpr, name, okExpr]) i t))
[theExpr@(XObj The _ _), typeXObj, value] ->
do expandedValue <- expand eval env value
return $ do okValue <- expandedValue
Right (XObj (Lst [theExpr, typeXObj, okValue]) i t)
do (ctx, expandedValue) <- expand eval ctx value
return (ctx, do okValue <- expandedValue
Right (XObj (Lst [theExpr, typeXObj, okValue]) i t))
(XObj The _ _ : _) ->
return (evalError ctx ("I didn’t understand the `the` at " ++ prettyInfoFromXObj xobj ++ ":\n\n" ++ pretty xobj ++ "\n\nIs it valid? Every `the` needs to follow the form `(the type expression)`.") Nothing)
[ifExpr@(XObj If _ _), condition, trueBranch, falseBranch] ->
do expandedCondition <- expand eval env condition
expandedTrueBranch <- expand eval env trueBranch
expandedFalseBranch <- expand eval env falseBranch
return $ do okCondition <- expandedCondition
okTrueBranch <- expandedTrueBranch
okFalseBranch <- expandedFalseBranch
-- This is a HACK so that each branch of the if statement
-- has a "safe place" (= a do-expression with just one element)
-- where it can store info about its deleters. Without this,
-- An if statement with let-expression inside will duplicate
-- the calls to Delete when emitting code.
let wrappedTrue =
case okTrueBranch of
XObj (Lst (XObj Do _ _ : _)) _ _ -> okTrueBranch -- Has a do-expression already
_ -> XObj (Lst [XObj Do Nothing Nothing, okTrueBranch]) (info okTrueBranch) Nothing
wrappedFalse =
case okFalseBranch of
XObj (Lst (XObj Do _ _ : _)) _ _ -> okFalseBranch -- Has a do-expression already
_ -> XObj (Lst [XObj Do Nothing Nothing, okFalseBranch]) (info okFalseBranch) Nothing
do (ctx, expandedCondition) <- expand eval ctx condition
(ctx, expandedTrueBranch) <- expand eval ctx trueBranch
(ctx, expandedFalseBranch) <- expand eval ctx falseBranch
return (ctx, do okCondition <- expandedCondition
okTrueBranch <- expandedTrueBranch
okFalseBranch <- expandedFalseBranch
-- This is a HACK so that each branch of the if statement
-- has a "safe place" (= a do-expression with just one element)
-- where it can store info about its deleters. Without this,
-- An if statement with let-expression inside will duplicate
-- the calls to Delete when emitting code.
let wrappedTrue =
case okTrueBranch of
XObj (Lst (XObj Do _ _ : _)) _ _ -> okTrueBranch -- Has a do-expression already
_ -> XObj (Lst [XObj Do Nothing Nothing, okTrueBranch]) (info okTrueBranch) Nothing
wrappedFalse =
case okFalseBranch of
XObj (Lst (XObj Do _ _ : _)) _ _ -> okFalseBranch -- Has a do-expression already
_ -> XObj (Lst [XObj Do Nothing Nothing, okFalseBranch]) (info okFalseBranch) Nothing
Right (XObj (Lst [ifExpr, okCondition, wrappedTrue, wrappedFalse]) i t)
Right (XObj (Lst [ifExpr, okCondition, wrappedTrue, wrappedFalse]) i t))
[letExpr@(XObj Let _ _), XObj (Arr bindings) bindi bindt, body] ->
if even (length bindings)
then do bind <- mapM (\(n, x) -> do x' <- expand eval env x
return $ do okX <- x'
Right [n, okX])
(pairwise bindings)
expandedBody <- expand eval env body
return $ do okBindings <- sequence bind
okBody <- expandedBody
Right (XObj (Lst [letExpr, XObj (Arr (concat okBindings)) bindi bindt, okBody]) i t)
then do (ctx, bind) <- foldlM successiveExpand (ctx, Right []) (pairwise bindings)
(newCtx, expandedBody) <- expand eval ctx body
return (newCtx, do okBindings <- bind
okBody <- expandedBody
Right (XObj (Lst [letExpr, XObj (Arr (concat okBindings)) bindi bindt, okBody]) i t))
else return (evalError ctx (
"I ecountered an odd number of forms inside a `let` (`" ++
pretty xobj ++ "`)") (info xobj))
where successiveExpand (ctx, acc) (n, x) =
case acc of
Left err -> return (ctx, acc)
Right l -> do
(newCtx, x') <- expand eval ctx x
case x' of
Left err -> return (newCtx, Left err)
Right okX -> return (newCtx, Right (l ++ [[n, okX]]))
matchExpr@(XObj Match _ _) : (expr : rest)
| null rest ->
return (evalError ctx "I encountered a `match` without forms" (info xobj))
| even (length rest) ->
do expandedExpr <- expand eval env expr
expandedPairs <- mapM (\(l,r) -> do expandedR <- expand eval env r
return [Right l, expandedR])
(pairwise rest)
let expandedRest = sequence (concat expandedPairs)
return $ do okExpandedExpr <- expandedExpr
okExpandedRest <- expandedRest
return (XObj (Lst (matchExpr : okExpandedExpr : okExpandedRest)) i t)
do (ctx, expandedExpr) <- expand eval ctx expr
(newCtx, expandedPairs) <- foldlM successiveExpand (ctx, Right []) (pairwise rest)
return (newCtx, do okExpandedExpr <- expandedExpr
okExpandedPairs <- expandedPairs
Right (XObj (Lst (matchExpr : okExpandedExpr : (concat okExpandedPairs))) i t))
| otherwise -> return (evalError ctx
"I encountered an odd number of forms inside a `match`" (info xobj))
where successiveExpand (ctx, acc) (l, r) =
case acc of
Left err -> return (ctx, acc)
Right lst -> do
(newCtx, expandedR) <- expand eval ctx r
case expandedR of
Left err -> return (newCtx, Left err)
Right v -> return (newCtx, Right (lst ++ [[l, v]]))
doExpr@(XObj Do _ _) : expressions ->
do expandedExpressions <- mapM (expand eval env) expressions
return $ do okExpressions <- sequence expandedExpressions
Right (XObj (Lst (doExpr : okExpressions)) i t)
do (newCtx, expandedExpressions) <- foldlM successiveExpand (ctx, Right []) expressions
return (newCtx, do okExpressions <- expandedExpressions
Right (XObj (Lst (doExpr : okExpressions)) i t))
[withExpr@(XObj With _ _), pathExpr@(XObj (Sym path _) _ _), expression] ->
do expandedExpression <- expand eval env expression
return $ do okExpression <- expandedExpression
Right (XObj (Lst [withExpr, pathExpr , okExpression]) i t) -- Replace the with-expression with just the expression!
do (newCtx, expandedExpression) <- expand eval ctx expression
return (newCtx, do okExpression <- expandedExpression
Right (XObj (Lst [withExpr, pathExpr , okExpression]) i t)) -- Replace the with-expression with just the expression!
[withExpr@(XObj With _ _), _, _] ->
return (evalError ctx ("I encountered the value `" ++ pretty xobj ++
"` inside a `with` at " ++ prettyInfoFromXObj xobj ++
@ -132,44 +141,52 @@ expand eval env xobj =
".\n\n`with` accepts only one expression, except at the top level.") Nothing)
XObj Mod{} _ _ : _ ->
return (evalError ctx ("I can’t evaluate the module `" ++ pretty xobj ++ "`") (info xobj))
f:args -> do expandedF <- expand eval env f
expandedArgs <- fmap sequence (mapM (expand eval env) args)
case expandedF of
Right (XObj (Lst [XObj Dynamic _ _, _, XObj (Arr _) _ _, _]) _ _) ->
--trace ("Found dynamic: " ++ pretty xobj)
eval env xobj
Right (XObj (Lst [XObj Macro _ _, _, XObj (Arr _) _ _, _]) _ _) ->
--trace ("Found macro: " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj)
eval env xobj
Right (XObj (Lst [XObj (Command callback) _ _, _]) _ _) ->
getCommand callback args
Right _ ->
return $ do okF <- expandedF
okArgs <- expandedArgs
Right (XObj (Lst (okF : okArgs)) i t)
Left err -> return (Left err)
f:args ->
do (ctx', expandedF) <- expand eval ctx f
(ctx'', expandedArgs) <- foldlM successiveExpand (ctx, Right []) args
case expandedF of
Right (XObj (Lst [XObj Dynamic _ _, _, XObj (Arr _) _ _, _]) _ _) ->
--trace ("Found dynamic: " ++ pretty xobj)
eval ctx'' xobj
Right (XObj (Lst [XObj Macro _ _, _, XObj (Arr _) _ _, _]) _ _) ->
--trace ("Found macro: " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj)
eval ctx'' xobj
Right (XObj (Lst [XObj (Command callback) _ _, _]) _ _) ->
getCommand callback ctx args
Right _ ->
return (ctx'', do okF <- expandedF
okArgs <- expandedArgs
Right (XObj (Lst (okF : okArgs)) i t))
Left err -> return (ctx'', Left err)
expandList _ = error "Can't expand non-list in expandList."
expandArray :: XObj -> StateT Context IO (Either EvalError XObj)
expandArray :: XObj -> IO (Context, Either EvalError XObj)
expandArray (XObj (Arr xobjs) i t) =
do evaledXObjs <- fmap sequence (mapM (expand eval env) xobjs)
return $ do okXObjs <- evaledXObjs
Right (XObj (Arr okXObjs) i t)
do (newCtx, evaledXObjs) <- foldlM successiveExpand (ctx, Right []) xobjs
return (newCtx, do okXObjs <- evaledXObjs
Right (XObj (Arr okXObjs) i t))
expandArray _ = error "Can't expand non-array in expandArray."
expandSymbol :: XObj -> StateT Context IO (Either a XObj)
expandSymbol :: XObj -> Either a XObj
expandSymbol (XObj (Sym path _) _ _) =
case lookupInEnv path env of
Just (_, Binder _ (XObj (Lst (XObj (External _) _ _ : _)) _ _)) -> return (Right xobj)
Just (_, Binder _ (XObj (Lst (XObj (Instantiate _) _ _ : _)) _ _)) -> return (Right xobj)
Just (_, Binder _ (XObj (Lst (XObj (Deftemplate _) _ _ : _)) _ _)) -> return (Right xobj)
Just (_, Binder _ (XObj (Lst (XObj (Defn _) _ _ : _)) _ _)) -> return (Right xobj)
Just (_, Binder _ (XObj (Lst (XObj Def _ _ : _)) _ _)) -> return (Right xobj)
Just (_, Binder _ (XObj (Lst (XObj (Defalias _) _ _ : _)) _ _)) -> return (Right xobj)
Just (_, Binder _ found) -> return (Right found) -- use the found value
Nothing -> return (Right xobj) -- symbols that are not found are left as-is
case lookupInEnv path (contextEnv ctx) of
Just (_, Binder _ (XObj (Lst (XObj (External _) _ _ : _)) _ _)) -> Right xobj
Just (_, Binder _ (XObj (Lst (XObj (Instantiate _) _ _ : _)) _ _)) -> Right xobj
Just (_, Binder _ (XObj (Lst (XObj (Deftemplate _) _ _ : _)) _ _)) -> Right xobj
Just (_, Binder _ (XObj (Lst (XObj (Defn _) _ _ : _)) _ _)) -> Right xobj
Just (_, Binder _ (XObj (Lst (XObj Def _ _ : _)) _ _)) -> Right xobj
Just (_, Binder _ (XObj (Lst (XObj (Defalias _) _ _ : _)) _ _)) -> Right xobj
Just (_, Binder _ found) -> Right found -- use the found value
Nothing -> Right xobj -- symbols that are not found are left as-is
expandSymbol _ = error "Can't expand non-symbol in expandSymbol."
successiveExpand (ctx, acc) e =
case acc of
Left err -> return (ctx, acc)
Right lst -> do
(newCtx, expanded) <- expand eval ctx e
return (newCtx, Right (lst ++ [e]))
-- | Replace all the infoIdentifier:s on all nested XObj:s
setNewIdentifiers :: XObj -> XObj
setNewIdentifiers root = let final = evalState (visit root) 0

6
src/Lookup.hs
View File

@ -131,8 +131,6 @@ extendEnv env name xobj = envAddBinding env name (Binder emptyMeta xobj)
envInsertAt :: Env -> SymPath -> Binder -> Env
envInsertAt env (SymPath [] name) binder =
envAddBinding env name binder
envInsertAt env (SymPath ("LET":ps) name) xobj =
envInsertAt env (SymPath ps name) xobj
envInsertAt env (SymPath (p:ps) name) xobj =
case Map.lookup p (envBindings env) of
Just (Binder existingMeta (XObj (Mod innerEnv) i t)) ->
@ -168,6 +166,10 @@ getEnv env (p:ps) = case Map.lookup p (envBindings env) of
Just _ -> error "Can't get non-env."
Nothing -> error "Can't get env."
contextEnv :: Context -> Env
contextEnv Context{contextInternalEnv=Just e} = e
contextEnv Context{contextGlobalEnv=e, contextPath=p} = getEnv e p
-- | Checks if an environment is "external", meaning it's either the global scope or a module scope.
envIsExternal :: Env -> Bool
envIsExternal env =

11
src/Obj.hs
View File

@ -55,7 +55,7 @@ data Obj = Sym SymPath SymbolMode
| Lst [XObj]
| Arr [XObj]
| Dict (Map.Map XObj XObj)
| Closure XObj ClosureEnv
| Closure XObj ClosureContext
| Defn (Maybe (Set.Set XObj)) -- if this is a lifted lambda it needs the set of captured variables
| Def
| Fn (Maybe SymPath) (Set.Set XObj) -- the name of the lifted function, the set of variables this lambda captures, and a dynamic environment
@ -94,7 +94,9 @@ instance Ord Obj where
compare a b = compare (show a) (show b)
-- TODO: handle comparison of lists, arrays and dictionaries
newtype CommandFunctionType = CommandFunction { getCommand :: [XObj] -> StateT Context IO (Either EvalError XObj) }
type CommandCallback = Context -> [XObj] -> IO (Context, (Either EvalError XObj))
newtype CommandFunctionType = CommandFunction { getCommand :: CommandCallback }
instance Eq CommandFunctionType where
a == b = True
@ -465,10 +467,10 @@ data Env = Env { envBindings :: Map.Map String Binder
, envFunctionNestingLevel :: Int -- Normal defn:s have 0, lambdas get +1 for each level of nesting
} deriving (Show, Eq)
newtype ClosureEnv = CEnv Env
newtype ClosureContext = CCtx Context
deriving (Show)
instance Eq ClosureEnv where
instance Eq ClosureContext where
_ == _ = True
@ -788,6 +790,7 @@ data ExecutionMode = Repl | Build | BuildAndRun | Install String | Check derivin
-- | Information needed by the REPL
data Context = Context { contextGlobalEnv :: Env
, contextInternalEnv :: Maybe Env
, contextTypeEnv :: TypeEnv
, contextPath :: [String]
, contextProj :: Project

357
src/Primitives.hs
View File

@ -1,6 +1,7 @@
module Primitives where
import Control.Monad.State.Lazy (StateT(..), get, put, liftIO, foldM, when, unless)
import Control.Monad (unless, when, foldM)
import Control.Monad.IO.Class (liftIO)
import Data.List (foldl')
import qualified Data.Map as Map
@ -15,11 +16,13 @@ import TypeError
import Types
import Util
type Primitive = XObj -> Env -> [XObj] -> StateT Context IO (Either EvalError XObj)
import Debug.Trace
found binder =
type Primitive = XObj -> Context -> [XObj] -> IO (Context, Either EvalError XObj)
found ctx binder =
liftIO $ do putStrLnWithColor White (show binder)
return dynamicNil
return (ctx, dynamicNil)
makePrim :: String -> Int -> String -> Primitive -> (SymPath, Primitive)
makePrim name arity example callback =
@ -29,9 +32,8 @@ makeVarPrim :: String -> String -> Primitive -> (SymPath, Primitive)
makeVarPrim name example callback =
makePrim' name Nothing example callback
argumentErr :: String -> String -> String -> XObj -> StateT Context IO (Either EvalError XObj)
argumentErr fun ty number actual = do
ctx <- get
argumentErr :: Context -> String -> String -> String -> XObj -> IO (Context, Either EvalError XObj)
argumentErr ctx fun ty number actual =
return (evalError ctx (
"`" ++ fun ++ "` expected " ++ ty ++ " as its " ++ number ++
" argument, but got `" ++ pretty actual ++ "`") (info actual))
@ -43,73 +45,63 @@ makePrim' name maybeArity example callback =
where wrapped =
case maybeArity of
Just a ->
\x e l ->
\x c l ->
let ll = length l
in (if ll /= a then err x a ll else callback x e l)
in (if ll /= a then err x c a ll else callback x c l)
Nothing -> callback
err :: XObj -> Int -> Int -> StateT Context IO (Either EvalError XObj)
err x a l = do
ctx <- get
err :: XObj -> Context -> Int -> Int -> IO (Context, Either EvalError XObj)
err x ctx a l =
return (evalError ctx (
"The primitive `" ++ name ++ "` expected " ++ show a ++
" arguments, but got " ++ show l ++ ".\n\nExample Usage:\n```\n" ++
example ++ "\n```\n") (info x))
primitiveFile :: Primitive
primitiveFile x@(XObj _ i t) _ [] = do
ctx <- get
primitiveFile x@(XObj _ i t) ctx [] =
case i of
Just info -> return (Right (XObj (Str (infoFile info)) i t))
Just info -> return (ctx, Right (XObj (Str (infoFile info)) i t))
Nothing ->
return (evalError ctx ("No information about object " ++ pretty x) (info x))
primitiveFile x@(XObj _ i t) _ [XObj _ mi _] = do
ctx <- get
primitiveFile x@(XObj _ i t) ctx [XObj _ mi _] =
case mi of
Just info -> return (Right (XObj (Str (infoFile info)) i t))
Just info -> return (ctx, Right (XObj (Str (infoFile info)) i t))
Nothing ->
return (evalError ctx ("No information about object " ++ pretty x) (info x))
primitiveFile x@(XObj _ i t) _ args = do
ctx <- get
primitiveFile x@(XObj _ i t) ctx args =
return (
evalError ctx
("`file` expected 0 or 1 arguments, but got " ++ show (length args))
(info x))
primitiveLine :: Primitive
primitiveLine x@(XObj _ i t) _ [] = do
ctx <- get
primitiveLine x@(XObj _ i t) ctx [] =
case i of
Just info -> return (Right (XObj (Num IntTy (fromIntegral (infoLine info))) i t))
Just info -> return (ctx, Right (XObj (Num IntTy (fromIntegral (infoLine info))) i t))
Nothing ->
return (evalError ctx ("No information about object " ++ pretty x) (info x))
primitiveLine x@(XObj _ i t) _ [XObj _ mi _] = do
ctx <- get
primitiveLine x@(XObj _ i t) ctx [XObj _ mi _] =
case mi of
Just info -> return (Right (XObj (Num IntTy (fromIntegral (infoLine info))) i t))
Just info -> return (ctx, Right (XObj (Num IntTy (fromIntegral (infoLine info))) i t))
Nothing ->
return (evalError ctx ("No information about object " ++ pretty x) (info x))
primitiveLine x@(XObj _ i t) _ args = do
ctx <- get
primitiveLine x@(XObj _ i t) ctx args =
return (
evalError ctx
("`line` expected 0 or 1 arguments, but got " ++ show (length args))
(info x))
primitiveColumn :: Primitive
primitiveColumn x@(XObj _ i t) _ [] = do
ctx <- get
primitiveColumn x@(XObj _ i t) ctx [] =
case i of
Just info -> return (Right (XObj (Num IntTy (fromIntegral (infoColumn info))) i t))
Just info -> return (ctx, Right (XObj (Num IntTy (fromIntegral (infoColumn info))) i t))
Nothing ->
return (evalError ctx ("No information about object " ++ pretty x) (info x))
primitiveColumn x@(XObj _ i t) _ [XObj _ mi _] = do
ctx <- get
primitiveColumn x@(XObj _ i t) ctx [XObj _ mi _] =
case mi of
Just info -> return (Right (XObj (Num IntTy (fromIntegral (infoColumn info))) i t))
Just info -> return (ctx, Right (XObj (Num IntTy (fromIntegral (infoColumn info))) i t))
Nothing ->
return (evalError ctx ("No information about object " ++ pretty x) (info x))
primitiveColumn x@(XObj _ i t) _ args = do
ctx <- get
primitiveColumn x@(XObj _ i t) ctx args =
return (
evalError ctx
("`column` expected 0 or 1 arguments, but got " ++ show (length args))
@ -142,7 +134,7 @@ registerDefnOrDefInInterfaceIfNeeded ctx xobj =
_ -> return ctx
define :: Bool -> Context -> XObj -> IO Context
define hidden ctx@(Context globalEnv typeEnv _ proj _ _ _) annXObj =
define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj =
let previousType =
case lookupInEnv (getPath annXObj) globalEnv of
Just (_, Binder _ found) -> ty found
@ -180,19 +172,15 @@ define hidden ctx@(Context globalEnv typeEnv _ proj _ _ _) annXObj =
return (ctx' { contextGlobalEnv = envInsertAt globalEnv (getPath annXObj) (Binder adjustedMeta annXObj) })
primitiveRegisterType :: Primitive
primitiveRegisterType _ e [XObj (Sym (SymPath [] t) _) _ _] = do
ctx <- get
primitiveRegisterType _ ctx [XObj (Sym (SymPath [] t) _) _ _] = do
let pathStrings = contextPath ctx
typeEnv = contextTypeEnv ctx
path = SymPath pathStrings t
typeDefinition = XObj (Lst [XObj ExternalType Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]) Nothing (Just TypeTy)
put (ctx { contextTypeEnv = TypeEnv (extendEnv (getTypeEnv typeEnv) t typeDefinition) })
return dynamicNil
primitiveRegisterType _ _ [x] = do
ctx <- get
return (ctx { contextTypeEnv = TypeEnv (extendEnv (getTypeEnv typeEnv) t typeDefinition) }, dynamicNil)
primitiveRegisterType _ ctx [x] =
return (evalError ctx ("`register-type` takes a symbol, but it got " ++ pretty x) (info x))
primitiveRegisterType _ _ (x@(XObj (Sym (SymPath [] t) _) _ _):members) = do
ctx <- get
primitiveRegisterType _ ctx (x@(XObj (Sym (SymPath [] t) _) _ _):members) = do
let pathStrings = contextPath ctx
globalEnv = contextGlobalEnv ctx
typeEnv = contextTypeEnv ctx
@ -208,31 +196,28 @@ primitiveRegisterType _ _ (x@(XObj (Sym (SymPath [] t) _) _ _):members) = do
, contextTypeEnv = TypeEnv (extendEnv (getTypeEnv typeEnv) t typeDefinition)
})
contextWithDefs <- liftIO $ foldM (define True) ctx' deps
put contextWithDefs
return dynamicNil
return (contextWithDefs, dynamicNil)
notFound :: XObj -> SymPath -> StateT Context IO (Either EvalError XObj)
notFound x path = do
ctx <- get
notFound :: Context -> XObj -> SymPath -> IO (Context, Either EvalError XObj)
notFound ctx x path =
return (evalError ctx ("I can’t find the symbol `" ++ show path ++ "`") (info x))
primitiveInfo :: Primitive
primitiveInfo _ env [target@(XObj (Sym path@(SymPath _ name) _) _ _)] = do
ctx <- get
let typeEnv = contextTypeEnv ctx
primitiveInfo _ ctx [target@(XObj (Sym path@(SymPath _ name) _) _ _)] = do
let env = contextEnv ctx
typeEnv = contextTypeEnv ctx
case path of
SymPath [] _ ->
-- First look in the type env, then in the global env:
case lookupInEnv path (getTypeEnv typeEnv) of
Nothing -> printer True True (lookupInEnv path env)
found -> do printer True True found -- this will print the interface itself
printer True False (lookupInEnv path env)-- this will print the locations of the implementers of the interface
Nothing -> printer env True True (lookupInEnv path env)
found -> do printer env True True found -- this will print the interface itself
printer env True False (lookupInEnv path env)-- this will print the locations of the implementers of the interface
qualifiedPath ->
case lookupInEnv path env of
Nothing -> notFound target path
found -> printer False True found
where printer allowLookupInALL errNotFound binderPair = do
ctx <- get
Nothing -> notFound ctx target path
found -> printer env False True found
where printer env allowLookupInALL errNotFound binderPair = do
let proj = contextProj ctx
case binderPair of
Just (_, binder@(Binder metaData x@(XObj _ (Just i) _))) ->
@ -243,8 +228,8 @@ primitiveInfo _ env [target@(XObj (Sym path@(SymPath _ name) _) _ _)] = do
printDoc metaData proj x
Nothing | allowLookupInALL ->
case multiLookupALL name env of
[] -> if errNotFound then notFound target path else
return dynamicNil
[] -> if errNotFound then notFound ctx target path else
return (ctx, dynamicNil)
binders -> do liftIO $
mapM_
(\ (env, binder@(Binder _ (XObj _ i _))) ->
@ -253,75 +238,70 @@ primitiveInfo _ env [target@(XObj (Sym path@(SymPath _ name) _) _ _)] = do
(show binder ++ " Defined at " ++ prettyInfo i')
Nothing -> putStrLnWithColor White (show binder))
binders
return dynamicNil
| errNotFound -> notFound target path
| otherwise -> return dynamicNil
return (ctx, dynamicNil)
| errNotFound -> notFound ctx target path
| otherwise -> return (ctx, dynamicNil)
printDoc metaData proj x = do
case Map.lookup "doc" (getMeta metaData) of
Just (XObj (Str val) _ _) -> liftIO $ putStrLn ("Documentation: " ++ val)
Nothing -> return ()
liftIO $ when (projectPrintTypedAST proj) $ putStrLnWithColor Yellow (prettyTyped x)
return dynamicNil
return (ctx, dynamicNil)
primitiveInfo _ ctx [notName] =
argumentErr ctx "info" "a name" "first" notName
dynamicOrMacroWith :: (SymPath -> [XObj]) -> Ty -> String -> XObj -> StateT Context IO (Either EvalError XObj)
dynamicOrMacroWith producer ty name body =
do ctx <- get
let pathStrings = contextPath ctx
globalEnv = contextGlobalEnv ctx
path = SymPath pathStrings name
elem = XObj (Lst (producer path)) (info body) (Just ty)
meta = existingMeta globalEnv elem
put (ctx { contextGlobalEnv = envInsertAt globalEnv path (Binder meta elem) })
return dynamicNil
dynamicOrMacroWith :: Context -> (SymPath -> [XObj]) -> Ty -> String -> XObj -> IO (Context, Either EvalError XObj)
dynamicOrMacroWith ctx producer ty name body = do
let pathStrings = contextPath ctx
globalEnv = contextGlobalEnv ctx
path = SymPath pathStrings name
elem = XObj (Lst (producer path)) (info body) (Just ty)
meta = existingMeta globalEnv elem
return (ctx { contextGlobalEnv = envInsertAt globalEnv path (Binder meta elem) }, dynamicNil)
dynamicOrMacro :: Obj -> Ty -> String -> XObj -> XObj -> StateT Context IO (Either EvalError XObj)
dynamicOrMacro pat ty name params body =
dynamicOrMacroWith (\path -> [XObj pat Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing, params, body]) ty name body
dynamicOrMacro :: Context -> Obj -> Ty -> String -> XObj -> XObj -> IO (Context, Either EvalError XObj)
dynamicOrMacro ctx pat ty name params body =
dynamicOrMacroWith ctx (\path -> [XObj pat Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing, params, body]) ty name body
primitiveDefndynamic :: Primitive
primitiveDefndynamic _ _ [XObj (Sym (SymPath [] name) _) _ _, params, body] =
dynamicOrMacro Dynamic DynamicTy name params body
primitiveDefndynamic _ _ [notName, params, body] =
argumentErr "defndynamic" "a name" "first" notName
primitiveDefndynamic _ ctx [XObj (Sym (SymPath [] name) _) _ _, params, body] =
dynamicOrMacro ctx Dynamic DynamicTy name params body
primitiveDefndynamic _ ctx [notName, params, body] =
argumentErr ctx "defndynamic" "a name" "first" notName
primitiveDefmacro :: Primitive
primitiveDefmacro _ _ [XObj (Sym (SymPath [] name) _) _ _, params, body] =
dynamicOrMacro Macro MacroTy name params body
primitiveDefmacro _ _ [notName, params, body] =
argumentErr "defmacro" "a name" "first" notName
primitiveDefmacro _ ctx [XObj (Sym (SymPath [] name) _) _ _, params, body] =
dynamicOrMacro ctx Macro MacroTy name params body
primitiveDefmacro _ ctx [notName, params, body] =
argumentErr ctx "defmacro" "a name" "first" notName
primitiveType :: Primitive
primitiveType _ _ [x@(XObj (Sym path@(SymPath [] name) _) _ _)] = do
ctx <- get
primitiveType _ ctx [x@(XObj (Sym path@(SymPath [] name) _) _ _)] = do
let env = contextGlobalEnv ctx
case lookupInEnv path env of
Just (_, binder) ->
found binder
found ctx binder
Nothing ->
case multiLookupALL name env of
[] ->
notFound x path
notFound ctx x path
binders ->
liftIO $ do mapM_ (\(env, binder) -> putStrLnWithColor White (show binder)) binders
return dynamicNil
primitiveType _ _ [x@(XObj (Sym qualifiedPath _) _ _)] = do
ctx <- get
return (ctx, dynamicNil)
primitiveType _ ctx [x@(XObj (Sym qualifiedPath _) _ _)] = do
let env = contextGlobalEnv ctx
case lookupInEnv qualifiedPath env of
Just (_, binder) ->
found binder
Nothing ->
notFound x qualifiedPath
primitiveType _ _ [x] = do
ctx <- get
Just (_, binder) -> found ctx binder
Nothing -> notFound ctx x qualifiedPath
primitiveType _ ctx [x] =
return (evalError ctx ("Can't get the type of non-symbol: " ++ pretty x) (info x))
primitiveMembers :: Primitive
primitiveMembers _ env [target] = do
ctx <- get
let typeEnv = contextTypeEnv ctx
primitiveMembers _ ctx [target] = do
let env = contextEnv ctx
typeEnv = contextTypeEnv ctx
fppl = projectFilePathPrintLength (contextProj ctx)
case bottomedTarget target of
case bottomedTarget env target of
XObj (Sym path@(SymPath _ name) _) _ _ ->
case lookupInEnv path (getTypeEnv typeEnv) of
Just (_, Binder _ (XObj (Lst [
@ -329,13 +309,13 @@ primitiveMembers _ env [target] = do
XObj (Sym (SymPath pathStrings typeName) Symbol) Nothing Nothing,
XObj (Arr members) _ _]) _ _))
->
return (Right (XObj (Arr (map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members))) Nothing Nothing))
return (ctx, Right (XObj (Arr (map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members))) Nothing Nothing))
Just (_, Binder _ (XObj (Lst (
XObj (DefSumtype structTy) Nothing Nothing :
XObj (Sym (SymPath pathStrings typeName) Symbol) Nothing Nothing :
sumtypeCases)) _ _))
->
return (Right (XObj (Arr (concatMap getMembersFromCase sumtypeCases)) Nothing Nothing))
return (ctx, Right (XObj (Arr (concatMap getMembersFromCase sumtypeCases)) Nothing Nothing))
where getMembersFromCase :: XObj -> [XObj]
getMembersFromCase (XObj (Lst members) _ _) =
map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members)
@ -346,7 +326,7 @@ primitiveMembers _ env [target] = do
_ ->
return (evalError ctx ("Can't find a struct type named '" ++ name ++ "' in type environment") (info target))
_ -> return (evalError ctx ("Can't get the members of non-symbol: " ++ pretty target) (info target))
where bottomedTarget target =
where bottomedTarget env target =
case target of
XObj (Sym targetPath _) _ _ ->
case lookupInEnv targetPath env of
@ -355,48 +335,46 @@ primitiveMembers _ env [target] = do
-- module
Just (_, Binder _ (XObj (Mod _) _ _)) -> target
-- if we’re recursing into a non-sym, we’ll stop one level down
Just (_, Binder _ x) -> bottomedTarget x
Just (_, Binder _ x) -> bottomedTarget env x
_ -> target
_ -> target
-- | Set meta data for a Binder
primitiveMetaSet :: Primitive
primitiveMetaSet _ env [target@(XObj (Sym path@(SymPath _ name) _) _ _), XObj (Str key) _ _, value] =
do ctx <- get
let pathStrings = contextPath ctx
fppl = projectFilePathPrintLength (contextProj ctx)
case lookupInEnv (consPath pathStrings path) env of
Just (_, binder@(Binder _ xobj)) ->
-- | Set meta on existing binder
setMetaOn ctx binder
Nothing ->
case path of
-- | If the path is unqualified, create a binder and set the meta on that one. This enables docstrings before function exists.
(SymPath [] name) ->
setMetaOn ctx (Binder emptyMeta (XObj (Lst [XObj DocStub Nothing Nothing,
XObj (Sym (SymPath pathStrings name) Symbol) Nothing Nothing])
(Just dummyInfo)
(Just (VarTy "a"))))
(SymPath _ _) ->
return (evalError ctx ("`meta-set!` failed, I can't find the symbol `" ++ show path ++ "`") (info target))
where
setMetaOn :: Context -> Binder -> StateT Context IO (Either EvalError XObj)
setMetaOn ctx binder@(Binder metaData xobj) =
do let globalEnv = contextGlobalEnv ctx
newMetaData = MetaData (Map.insert key value (getMeta metaData))
xobjPath = getPath xobj
newBinder = binder { binderMeta = newMetaData }
newEnv = envInsertAt globalEnv xobjPath newBinder
put (ctx { contextGlobalEnv = newEnv })
return dynamicNil
primitiveMetaSet _ _ [XObj (Sym _ _) _ _, key, _] =
argumentErr "meta-set!" "a string" "second" key
primitiveMetaSet _ _ [target, _, _] =
argumentErr "meta-set!" "a symbol" "first" target
primitiveMetaSet _ ctx [target@(XObj (Sym path@(SymPath _ name) _) _ _), XObj (Str key) _ _, value] = do
let env = contextGlobalEnv ctx
pathStrings = contextPath ctx
fppl = projectFilePathPrintLength (contextProj ctx)
case lookupInEnv (consPath pathStrings path) env of
Just (_, binder@(Binder _ xobj)) ->
-- | Set meta on existing binder
setMetaOn ctx binder
Nothing ->
case path of
-- | If the path is unqualified, create a binder and set the meta on that one. This enables docstrings before function exists.
(SymPath [] name) ->
setMetaOn ctx (Binder emptyMeta (XObj (Lst [XObj DocStub Nothing Nothing,
XObj (Sym (SymPath pathStrings name) Symbol) Nothing Nothing])
(Just dummyInfo)
(Just (VarTy "a"))))
(SymPath _ _) ->
return (evalError ctx ("`meta-set!` failed, I can't find the symbol `" ++ show path ++ "`") (info target))
where
setMetaOn :: Context -> Binder -> IO (Context, Either EvalError XObj)
setMetaOn ctx binder@(Binder metaData xobj) =
do let globalEnv = contextGlobalEnv ctx
newMetaData = MetaData (Map.insert key value (getMeta metaData))
xobjPath = getPath xobj
newBinder = binder { binderMeta = newMetaData }
newEnv = envInsertAt globalEnv xobjPath newBinder
return (ctx { contextGlobalEnv = newEnv }, dynamicNil)
primitiveMetaSet _ ctx [XObj (Sym _ _) _ _, key, _] =
argumentErr ctx "meta-set!" "a string" "second" key
primitiveMetaSet _ ctx [target, _, _] =
argumentErr ctx "meta-set!" "a symbol" "first" target
registerInterfaceFunctions :: String -> Ty -> StateT Context IO ()
registerInterfaceFunctions name t = do
ctx <- get
registerInterfaceFunctions :: Context -> String -> Ty -> IO Context
registerInterfaceFunctions ctx name t = do
let env = contextGlobalEnv ctx
found = multiLookupALL name env
binders = map snd found
@ -406,12 +384,10 @@ registerInterfaceFunctions name t = do
(Right ctx) binders
case resultCtx of
Left err -> error err
Right ctx' -> put ctx'
return ()
Right ctx' -> return ctx'
primitiveDefinterface :: Primitive
primitiveDefinterface xobj _ [nameXObj@(XObj (Sym path@(SymPath [] name) _) _ _), ty] = do
ctx <- get
primitiveDefinterface xobj ctx [nameXObj@(XObj (Sym path@(SymPath [] name) _) _ _), ty] = do
let fppl = projectFilePathPrintLength (contextProj ctx)
typeEnv = getTypeEnv (contextTypeEnv ctx)
case xobjToTy ty of
@ -420,23 +396,21 @@ primitiveDefinterface xobj _ [nameXObj@(XObj (Sym path@(SymPath [] name) _) _ _)
Just (_, Binder _ (XObj (Lst (XObj (Interface foundType _) _ _ : _)) _ _)) ->
-- The interface already exists, so it will be left as-is.
if foundType == t
then return dynamicNil
then return (ctx, dynamicNil)
else return (evalError ctx ("Tried to change the type of interface `" ++ show path ++ "` from `" ++ show foundType ++ "` to `" ++ show t ++ "`") (info xobj))
Nothing ->
let interface = defineInterface name t [] (info nameXObj)
typeEnv' = TypeEnv (envInsertAt typeEnv (SymPath [] name) (Binder emptyMeta interface))
in do put (ctx { contextTypeEnv = typeEnv' })
registerInterfaceFunctions name t
return dynamicNil
in do
newCtx <- registerInterfaceFunctions (ctx { contextTypeEnv = typeEnv' }) name t
return (newCtx, dynamicNil)
Nothing ->
return (evalError ctx ("Invalid type for interface `" ++ name ++ "`: " ++ pretty ty) (info ty))
primitiveDefinterface _ _ [name, _] = do
ctx <- get
primitiveDefinterface _ ctx [name, _] = do
return (evalError ctx ("`definterface` expects a name as first argument, but got `" ++ pretty name ++ "`") (info name))
registerInternal :: String -> XObj -> Maybe String -> StateT Context IO (Either EvalError XObj)
registerInternal name ty override = do
ctx <- get
registerInternal :: Context -> String -> XObj -> Maybe String -> IO (Context, Either EvalError XObj)
registerInternal ctx name ty override = do
let pathStrings = contextPath ctx
fppl = projectFilePathPrintLength (contextProj ctx)
globalEnv = contextGlobalEnv ctx
@ -452,42 +426,36 @@ registerInternal name ty override = do
Left errorMessage ->
return (makeEvalError ctx Nothing errorMessage (info ty))
Right ctx' ->
do put (ctx' { contextGlobalEnv = env' })
return dynamicNil
do return (ctx' { contextGlobalEnv = env' }, dynamicNil)
Nothing ->
return (evalError ctx
("Can't understand type when registering '" ++ name ++ "'") (info ty))
primitiveRegister :: Primitive
primitiveRegister _ _ [XObj (Sym (SymPath _ name) _) _ _, ty] =
registerInternal name ty Nothing
primitiveRegister _ _ [name, _] = do
ctx <- get
primitiveRegister _ ctx [XObj (Sym (SymPath _ name) _) _ _, ty] =
registerInternal ctx name ty Nothing
primitiveRegister _ ctx [name, _] =
return (evalError ctx
("`register` expects a name as first argument, but got `" ++ pretty name ++ "`")
(info name))
primitiveRegister _ _ [XObj (Sym (SymPath _ name) _) _ _, ty, XObj (Str override) _ _] =
registerInternal name ty (Just override)
primitiveRegister _ _ [XObj (Sym (SymPath _ name) _) _ _, _, override] = do
ctx <- get
primitiveRegister _ ctx [XObj (Sym (SymPath _ name) _) _ _, ty, XObj (Str override) _ _] =
registerInternal ctx name ty (Just override)
primitiveRegister _ ctx [XObj (Sym (SymPath _ name) _) _ _, _, override] =
return (evalError ctx
("`register` expects a string as third argument, but got `" ++ pretty override ++ "`")
(info override))
primitiveRegister _ _ [name, _, _] = do
ctx <- get
primitiveRegister _ ctx [name, _, _] =
return (evalError ctx
("`register` expects a name as first argument, but got `" ++ pretty name ++ "`")
(info name))
primitiveRegister x _ _ = do
ctx <- get
primitiveRegister x ctx _ =
return (evalError ctx
("I didn’t understand the form `" ++ pretty x ++
"`.\n\nIs it valid? Every `register` needs to follow the form `(register name <signature> <optional: override>)`.")
(info x))
primitiveDeftype :: Primitive
primitiveDeftype xobj _ (name:rest) = do
ctx <- get
primitiveDeftype xobj ctx (name:rest) =
case rest of
(XObj (Arr a) _ _ : _) -> if all isUnqualifiedSym (map fst (members a))
then deftype name
@ -500,14 +468,12 @@ primitiveDeftype xobj _ (name:rest) = do
where deftype name@(XObj (Sym (SymPath _ ty) _) _ _) = deftype' name ty []
deftype (XObj (Lst (name@(XObj (Sym (SymPath _ ty) _) _ _) : tyvars)) _ _) =
deftype' name ty tyvars
deftype name = do
ctx <- get
deftype name =
return (evalError ctx
("Invalid name for type definition: " ++ pretty name)
(info name))
deftype' :: XObj -> String -> [XObj] -> StateT Context IO (Either EvalError XObj)
deftype' :: XObj -> String -> [XObj] -> IO (Context, Either EvalError XObj)
deftype' nameXObj typeName typeVariableXObjs = do
ctx <- get
let pathStrings = contextPath ctx
fppl = projectFilePathPrintLength (contextProj ctx)
env = contextGlobalEnv ctx
@ -542,17 +508,17 @@ primitiveDeftype xobj _ (name:rest) = do
[(SymPath (pathStrings ++ [typeModuleName]) "str", FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy)
,(SymPath (pathStrings ++ [typeModuleName]) "copy", FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy)]
case ctxWithInterfaceRegistrations of
Left err -> liftIO (putStrLnWithColor Red err)
Right ok -> put ok
return dynamicNil
Left err -> do
liftIO (putStrLnWithColor Red err)
return (ctx, dynamicNil)
Right ok -> return (ok, dynamicNil)
Left err ->
return (makeEvalError ctx (Just err) ("Invalid type definition for '" ++ pretty nameXObj ++ "':\n\n" ++ show err) Nothing)
(_, Nothing) ->
return (makeEvalError ctx Nothing ("Invalid type variables for type definition: " ++ pretty nameXObj) (info nameXObj))
primitiveUse :: Primitive
primitiveUse xobj _ [XObj (Sym path _) _ _] = do
ctx <- get
primitiveUse xobj ctx [XObj (Sym path _) _ _] = do
let pathStrings = contextPath ctx
fppl = projectFilePathPrintLength (contextProj ctx)
env = contextGlobalEnv ctx
@ -562,16 +528,14 @@ primitiveUse xobj _ [XObj (Sym path _) _ _] = do
innerEnv = getEnv env pathStrings -- Duplication of e?
case lookupInEnv path innerEnv of
Just (_, Binder _ _) ->
do put $ ctx { contextGlobalEnv = envReplaceEnvAt env pathStrings e' }
return dynamicNil
return (ctx { contextGlobalEnv = envReplaceEnvAt env pathStrings e' }, dynamicNil)
Nothing ->
return (evalError ctx
("Can't find a module named '" ++ show path ++ "'") (info xobj))
-- | Get meta data for a Binder
primitiveMeta :: Primitive
primitiveMeta (XObj _ i _) _ [XObj (Sym path _) _ _, XObj (Str key) _ _] = do
ctx <- get
primitiveMeta (XObj _ i _) ctx [XObj (Sym path _) _ _, XObj (Str key) _ _] = do
let pathStrings = contextPath ctx
fppl = projectFilePathPrintLength (contextProj ctx)
globalEnv = contextGlobalEnv ctx
@ -579,22 +543,23 @@ primitiveMeta (XObj _ i _) _ [XObj (Sym path _) _ _, XObj (Str key) _ _] = do
Just (_, Binder metaData _) ->
case Map.lookup key (getMeta metaData) of
Just foundValue ->
return (Right foundValue)
return (ctx, Right foundValue)
Nothing ->
return dynamicNil
return (ctx, dynamicNil)
Nothing ->
return (evalError ctx
("`meta` failed, I can’t find `" ++ show path ++ "`")
i)
primitiveMeta _ _ [XObj (Sym path _) _ _, key@(XObj _ i _)] =
argumentErr "meta" "a string" "second" key
primitiveMeta _ _ [path@(XObj _ i _), _] =
argumentErr "meta" "a symbol" "first" path
primitiveMeta _ ctx [XObj (Sym path _) _ _, key@(XObj _ i _)] =
argumentErr ctx "meta" "a string" "second" key
primitiveMeta _ ctx [path@(XObj _ i _), _] =
argumentErr ctx "meta" "a symbol" "first" path
primitiveDefined :: Primitive
primitiveDefined _ env [XObj (Sym path _) _ _] =
primitiveDefined _ ctx [XObj (Sym path _) _ _] = do
let env = contextEnv ctx
case lookupInEnv path env of
Just found -> return (Right trueXObj)
Nothing -> return (Right falseXObj)
primitiveDefined _ _ [arg] =
argumentErr "defined" "a symbol" "first" arg
Just found -> return (ctx, Right trueXObj)
Nothing -> return (ctx, Right falseXObj)
primitiveDefined _ ctx [arg] =
argumentErr ctx "defined" "a symbol" "first" arg

2
src/StartingEnv.hs
View File

@ -405,7 +405,7 @@ startingGlobalEnv noArray =
++ [("System", Binder emptyMeta (XObj (Mod systemModule) Nothing Nothing))]
++ [("Dynamic", Binder emptyMeta (XObj (Mod dynamicModule) Nothing Nothing))]
++ [("Function", Binder emptyMeta (XObj (Mod functionModule) Nothing Nothing))]
++ [("Unsafe", Binder emptyMeta (XObj (Mod unsafeModule) Nothing Nothing))]
++ [("Unsafe", Binder emptyMeta (XObj (Mod unsafeModule) Nothing Nothing))]
-- | The type environment (containing deftypes and interfaces) before any code is run.
startingTypeEnv :: Env

8
src/TypeError.hs
View File

@ -384,11 +384,11 @@ showTypeFromXObj mappings xobj =
Just t -> show (recursiveLookupTy mappings t)
Nothing -> "Type missing"
evalError :: Context -> String -> Maybe Info -> Either EvalError a
evalError :: Context -> String -> Maybe Info -> (Context, Either EvalError a)
evalError ctx msg i = makeEvalError ctx Nothing msg i
-- | Print type errors correctly when running the compiler in 'Check' mode
makeEvalError :: Context -> Maybe TypeError.TypeError -> String -> Maybe Info -> Either EvalError a
makeEvalError :: Context -> Maybe TypeError.TypeError -> String -> Maybe Info -> (Context, Either EvalError a)
makeEvalError ctx err msg info =
let fppl = projectFilePathPrintLength (contextProj ctx)
history = contextHistory ctx
@ -399,5 +399,5 @@ makeEvalError ctx err msg info =
case info of
Just okInfo -> machineReadableInfo fppl okInfo ++ " " ++ msg
Nothing -> msg
in Left (EvalError messageWhenChecking [] fppl info) -- Passing no history to avoid appending it at the end in 'show' instance for EvalError
_ -> Left (EvalError msg history fppl info)
in (ctx, Left (EvalError messageWhenChecking [] fppl info)) -- Passing no history to avoid appending it at the end in 'show' instance for EvalError
_ -> (ctx, Left (EvalError msg history fppl info))