mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-11 05:25:28 +03:00
refactor: move form validation into a separate module (#1233)
This commit is contained in:
Scott Olsen
GitHub
parent
7c821543bc
commit
4f7905d85b
@ -29,6 +29,7 @@ library
|
||||
EvalError,
|
||||
Eval,
|
||||
Expand,
|
||||
Forms,
|
||||
GenerateConstraints,
|
||||
Infer,
|
||||
Info,
|
||||
|
||||
468
src/Eval.hs
468
src/Eval.hs
@ -10,7 +10,7 @@ import Control.Exception
|
||||
import Control.Monad.State
|
||||
import Data.Either (fromRight)
|
||||
import Data.Foldable (foldlM, foldrM)
|
||||
import Data.List (foldl', intercalate, isSuffixOf)
|
||||
import Data.List (foldl', isSuffixOf)
|
||||
import Data.List.Split (splitOn, splitWhen)
|
||||
import Data.Maybe (fromJust, fromMaybe, isJust)
|
||||
import Emit
|
||||
@ -35,6 +35,7 @@ import TypeError
|
||||
import Types
|
||||
import Util
|
||||
import Prelude hiding (exp, mod)
|
||||
import Forms
|
||||
|
||||
-- TODO: Formalize "lookup order preference" a bit better and move into
|
||||
-- the Context module.
|
||||
@ -48,6 +49,8 @@ data Resolver
|
||||
= ResolveGlobal
|
||||
| ResolveLocal
|
||||
|
||||
type Evaluator = [XObj] -> IO (Context, Either EvalError XObj)
|
||||
|
||||
-- Prefer dynamic bindings
|
||||
evalDynamic :: Resolver -> Context -> XObj -> IO (Context, Either EvalError XObj)
|
||||
evalDynamic resolver ctx xobj = eval ctx xobj PreferDynamic resolver
|
||||
@ -181,246 +184,59 @@ eval ctx xobj@(XObj o info ty) preference resolver =
|
||||
resolveDef (XObj (Lst [XObj DefDynamic _ _, _, value]) _ _) = value
|
||||
resolveDef (XObj (Lst [XObj LocalDef _ _, _, value]) _ _) = value
|
||||
resolveDef x = x
|
||||
|
||||
eval' form =
|
||||
case form of
|
||||
[XObj If _ _, mcond, mtrue, mfalse] -> do
|
||||
(newCtx, evd) <- eval ctx mcond preference ResolveLocal
|
||||
case evd of
|
||||
Right cond ->
|
||||
case xobjObj cond of
|
||||
Bol b -> eval newCtx (if b then mtrue else mfalse) preference ResolveLocal
|
||||
_ ->
|
||||
pure (throwErr (IfContainsNonBool cond) ctx (xobjInfo cond))
|
||||
Left e -> pure (newCtx, Left e)
|
||||
XObj If _ _ : _ ->
|
||||
pure (throwErr (IfMalformed xobj) ctx (xobjInfo xobj))
|
||||
[XObj (Defn _) _ _, name, args@(XObj (Arr a) _ _), _] ->
|
||||
case xobjObj name of
|
||||
(Sym (SymPath [] _) _) ->
|
||||
if all isUnqualifiedSym a
|
||||
then specialCommandDefine ctx xobj
|
||||
else pure (throwErr (DefnContainsQualifiedArgs args) ctx (xobjInfo xobj))
|
||||
_ ->
|
||||
pure (throwErr (DefnIdentifierIsQualified name) ctx (xobjInfo xobj))
|
||||
[XObj (Defn _) _ _, _, invalidArgs, _] ->
|
||||
pure (throwErr (defnInvalidArgs [invalidArgs]) ctx (xobjInfo xobj))
|
||||
(defn@(XObj (Defn _) _ _) : _) ->
|
||||
pure (throwErr (DefnMalformed xobj) ctx (xobjInfo defn))
|
||||
[XObj Def _ _, name, _] ->
|
||||
if isUnqualifiedSym name
|
||||
then specialCommandDefine ctx xobj
|
||||
else pure (throwErr (DefIdentifierIsQualified name) ctx (xobjInfo xobj))
|
||||
[the@(XObj The _ _), t, value] ->
|
||||
do
|
||||
(newCtx, evaledValue) <- expandAll (evalDynamic ResolveLocal) ctx value -- TODO: Why expand all here?
|
||||
pure
|
||||
( newCtx,
|
||||
do
|
||||
okValue <- evaledValue
|
||||
Right (XObj (Lst [the, t, okValue]) info ty)
|
||||
)
|
||||
(XObj The _ _ : _) ->
|
||||
pure (throwErr (TheMalformed xobj) ctx (xobjInfo xobj))
|
||||
[XObj Let _ _, XObj (Arr bindings) _ _, body]
|
||||
| odd (length bindings) ->
|
||||
pure (throwErr (LetUnevenForms xobj) ctx (xobjInfo xobj))
|
||||
| not (all isSym (evenIndices bindings)) ->
|
||||
pure (throwErr (LetMalformedIdentifiers bindings) ctx (xobjInfo xobj))
|
||||
| otherwise ->
|
||||
do
|
||||
let binds = unwrapVar (pairwise bindings) []
|
||||
ni = Env Map.empty (contextInternalEnv ctx) Nothing Set.empty InternalEnv 0
|
||||
eitherCtx <- foldrM successiveEval' (Right (replaceInternalEnv ctx ni)) binds
|
||||
case eitherCtx of
|
||||
Left err -> pure (ctx, Left err)
|
||||
Right newCtx -> do
|
||||
(finalCtx, evaledBody) <- eval newCtx body (PreferLocal (map (\(name, _) -> (SymPath [] name)) binds)) ResolveLocal
|
||||
let Just e = contextInternalEnv finalCtx
|
||||
parentEnv = fromMaybe e (envParent e)
|
||||
pure
|
||||
( replaceInternalEnv finalCtx parentEnv,
|
||||
do
|
||||
okBody <- evaledBody
|
||||
Right okBody
|
||||
)
|
||||
where
|
||||
unwrapVar [] acc = acc
|
||||
unwrapVar ((XObj (Sym (SymPath [] x) _) _ _, y) : xs) acc = unwrapVar xs ((x, y) : acc)
|
||||
unwrapVar _ _ = error "unwrapvar"
|
||||
successiveEval' (n, x) =
|
||||
\case
|
||||
err@(Left _) -> pure err
|
||||
Right ctx' -> do
|
||||
-- Bind a reference to the let bind in a recursive
|
||||
-- environment. This permits recursion in anonymous functions
|
||||
-- in let binds such as:
|
||||
-- (let [f (fn [x] (if (= x 1) x (f (dec x))))] (f 10))
|
||||
let origin = (contextInternalEnv ctx')
|
||||
recFix = (E.recursive origin (Just "let-rec-env") 0)
|
||||
Right envWithSelf = E.insertX recFix (SymPath [] n) x
|
||||
ctx'' = replaceInternalEnv ctx' envWithSelf
|
||||
(newCtx, res) <- eval ctx'' x preference resolver
|
||||
case res of
|
||||
Right okX ->
|
||||
pure $ Right (fromRight (error "Failed to eval let binding!!") (bindLetDeclaration (newCtx {contextInternalEnv = origin}) n okX))
|
||||
Left err -> pure $ Left err
|
||||
[f@(XObj Fn {} _ _), args@(XObj (Arr a) _ _), body] -> do
|
||||
(newCtx, expanded) <- macroExpand ctx body
|
||||
pure $
|
||||
case expanded of
|
||||
Right b ->
|
||||
if all isUnqualifiedSym a
|
||||
then (newCtx, Right (XObj (Closure (XObj (Lst [f, args, b]) info ty) (CCtx newCtx)) info ty))
|
||||
else (throwErr (FnContainsQualifiedArgs args) ctx (xobjInfo args))
|
||||
Left err -> (ctx, Left err)
|
||||
XObj (Closure (XObj (Lst [XObj (Fn _ _) _ _, XObj (Arr params) _ _, body]) _ _) (CCtx c)) _ _ : args ->
|
||||
case checkArity (pretty xobj) params args of
|
||||
Left err -> pure (evalError ctx err (xobjInfo xobj))
|
||||
Right () ->
|
||||
do
|
||||
(newCtx, evaledArgs) <- foldlM successiveEval (ctx, Right []) args
|
||||
case evaledArgs of
|
||||
Right okArgs -> do
|
||||
let newGlobals = (contextGlobalEnv newCtx) <> (contextGlobalEnv c)
|
||||
newTypes = TypeEnv $ (getTypeEnv (contextTypeEnv newCtx)) <> (getTypeEnv (contextTypeEnv c))
|
||||
updater = replaceHistory' (contextHistory ctx) . replaceGlobalEnv' newGlobals . replaceTypeEnv' newTypes
|
||||
(ctx', res) <- apply (updater c) body params okArgs
|
||||
pure (replaceGlobalEnv newCtx (contextGlobalEnv ctx'), res)
|
||||
Left err -> pure (newCtx, Left err)
|
||||
XObj (Lst [XObj Dynamic _ _, sym, XObj (Arr params) _ _, body]) i _ : args ->
|
||||
case checkArity (getName sym) params args of
|
||||
Left err ->
|
||||
pure (evalError ctx err i)
|
||||
Right () ->
|
||||
do
|
||||
(newCtx, evaledArgs) <- foldlM successiveEval (ctx, Right []) args
|
||||
case evaledArgs of
|
||||
Right okArgs -> apply newCtx body params okArgs
|
||||
Left err -> pure (newCtx, Left err)
|
||||
XObj (Lst [XObj Macro _ _, sym, XObj (Arr params) _ _, body]) i _ : args ->
|
||||
case checkArity (getName sym) params args of
|
||||
Left err -> pure (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
|
||||
(ctx', res) <- apply ctx body params args
|
||||
case res of
|
||||
Right xobj' -> macroExpand ctx' xobj'
|
||||
Left _ -> pure (ctx, res)
|
||||
[XObj (Lst [XObj (Command (NullaryCommandFunction nullary)) _ _, _, _]) _ _] ->
|
||||
do
|
||||
(c, evaledArgs) <- foldlM successiveEval (ctx, Right []) []
|
||||
case evaledArgs of
|
||||
Right [] -> nullary c
|
||||
Right _ -> error "eval nullary"
|
||||
Left err -> pure (ctx, Left err)
|
||||
[XObj (Lst [XObj (Command (UnaryCommandFunction unary)) _ _, _, _]) _ _, x] ->
|
||||
do
|
||||
(c, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x]
|
||||
case evaledArgs of
|
||||
Right [x'] -> unary c x'
|
||||
Right _ -> error "eval unary"
|
||||
Left err -> pure (ctx, Left err)
|
||||
[XObj (Lst [XObj (Command (BinaryCommandFunction binary)) _ _, _, _]) _ _, x, y] ->
|
||||
do
|
||||
(c, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x, y]
|
||||
case evaledArgs of
|
||||
Right [x', y'] -> binary c x' y'
|
||||
Right _ -> error "eval binary"
|
||||
Left err -> pure (ctx, Left err)
|
||||
[XObj (Lst [XObj (Command (TernaryCommandFunction ternary)) _ _, _, _]) _ _, x, y, z] ->
|
||||
do
|
||||
(c, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x, y, z]
|
||||
case evaledArgs of
|
||||
Right [x', y', z'] -> ternary c x' y' z'
|
||||
Right _ -> error "eval ternary"
|
||||
Left err -> pure (ctx, Left err)
|
||||
XObj (Lst [XObj (Command (VariadicCommandFunction variadic)) _ _, _, _]) _ _ : args ->
|
||||
do
|
||||
(c, evaledArgs) <- foldlM successiveEval (ctx, Right []) args
|
||||
case evaledArgs of
|
||||
Right xs -> variadic c xs
|
||||
Left err -> pure (ctx, Left err)
|
||||
XObj (Lst [XObj (Command _) _ _, sym, XObj (Arr params) _ _]) i _ : args ->
|
||||
badArity (getName sym) params args i
|
||||
[e@(XObj (Lst [XObj (Primitive (NullaryPrimitive nullary)) _ _, _, _]) _ _)] -> nullary e ctx
|
||||
[e@(XObj (Lst [XObj (Primitive (UnaryPrimitive unary)) _ _, _, _]) _ _), x] -> unary e ctx x
|
||||
[e@(XObj (Lst [XObj (Primitive (BinaryPrimitive binary)) _ _, _, _]) _ _), x, y] -> binary e ctx x y
|
||||
[e@(XObj (Lst [XObj (Primitive (TernaryPrimitive ternary)) _ _, _, _]) _ _), x, y, z] -> ternary e ctx x y z
|
||||
[e@(XObj (Lst [XObj (Primitive (QuaternaryPrimitive quaternary)) _ _, _, _]) _ _), x, y, z, w] -> quaternary e ctx x y z w
|
||||
e@(XObj (Lst [XObj (Primitive (VariadicPrimitive variadic)) _ _, _, _]) _ _) : args -> variadic e ctx args
|
||||
XObj (Lst [XObj (Primitive _) _ _, sym, XObj (Arr params) _ _]) i _ : args -> badArity (getName sym) params args i
|
||||
XObj (Lst (XObj (Defn _) _ _ : _)) _ _ : _ -> pure (ctx, Left (HasStaticCall xobj info))
|
||||
XObj (Lst (XObj (Interface _ _) _ _ : _)) _ _ : _ -> pure (ctx, Left (HasStaticCall xobj info))
|
||||
XObj (Lst (XObj (Instantiate _) _ _ : _)) _ _ : _ -> pure (ctx, Left (HasStaticCall xobj info))
|
||||
XObj (Lst (XObj (Deftemplate _) _ _ : _)) _ _ : _ -> pure (ctx, Left (HasStaticCall xobj info))
|
||||
XObj (Lst (XObj (External _) _ _ : _)) _ _ : _ -> pure (ctx, Left (HasStaticCall xobj info))
|
||||
XObj (Match _) _ _ : _ -> pure (ctx, Left (HasStaticCall xobj info))
|
||||
XObj Ref _ _ : _ -> pure (ctx, Left (HasStaticCall xobj info))
|
||||
l@(XObj (Lst _) i t) : args -> do
|
||||
(newCtx, f) <- eval ctx l preference ResolveLocal
|
||||
case f of
|
||||
Right fun -> do
|
||||
(newCtx', res) <- eval (pushFrame newCtx xobj) (XObj (Lst (fun : args)) i t) preference ResolveLocal
|
||||
pure (popFrame newCtx', res)
|
||||
x -> pure (newCtx, x)
|
||||
x@(XObj (Sym _ _) i _) : args -> do
|
||||
(newCtx, f) <- eval ctx x preference resolver
|
||||
case f of
|
||||
Right fun -> do
|
||||
(newCtx', res) <- eval (pushFrame ctx xobj) (XObj (Lst (fun : args)) i ty) preference resolver
|
||||
pure (popFrame newCtx', res)
|
||||
Left err -> pure (newCtx, Left err)
|
||||
XObj With _ _ : xobj'@(XObj (Sym path _) _ _) : forms ->
|
||||
specialCommandWith ctx xobj' path forms
|
||||
XObj With _ _ : x : _ ->
|
||||
pure (throwErr (withInvalidArgs [x]) ctx (xobjInfo xobj))
|
||||
XObj SetBang _ _ : args -> specialCommandSet ctx args
|
||||
[XObj Do _ _] ->
|
||||
pure (throwErr DoMissingForms ctx (xobjInfo xobj))
|
||||
XObj Do _ _ : rest -> foldlM successiveEval' (ctx, dynamicNil) rest
|
||||
where
|
||||
successiveEval' (ctx', acc) x =
|
||||
case acc of
|
||||
err@(Left _) -> pure (ctx', err)
|
||||
Right _ -> eval ctx' x preference resolver
|
||||
[XObj While _ _, cond, body] ->
|
||||
specialCommandWhile ctx cond body
|
||||
[] -> pure (ctx, dynamicNil)
|
||||
_ -> pure (throwErr (UnknownForm xobj) ctx (xobjInfo xobj))
|
||||
badArity name params args i = case checkArity name params args of
|
||||
Left err -> pure (evalError ctx err i)
|
||||
Right () -> error "badarity"
|
||||
checkArity name params args =
|
||||
let la = length args
|
||||
withRest = any ((":rest" ==) . getName) params
|
||||
lp = length params - (if withRest then 2 else 0)
|
||||
in if lp == la || (withRest && la >= lp)
|
||||
then Right ()
|
||||
else
|
||||
if la < lp
|
||||
then
|
||||
Left
|
||||
( name
|
||||
++ " expected "
|
||||
++ show lp
|
||||
++ " arguments but received only "
|
||||
++ show la
|
||||
++ ".\n\nYou’ll have to provide "
|
||||
++ intercalate ", " (map pretty (drop la params))
|
||||
++ " as well."
|
||||
)
|
||||
else
|
||||
Left
|
||||
( name
|
||||
++ " expected "
|
||||
++ show lp
|
||||
++ " arguments, but received "
|
||||
++ show la
|
||||
++ ".\n\nThe arguments "
|
||||
++ intercalate ", " (map pretty (drop lp args))
|
||||
++ " are not needed."
|
||||
)
|
||||
case validate form of
|
||||
Left e -> pure (evalError ctx (format e) (xobjInfo xobj))
|
||||
Right form' ->
|
||||
case form' of
|
||||
(IfPat _ _ _) -> evaluateIf form'
|
||||
(DefnPat _ _ _) -> specialCommandDefine ctx xobj
|
||||
(DefPat _ _) -> specialCommandDefine ctx xobj
|
||||
(ThePat _ _ _) -> evaluateThe form'
|
||||
(LetPat _ _) -> evaluateLet form'
|
||||
(FnPat _ _ _) -> evaluateFn form'
|
||||
(AppPat (ClosurePat _ _ _) _) -> evaluateClosure form'
|
||||
(AppPat (DynamicFnPat _ _ _) _) -> evaluateDynamicFn form'
|
||||
(AppPat (MacroPat _ _ _) _) -> evaluateMacro form'
|
||||
(AppPat (CommandPat _ _ _) _) -> evaluateCommand form'
|
||||
(AppPat (PrimitivePat _ _ _) _) -> evaluatePrimitive form'
|
||||
(WithPat (SymPat sym path) forms) -> specialCommandWith ctx sym path forms
|
||||
(DoPat forms) -> evaluateSideEffects forms
|
||||
(WhilePat cond body) -> specialCommandWhile ctx cond body
|
||||
-- This next match is a bit redundant looking at first glance, but
|
||||
-- it is necessary to prevent hangs on input such as: `((def foo 2)
|
||||
-- 4)`. Ideally, we could perform only *one* static check (the one
|
||||
-- we do in eval). But the timing is wrong.
|
||||
-- The `def` in the example above initially comes into the
|
||||
-- evaluator as a *Sym*, **not** as a `Def` xobj. So, we need to
|
||||
-- discriminate on the result of evaluating the symbol to eagerly
|
||||
-- break the evaluation loop, otherwise we will proceed to evaluate
|
||||
-- the def form, yielding Unit, and attempt to reevaluate unit
|
||||
-- indefinitely on subsequent eval loops.
|
||||
-- Importantly, the loop *is only broken on literal nested lists*.
|
||||
-- That is, passing a *symbol* that, e.g. resolves to a defn list, won't
|
||||
-- break our normal loop.
|
||||
(AppPat (ListPat self ((SymPat x _):xs)) args) ->
|
||||
do (_, evald) <- eval ctx x preference ResolveGlobal
|
||||
case evald of
|
||||
Left err -> pure (evalError ctx (show err) (xobjInfo xobj))
|
||||
Right x' -> case checkStatic' x' of
|
||||
Right _ -> evaluateApp ((XObj (Lst (x':xs)) (xobjInfo self) (xobjTy self)):args)
|
||||
Left er -> pure (evalError ctx (show er) (xobjInfo xobj))
|
||||
(SetPat iden value) -> specialCommandSet ctx (iden:[value])
|
||||
(AppPat (SymPat _ _) _) -> evaluateApp form'
|
||||
[] -> pure (ctx, dynamicNil)
|
||||
_ -> pure (throwErr (UnknownForm xobj) ctx (xobjInfo xobj))
|
||||
checkStatic' (XObj Def _ _) = Left (HasStaticCall xobj info)
|
||||
checkStatic' (XObj (Defn _) _ _) = Left (HasStaticCall xobj info)
|
||||
checkStatic' (XObj (Interface _ _) _ _) = Left (HasStaticCall xobj info)
|
||||
checkStatic' (XObj (Instantiate _) _ _) = Left (HasStaticCall xobj info)
|
||||
checkStatic' (XObj (Deftemplate _) _ _) = Left (HasStaticCall xobj info)
|
||||
checkStatic' (XObj (External _) _ _) = Left (HasStaticCall xobj info)
|
||||
checkStatic' (XObj (Match _) _ _) = Left (HasStaticCall xobj info)
|
||||
checkStatic' (XObj Ref _ _) = Left (HasStaticCall xobj info)
|
||||
checkStatic' x' = Right x'
|
||||
successiveEval (ctx', acc) x =
|
||||
case acc of
|
||||
Left _ -> pure (ctx', acc)
|
||||
@ -430,6 +246,178 @@ eval ctx xobj@(XObj o info ty) preference resolver =
|
||||
Right res -> (newCtx, Right (l ++ [res]))
|
||||
Left err -> (newCtx, Left err)
|
||||
|
||||
evaluateIf :: Evaluator
|
||||
evaluateIf (IfPat cond true false) = do
|
||||
(newCtx, evd) <- eval ctx cond preference ResolveLocal
|
||||
case evd of
|
||||
Right cond' ->
|
||||
case xobjObj cond' of
|
||||
Bol b -> eval newCtx (if b then true else false) preference ResolveLocal
|
||||
_ ->
|
||||
pure (throwErr (IfContainsNonBool cond) ctx (xobjInfo cond))
|
||||
Left e -> pure (newCtx, Left e)
|
||||
evaluateIf _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
|
||||
|
||||
evaluateThe :: Evaluator
|
||||
evaluateThe (ThePat the t value) = do
|
||||
(newCtx, evaledValue) <- expandAll (evalDynamic ResolveLocal) ctx value -- TODO: Why expand all here?
|
||||
pure
|
||||
( newCtx,
|
||||
do
|
||||
okValue <- evaledValue
|
||||
Right (XObj (Lst [the, t, okValue]) info ty)
|
||||
)
|
||||
evaluateThe _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
|
||||
|
||||
evaluateLet :: Evaluator
|
||||
evaluateLet (LetPat (ArrPat _ bindings) body) = do
|
||||
let binds = unwrapVar (pairwise bindings) []
|
||||
ni = Env Map.empty (contextInternalEnv ctx) Nothing Set.empty InternalEnv 0
|
||||
eitherCtx <- foldrM successiveEval' (Right (replaceInternalEnv ctx ni)) binds
|
||||
case eitherCtx of
|
||||
Left err -> pure (ctx, Left err)
|
||||
Right newCtx -> do
|
||||
(finalCtx, evaledBody) <- eval newCtx body (PreferLocal (map (\(name, _) -> (SymPath [] name)) binds)) ResolveLocal
|
||||
let Just e = contextInternalEnv finalCtx
|
||||
parentEnv = fromMaybe e (envParent e)
|
||||
pure
|
||||
( replaceInternalEnv finalCtx parentEnv,
|
||||
do
|
||||
okBody <- evaledBody
|
||||
Right okBody
|
||||
)
|
||||
where
|
||||
unwrapVar [] acc = acc
|
||||
unwrapVar ((XObj (Sym (SymPath [] x) _) _ _, y) : xs) acc = unwrapVar xs ((x, y) : acc)
|
||||
unwrapVar _ _ = error "unwrapvar"
|
||||
successiveEval' (n, x) =
|
||||
\case
|
||||
err@(Left _) -> pure err
|
||||
Right ctx' -> do
|
||||
-- Bind a reference to the let bind in a recursive
|
||||
-- environment. This permits recursion in anonymous functions
|
||||
-- in let binds such as:
|
||||
-- (let [f (fn [x] (if (= x 1) x (f (dec x))))] (f 10))
|
||||
let origin = (contextInternalEnv ctx')
|
||||
recFix = (E.recursive origin (Just "let-rec-env") 0)
|
||||
Right envWithSelf = E.insertX recFix (SymPath [] n) x
|
||||
ctx'' = replaceInternalEnv ctx' envWithSelf
|
||||
(newCtx, res) <- eval ctx'' x preference resolver
|
||||
case res of
|
||||
Right okX ->
|
||||
pure $ Right (fromRight (error "Failed to eval let binding!!") (bindLetDeclaration (newCtx {contextInternalEnv = origin}) n okX))
|
||||
Left err -> pure $ Left err
|
||||
evaluateLet _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
|
||||
|
||||
evaluateFn :: Evaluator
|
||||
evaluateFn (FnPat self args body) = do
|
||||
(newCtx, expanded) <- macroExpand ctx body
|
||||
pure $
|
||||
case expanded of
|
||||
Right b ->
|
||||
(newCtx, Right (XObj (Closure (XObj (Lst [self, args, b]) info ty) (CCtx newCtx)) info ty))
|
||||
Left err -> (ctx, Left err)
|
||||
evaluateFn _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
|
||||
|
||||
evaluateClosure :: Evaluator
|
||||
evaluateClosure (AppPat (ClosurePat params body c) args) = do
|
||||
(newCtx, evaledArgs) <- foldlM successiveEval (ctx, Right []) args
|
||||
case evaledArgs of
|
||||
Right okArgs -> do
|
||||
let newGlobals = (contextGlobalEnv newCtx) <> (contextGlobalEnv c)
|
||||
newTypes = TypeEnv $ (getTypeEnv (contextTypeEnv newCtx)) <> (getTypeEnv (contextTypeEnv c))
|
||||
updater = replaceHistory' (contextHistory ctx) . replaceGlobalEnv' newGlobals . replaceTypeEnv' newTypes
|
||||
(ctx', res) <- apply (updater c) body params okArgs
|
||||
pure (replaceGlobalEnv newCtx (contextGlobalEnv ctx'), res)
|
||||
Left err -> pure (newCtx, Left err)
|
||||
evaluateClosure _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
|
||||
|
||||
evaluateDynamicFn :: Evaluator
|
||||
evaluateDynamicFn (AppPat (DynamicFnPat _ params body) args) = do
|
||||
(newCtx, evaledArgs) <- foldlM successiveEval (ctx, Right []) args
|
||||
case evaledArgs of
|
||||
Right okArgs -> apply newCtx body params okArgs
|
||||
Left err -> pure (newCtx, Left err)
|
||||
evaluateDynamicFn _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
|
||||
|
||||
evaluateMacro :: Evaluator
|
||||
evaluateMacro (AppPat (MacroPat _ params body) args) = do
|
||||
(ctx', res) <- apply ctx body params args
|
||||
case res of
|
||||
Right xobj' -> macroExpand ctx' xobj'
|
||||
Left _ -> pure (ctx, res)
|
||||
evaluateMacro _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
|
||||
|
||||
evaluateCommand :: Evaluator
|
||||
evaluateCommand (AppPat (CommandPat (NullaryCommandFunction nullary) _ _) []) =
|
||||
nullary ctx
|
||||
evaluateCommand (AppPat (CommandPat (UnaryCommandFunction unary) _ _) [x]) = do
|
||||
(c, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x]
|
||||
case evaledArgs of
|
||||
Right args -> let [x'] = take 1 args in unary c x'
|
||||
Left err -> pure (ctx, Left err)
|
||||
evaluateCommand (AppPat (CommandPat (BinaryCommandFunction binary) _ _) [x, y]) = do
|
||||
(c, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x, y]
|
||||
case evaledArgs of
|
||||
Right args -> let [x', y'] = take 2 args in binary c x' y'
|
||||
Left err -> pure (ctx, Left err)
|
||||
evaluateCommand (AppPat (CommandPat (TernaryCommandFunction ternary) _ _) [x, y, z]) = do
|
||||
(c, evaledArgs) <- foldlM successiveEval (ctx, Right []) [x, y, z]
|
||||
case evaledArgs of
|
||||
Right args' -> let [x', y', z'] = take 3 args' in ternary c x' y' z'
|
||||
Left err -> pure (ctx, Left err)
|
||||
evaluateCommand (AppPat (CommandPat (VariadicCommandFunction variadic) _ _) args) = do
|
||||
(c, evaledArgs) <- foldlM successiveEval (ctx, Right []) args
|
||||
case evaledArgs of
|
||||
Right args' -> variadic c args'
|
||||
Left err -> pure (ctx, Left err)
|
||||
-- Should be caught during validation
|
||||
evaluateCommand (AppPat (CommandPat _ _ _) _) =
|
||||
pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
|
||||
evaluateCommand _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
|
||||
|
||||
evaluatePrimitive :: Evaluator
|
||||
evaluatePrimitive (AppPat p@(PrimitivePat (NullaryPrimitive nullary) _ _) []) =
|
||||
nullary p ctx
|
||||
evaluatePrimitive (AppPat p@(PrimitivePat (UnaryPrimitive unary) _ _) [x]) = do
|
||||
unary p ctx x
|
||||
evaluatePrimitive (AppPat p@(PrimitivePat (BinaryPrimitive binary) _ _) [x, y]) = do
|
||||
binary p ctx x y
|
||||
evaluatePrimitive (AppPat p@(PrimitivePat (TernaryPrimitive ternary) _ _) [x, y, z]) = do
|
||||
ternary p ctx x y z
|
||||
evaluatePrimitive (AppPat p@(PrimitivePat (QuaternaryPrimitive quaternary) _ _) [x, y, z, w]) = do
|
||||
quaternary p ctx x y z w
|
||||
evaluatePrimitive (AppPat p@(PrimitivePat (VariadicPrimitive variadic) _ _) args) = do
|
||||
variadic p ctx args
|
||||
-- Should be caught during validation
|
||||
evaluatePrimitive (AppPat (PrimitivePat _ _ _) _) =
|
||||
pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
|
||||
evaluatePrimitive _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
|
||||
|
||||
evaluateApp :: Evaluator
|
||||
evaluateApp (AppPat f' args) =
|
||||
case f' of
|
||||
(ListPat l _) -> go l
|
||||
(SymPat sym _) -> go sym
|
||||
_ -> pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
|
||||
where go x =
|
||||
do (newCtx, f) <- eval ctx x preference ResolveLocal
|
||||
case f of
|
||||
Right fun -> do
|
||||
(newCtx', res) <- eval (pushFrame newCtx xobj) (XObj (Lst (fun : args)) (xobjInfo x) (xobjTy x)) preference ResolveLocal
|
||||
pure (popFrame newCtx', res)
|
||||
x' -> pure (newCtx, x')
|
||||
evaluateApp _ = pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
|
||||
|
||||
evaluateSideEffects :: Evaluator
|
||||
evaluateSideEffects forms = do
|
||||
foldlM successiveEval' (ctx, dynamicNil) forms
|
||||
where
|
||||
successiveEval' (ctx', acc) x =
|
||||
case acc of
|
||||
err@(Left _) -> pure (ctx', err)
|
||||
Right _ -> eval ctx' x preference resolver
|
||||
|
||||
macroExpand :: Context -> XObj -> IO (Context, Either EvalError XObj)
|
||||
macroExpand ctx xobj =
|
||||
case xobj of
|
||||
|
||||
412
src/Forms.hs
Normal file
412
src/Forms.hs
Normal file
@ -0,0 +1,412 @@
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
-- | Module Forms both defines valid forms in Carp and performs validation on
|
||||
-- unchecked forms (xobjs).
|
||||
--
|
||||
-- It defines a number of pattern synonyms for ease of pattern matching.
|
||||
module Forms (
|
||||
validate,
|
||||
format,
|
||||
Malformed(GenericMalformed),
|
||||
pattern ArrPat,
|
||||
pattern ListPat,
|
||||
pattern SymPat,
|
||||
pattern UnqualifiedSymPat,
|
||||
pattern DefPat,
|
||||
pattern DefnPat,
|
||||
pattern IfPat,
|
||||
pattern ThePat,
|
||||
pattern LetPat,
|
||||
pattern FnPat,
|
||||
pattern ClosurePat,
|
||||
pattern DynamicFnPat,
|
||||
pattern MacroPat,
|
||||
pattern CommandPat,
|
||||
pattern PrimitivePat,
|
||||
pattern AppPat,
|
||||
pattern WithPat,
|
||||
pattern DoPat,
|
||||
pattern WhilePat,
|
||||
pattern SetPat,
|
||||
) where
|
||||
|
||||
import Obj
|
||||
import SymPath
|
||||
import Util
|
||||
import Data.List (intercalate)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Data
|
||||
|
||||
-- Specialized constructors for each built-in language form.
|
||||
|
||||
-- | Error type representing a generic malformed expression.
|
||||
data Malformed = InvalidIdentifier XObj Modifier
|
||||
| QualifiedIdentifier XObj Modifier
|
||||
| GenericMalformed XObj
|
||||
| InvalidArguments XObj Modifier
|
||||
| InvalidBody XObj Modifier
|
||||
| InvalidCondition XObj Modifier
|
||||
| InvalidType XObj Modifier
|
||||
| InvalidBindings XObj Modifier
|
||||
| UnevenForms XObj Int Modifier
|
||||
| InsufficientArguments XObj Int Int [XObj]
|
||||
| TooManyArguments XObj Int Int [XObj]
|
||||
| InvalidApplication XObj
|
||||
| DoMissingForms
|
||||
|
||||
instance Show Malformed where
|
||||
show (QualifiedIdentifier x modifier) =
|
||||
"I expected an unqualified symbol, but got: " ++ pretty x
|
||||
++ formatModifier modifier
|
||||
show (InvalidIdentifier x modifier) =
|
||||
"I expected a symbol, but got: " ++ pretty x
|
||||
++ formatModifier modifier
|
||||
show (InvalidArguments x modifier) =
|
||||
"`I expected an array of valid arguments, but got: " ++ pretty x
|
||||
++ formatModifier modifier
|
||||
show (InvalidBody x modifier) =
|
||||
"I expected a valid definition body, but got: " ++ pretty x
|
||||
++ formatModifier modifier
|
||||
show (InvalidCondition x modifier) =
|
||||
"I expected a boolean condition, but got: " ++ pretty x
|
||||
++ formatModifier modifier
|
||||
show (InvalidType x modifier) =
|
||||
"I expected the name of a type, but got: " ++ pretty x
|
||||
++ formatModifier modifier
|
||||
show (InvalidBindings bindings modifier) =
|
||||
"Expected an array of name-value binding pairs, but got: " ++ pretty bindings
|
||||
++ formatModifier modifier
|
||||
show (UnevenForms forms len modifier) =
|
||||
"Expected an even number of forms, but got: " ++ pretty forms
|
||||
++ "of length " ++ show len ++ " " ++ formatModifier modifier
|
||||
show (InsufficientArguments form lenExpected lenRecieved params) =
|
||||
let name = case form of
|
||||
(DynamicFnPat sym _ _) -> getName sym
|
||||
(MacroPat sym _ _) -> getName sym
|
||||
(CommandPat _ sym _) -> getName sym
|
||||
(PrimitivePat _ sym _) -> getName sym
|
||||
XObj Ref _ _ -> "ref"
|
||||
_ -> pretty form
|
||||
in name ++ " expected "
|
||||
++ show lenExpected
|
||||
++ " arguments but received only "
|
||||
++ show lenRecieved
|
||||
++ ".\n\nYou’ll have to provide "
|
||||
++ intercalate ", " (map pretty (drop lenRecieved params))
|
||||
++ " as well."
|
||||
show (TooManyArguments form lenExpected lenRecieved args) =
|
||||
let name = case form of
|
||||
(DynamicFnPat sym _ _) -> getName sym
|
||||
(MacroPat sym _ _) -> getName sym
|
||||
(CommandPat _ sym _) -> getName sym
|
||||
(PrimitivePat _ sym _) -> getName sym
|
||||
XObj Ref _ _ -> "ref"
|
||||
_ -> pretty form
|
||||
in name ++ " expected "
|
||||
++ show lenExpected
|
||||
++ " arguments but received "
|
||||
++ show lenRecieved
|
||||
++ ".\n\nThe arguments "
|
||||
++ intercalate ", " (map pretty (drop lenExpected args))
|
||||
++ " are not needed."
|
||||
show (InvalidApplication xobj) =
|
||||
"Expected a function or macro, but got: " ++ pretty xobj
|
||||
show (DoMissingForms) =
|
||||
"Expected one or more forms in a `do` form, but got none."
|
||||
show (GenericMalformed x) =
|
||||
"The form: " ++ pretty x ++ " is malformed"
|
||||
|
||||
-- | Specific errors for particular types of malformed expressions.
|
||||
data Modifier = DefnQualifiedSyms XObj
|
||||
| DefnNonArrayArgs XObj
|
||||
| DefnNonSymArgs XObj
|
||||
| IfInvalidCondition XObj
|
||||
| WhileInvalidCondition XObj
|
||||
| TheInvalidType XObj
|
||||
| LetMalformedBinding XObj
|
||||
| LetUnevenForms XObj
|
||||
| LetNonArrayBindings XObj
|
||||
| FnQualifiedSyms XObj
|
||||
| FnNonArrayArgs XObj
|
||||
| FnNonSymArgs XObj
|
||||
| InvalidWith XObj
|
||||
| None
|
||||
|
||||
instance Show Modifier where
|
||||
show None = ""
|
||||
show (DefnQualifiedSyms arg) =
|
||||
"`defn` requires all of its arguments to be unqualified symbols, but the arugment: "
|
||||
++ pretty arg ++ " is qualified"
|
||||
show (DefnNonArrayArgs args) =
|
||||
"`defn` requires an array of arugments, but it got: " ++ pretty args
|
||||
show (DefnNonSymArgs arg) =
|
||||
"`defn` requires an array of symbols as arguments, but the argument: "
|
||||
++ pretty arg ++ " is not a symbol"
|
||||
show (IfInvalidCondition cond) =
|
||||
"`if` requires a condition that can be evaluated to a boolean, but it got: "
|
||||
++ pretty cond ++ " which cannot resolve to a boolean value."
|
||||
show (WhileInvalidCondition cond) =
|
||||
"`while` requires a condition that can be evaluated to a boolean, but it got: "
|
||||
++ pretty cond ++ " which cannot resolve to a boolean value."
|
||||
show (TheInvalidType t) =
|
||||
"`the` requires a valid type name, but it got: "
|
||||
++ pretty t ++ " which is not a valid type name"
|
||||
show (LetMalformedBinding bind) =
|
||||
"`let` requires name-value binding pairs, but it got: " ++ pretty bind
|
||||
++ " as a binding name, which is invalid. Binding names must be symbols"
|
||||
show (LetUnevenForms arr) =
|
||||
"`let` requires an even number of name-value bindings forms, but it got: " ++ pretty arr
|
||||
show (LetNonArrayBindings invalid) =
|
||||
"`let` requires an array of bindings, but it got: " ++ pretty invalid
|
||||
show (FnQualifiedSyms arg) =
|
||||
"`fn` requires all of its arguments to be unqualified symbols, but the arugment: "
|
||||
++ pretty arg ++ " is qualified"
|
||||
show (FnNonArrayArgs args) =
|
||||
"`fn` requires an array of arugments, but it got: " ++ pretty args
|
||||
show (FnNonSymArgs arg) =
|
||||
"`fn` requires an array of symbols as arguments, but the argument: "
|
||||
++ pretty arg ++ " is not a symbol"
|
||||
show (InvalidWith x) =
|
||||
"`with` requires a symbol as an arugment, but got: " ++ pretty x
|
||||
|
||||
formatModifier :: Modifier -> String
|
||||
formatModifier None = ""
|
||||
formatModifier m = "\n - " ++ show m
|
||||
|
||||
-- | Format a malformed form error for printing.
|
||||
format :: Malformed -> String
|
||||
format e = "[ERROR] " ++ show e
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Validation functions
|
||||
|
||||
-- | Validate a given XObj to ensure it is a well formed expression of the language.
|
||||
validate :: [XObj] -> Either Malformed [XObj]
|
||||
validate xs =
|
||||
case xs of
|
||||
DefPat _ _ -> validateDef xs
|
||||
DefnPat _ _ _ -> validateDefn xs
|
||||
IfPat _ _ _ -> validateIf xs
|
||||
ThePat _ _ _ -> validateThe xs
|
||||
LetPat _ _ -> validateLet xs
|
||||
FnPat _ _ _ -> validateFn xs
|
||||
WithPat _ _ -> validateWith xs
|
||||
DoPat _ -> validateDo xs
|
||||
WhilePat _ _ -> validateWhile xs
|
||||
-- There are a number of application patterns (the "has static call patterns")
|
||||
-- that are formally caught at evaluation time.
|
||||
AppPat (ClosurePat _ _ _) _ -> validateApp xs
|
||||
AppPat (DynamicFnPat _ _ _) _ -> validateApp xs
|
||||
AppPat (MacroPat _ _ _) _ -> validateApp xs
|
||||
AppPat (CommandPat _ _ _) _ -> validateApp xs
|
||||
AppPat (PrimitivePat _ _ _) _ -> validateApp xs
|
||||
AppPat (XObj Ref _ _) _ -> validateApp xs
|
||||
_ -> Right xs
|
||||
|
||||
-- TODO: Complete validation of if currently relies on evaluating its condition
|
||||
-- for truthiness But there is a class of list forms we can rule out purely
|
||||
-- symbolically, e.g. `def`, etc..
|
||||
validateIf :: [XObj] -> Either Malformed [XObj]
|
||||
validateIf x@(IfPat (ListPat _ _) _ _) = Right x -- needs further evaluation
|
||||
validateIf (IfPat (ArrPat invalid _) _ _) = Left (InvalidCondition invalid (IfInvalidCondition invalid))
|
||||
validateIf x@(IfPat cond _ _)
|
||||
| isSym cond = Right x -- needs further evaluation
|
||||
| isBool cond = Right x
|
||||
| otherwise = Left (InvalidCondition cond (IfInvalidCondition cond))
|
||||
validateIf invalid = Left (GenericMalformed (XObj (Lst invalid) Nothing Nothing))
|
||||
|
||||
-- | Validation of (while cond body) expressions.
|
||||
validateWhile :: [XObj] -> Either Malformed [XObj]
|
||||
validateWhile x@(WhilePat (ListPat _ _) _) = Right x -- needs further evaluation
|
||||
validateWhile (WhilePat (ArrPat invalid _) _) = Left (InvalidCondition invalid (WhileInvalidCondition invalid))
|
||||
validateWhile x@(WhilePat cond _)
|
||||
| isSym cond = Right x -- needs further evaluation
|
||||
| isBool cond = Right x
|
||||
| otherwise = Left (InvalidCondition cond (WhileInvalidCondition cond))
|
||||
validateWhile invalid = Left (GenericMalformed (XObj (Lst invalid) Nothing Nothing))
|
||||
|
||||
-- | Validation of (def name value) expressions.
|
||||
validateDef :: [XObj] -> Either Malformed [XObj]
|
||||
validateDef x@(DefPat (UnqualifiedSymPat _ _) _) = Right x
|
||||
validateDef (DefPat (SymPat invalid _) _) = Left (QualifiedIdentifier invalid None)
|
||||
validateDef (DefPat invalid _) = Left (InvalidIdentifier invalid None)
|
||||
validateDef def = Left (GenericMalformed (XObj (Lst def) Nothing Nothing))
|
||||
|
||||
-- | Validation of (defn name [args] body) expressions.
|
||||
validateDefn :: [XObj] -> Either Malformed [XObj]
|
||||
validateDefn x@(DefnPat (UnqualifiedSymPat _ _) (ArrPat arr args) _)
|
||||
| not (all isSym args) = Left (InvalidArguments arr (DefnNonSymArgs (head (remove isSym args))))
|
||||
| not (all isUnqualifiedSym args) =
|
||||
Left (InvalidArguments arr (DefnQualifiedSyms (head (remove isUnqualifiedSym args))))
|
||||
| otherwise = pure x
|
||||
validateDefn (DefnPat (UnqualifiedSymPat _ _) invalid _) =
|
||||
Left (InvalidArguments invalid (DefnNonArrayArgs invalid))
|
||||
validateDefn (DefnPat (SymPat invalid _) _ _) = Left (QualifiedIdentifier invalid None)
|
||||
validateDefn (DefnPat invalid _ _) = Left (InvalidIdentifier invalid None)
|
||||
validateDefn defn = Left (GenericMalformed (XObj (Lst defn) Nothing Nothing))
|
||||
|
||||
-- | Validation of (the type body) expressions
|
||||
validateThe :: [XObj] -> Either Malformed [XObj]
|
||||
validateThe x@(ThePat _ t _) =
|
||||
case xobjToTy t of
|
||||
Nothing -> Left (InvalidType t (TheInvalidType t))
|
||||
Just _ -> Right x
|
||||
validateThe the = Left (GenericMalformed (XObj (Lst the) Nothing Nothing))
|
||||
|
||||
-- | Validation of (let [bindings] body) expressions.
|
||||
validateLet :: [XObj] -> Either Malformed [XObj]
|
||||
validateLet x@(LetPat (ArrPat arr binds) _)
|
||||
| odd (length binds) =
|
||||
Left (UnevenForms arr (length binds) (LetUnevenForms arr))
|
||||
| not (all isSym (evenIndices binds)) =
|
||||
Left (InvalidBindings arr (LetMalformedBinding (head (remove isSym (evenIndices binds)))))
|
||||
| otherwise = Right x
|
||||
validateLet (LetPat invalid _) = Left (InvalidBindings invalid (LetNonArrayBindings invalid))
|
||||
validateLet lett = Left (GenericMalformed (XObj (Lst lett) Nothing Nothing))
|
||||
|
||||
-- | Validation of (fn [args] body) expressions.
|
||||
validateFn :: [XObj] -> Either Malformed [XObj]
|
||||
validateFn x@(FnPat _ (ArrPat arr args) _)
|
||||
| not (all isSym args) = Left (InvalidArguments arr (FnNonSymArgs (head (remove isSym args))))
|
||||
| not (all isUnqualifiedSym args) =
|
||||
Left (InvalidArguments arr (FnQualifiedSyms (head (remove isUnqualifiedSym args))))
|
||||
| otherwise = pure x
|
||||
validateFn (FnPat _ invalid _) = Left (InvalidArguments invalid (FnNonArrayArgs invalid))
|
||||
validateFn fn = Left (GenericMalformed (XObj (Lst fn) Nothing Nothing))
|
||||
|
||||
-- | Validation of (do body) expressions.
|
||||
validateDo :: [XObj] -> Either Malformed [XObj]
|
||||
validateDo x@(DoPat forms) =
|
||||
case forms of
|
||||
[] -> Left DoMissingForms
|
||||
_ -> Right x
|
||||
validateDo doo = Left (GenericMalformed (XObj (Lst doo) Nothing Nothing))
|
||||
|
||||
-- | Validation of (function arguments) function applications.
|
||||
validateApp :: [XObj] -> Either Malformed [XObj]
|
||||
-- Special case for Refs
|
||||
validateApp x@(AppPat f@(XObj Ref _ _) args) =
|
||||
checkAppArity f [(XObj (Sym (SymPath [] "x") Symbol) Nothing Nothing)] args >> Right x
|
||||
validateApp x@(AppPat f@(ClosurePat params _ _) args) =
|
||||
checkAppArity f params args >> Right x
|
||||
validateApp x@(AppPat f@(DynamicFnPat _ params _) args) =
|
||||
checkAppArity f params args >> Right x
|
||||
validateApp x@(AppPat f@(MacroPat _ params _) args) =
|
||||
checkAppArity f params args >> Right x
|
||||
validateApp x@(AppPat f@(CommandPat arity _ _) args) =
|
||||
case arity of
|
||||
(NullaryCommandFunction _) -> checkAppArity f p args >> Right x
|
||||
(UnaryCommandFunction _) -> checkAppArity f p args >> Right x
|
||||
(BinaryCommandFunction _) -> checkAppArity f p args >> Right x
|
||||
(TernaryCommandFunction _) -> checkAppArity f p args >> Right x
|
||||
(VariadicCommandFunction _) -> Right x
|
||||
where p = (\y -> XObj (Sym (SymPath [] y) Symbol) Nothing Nothing) <$> argnames
|
||||
argnames =
|
||||
case arity of
|
||||
NullaryCommandFunction _ -> []
|
||||
UnaryCommandFunction _ -> ["x"]
|
||||
BinaryCommandFunction _ -> ["x", "y"]
|
||||
TernaryCommandFunction _ -> ["x", "y", "z"]
|
||||
VariadicCommandFunction _ -> []
|
||||
validateApp x@(AppPat f@(PrimitivePat arity _ _) args) =
|
||||
case arity of
|
||||
(NullaryPrimitive _) -> checkAppArity f p args >> Right x
|
||||
(UnaryPrimitive _) -> checkAppArity f p args >> Right x
|
||||
(BinaryPrimitive _) -> checkAppArity f p args >> Right x
|
||||
(TernaryPrimitive _) -> checkAppArity f p args >> Right x
|
||||
(QuaternaryPrimitive _) -> checkAppArity f p args >> Right x
|
||||
(VariadicPrimitive _) -> Right x
|
||||
where p = (\y -> XObj (Sym (SymPath [] y) Symbol) Nothing Nothing) <$> argnames
|
||||
argnames =
|
||||
case arity of
|
||||
NullaryPrimitive _ -> []
|
||||
UnaryPrimitive _ -> ["x"]
|
||||
BinaryPrimitive _ -> ["x", "y"]
|
||||
TernaryPrimitive _ -> ["x", "y", "z"]
|
||||
QuaternaryPrimitive _ -> ["x", "y", "z", "w"]
|
||||
VariadicPrimitive _ -> []
|
||||
validateApp (AppPat invalid _) = Left (InvalidApplication invalid)
|
||||
validateApp app = Left (GenericMalformed (XObj (Lst app) Nothing Nothing))
|
||||
|
||||
-- | Validation of (with module body) expressions
|
||||
validateWith :: [XObj] -> Either Malformed [XObj]
|
||||
validateWith x@(WithPat (SymPat _ _) _) = Right x
|
||||
validateWith (WithPat invalid _) = Left (InvalidIdentifier invalid (InvalidWith invalid))
|
||||
validateWith with = Left (GenericMalformed (XObj (Lst with) Nothing Nothing))
|
||||
|
||||
-- | Checks that the number of arguments passed to a function are correct.
|
||||
checkAppArity :: XObj -> [XObj] -> [XObj] -> Either Malformed ()
|
||||
checkAppArity xobj params args =
|
||||
let la = length args
|
||||
withRest = any ((":rest" ==) . getName) params
|
||||
lp = length params - (if withRest then 2 else 0)
|
||||
in if lp == la || (withRest && la >= lp)
|
||||
then Right ()
|
||||
else
|
||||
if la < lp
|
||||
then Left (InsufficientArguments xobj lp la params)
|
||||
else Left (TooManyArguments xobj lp la args)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Pattern Synonyms
|
||||
|
||||
pattern ArrPat :: XObj -> [XObj] -> XObj
|
||||
pattern ArrPat self members <- self@(XObj (Arr members) _ _)
|
||||
|
||||
pattern ListPat :: XObj -> [XObj] -> XObj
|
||||
pattern ListPat self members <- self@(XObj (Lst members) _ _)
|
||||
|
||||
pattern SymPat :: XObj -> SymPath -> XObj
|
||||
pattern SymPat self path <- self@(XObj (Sym path _) _ _)
|
||||
|
||||
pattern UnqualifiedSymPat :: XObj -> SymPath -> XObj
|
||||
pattern UnqualifiedSymPat self path <- self@(XObj (Sym path@(SymPath [] _) _) _ _)
|
||||
|
||||
pattern DefPat :: XObj -> XObj -> [XObj]
|
||||
pattern DefPat name value <- [XObj Def _ _, name, value]
|
||||
|
||||
pattern DefnPat :: XObj -> XObj -> XObj -> [XObj]
|
||||
pattern DefnPat name args body <- [XObj (Defn _) _ _, name, args, body]
|
||||
|
||||
pattern IfPat :: XObj -> XObj -> XObj -> [XObj]
|
||||
pattern IfPat cond true false <- [XObj If _ _, cond, true, false]
|
||||
|
||||
pattern ThePat :: XObj -> XObj -> XObj -> [XObj]
|
||||
pattern ThePat self t value <- [self@(XObj The _ _), t, value]
|
||||
|
||||
pattern LetPat :: XObj -> XObj -> [XObj]
|
||||
pattern LetPat bindings body <- [XObj Let _ _, bindings, body]
|
||||
|
||||
pattern FnPat :: XObj -> XObj -> XObj -> [XObj]
|
||||
pattern FnPat self args body <- [self@(XObj (Fn _ _) _ _), args, body]
|
||||
|
||||
pattern ClosurePat :: [XObj] -> XObj -> Context -> XObj
|
||||
pattern ClosurePat params body ctx <- XObj (Closure (XObj (Lst [_, (ArrPat _ params), body]) _ _) (CCtx ctx)) _ _
|
||||
|
||||
pattern DynamicFnPat :: XObj -> [XObj] -> XObj -> XObj
|
||||
pattern DynamicFnPat sym params body <- XObj (Lst [XObj Dynamic _ _, sym, (ArrPat _ params), body]) _ _
|
||||
|
||||
pattern MacroPat :: XObj -> [XObj] -> XObj -> XObj
|
||||
pattern MacroPat sym params body <- XObj (Lst [XObj Macro _ _, sym, (ArrPat _ params), body]) _ _
|
||||
|
||||
pattern CommandPat :: CommandFunctionType -> XObj -> [XObj] -> XObj
|
||||
pattern CommandPat arity sym params <- XObj (Lst [XObj (Command arity) _ _, sym, (ArrPat _ params)]) _ _
|
||||
|
||||
pattern PrimitivePat :: PrimitiveFunctionType -> XObj -> [XObj] -> XObj
|
||||
pattern PrimitivePat arity sym params <- XObj (Lst [XObj (Primitive arity) _ _, sym, (ArrPat _ params)]) _ _
|
||||
|
||||
pattern AppPat :: XObj -> [XObj] -> [XObj]
|
||||
pattern AppPat f args <- (f:args)
|
||||
|
||||
pattern WithPat :: XObj -> [XObj] -> [XObj]
|
||||
pattern WithPat sym forms <- (XObj With _ _: sym: forms)
|
||||
|
||||
pattern DoPat :: [XObj] -> [XObj]
|
||||
pattern DoPat forms <- (XObj Do _ _ : forms)
|
||||
|
||||
pattern WhilePat :: XObj -> XObj -> [XObj]
|
||||
pattern WhilePat cond body <- [XObj While _ _, cond, body]
|
||||
|
||||
pattern SetPat :: XObj -> XObj -> [XObj]
|
||||
pattern SetPat iden value <- [XObj SetBang _ _, iden, value]
|
||||
11
src/Obj.hs
11
src/Obj.hs
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
module Obj where
|
||||
|
||||
@ -213,6 +214,10 @@ isLiteral (XObj (Chr _) _ _) = True
|
||||
isLiteral (XObj (Bol _) _ _) = True
|
||||
isLiteral _ = False
|
||||
|
||||
isBool :: XObj -> Bool
|
||||
isBool (XObj (Bol _) _ _) = True
|
||||
isBool _ = False
|
||||
|
||||
isExternalFunction :: XObj -> Bool
|
||||
isExternalFunction (XObj (Lst (XObj (External _) _ _ : _)) _ _) = True
|
||||
isExternalFunction _ = False
|
||||
@ -561,7 +566,7 @@ instance Show EvalError where
|
||||
if null t
|
||||
then ""
|
||||
else
|
||||
"\n\nTraceback:\n"
|
||||
"\n\nTraceback:\n "
|
||||
++ unlines (map (\x -> prettyUpTo 60 x ++ showInfo (xobjInfo x)) t)
|
||||
|
||||
-- | Get the type of an XObj as a string.
|
||||
@ -1122,6 +1127,10 @@ trueXObj = XObj (Bol True) Nothing Nothing
|
||||
falseXObj :: XObj
|
||||
falseXObj = XObj (Bol False) Nothing Nothing
|
||||
|
||||
isList :: XObj -> Bool
|
||||
isList (XObj (Lst _) _ _) = True
|
||||
isList _ = False
|
||||
|
||||
-- | Applies an XObj transformation over all atomic XObjs in a form, retaining
|
||||
-- list and array structure.
|
||||
walk :: (XObj -> XObj) -> XObj -> XObj
|
||||
|
||||
@ -1 +1,3 @@
|
||||
multiarg-ref.carp:2:1 `ref` takes a single argument, but I got `(ref 1 2)`.
|
||||
multiarg-ref.carp:2:2 [ERROR] ref expected 1 arguments but received 2.
|
||||
|
||||
The arguments 2 are not needed.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user