Carp/src/Eval.hs

{-# LANGUAGE LambdaCase #-}

module Eval where

import ColorText
import Commands
import Context
import Control.Applicative
import Control.Exception
import Control.Monad.State
import Data.Either (fromRight)
import Data.Foldable (foldlM, foldrM)
import Data.List (foldl', isSuffixOf)
import Data.List.Split (splitOn, splitWhen)
import Data.Maybe (fromJust, fromMaybe, isJust)
import Emit
import qualified Env as E
import EvalError
import Expand
import Forms
import Infer
import Info
import qualified Map
import qualified Meta
import Obj
import Parsing
import Path
import Primitives
import Project
import Qualify
import qualified Set
import System.Exit (ExitCode (..), exitSuccess, exitWith)
import System.Process (readProcessWithExitCode)
import qualified Text.Parsec as Parsec
import TypeError
import Types
import Util
import Prelude hiding (exp, mod)

-- TODO: Formalize "lookup order preference" a bit better and move into
-- the Context module.
data LookupPreference
  = PreferDynamic
  | PreferGlobal
  | PreferLocal [SymPath]
  deriving (Show)

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

-- Prefer global bindings
evalStatic :: Resolver -> Context -> XObj -> IO (Context, Either EvalError XObj)
evalStatic resolver ctx xobj = eval ctx xobj PreferGlobal resolver

-- | Dynamic (REPL) evaluation of XObj:s (s-expressions)
-- Note: You might find a bunch of code of the following form both here and in
-- macroExpand:
--
-- pure (ctx, do res <- <something>
--               Right <something else with res>)
--
-- This might a little weird to you, and rightfully so. Through the nested do
-- we ensure that an evaluation is forced where it needs to be, since we depend
-- on the state here; eval is inherently stateful (because it carries around
-- the compiler’s context, which might change after each macro expansion), and
-- it gets real weird with laziness. (Note to the note: this code is mostly a
-- remnant of us using StateT, and might not be necessary anymore since we
-- switched to more explicit state-passing.)
eval :: Context -> XObj -> LookupPreference -> Resolver -> IO (Context, Either EvalError XObj)
eval ctx xobj@(XObj o info ty) preference resolver =
  case o of
    Lst body -> eval' body
    Sym spath@(SymPath p n) _ ->
      pure $
        case resolver of
          ResolveGlobal -> unwrapLookup ((tryAllLookups preference) >>= checkStatic)
          ResolveLocal -> unwrapLookup (tryAllLookups preference)
      where
        checkStatic v@(_, Right (XObj (Lst ((XObj obj _ _) : _)) _ _)) =
          if isResolvableStaticObj obj
            then pure (ctx, Left (HasStaticCall xobj info))
            else pure v
        checkStatic v = pure v
        -- all else failed, error.
        unwrapLookup =
          fromMaybe
            (throwErr (SymbolNotFound spath) ctx info)
        -- Try all lookups performs lookups for symbols based on a given
        -- lookup preference.
        tryAllLookups :: LookupPreference -> Maybe (Context, Either EvalError XObj)
        tryAllLookups PreferDynamic = (getDynamic) <|> fullLookup
        tryAllLookups PreferGlobal = (getGlobal spath) <|> fullLookup
        tryAllLookups (PreferLocal shadows) = (if spath `elem` shadows then (getLocal n) else (getDynamic)) <|> fullLookup
        fullLookup = (tryDynamicLookup <|> (if null p then tryInternalLookup spath <|> tryLookup spath else tryLookup spath))
        getDynamic :: Maybe (Context, Either EvalError XObj)
        getDynamic =
          do
            (Binder _ found) <- maybeId (E.findValueBinder (contextGlobalEnv ctx) (SymPath ("Dynamic" : p) n))
            pure (ctx, Right (resolveDef found))
        getGlobal :: SymPath -> Maybe (Context, Either EvalError XObj)
        getGlobal path =
          do
            (Binder meta found) <- maybeId (E.findValueBinder (contextGlobalEnv ctx) path)
            checkPrivate meta found
        tryDynamicLookup :: Maybe (Context, Either EvalError XObj)
        tryDynamicLookup =
          do
            (Binder meta found) <- maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath ("Dynamic" : p) n))
            checkPrivate meta found
        getLocal :: String -> Maybe (Context, Either EvalError XObj)
        getLocal name =
          do
            internal <- contextInternalEnv ctx
            (Binder _ found) <- maybeId (E.getValueBinder internal name)
            pure (ctx, Right (resolveDef found))
        -- TODO: Deprecate this function?
        -- The behavior here is a bit nefarious since it relies on cached
        -- environment parents (it calls `search` on the "internal" binder).
        -- But for now, it seems to be needed for some cases.
        tryInternalLookup :: SymPath -> Maybe (Context, Either EvalError XObj)
        tryInternalLookup path =
          --trace ("Looking for internally " ++ show path) -- ++ show (fmap (fmap E.binders . E.parent) (contextInternalEnv ctx)))
          ( contextInternalEnv ctx
              >>= \e ->
                maybeId (E.searchValueBinder e path)
                  >>= \(Binder meta found) -> checkPrivate meta found
          )
        tryLookup :: SymPath -> Maybe (Context, Either EvalError XObj)
        tryLookup path =
          ( maybeId (E.searchValueBinder (contextGlobalEnv ctx) path)
              >>= \(Binder meta found) -> checkPrivate meta found
          )
            <|> ( (maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath ((contextPath ctx) ++ p) n)))
                    >>= \(Binder meta found) -> checkPrivate meta found
                )
            <|> ( maybeId (lookupBinderInTypeEnv ctx path)
                    >>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
                )
            <|> ( foldl
                    (<|>)
                    Nothing
                    ( map
                        ( \(SymPath p' n') ->
                            maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath (p' ++ (n' : p)) n))
                              >>= \(Binder meta found) -> checkPrivate meta found
                        )
                        (Set.toList (envUseModules (contextGlobalEnv ctx)))
                    )
                )
        checkPrivate meta found =
          pure $
            if metaIsTrue meta "private"
              then throwErr (PrivateBinding (getPath found)) ctx info
              else (ctx, Right (resolveDef found))
    Arr objs -> do
      (newCtx, evaled) <- foldlM successiveEval (ctx, Right []) objs
      pure
        ( newCtx,
          do
            ok <- evaled
            Right (XObj (Arr ok) info ty)
        )
    StaticArr objs -> do
      (newCtx, evaled) <- foldlM successiveEval (ctx, Right []) objs
      pure
        ( newCtx,
          do
            ok <- evaled
            Right (XObj (StaticArr ok) info ty)
        )
    _ -> do
      (nctx, res) <- annotateWithinContext ctx xobj
      pure $ case res of
        Left e -> (nctx, Left e)
        Right (val, _) -> (nctx, Right val)
  where
    resolveDef (XObj (Lst [XObj DefDynamic _ _, _, value]) _ _) = value
    resolveDef (XObj (Lst [XObj LocalDef _ _, _, value]) _ _) = value
    resolveDef x = x
    eval' form =
      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 _ sym@(SymPat path _) forms) -> specialCommandWith ctx sym path forms
            (DoPat _ forms) -> evaluateSideEffects forms
            (WhilePat _ cond body) -> specialCommandWhile ctx cond body
            (SetPat _ iden value) -> specialCommandSet ctx (iden : [value])
            -- 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 self@(ListPat (x@(SymPat _ _) : _)) 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 (self : args)
                    Left er -> pure (ctx, Left er)
            (AppPat (ListPat _) _) -> evaluateApp form'
            (AppPat (SymPat _ _) _) -> evaluateApp form'
            (AppPat (XObj other _ _) _)
              | isResolvableStaticObj other ->
                pure (ctx, (Left (HasStaticCall xobj info)))
            [] -> 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)
        Right l -> do
          (newCtx, evald) <- eval ctx' x preference resolver
          pure $ case evald of
            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 = envParent e
          pure
            ( replaceInternalEnvMaybe 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 = if isFn x then E.insertX recFix (SymPath [] n) x else Right recFix
                  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
        l@(ListPat _) -> go l ResolveLocal
        sym@(SymPat _ _) -> go sym resolver
        _ -> pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
      where
        go x resolve =
          do
            (newCtx, f) <- eval ctx x preference resolve
            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
    XObj (Arr objs) i t -> do
      (newCtx, expanded) <- foldlM successiveExpand (ctx, Right []) objs
      pure
        ( newCtx,
          do
            ok <- expanded
            Right (XObj (Arr ok) i t)
        )
    XObj (StaticArr objs) i t -> do
      (newCtx, expanded) <- foldlM successiveExpand (ctx, Right []) objs
      pure
        ( newCtx,
          do
            ok <- expanded
            Right (XObj (StaticArr ok) i t)
        )
    XObj (Lst (XObj (Sym (SymPath [] "defmodule") _) _ _ : _)) _ _ ->
      pure (ctx, Right xobj)
    XObj (Lst [XObj (Sym (SymPath [] "quote") _) _ _, _]) _ _ ->
      pure (ctx, Right xobj)
    XObj (Lst [XObj (Lst (XObj Macro _ _ : _)) _ _]) _ _ -> evalDynamic ResolveLocal ctx xobj
    XObj (Lst (x@(XObj (Sym _ _) _ _) : args)) i t -> do
      (_, f) <- evalDynamic ResolveLocal ctx x
      case f of
        Right m@(XObj (Lst (XObj Macro _ _ : _)) _ _) -> do
          (newCtx', res) <- evalDynamic ResolveLocal ctx (XObj (Lst (m : args)) i t)
          pure (newCtx', res)
        _ -> do
          (newCtx, expanded) <- foldlM successiveExpand (ctx, Right []) args
          pure
            ( newCtx,
              do
                ok <- expanded
                Right (XObj (Lst (x : ok)) i t)
            )
    XObj (Lst objs) i t -> do
      (newCtx, expanded) <- foldlM successiveExpand (ctx, Right []) objs
      pure
        ( newCtx,
          do
            ok <- expanded
            Right (XObj (Lst ok) i t)
        )
    _ -> pure (ctx, Right xobj)
  where
    successiveExpand (ctx', acc) x =
      case acc of
        Left _ -> pure (ctx', acc)
        Right l -> do
          (newCtx, expanded) <- macroExpand ctx' x
          pure $ case expanded of
            Right res -> (newCtx, Right (l ++ [res]))
            Left err -> (newCtx, Left err)

apply :: Context -> XObj -> [XObj] -> [XObj] -> IO (Context, Either EvalError XObj)
apply ctx@Context {contextInternalEnv = internal} body params args =
  let allParams = map getName params
   in case splitWhen (":rest" ==) allParams of
        [a, b] -> callWith a b
        [a] -> callWith a []
        _ ->
          pure (throwErr (MacroBadArgumentSplit allParams) ctx Nothing)
  where
    callWith proper rest = do
      let n = length proper
          insideEnv = Env Map.empty internal Nothing Set.empty InternalEnv 0
          insideEnv' =
            foldl'
              (\e (p, x) -> fromRight (error "Couldn't add local def ") (E.insertX e (SymPath [] p) (toLocalDef p x)))
              insideEnv
              (zip proper (take n args))
          insideEnv'' =
            if null rest
              then insideEnv'
              else
                fromRight
                  (error "couldn't insert into inside env")
                  ( E.insertX
                      insideEnv'
                      (SymPath [] (head rest))
                      (XObj (Lst (drop n args)) Nothing Nothing)
                  )
          binds = if null rest then proper else proper ++ [(head rest)]
      (c, r) <- (eval (replaceInternalEnv ctx insideEnv'') body (PreferLocal (map (\x -> (SymPath [] x)) binds)) ResolveLocal)
      pure (c {contextInternalEnv = internal}, r)

-- | Parses a string and then converts the resulting forms to commands, which are evaluated in order.
executeString :: Bool -> Bool -> Context -> String -> String -> IO Context
executeString = executeStringAtLine 1

executeStringAtLine :: Int -> Bool -> Bool -> Context -> String -> String -> IO Context
executeStringAtLine line doCatch printResult ctx input fileName =
  if doCatch then catch exec (catcher ctx) else exec
  where
    exec = case parseAtLine line input fileName of
      Left parseError ->
        let sourcePos = Parsec.errorPos parseError
            parseErrorXObj =
              XObj
                (Lst [])
                ( Just
                    dummyInfo
                      { infoFile = fileName,
                        infoLine = Parsec.sourceLine sourcePos,
                        infoColumn = Parsec.sourceColumn sourcePos
                      }
                )
                Nothing
         in do
              _ <- liftIO $ treatErr ctx (replaceChars (Map.fromList [('\n', " ")]) (show parseError)) parseErrorXObj
              pure ctx
      Right xobjs -> do
        (res, ctx') <-
          foldM
            interactiveFolder
            (XObj (Lst []) (Just dummyInfo) (Just UnitTy), ctx)
            xobjs
        when
          (printResult && xobjTy res /= Just UnitTy)
          (putStrLnWithColor Yellow ("=> " ++ pretty res))
        pure ctx'
    interactiveFolder (_, context) =
      executeCommand context
    treatErr ctx' e xobj = do
      let fppl = projectFilePathPrintLength (contextProj ctx')
      case contextExecMode ctx' of
        Check -> putStrLn (machineReadableInfoFromXObj fppl xobj ++ " " ++ e)
        _ -> emitErrorWithLabel "PARSE ERROR" e
      throw CancelEvaluationException

-- | Used by functions that has a series of forms to evaluate and need to fold over them (producing a new Context in the end)
folder :: Context -> XObj -> IO Context
folder context xobj = do
  (_, ctx) <- executeCommand context xobj
  pure ctx

-- | Take a repl command and execute it.
executeCommand :: Context -> XObj -> IO (XObj, Context)
executeCommand ctx@(Context env _ _ _ _ _ _ _) xobj =
  do
    when (isJust (envModuleName env)) $
      error ("Global env module name is " ++ fromJust (envModuleName env) ++ " (should be Nothing).")
    -- The s-expression command is a special case that prefers global/static bindings over dynamic bindings
    -- when given a naked binding (no path) as an argument; (s-expr inc)
    (newCtx, result) <- if xobjIsSexp xobj then evalStatic ResolveGlobal ctx xobj else evalDynamic ResolveGlobal ctx xobj
    case result of
      Left e@EvalError {} -> do
        reportExecutionError newCtx (show e)
        pure (xobj, newCtx)
      -- special case: calling something static at the repl
      Right (XObj (Lst (XObj (Lst (XObj (Defn _) _ _ : (XObj (Sym (SymPath [] "main") _) _ _) : _)) _ _ : _)) _ _) ->
        executeCommand newCtx (withBuildAndRun (XObj (Lst []) (Just dummyInfo) Nothing))
      Left (HasStaticCall _ _) ->
        callFromRepl newCtx xobj
      Right res -> pure (res, newCtx)
  where
    callFromRepl newCtx xobj' = do
      (nc, r) <- annotateWithinContext newCtx xobj'
      case r of
        Right (ann, deps) -> do
          ctxWithDeps <- liftIO $ foldM (define True) nc (map Qualified deps)
          executeCommand ctxWithDeps (withBuildAndRun (buildMainFunction ann))
        Left err -> do
          reportExecutionError nc (show err)
          pure (xobj', nc)
    withBuildAndRun xobj' =
      XObj
        ( Lst
            [ XObj Do (Just dummyInfo) Nothing,
              xobj',
              XObj
                (Lst [XObj (Sym (SymPath [] "build") Symbol) (Just dummyInfo) Nothing, trueXObj])
                (Just dummyInfo)
                Nothing,
              XObj
                (Lst [XObj (Sym (SymPath [] "run") Symbol) (Just dummyInfo) Nothing])
                (Just dummyInfo)
                Nothing,
              (XObj (Lst []) (Just dummyInfo) (Just UnitTy))
            ]
        )
        (Just dummyInfo)
        Nothing
    xobjIsSexp (XObj (Lst (XObj (Sym (SymPath [] "s-expr") Symbol) _ _ : _)) _ _) = True
    xobjIsSexp _ = False

reportExecutionError :: Context -> String -> IO ()
reportExecutionError ctx errorMessage =
  case contextExecMode ctx of
    Check -> putStrLn errorMessage
    _ ->
      do
        emitErrorBare errorMessage
        throw CancelEvaluationException

-- | Decides what to do when the evaluation fails for some reason.
catcher :: Context -> CarpException -> IO Context
catcher ctx exception =
  case exception of
    (ShellOutException message rc) -> emitErrorWithLabel "RUNTIME ERROR" message >> stop rc
    CancelEvaluationException -> stop 1
    EvalException err -> emitError (show err) >> stop 1
  where
    stop rc =
      case contextExecMode ctx of
        Repl -> pure ctx
        Build -> exitWith (ExitFailure rc)
        Install _ -> exitWith (ExitFailure rc)
        BuildAndRun -> exitWith (ExitFailure rc)
        Check -> exitSuccess

specialCommandWith :: Context -> XObj -> SymPath -> [XObj] -> IO (Context, Either EvalError XObj)
specialCommandWith ctx _ path forms = do
  let Just env = contextInternalEnv ctx <|> maybeId (innermostModuleEnv ctx) <|> Just (contextGlobalEnv ctx)
      useThese = envUseModules env
      env' = env {envUseModules = Set.insert path useThese}
      ctx' = replaceGlobalEnv ctx env'
  ctxAfter <- liftIO $ foldM folder ctx' forms
  let Just envAfter = contextInternalEnv ctxAfter <|> maybeId (innermostModuleEnv ctxAfter) <|> Just (contextGlobalEnv ctxAfter)
      -- undo ALL use:s made inside the 'with'.
      ctxAfter' = replaceGlobalEnv ctx (envAfter {envUseModules = useThese})
  pure (ctxAfter', dynamicNil)

specialCommandDefine :: Context -> XObj -> IO (Context, Either EvalError XObj)
specialCommandDefine ctx xobj =
  do
    (newCtx, result) <- annotateWithinContext ctx xobj
    case result of
      Right (annXObj, annDeps) ->
        do
          ctxWithDeps <- liftIO $ foldM (define True) newCtx (map Qualified annDeps)
          ctxWithDef <- liftIO $ define False ctxWithDeps (Qualified annXObj)
          pure (ctxWithDef, dynamicNil)
      Left err ->
        pure (ctx, Left err)

specialCommandWhile :: Context -> XObj -> XObj -> IO (Context, Either EvalError XObj)
specialCommandWhile ctx cond body = do
  (newCtx, evd) <- evalDynamic ResolveLocal ctx cond
  case evd of
    Right c ->
      case xobjObj c of
        Bol b ->
          if b
            then do
              (newCtx', _) <- evalDynamic ResolveLocal newCtx body
              specialCommandWhile newCtx' cond body
            else pure (newCtx, dynamicNil)
        _ ->
          pure (throwErr (WhileContainsNonBool c) ctx (xobjInfo c))
    Left e -> pure (newCtx, Left e)

getSigFromDefnOrDef :: Context -> XObj -> Either EvalError (Maybe (Ty, XObj))
getSigFromDefnOrDef ctx xobj =
  let pathStrings = contextPath ctx
      globalEnv = contextGlobalEnv ctx
      fppl = projectFilePathPrintLength (contextProj ctx)
      path = getPath xobj
      fullPath = case path of
        (SymPath [] _) -> consPath pathStrings path
        (SymPath _ _) -> path
      metaData = either (const emptyMeta) id (E.lookupMeta globalEnv fullPath)
   in case Meta.get "sig" metaData of
        Just foundSignature ->
          case xobjToTy foundSignature of
            Just t ->
              let sigToken = XObj (Sym (SymPath [] "sig") Symbol) Nothing Nothing
                  nameToken = XObj (Sym (SymPath [] (getName xobj)) Symbol) Nothing Nothing
                  recreatedSigForm = XObj (Lst [sigToken, nameToken, foundSignature]) Nothing (Just MacroTy)
               in Right (Just (t, recreatedSigForm))
            Nothing -> Left (EvalError ("Can't use '" ++ pretty foundSignature ++ "' as a type signature") (contextHistory ctx) fppl (xobjInfo xobj))
        Nothing -> Right Nothing

annotateWithinContext :: Context -> XObj -> IO (Context, Either EvalError (XObj, [XObj]))
annotateWithinContext ctx xobj = do
  let globalEnv = contextGlobalEnv ctx
      typeEnv = contextTypeEnv ctx
      sig = getSigFromDefnOrDef ctx xobj
      fppl = projectFilePathPrintLength (contextProj ctx)
  case sig of
    Left err -> pure (ctx, Left err)
    Right okSig -> do
      (_, expansionResult) <- expandAll (evalDynamic ResolveLocal) ctx xobj
      case expansionResult of
        Left err -> pure (ctx, Left err)
        Right expanded ->
          let xobjFullSymbols = qualify ctx expanded
           in case xobjFullSymbols of
                Left err -> pure (evalError ctx (show err) (xobjInfo xobj))
                Right xs ->
                  case annotate typeEnv globalEnv xs okSig of
                    Left err ->
                      -- TODO: Replace this with a single call to evalError (which already checks the execution mode)
                      case contextExecMode ctx of
                        Check -> pure (evalError ctx (joinLines (machineReadableErrorStrings fppl err)) Nothing)
                        _ -> pure (evalError ctx (show err) (xobjInfo xobj))
                    Right ok -> pure (ctx, Right ok)

primitiveDefmodule :: VariadicPrimitiveCallback
primitiveDefmodule xobj ctx@(Context env i tenv pathStrings _ _ _ _) (XObj (Sym (SymPath [] moduleName) _) si _ : innerExpressions) =
  -- N.B. The `envParent` rewrite at the end of this line is important!
  -- lookups delve into parent envs by default, which is normally what we want, but in this case it leads to problems
  -- when submodules happen to share a name with an existing module or type at the global level.
  either (const (defineNewModule emptyMeta)) updateExistingModule (E.searchValueBinder ((fromRight env (E.getInnerEnv env pathStrings)) {envParent = Nothing}) (SymPath [] moduleName))
    >>= defineModuleBindings
    >>= \(newCtx, result) ->
      let updater c = (c {contextInternalEnv = (E.parent =<< contextInternalEnv c)})
       in case result of
            Left err -> pure (newCtx, Left err)
            Right _ -> pure (updater (popModulePath newCtx), dynamicNil)
  where
    --------------------------------------------------------------------------------
    -- Update an existing module by modifying its environment parents and updating the current context path.
    updateExistingModule :: Binder -> IO (Context, Either EvalError XObj)
    updateExistingModule (Binder _ (XObj (Mod innerEnv _) _ _)) =
      let updateContext =
            replacePath' (contextPath ctx ++ [moduleName])
              . replaceInternalEnv' (innerEnv {envParent = i})
       in pure (updateContext ctx, dynamicNil)
    updateExistingModule (Binder meta (XObj (Lst [XObj MetaStub _ _, _]) _ _)) =
      defineNewModule meta
    updateExistingModule _ =
      pure (throwErr (ModuleRedefinition moduleName) ctx (xobjInfo xobj))
    --------------------------------------------------------------------------------
    -- Define a brand new module with a context's current environments as its parents.
    defineNewModule :: MetaData -> IO (Context, Either EvalError XObj)
    defineNewModule meta =
      pure (fromRight ctx (updater ctx), dynamicNil)
      where
        moduleDefs = E.new (Just (fromRight env (E.getInnerEnv env pathStrings))) (Just moduleName)
        moduleTypes = E.new (Just tenv) (Just moduleName)
        newModule = XObj (Mod moduleDefs moduleTypes) si (Just ModuleTy)
        updater = \c ->
          insertInGlobalEnv' (markQualified (SymPath pathStrings moduleName)) (Binder meta newModule) c
            >>= pure . replaceInternalEnv' (moduleDefs {envParent = i})
            >>= pure . replacePath' (contextPath ctx ++ [moduleName])
    --------------------------------------------------------------------------------
    -- Define bindings for the module.
    defineModuleBindings :: (Context, Either EvalError XObj) -> IO (Context, Either EvalError XObj)
    defineModuleBindings (context, Left e) = pure (context, Left e)
    defineModuleBindings (context, _) =
      foldM step (context, dynamicNil) innerExpressions
    step :: (Context, Either EvalError XObj) -> XObj -> IO (Context, Either EvalError XObj)
    step (ctx', Left e) _ = pure (ctx', Left e)
    step (ctx', Right _) expressions =
      macroExpand ctx' expressions
        >>= \(ctx'', res) -> case res of
          Left err -> pure (ctx'', Left err)
          Right r -> evalDynamic ResolveLocal ctx'' r
primitiveDefmodule _ ctx (x : _) =
  pure (throwErr (DefmoduleContainsNonSymbol x) ctx (xobjInfo x))
primitiveDefmodule xobj ctx [] =
  pure (throwErr DefmoduleNoArgs ctx (xobjInfo xobj))

-- | "NORMAL" COMMANDS (just like the ones in Command.hs, but these need access to 'eval', etc.)

-- | Command for loading a Carp file.
commandLoad :: VariadicCommandCallback
commandLoad ctx [xobj@(XObj (Str path) i _), XObj (Str toLoad) _ _] =
  loadInternal ctx xobj path i (Just toLoad) DoesReload
commandLoad ctx [XObj (Str _) _ _, x] =
  pure $ throwErr (loadInvalidArgs [x]) ctx (xobjInfo x)
commandLoad ctx [x, _] =
  pure $ throwErr (loadInvalidArgs [x]) ctx (xobjInfo x)
commandLoad ctx [xobj@(XObj (Str path) i _)] =
  loadInternal ctx xobj path i Nothing DoesReload
commandLoad ctx x =
  pure $ throwErr (loadInvalidArgs x) ctx Nothing

commandLoadOnce :: VariadicCommandCallback
commandLoadOnce ctx [xobj@(XObj (Str path) i _), XObj (Str toLoad) _ _] =
  loadInternal ctx xobj path i (Just toLoad) Frozen
commandLoadOnce ctx [XObj (Str _) _ _, x] =
  pure $ throwErr (loadOnceInvalidArgs [x]) ctx (xobjInfo x)
commandLoadOnce ctx [x, _] =
  pure $ throwErr (loadOnceInvalidArgs [x]) ctx (xobjInfo x)
commandLoadOnce ctx [xobj@(XObj (Str path) i _)] =
  loadInternal ctx xobj path i Nothing Frozen
commandLoadOnce ctx x =
  pure $ throwErr (loadOnceInvalidArgs x) ctx Nothing

loadInternal :: Context -> XObj -> String -> Maybe Info -> Maybe String -> ReloadMode -> IO (Context, Either EvalError XObj)
loadInternal ctx xobj path i fileToLoad reloadMode = 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) :
        map (</> path) (projectCarpSearchPaths proj) -- the path from the file that contains the '(load)', or the current directory if not loading from a file (e.g. the repl)
          ++ [carpDir </> "core" </> path] -- user defined search paths
          ++ [libDir </> path]
      firstM _ [] = pure Nothing
      firstM p (x : xs) = do
        q <- p x
        if q
          then pure $ Just x
          else firstM p xs
  existingPath <- liftIO $ firstM doesFileExist fullSearchPaths
  case existingPath of
    Nothing ->
      if '@' `elem` path
        then tryInstall path
        else pure $ invalidPath ctx path
    Just firstPathFound ->
      do
        canonicalPath <- liftIO (canonicalizePath firstPathFound)
        fileThatLoads <- liftIO (canonicalizePath $ maybe "" infoFile i)
        if canonicalPath == fileThatLoads
          then pure $ cantLoadSelf ctx path
          else do
            let alreadyLoaded = projectAlreadyLoaded proj ++ frozenPaths proj
            if canonicalPath `elem` alreadyLoaded
              then pure (ctx, dynamicNil)
              else do
                contents <- liftIO $ slurp canonicalPath
                let files = projectFiles proj
                    files' =
                      if canonicalPath `elem` map fst files
                        then files
                        else files ++ [(canonicalPath, reloadMode)]
                    prevStack = projectLoadStack proj
                    proj' =
                      proj
                        { projectFiles = files',
                          projectAlreadyLoaded = canonicalPath : alreadyLoaded,
                          projectLoadStack = canonicalPath : prevStack
                        }
                newCtx <- liftIO $ executeString True False (replaceProject ctx proj') contents canonicalPath
                pure (replaceProject newCtx (contextProj newCtx) {projectLoadStack = prevStack}, dynamicNil)
  where
    frozenPaths proj =
      if projectForceReload proj
        then [] -- No paths are Frozen when the "force reload" project setting is true.
        else map fst $ filter (isFrozen . snd) (projectFiles proj)
    isFrozen Frozen = True
    isFrozen _ = False
    invalidPath ctx' path' =
      throwErr (LoadFileNotFound path') ctx' (xobjInfo xobj)
    invalidPathWith ctx' path' stderr cleanup cleanupPath = do
      _ <- liftIO $ when cleanup (removeDirectoryRecursive cleanupPath)
      pure $
        throwErr (LoadGitFailure path' stderr) ctx' (xobjInfo xobj)
    replaceC _ _ [] = []
    replaceC c s (a : b) = if a == c then s ++ replaceC c s b else a : replaceC c s b
    cantLoadSelf ctx' path' =
      throwErr (LoadRecursiveLoad path') ctx' (xobjInfo xobj)
    tryInstall path' =
      let split = splitOn "@" path'
       in tryInstallWithCheckout (joinWith "@" (init split)) (last split)
    fromURL url =
      let split = splitOn "/" (replaceC ':' "_COLON_" url)
          first = head split
       in if first `elem` ["https_COLON_", "http_COLON_"]
            then joinWith "/" (tail (tail split))
            else
              if '@' `elem` first
                then joinWith "/" (joinWith "@" (tail (splitOn "@" first)) : tail split)
                else url
    tryInstallWithCheckout path' toCheckout = do
      let proj = contextProj ctx
      fpath <- liftIO $ cachePath $ projectLibDir proj </> fromURL path' </> toCheckout
      cur <- liftIO getCurrentDirectory
      pathExists <- liftIO $ doesPathExist fpath
      let cleanup = not pathExists
      _ <- liftIO $ createDirectoryIfMissing True fpath
      _ <- liftIO $ setCurrentDirectory fpath
      (_, txt, _) <- liftIO $ readProcessWithExitCode "git" ["rev-parse", "--abbrev-ref=loose", "HEAD"] ""
      if txt == "HEAD\n"
        then do
          _ <- liftIO $ setCurrentDirectory cur
          doGitLoad path' fpath
        else do
          _ <- liftIO $ readProcessWithExitCode "git" ["init"] ""
          _ <- liftIO $ readProcessWithExitCode "git" ["remote", "add", "origin", path'] ""
          (x0, _, stderr0) <- liftIO $ readProcessWithExitCode "git" ["fetch", "--all", "--tags"] ""
          case x0 of
            ExitFailure _ -> do
              _ <- liftIO $ setCurrentDirectory cur
              invalidPathWith ctx path' stderr0 cleanup fpath
            ExitSuccess -> do
              (x1, _, stderr1) <- liftIO $ readProcessWithExitCode "git" ["checkout", toCheckout] ""
              _ <- liftIO $ setCurrentDirectory cur
              case x1 of
                ExitSuccess -> doGitLoad path' fpath
                ExitFailure _ -> invalidPathWith ctx path' stderr1 cleanup fpath
    doGitLoad path' fpath =
      case fileToLoad of
        Just file -> commandLoad ctx [XObj (Str (fpath </> file)) Nothing Nothing]
        Nothing ->
          -- we’re guessing what file to use here
          let fName = last (splitOn "/" path')
              realName' =
                if ".git" `isSuffixOf` fName
                  then take (length fName - 4) fName
                  else fName
              realName =
                if ".carp" `isSuffixOf` realName'
                  then realName'
                  else realName' ++ ".carp"
              fileToLoad' = fpath </> realName
              mainToLoad = fpath </> "main.carp"
           in do
                (newCtx, res) <- commandLoad ctx [XObj (Str fileToLoad') Nothing Nothing]
                case res of
                  ret@(Right _) -> pure (newCtx, ret)
                  Left _ -> commandLoad ctx [XObj (Str mainToLoad) Nothing Nothing]

-- | Load several files in order.
loadFiles :: Context -> [FilePath] -> IO Context
loadFiles = loadFilesExt commandLoad

loadFilesOnce :: Context -> [FilePath] -> IO Context
loadFilesOnce = loadFilesExt commandLoadOnce

loadFilesExt :: VariadicCommandCallback -> Context -> [FilePath] -> IO Context
loadFilesExt loadCmd = foldM load
  where
    load :: Context -> FilePath -> IO Context
    load ctx file = do
      (newCtx, ret) <- loadCmd ctx [XObj (Str file) Nothing Nothing]
      case ret of
        Left err -> throw (EvalException err)
        Right _ -> pure newCtx

-- | Command for reloading all files in the project (= the files that has been loaded before).
commandReload :: NullaryCommandCallback
commandReload ctx = do
  let paths = projectFiles (contextProj ctx)
      f :: Context -> (FilePath, ReloadMode) -> IO Context
      f context (_, Frozen) | not (projectForceReload (contextProj context)) = pure context
      f context (filepath, _) =
        do
          let proj = contextProj context
              alreadyLoaded = projectAlreadyLoaded proj
          if filepath `elem` alreadyLoaded
            then pure context
            else do
              contents <- slurp filepath
              let proj' = proj {projectAlreadyLoaded = filepath : alreadyLoaded}
              executeString False False (replaceProject context proj') contents filepath
  newCtx <- liftIO (foldM f ctx paths)
  pure (newCtx, dynamicNil)

-- | Command for expanding a form and its macros.
commandExpand :: UnaryCommandCallback
commandExpand = macroExpand

-- | This function will show the resulting C code from an expression.
-- | i.e. (Int.+ 2 3) => "_0 = 2 + 3"
commandC :: UnaryCommandCallback
commandC ctx xobj = do
  (newCtx, result) <- expandAll (evalDynamic ResolveLocal) ctx xobj
  case result of
    Left err -> pure (newCtx, Left err)
    Right expanded -> do
      (_, annotated) <- annotateWithinContext newCtx expanded
      case annotated of
        Left err -> pure $ evalError newCtx (show err) (xobjInfo xobj)
        Right (annXObj, annDeps) ->
          do
            let cXObj = printC annXObj
                cDeps = concatMap printC annDeps
                c = cDeps ++ cXObj
            liftIO (putStr c)
            pure (newCtx, dynamicNil)

-- | This function will return the compiled AST.
commandExpandCompiled :: UnaryCommandCallback
commandExpandCompiled ctx xobj = do
  (newCtx, result) <- expandAll (evalDynamic ResolveLocal) ctx xobj
  case result of
    Left err -> pure (newCtx, Left err)
    Right expanded -> do
      (_, annotated) <- annotateWithinContext newCtx expanded
      case annotated of
        Left err -> pure $ evalError newCtx (show err) (xobjInfo xobj)
        Right (annXObj, _) -> pure (newCtx, Right annXObj)

-- | Helper function for commandC
printC :: XObj -> String
printC xobj =
  case checkForUnresolvedSymbols xobj of
    Left e ->
      strWithColor Red (show e ++ ", can't print resulting code.\n")
    Right _ ->
      strWithColor Green (toC All (Binder emptyMeta xobj))

buildMainFunction :: XObj -> XObj
buildMainFunction xobj =
  XObj
    ( Lst
        [ XObj (Defn Nothing) di Nothing,
          XObj (Sym (SymPath [] "main") Symbol) di Nothing,
          XObj (Arr []) di Nothing,
          XObj
            ( Lst
                [ XObj Do di Nothing,
                  case xobjTy xobj of
                    Nothing -> error "buildmainfunction"
                    Just UnitTy -> xobj
                    Just (RefTy _ _) ->
                      XObj
                        (Lst [XObj (Sym (SymPath [] "println*") Symbol) di Nothing, xobj])
                        di
                        (Just UnitTy)
                    Just _ ->
                      XObj
                        ( Lst
                            [ XObj (Sym (SymPath [] "println*") Symbol) di Nothing,
                              XObj
                                (Lst [XObj Ref di Nothing, xobj])
                                di
                                (Just UnitTy)
                            ]
                        )
                        di
                        (Just UnitTy),
                  XObj (Num IntTy 0) di Nothing
                ]
            )
            di
            Nothing
        ]
    )
    di
    (Just (FuncTy [] UnitTy StaticLifetimeTy))
  where
    di = Just dummyInfo

primitiveDefdynamic :: BinaryPrimitiveCallback
primitiveDefdynamic _ ctx (XObj (Sym (SymPath [] name) _) _ _) value = do
  (newCtx, result) <- evalDynamic ResolveLocal ctx value
  case result of
    Left err -> pure (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 _ =
  pure (throwErr (DefnDynamicInvalidName notName) ctx (xobjInfo notName))

specialCommandSet :: Context -> [XObj] -> IO (Context, Either EvalError XObj)
specialCommandSet ctx [orig@(XObj (Sym path@(SymPath _ _) _) _ _), val] =
  let lookupInternal =
        maybe (Left "") Right (contextInternalEnv ctx)
          >>= \e ->
            unwrapErr (E.searchValueBinder e path)
              >>= \binder -> pure (binder, setInternal, e)
      lookupGlobal =
        Right (contextGlobalEnv ctx)
          >>= \e ->
            unwrapErr (E.searchValueBinder e path)
              >>= \binder -> pure (binder, setGlobal, e)
   in either
        ((const (pure $ (throwErr (SetVarNotFound orig) ctx (xobjInfo orig)))))
        (\(binder', setter', env') -> evalAndSet binder' setter' env')
        (lookupInternal <> lookupGlobal)
  where
    evalAndSet :: Binder -> (Context -> Env -> Either EvalError XObj -> Binder -> IO (Context, Either EvalError XObj)) -> Env -> IO (Context, Either EvalError XObj)
    evalAndSet binder setter env =
      case xobjTy (binderXObj binder) of
        -- don't type check dynamic or untyped bindings
        -- TODO: Figure out why untyped cases are sometimes coming into set!
        Just DynamicTy -> handleUnTyped
        Nothing -> handleUnTyped
        _ ->
          evalDynamic ResolveLocal ctx val
            >>= \(newCtx, result) ->
              case result of
                Right evald -> typeCheckValueAgainstBinder newCtx evald binder >>= \(nctx, typedVal) -> setter nctx env typedVal binder
                left -> pure (newCtx, left)
      where
        handleUnTyped :: IO (Context, Either EvalError XObj)
        handleUnTyped =
          evalDynamic ResolveLocal ctx val
            >>= \(newCtx, result) -> setter newCtx env result binder
    setGlobal :: Context -> Env -> Either EvalError XObj -> Binder -> IO (Context, Either EvalError XObj)
    setGlobal ctx' env value binder =
      pure $ either (failure ctx' orig) (success ctx') value
      where
        success c xo = (replaceGlobalEnv c (setStaticOrDynamicVar path env binder xo), dynamicNil)
    setInternal :: Context -> Env -> Either EvalError XObj -> Binder -> IO (Context, Either EvalError XObj)
    setInternal ctx' env value binder =
      pure $ either (failure ctx' orig) (success ctx') value
      where
        success c xo = (replaceInternalEnv c (setStaticOrDynamicVar path env binder xo), dynamicNil)
specialCommandSet ctx [notName, _] =
  pure (throwErr (SetInvalidVarName notName) ctx (xobjInfo notName))
specialCommandSet ctx args =
  pure (throwErr (setInvalidArgs args) ctx (if null args then Nothing else xobjInfo (head args)))

-- | Convenience method for signifying failure in a given context.
failure :: Context -> XObj -> EvalError -> (Context, Either EvalError a)
failure ctx orig err = evalError ctx (show err) (xobjInfo orig)

-- | Given a context, value XObj and an existing binder, check whether or not
-- the given value has a type matching the binder's in the given context.
typeCheckValueAgainstBinder :: Context -> XObj -> Binder -> IO (Context, Either EvalError XObj)
typeCheckValueAgainstBinder ctx val binder = do
  (ctx', typedValue) <- annotateWithinContext ctx val
  pure $ case typedValue of
    Right (val', _) -> go ctx' binderTy val'
    Left err -> (ctx', Left err)
  where
    path = getPath (binderXObj binder)
    binderTy = xobjTy (binderXObj binder)
    typeErr x = throwErr (SetTypeMismatch path (fromJust (xobjTy x)) (fromJust binderTy)) ctx (xobjInfo x)
    go ctx'' (Just DynamicTy) x = (ctx'', Right x)
    go ctx'' t x@(XObj _ _ t') = if t == t' then (ctx'', Right x) else typeErr x

-- | Sets a variable, checking whether or not it is static or dynamic, and
-- assigns an appropriate type to the variable.
-- Returns a new environment containing the assignment.
setStaticOrDynamicVar :: SymPath -> Env -> Binder -> XObj -> Env
setStaticOrDynamicVar path@(SymPath _ name) env binder value =
  case binder of
    (Binder meta (XObj (Lst (def@(XObj Def _ _) : sym : _)) _ t)) ->
      fromRight env (E.insert env path (Binder meta (XObj (Lst [def, sym, value]) (xobjInfo value) t)))
    (Binder meta (XObj (Lst (defdy@(XObj DefDynamic _ _) : sym : _)) _ _)) ->
      fromRight env (E.insert env path (Binder meta (XObj (Lst [defdy, sym, value]) (xobjInfo value) (Just DynamicTy))))
    (Binder meta (XObj (Lst (lett@(XObj LocalDef _ _) : sym : _)) _ t)) ->
      fromRight (error "FAILED!") (E.replaceInPlace env name (Binder meta (XObj (Lst [lett, sym, value]) (xobjInfo value) t)))
    -- shouldn't happen, errors are thrown at call sites.
    -- TODO: Return an either here to propagate error.
    _ -> env

primitiveEval :: UnaryPrimitiveCallback
primitiveEval _ ctx val = do
  -- primitives don’t evaluate their arguments, so this needs to double-evaluate
  (newCtx, arg) <- evalDynamic ResolveLocal ctx val
  case arg of
    Left err -> pure (newCtx, Left err)
    Right evald -> do
      (newCtx', expanded) <- macroExpand newCtx evald
      case expanded of
        Left err -> pure (newCtx', Left err)
        Right ok -> do
          (finalCtx, res) <- evalDynamic ResolveLocal newCtx' ok
          pure $ case res of
            Left (HasStaticCall x i) -> throwErr (StaticCall x) ctx i
            _ -> (finalCtx, res)

dynamicOrMacro :: Context -> Obj -> Ty -> String -> XObj -> XObj -> IO (Context, Either EvalError XObj)
dynamicOrMacro ctx pat ty name params body = do
  (ctx', exp) <- macroExpand ctx body
  case exp of
    Right expanded ->
      dynamicOrMacroWith ctx' (\path -> [XObj pat Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing, params, expanded]) ty name body
    Left _ -> pure (ctx, exp)

primitiveDefndynamic :: TernaryPrimitiveCallback
primitiveDefndynamic _ ctx (XObj (Sym (SymPath [] name) _) _ _) params body =
  dynamicOrMacro ctx Dynamic DynamicTy name params body
primitiveDefndynamic _ ctx notName _ _ =
  argumentErr ctx "defndynamic" "a name" "first" notName

primitiveDefmacro :: TernaryPrimitiveCallback
primitiveDefmacro _ ctx (XObj (Sym (SymPath [] name) _) _ _) params body =
  dynamicOrMacro ctx Macro MacroTy name params body
primitiveDefmacro _ ctx notName _ _ =
  argumentErr ctx "defmacro" "a name" "first" notName