content: {-# LANGUAGE TupleSections #-}
  
  module Primitives where
  
  import ColorText
  import Commands
  import Context
  import Control.Applicative
  import Control.Monad (foldM, unless, when)
  import Control.Monad.IO.Class (MonadIO, liftIO)
  import Data.Bifunctor
  import Data.Either (fromRight, isRight, rights)
  import Data.Functor ((<&>))
  import Data.List (foldl')
  import Data.Maybe (fromJust, fromMaybe)
  import Deftype
  import Emit
  import Env (addUsePath, contextEnv, insert, lookupBinderEverywhere, lookupEverywhere, lookupMeta, searchValueBinder)
  import EvalError
  import Infer
  import Info
  import Interfaces
  import Managed
  import qualified Map
  import qualified Meta
  import Obj
  import PrimitiveError
  import Project
  import Qualify (Qualified (..), QualifiedPath, getQualifiedPath, markQualified, qualify, qualifyNull, qualifyPath, unqualify)
  import Reify
  import Sumtypes
  import SymPath
  import Template
  import ToTemplate
  import TypeError
  import TypePredicates
  import Types
  import Util
  import Web.Browser (openBrowser)
  
  makeNullaryPrim :: SymPath -> NullaryPrimitiveCallback -> String -> String -> (String, Binder)
  makeNullaryPrim p = makePrim p . NullaryPrimitive
  
  makeUnaryPrim :: SymPath -> UnaryPrimitiveCallback -> String -> String -> (String, Binder)
  makeUnaryPrim p = makePrim p . UnaryPrimitive
  
  makeBinaryPrim :: SymPath -> BinaryPrimitiveCallback -> String -> String -> (String, Binder)
  makeBinaryPrim p = makePrim p . BinaryPrimitive
  
  makeTernaryPrim :: SymPath -> TernaryPrimitiveCallback -> String -> String -> (String, Binder)
  makeTernaryPrim p = makePrim p . TernaryPrimitive
  
  makeQuaternaryPrim :: SymPath -> QuaternaryPrimitiveCallback -> String -> String -> (String, Binder)
  makeQuaternaryPrim p = makePrim p . QuaternaryPrimitive
  
  makeVariadicPrim :: SymPath -> VariadicPrimitiveCallback -> String -> String -> (String, Binder)
  makeVariadicPrim p = makePrim p . VariadicPrimitive
  
  argumentErr :: Context -> String -> String -> String -> XObj -> IO (Context, Either EvalError XObj)
  argumentErr ctx fun ty number actual =
    pure (toEvalError ctx actual (ArgumentTypeError fun ty number actual))
  
  makePrim :: SymPath -> PrimitiveFunctionType -> String -> String -> (String, Binder)
  makePrim path callback doc example =
    (name, Binder meta prim)
    where
      SymPath _ name = path
      exampleUsage = "Example Usage:\n```\n" ++ example ++ "\n```\n"
      docString = doc ++ "\n\n" ++ exampleUsage
      meta = Meta.set "doc" (XObj (Str docString) Nothing Nothing) emptyMeta
      prim =
        XObj
          ( Lst
              [ XObj (Primitive callback) (Just dummyInfo) Nothing,
                XObj (Sym path Symbol) Nothing Nothing,
                XObj (Arr args) Nothing Nothing
              ]
          )
          (Just dummyInfo {infoFile = "Core Primitives"})
          (Just DynamicTy)
      args = (\x -> XObj (Sym (SymPath [] x) Symbol) Nothing Nothing) <$> argnames
      argnames = case callback of
        NullaryPrimitive _ -> []
        UnaryPrimitive _ -> ["x"]
        BinaryPrimitive _ -> ["x", "y"]
        TernaryPrimitive _ -> ["x", "y", "z"]
        QuaternaryPrimitive _ -> ["x", "y", "z", "w"]
        VariadicPrimitive _ -> []
  
  infoXObjOrError :: Context -> (Context, Either EvalError XObj) -> Maybe Info -> Maybe XObj -> (Context, Either EvalError XObj)
  infoXObjOrError ctx err i = maybe err (\xobj -> (ctx, Right xobj {xobjInfo = i}))
  
  primitiveFile :: VariadicPrimitiveCallback
  primitiveFile x@(XObj _ i _) ctx args =
    pure $ case args of
      [] -> infoXObjOrError ctx err i (getFileAsXObj fppl i)
      [XObj _ mi _] -> infoXObjOrError ctx err i (getFileAsXObj fppl mi)
      _ -> toEvalError ctx x (ArgumentArityError x "0 or 1" args)
    where
      fppl = projectFilePathPrintLength (contextProj ctx)
      err = toEvalError ctx x (MissingInfo x)
  
  primitiveLine :: VariadicPrimitiveCallback
  primitiveLine x@(XObj _ i _) ctx args =
    pure $ case args of
      [] -> infoXObjOrError ctx err i (getLineAsXObj i)
      [XObj _ mi _] -> infoXObjOrError ctx err i (getLineAsXObj mi)
      _ -> toEvalError ctx x (ArgumentArityError x "0 or 1" args)
    where
      err = toEvalError ctx x (MissingInfo x)
  
  primitiveColumn :: VariadicPrimitiveCallback
  primitiveColumn x@(XObj _ i _) ctx args =
    pure $ case args of
      [] -> infoXObjOrError ctx err i (getColumnAsXObj i)
      [XObj _ mi _] -> infoXObjOrError ctx err i (getColumnAsXObj mi)
      _ -> toEvalError ctx x (ArgumentArityError x "0 or 1" args)
    where
      err = toEvalError ctx x (MissingInfo x)
  
  primitiveImplements :: BinaryPrimitiveCallback
  primitiveImplements _ ctx x@(XObj (Sym interface@(SymPath _ _) _) _ _) (XObj (Sym path _) _ _) =
    do
      (maybeInterface, maybeImpl) <- pure (lookupInterface ctx interface, lookupBinderInGlobalEnv ctx qpath)
      case (maybeInterface, maybeImpl) of
        (_, Left _) -> updateMeta (Meta.stub (contextualize path ctx)) ctx
        (Left _, Right implBinder) ->
          warn >> updateMeta implBinder ctx
        (Right interfaceBinder, Right implBinder) ->
          -- N.B. The found binding will be fully qualified!
          addToInterface interfaceBinder implBinder
    where
      qpath = qualifyNull ctx path
      warn :: IO ()
      warn = emitWarning (show (NonExistentInterfaceWarning x))
      addToInterface :: Binder -> Binder -> IO (Context, Either EvalError XObj)
      addToInterface inter impl =
        let (newCtx, maybeErr) = case registerInInterface ctx impl inter of
              (Right nc, me) -> (nc, me)
              _ -> error "primitives: failed to register in interface"
         in maybe (updateMeta impl newCtx) (handleError newCtx impl) maybeErr
      handleError :: Context -> Binder -> InterfaceError -> IO (Context, Either EvalError XObj)
      handleError context impl e@(AlreadyImplemented _ oldImplPath _ _) =
        emitWarning (show e) >> pure (removeInterfaceFromImplements oldImplPath x context) >>= updateMeta impl
      handleError context _ e =
        emitError (show e) >> pure (evalError context (show e) (xobjInfo x))
      updateMeta :: Binder -> Context -> IO (Context, Either EvalError XObj)
      updateMeta binder context =
        pure (fromRight (error "Couldn't insert updated meta!!") (fromJust updater), dynamicNil)
        where
          updater =
            ( ( Meta.getBinderMetaValue "implements" binder
                  <&> updateImplementations binder
              )
                <|> Just (updateImplementations binder (XObj (Lst []) (Just dummyInfo) (Just DynamicTy)))
            )
              >>= pure . (insertInGlobalEnv context qpath)
          updateImplementations :: Binder -> XObj -> Binder
          updateImplementations implBinder (XObj (Lst impls) inf ty) =
            if x `elem` impls
              then binder
              else Meta.updateBinderMeta implBinder "implements" (XObj (Lst (x : impls)) inf ty)
          updateImplementations implBinder _ =
            Meta.updateBinderMeta implBinder "implements" (XObj (Lst [x]) (Just dummyInfo) (Just DynamicTy))
  primitiveImplements x ctx (XObj (Sym _ _) _ _) y =
    pure $ toEvalError ctx x (ArgumentTypeError "implements" "a symbol" "second" y)
  primitiveImplements _ ctx x _ =
    pure $ toEvalError ctx x (ArgumentTypeError "implements" "a symbol" "first" x)
  
  -- N.B. Symbols come into this function FULLY QUALIFIED!
  -- see Eval.hs annotateWithinContext
  define :: Bool -> Context -> Qualified -> IO Context
  define hidden ctx qualifiedXObj =
    pure (if hidden then (Meta.hide freshBinder) else freshBinder)
      >>= \newBinder ->
        if isTypeDef annXObj
          then defineInTypeEnv newBinder
          else defineInGlobalEnv newBinder
    where
      annXObj = unQualified qualifiedXObj
      freshBinder = toBinder annXObj
      qpath = getQualifiedPath qualifiedXObj
      defineInTypeEnv :: Binder -> IO Context
      defineInTypeEnv = pure . fromRight ctx . (insertTypeBinder ctx qpath)
      defineInGlobalEnv :: Binder -> IO Context
      defineInGlobalEnv newBinder =
        when (projectEchoC (contextProj ctx) && canBeEmitted annXObj) (putStrLn (toC All (Binder emptyMeta annXObj)))
          >> case (lookupBinderInGlobalEnv ctx qpath) of
            Left _ -> pure (fromRight ctx (insertInGlobalEnv ctx qpath newBinder))
            Right oldBinder -> redefineExistingBinder oldBinder newBinder
      canBeEmitted :: XObj -> Bool
      canBeEmitted x = isRight (checkForUnresolvedSymbols x)
      redefineExistingBinder :: Binder -> Binder -> IO Context
      redefineExistingBinder old@(Binder meta _) (Binder _ x) =
        do
          unless (isInstantiation (binderXObj old)) (warnTypeChange old)
          -- TODO: Merge meta more elegantly.
          updatedContext <- (implementInterfaces (Binder meta x))
          pure (fromRight (error ("Failed to insert " ++ show qpath)) (insertInGlobalEnv updatedContext qpath (Binder meta x)))
      isInstantiation (XObj (Lst (XObj (Instantiate _) _ _ : _)) _ _) = True
      isInstantiation _ = False
      warnTypeChange :: Binder -> IO ()
      warnTypeChange binder =
        unless (areUnifiable (forceTy annXObj) previousType) warn
        where
          previousType = forceTy (binderXObj binder)
          warn :: IO ()
          warn =
            emitWarning (show (DefinitionTypeChangeWarning annXObj previousType))
      implementInterfaces :: Binder -> IO Context
      implementInterfaces binder =
        pure
          ( Meta.getBinderMetaValue "implements" binder
              -- TODO: Direct qualification!
              >>= \x -> case x of
                (XObj (Lst interfaces) _ _) -> pure (map Qualified interfaces)
                _ -> pure []
          )
          >>= \maybeinterfaces ->
            pure (rights (fmap (lookupBinderInTypeEnv ctx . getQualifiedPath) (fromMaybe [] maybeinterfaces)))
              >>= \interfaceBinders ->
                pure (foldl' (\(ctx', _) interface -> first (fromRight ctx') (registerInInterface ctx' binder interface)) (ctx, Nothing) interfaceBinders)
                  >>= \(newCtx, err) -> case err of
                    Just e -> printError (contextExecMode ctx) (show e) >> pure ctx
                    Nothing -> pure newCtx
      printError :: ExecutionMode -> String -> IO ()
      printError Check e =
        let fppl = projectFilePathPrintLength (contextProj ctx)
         in putStrLn (machineReadableInfoFromXObj fppl annXObj ++ " " ++ e)
      printError _ e = putStrLnWithColor Red e
  
  primitiveRegisterType :: VariadicPrimitiveCallback
  primitiveRegisterType _ ctx [XObj (Sym (SymPath [] t) _) _ _] =
    primitiveRegisterTypeWithoutFields ctx t Nothing
  primitiveRegisterType _ ctx [x] =
    pure (evalError ctx ("`register-type` takes a symbol, but it got " ++ pretty x) (xobjInfo x))
  primitiveRegisterType _ ctx [x@(XObj (Sym (SymPath [] _) _) _ _), XObj (Str "") _ _] =
    pure (evalError ctx ("cannot register type " ++ pretty x ++ " with an empty string override, this will produce invalid C") (xobjInfo x))
  primitiveRegisterType _ ctx [XObj (Sym (SymPath [] t) _) _ _, XObj (Str override) _ _] =
    primitiveRegisterTypeWithoutFields ctx t (Just override)
  primitiveRegisterType _ ctx [x@(XObj (Sym (SymPath [] t) _) _ _), XObj (Str override) _ _, members] =
    primitiveRegisterTypeWithFields ctx x t (Just override) members
  primitiveRegisterType _ ctx [x@(XObj (Sym (SymPath [] t) _) _ _), members] =
    primitiveRegisterTypeWithFields ctx x t Nothing members
  primitiveRegisterType x ctx _ = pure (toEvalError ctx x RegisterTypeError)
  
  -- | Register an external type that has no fields.
  primitiveRegisterTypeWithoutFields :: Context -> String -> Maybe String -> IO (Context, Either EvalError XObj)
  primitiveRegisterTypeWithoutFields ctx t override = do
    let path = SymPath (contextPath ctx) t
        typeDefinition = XObj (Lst [XObj (ExternalType override) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]) Nothing (Just TypeTy)
    -- TODO: Support registering types in modules
    case insertTypeBinder ctx (markQualified path) (toBinder typeDefinition) of
      Left e -> pure (evalError ctx (show e) Nothing)
      Right c -> pure (c, dynamicNil)
  
  -- | Register an external type that has fields.
  primitiveRegisterTypeWithFields :: Context -> XObj -> String -> Maybe String -> XObj -> IO (Context, Either EvalError XObj)
  primitiveRegisterTypeWithFields ctx x t override members =
    either
      handleErr
      updateContext
      (bindingsForRegisteredType (contextTypeEnv ctx) (contextGlobalEnv ctx) (contextPath ctx) t [members] Nothing preExistingModule)
    where
      handleErr e = pure $ makeEvalError ctx (Just e) (show e) (xobjInfo x)
      updateContext (typeModuleName, typeModuleXObj, deps) =
        do
          let typeDefinition = XObj (Lst [XObj (ExternalType override) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]) Nothing (Just TypeTy)
              path' = (qualifyPath ctx (SymPath [] typeModuleName))
              update = \c -> insertInGlobalEnv' path' (toBinder typeModuleXObj) c >>= insertTypeBinder' path' (toBinder typeDefinition)
              ctx' = fromRight (error "primitives: failed to update context in register type") $ update ctx
          -- TODO: Another case where define does not get formally qualified deps!
          contextWithDefs <- liftIO $ foldM (define True) ctx' (map Qualified deps)
          autoDerive
            contextWithDefs
            (StructTy (ConcreteNameTy (unqualify path')) [])
            [ lookupBinderInTypeEnv contextWithDefs (markQualified (SymPath [] "str")),
              lookupBinderInTypeEnv contextWithDefs (markQualified (SymPath [] "prn"))
            ]
      path = SymPath (contextPath ctx) t
      preExistingModule = case lookupBinderInGlobalEnv ctx path of
        Right (Binder _ (XObj (Mod found et) _ _)) -> Just (found, et)
        _ -> Nothing
  
  notFound :: Context -> XObj -> SymPath -> IO (Context, Either EvalError XObj)
  notFound ctx x path = pure (toEvalError ctx x (SymbolNotFoundError path))
  
  -- | Get information about a binding.
  primitiveInfo :: UnaryPrimitiveCallback
  primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ name) _) _ _) =
    case path of
      SymPath [] _ ->
        do
          let found = lookupBinderInTypeEnv ctx path
          _ <- printIfFound found
          _ <- printInterfaceImplementationsOrAll found otherBindings
          either (const (notFound ctx target path)) (const ok) (found <> fmap head otherBindings)
        where
          otherBindings =
            fmap (: []) (lookupBinderInContextEnv ctx path)
              <> (Right (lookupBinderEverywhere (contextGlobalEnv ctx) name))
      _ ->
        do
          let found = lookupBinderInTypeEnv ctx path
          let others = lookupBinderInContextEnv ctx path
          _ <- printIfFound found
          _ <- either (const (pure ())) printer others
          either (const (notFound ctx target path)) (const ok) (found <> others)
    where
      ok :: IO (Context, Either EvalError XObj)
      ok = pure (ctx, dynamicNil)
      printInterfaceImplementationsOrAll :: Either ContextError Binder -> Either ContextError [Binder] -> IO ()
      printInterfaceImplementationsOrAll interface impls =
        either
          (const (pure ()))
          (foldM (\_ binder -> printer binder) ())
          ( ( interface
                >>= \binder ->
                  pure (xobjObj (binderXObj binder))
                    >>= \obj ->
                      case obj of
                        (Lst [XObj (Interface _ _) _ _, _]) ->
                          fmap (filter (implementsInterface binder)) impls
                        _ -> impls
            )
              <> impls
          )
      implementsInterface :: Binder -> Binder -> Bool
      implementsInterface binder binder' =
        maybe
          False
          ( \x -> case x of
              (XObj (Lst impls) _ _) -> getBinderPath binder `elem` map getPath impls
              _ -> False
          )
          (Meta.getBinderMetaValue "implements" binder')
      printIfFound :: Either ContextError Binder -> IO ()
      printIfFound = either (const (pure ())) printer
      printer :: Binder -> IO ()
      printer binder@(Binder metaData x@(XObj _ (Just i) _)) =
        putStrLnWithColor Blue (forceShowBinder binder)
          >> putStrLn ("  Defined at " ++ prettyInfo i)
          >> printMeta metaData (contextProj ctx) x
      printer binder@(Binder metaData x) =
        print binder
          >> printMeta metaData (contextProj ctx) x
      printMeta :: MetaData -> Project -> XObj -> IO ()
      printMeta metaData proj x =
        maybe (pure ()) (printMetaVal "Documentation" (either (const "") id . unwrapStringXObj)) (Meta.get "doc" metaData)
          >> maybe (pure ()) (printMetaVal "Implements" getName) (Meta.get "implements" metaData)
          >> maybe (pure ()) (printMetaBool "Private") (Meta.get "private" metaData)
          >> maybe (pure ()) (printMetaBool "Hidden") (Meta.get "hidden" metaData)
          >> maybe (pure ()) (printMetaVal "Signature" pretty) (Meta.get "sig" metaData)
          >> maybe (pure ()) printDeprecated (Meta.get "deprecated" metaData)
          >> when (projectPrintTypedAST proj) (putStrLnWithColor Yellow (prettyTyped x))
      printMetaBool :: String -> XObj -> IO ()
      printMetaBool s (XObj (Bol True) _ _) = putStrLn ("  " ++ s)
      printMetaBool _ _ = return ()
      printDeprecated :: XObj -> IO ()
      printDeprecated (XObj (Bol True) _ _) = putStrLn "  Deprecated"
      printDeprecated (XObj (Str v) _ _) = putStrLn ("  Deprecated: " ++ v)
      printDeprecated _ = return ()
      printMetaVal :: String -> (XObj -> String) -> XObj -> IO ()
      printMetaVal s f xobj = putStrLn ("  " ++ s ++ ": " ++ f xobj)
  primitiveInfo _ ctx notName =
    argumentErr ctx "info" "a name" "first" notName
  
  -- | Get information about a binding.
  primitiveStructuredInfo :: UnaryPrimitiveCallback
  primitiveStructuredInfo (XObj _ i _) ctx (XObj (Sym path _) _ _) =
    case lookupBinderInTypeEnv ctx path of
      Right bind -> return (ctx, Right $ workOnBinder bind)
      Left _ ->
        case lookupBinderInContextEnv ctx path of
          Right bind -> return (ctx, Right $ workOnBinder bind)
          Left e -> return $ throwErr e ctx i
    where
      workOnBinder :: Binder -> XObj
      workOnBinder (Binder metaData (XObj _ (Just (Info l c f _ _)) t)) =
        makeX
          ( Lst
              [ (maybe (makeX (Lst [])) reify t),
                makeX
                  ( Lst
                      [ makeX (Str f),
                        makeX (Num IntTy (Integral l)),
                        makeX (Num IntTy (Integral c))
                      ]
                  ),
                metaList metaData
              ]
          )
      workOnBinder (Binder metaData (XObj _ _ t)) =
        makeX
          ( Lst
              [ (maybe (makeX (Lst [])) reify t),
                makeX (Lst []),
                metaList metaData
              ]
          )
      metaList :: MetaData -> XObj
      metaList (MetaData m) =
        makeX (Lst (map genPair (Map.toList m)))
        where
          genPair (s, x) = makeX (Lst [XObj (Str s) Nothing Nothing, x])
      makeX o = XObj o Nothing Nothing
  primitiveStructuredInfo _ ctx notName =
    argumentErr ctx "structured-info" "a name" "first" notName
  
  dynamicOrMacroWith :: Context -> (SymPath -> [XObj]) -> Ty -> String -> XObj -> IO (Context, Either EvalError XObj)
  dynamicOrMacroWith ctx producer ty name body = do
    let qpath = qualifyPath ctx (SymPath [] name)
        elt = XObj (Lst (producer (unqualify qpath))) (xobjInfo body) (Just ty)
        meta = fromRight emptyMeta (lookupMeta (contextGlobalEnv ctx) (getPath elt))
    pure
      ( case (insertInGlobalEnv ctx qpath (Binder meta elt)) of
          Left e -> evalError ctx (show e) (xobjInfo body)
          Right c -> (c, dynamicNil)
      )
  
  -- | Get the members of a type declaration.
  primitiveMembers :: UnaryPrimitiveCallback
  primitiveMembers _ ctx xobj@(XObj (Sym path _) _ _) =
    case (lookupBinderInTypeEnv ctx path) of
      Left _ -> pure $ toEvalError ctx xobj (StructNotFound xobj)
      Right b -> go (binderXObj b)
    where
      go :: XObj -> IO (Context, Either EvalError XObj)
      go (XObj (Lst [(XObj (Deftype _) _ _), _, (XObj (Arr members) _ _)]) _ _) =
        pure (ctx, Right (XObj (Arr (map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members))) Nothing Nothing))
      go (XObj (Lst ((XObj (DefSumtype _) _ _) : _ : cases)) _ _) =
        pure (ctx, (either Left (\a -> Right (XObj (Arr (concat a)) Nothing Nothing)) (mapM getMembersFromCase cases)))
      go x = pure (toEvalError ctx x (NonTypeInTypeEnv path x))
      getMembersFromCase :: XObj -> Either EvalError [XObj]
      getMembersFromCase (XObj (Lst members) _ _) =
        Right (map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members))
      getMembersFromCase x@(XObj (Sym _ _) _ _) =
        Right [XObj (Lst [x, XObj (Arr []) Nothing Nothing]) Nothing Nothing]
      getMembersFromCase x =
        second (: []) (snd (toEvalError ctx x (PrimitiveError.InvalidSumtypeCase x)))
  primitiveMembers _ ctx x = argumentErr ctx "members" "a symbol" "first" x
  
  -- | Set meta data for a Binder
  --
  -- Permits "forward-declaration": if the binder doesn't exist, it creates a
  -- "meta stub" for the binder with the meta information.
  primitiveMetaSet :: TernaryPrimitiveCallback
  primitiveMetaSet _ ctx target@(XObj (Sym path@(SymPath _ _) _) _ _) (XObj (Str key) _ _) value =
    pure $ either (const create) (,dynamicNil) (lookupGlobal <> lookupType)
    where
      qpath = qualifyPath ctx path
      lookupGlobal :: Either ContextError Context
      lookupGlobal =
        lookupBinderInGlobalEnv ctx path
          >>= \binder ->
            pure (Meta.updateBinderMeta binder key value)
              >>= insertInGlobalEnv ctx qpath
      lookupType :: Either ContextError Context
      lookupType =
        lookupBinderInTypeEnv ctx qpath
          >>= \binder ->
            pure (Meta.updateBinderMeta binder key value)
              >>= insertTypeBinder ctx qpath
      create :: (Context, Either EvalError XObj)
      create =
        let updated = Meta.updateBinderMeta (Meta.stub (unqualify qpath)) key value
         in case (insertInGlobalEnv ctx qpath updated) of
              Left e -> toEvalError ctx target (MetaSetFailed target (show e))
              Right c -> (c, dynamicNil)
  primitiveMetaSet _ ctx (XObj (Sym (SymPath _ _) _) _ _) key _ =
    argumentErr ctx "meta-set!" "a string" "second" key
  primitiveMetaSet _ ctx target _ _ =
    argumentErr ctx "meta-set!" "a symbol" "first" target
  
  primitiveDefinterface :: BinaryPrimitiveCallback
  primitiveDefinterface xobj ctx nameXObj@(XObj (Sym path@(SymPath [] name) _) _ _) ty =
    pure $ maybe invalidType validType (xobjToTy ty)
    where
      invalidType = evalError ctx ("Invalid type for interface `" ++ name ++ "`: " ++ pretty ty) (xobjInfo ty)
      validType t = either (const defInterface) updateInterface (lookupBinderInTypeEnv ctx path)
        where
          defInterface =
            let interface = defineInterface name t [] (xobjInfo nameXObj)
                binder = toBinder interface
                ctx' = fromRight (error "primitives: couldn't insert type binder for interface") $ insertTypeBinder ctx (markQualified (SymPath [] name)) binder
                newCtx = fromRight (error "primitives: couldn't retroactively register in interface") $ retroactivelyRegisterInInterface ctx' binder
             in (newCtx, dynamicNil)
          updateInterface binder = case binder of
            Binder _ (XObj (Lst (XObj (Interface foundType _) _ _ : _)) _ _) ->
              if foundType == t
                then (ctx, dynamicNil)
                else
                  evalError
                    ctx
                    ( "Tried to change the type of interface `"
                        ++ show path
                        ++ "` from `"
                        ++ show foundType
                        ++ "` to `"
                        ++ show t
                        ++ "`"
                    )
                    (xobjInfo xobj)
            _ -> error "updateinterface"
  primitiveDefinterface _ ctx name _ =
    pure (evalError ctx ("`definterface` expects a name as first argument, but got `" ++ pretty name ++ "`") (xobjInfo name))
  
  registerInternal :: Context -> String -> XObj -> Maybe String -> IO (Context, Either EvalError XObj)
  registerInternal ctx name ty override =
    pure $ maybe invalidType validType (xobjToTy ty)
    where
      invalidType =
        evalError
          ctx
          ( "Can't understand type when registering '" ++ name
              ++ "'"
          )
          (xobjInfo ty)
      -- TODO: Retroactively register in interface if implements metadata is present.
      validType t =
        let qpath = qualifyPath ctx (SymPath [] name)
            registration =
              XObj
                ( Lst
                    [ XObj (External override) Nothing Nothing,
                      XObj (Sym (unqualify qpath) Symbol) Nothing Nothing,
                      ty
                    ]
                )
                (xobjInfo ty)
                (Just t)
            meta = fromRight emptyMeta (lookupMeta (contextGlobalEnv ctx) (getPath registration))
         in case (insertInGlobalEnv ctx qpath (Binder meta registration)) of
              Left err -> evalError ctx (show err) (xobjInfo ty)
              Right c -> (c, dynamicNil)
  
  primitiveRegister :: VariadicPrimitiveCallback
  primitiveRegister _ ctx [XObj (Sym (SymPath [] name) _) _ _, ty] =
    registerInternal ctx name ty Nothing
  primitiveRegister _ ctx [invalid@(XObj (Sym _ _) _ _), _] =
    pure
      ( evalError
          ctx
          ("`register` expects an unqualified name as first argument, but got `" ++ pretty invalid ++ "`")
          (xobjInfo invalid)
      )
  primitiveRegister _ ctx [name, _] =
    pure
      ( evalError
          ctx
          ("`register` expects a name as first argument, but got `" ++ pretty name ++ "`")
          (xobjInfo name)
      )
  primitiveRegister _ ctx [XObj (Sym (SymPath _ name) _) _ _, ty, XObj (Str override) _ _] =
    registerInternal ctx name ty (Just override)
  primitiveRegister _ ctx [XObj (Sym (SymPath _ _) _) _ _, _, override] =
    pure
      ( evalError
          ctx
          ("`register` expects a string as third argument, but got `" ++ pretty override ++ "`")
          (xobjInfo override)
      )
  primitiveRegister _ ctx [name, _, _] =
    pure
      ( evalError
          ctx
          ("`register` expects a name as first argument, but got `" ++ pretty name ++ "`")
          (xobjInfo name)
      )
  primitiveRegister x ctx _ =
    pure
      ( evalError
          ctx
          ( "I didn’t understand the form `" ++ pretty x
              ++ "`.\n\nIs it valid? Every `register` needs to follow the form `(register name <signature> <optional: override>)`."
          )
          (xobjInfo x)
      )
  
  primitiveDeftype :: VariadicPrimitiveCallback
  primitiveDeftype xobj ctx (name : rest@(XObj (Arr a) _ _ : _)) =
    case members a of
      Nothing -> pure (toEvalError ctx xobj BadDeftypeMembers)
      Just ms -> ensureUnqualified (map fst ms)
    where
      members :: [XObj] -> Maybe [(XObj, XObj)]
      members [] = Just []
      members [_] = Nothing
      members (binding : val : xs) = members xs >>= \xs' -> pure $ (binding, val) : xs'
      ensureUnqualified :: [XObj] -> IO (Context, Either EvalError XObj)
      ensureUnqualified objs =
        if all isUnqualifiedSym objs
          then deftype ctx name (selectConstructor rest)
          else pure (toEvalError ctx xobj (QualifiedTypeMember rest))
  primitiveDeftype x ctx (name : rest) =
    if length rest > 128
      then pure (toEvalError ctx x TooManySumtypeCases)
      else deftype ctx name (selectConstructor rest)
  primitiveDeftype _ _ _ = error "primitivedeftype"
  
  type ModuleCreator = Context -> String -> [Ty] -> [XObj] -> Maybe Info -> Either TypeError (String, XObj, [XObj])
  
  -- | Build an XObj representing the constructor of a type in Carp.
  selectConstructor :: [XObj] -> (Ty -> (XObj, [XObj], ModuleCreator))
  selectConstructor xs =
    let (constructor, creator, mems) =
          if length xs == 1 && isArray (head xs)
            then (Deftype, moduleForDeftypeInContext, xs)
            else (DefSumtype, moduleForSumtypeInContext, xs)
     in \t ->
          ( XObj
              ( Lst
                  ( XObj (constructor t) Nothing Nothing :
                    XObj (Sym (getStructPath t) Symbol) Nothing Nothing :
                    mems
                  )
              )
              Nothing
              (Just TypeTy),
            mems,
            creator
          )
  
  deftype :: Context -> XObj -> (Ty -> (XObj, [XObj], ModuleCreator)) -> IO (Context, Either EvalError XObj)
  deftype ctx x@(XObj (Sym (SymPath [] name) _) _ _) constructor =
    do
      (ctxWithType, e) <- makeType ctx name [] constructor
      case e of
        Left err -> pure (evalError ctx (show err) (xobjInfo x))
        Right t ->
          autoDerive
            ctxWithType
            t
            [ lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "delete")),
              lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "str")),
              lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "copy"))
            ]
  deftype ctx x@(XObj (Lst ((XObj (Sym (SymPath [] name) _) _ _) : tyvars)) _ _) constructor =
    do
      (ctxWithType, e) <-
        ( either
            (\s -> pure (evalError ctx s Nothing))
            (\vars -> makeType ctx name vars constructor)
            (maybe (Left (show (InvalidTypeVariables x))) Right (checkVariables tyvars))
          )
      case e of
        Left err -> pure (evalError ctx (show err) (xobjInfo x))
        Right t ->
          autoDerive
            ctxWithType
            t
            [ lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "delete")),
              lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "str")),
              lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "copy"))
            ]
  deftype ctx name _ = pure $ toEvalError ctx name (InvalidTypeName name)
  
  checkVariables :: [XObj] -> Maybe [Ty]
  checkVariables vars = mapM xobjToTy vars
  
  makeType :: Context -> String -> [Ty] -> (Ty -> (XObj, [XObj], ModuleCreator)) -> IO (Context, Either EvalError Ty)
  makeType ctx name vars constructor =
    let qpath = (qualifyPath ctx (SymPath [] name))
        ty = StructTy (ConcreteNameTy (unqualify qpath)) vars
        (typeX, members, creator) = constructor ty
     in case ( unwrapTypeErr ctx (creator ctx name vars members Nothing)
                 >>= \(_, modx, deps) ->
                   pure (existingOr ctx qpath modx)
                     >>= \mod' ->
                       unwrapErr (insertType ctx qpath (toBinder typeX) mod')
                         >>= \c -> pure (foldM (define True) c (map Qualified deps))
             ) of
          Left e -> pure (evalError ctx e (xobjInfo typeX))
          Right result -> (result >>= \ctx' -> pure (ctx', pure ty))
    where
      existingOr :: Context -> QualifiedPath -> XObj -> Binder
      existingOr c q x@(XObj (Mod e _) _ _) =
        case ((lookupBinderInInternalEnv c q) <> (lookupBinderInGlobalEnv c q)) of
          Right (Binder meta (XObj (Mod ve te) ii tt)) ->
            (Binder meta (XObj (Mod (e <> ve) te) ii tt))
          _ -> (toBinder x)
      existingOr _ _ x = (toBinder x)
  
  -- | TODO: Possibly use this function in more places where currently 'unwrapErr' is
  -- used, since that function ignores contextExecMode/fppl.
  unwrapTypeErr :: Context -> Either TypeError a -> Either String a
  unwrapTypeErr ctx (Left err) = Left (typeErrorToString ctx err)
  unwrapTypeErr _ (Right x) = Right x
  
  -- | Automatically derive implementations of interfaces.
  autoDerive :: Context -> Ty -> [Either ContextError Binder] -> IO (Context, Either EvalError XObj)
  autoDerive c ty interfaces =
    let (SymPath mods tyname) = (getStructPath ty)
        implBinder :: String -> Ty -> Binder
        implBinder name t = Binder emptyMeta (XObj (Sym (SymPath (mods ++ [tyname]) name) Symbol) (Just dummyInfo) (Just t))
        getSig :: String -> Ty
        getSig "delete" = FuncTy [ty] UnitTy StaticLifetimeTy
        getSig "str" = FuncTy [RefTy ty (VarTy "q")] StringTy StaticLifetimeTy
        getSig "prn" = FuncTy [RefTy ty (VarTy "q")] StringTy StaticLifetimeTy
        getSig "copy" = FuncTy [RefTy ty (VarTy "q")] ty StaticLifetimeTy
        getSig _ = VarTy "z"
        registration interface =
          let name = getSimpleName (binderXObj interface)
              sig = getSig name
           in (implBinder name sig, sig, interface)
        derives =
          (sequence interfaces)
            >>= \binders -> pure (fmap registration binders)
     in case derives of
          Left _ -> pure (evalError c "Couldn't derive interfaces." Nothing)
          Right regs ->
            case foldl' (\(context, _) (path, sig, interface) -> first (fromRight (error "COULDNT DERIVE!")) (registerInInterfaceIfNeeded context path interface sig)) (c, Nothing) regs of
              (ci, Just err@AlreadyImplemented {}) -> emitWarning (show err) >> pure (ci, dynamicNil :: Either EvalError XObj)
              (_, Just err) -> pure $ evalError c (show err) Nothing
              (ci, Nothing) -> pure (ci, dynamicNil :: Either EvalError XObj)
  
  -- | Add a module to the list of implicitly imported modules.
  primitiveUse :: UnaryPrimitiveCallback
  primitiveUse xobj ctx (XObj (Sym path _) _ _) =
    let modulePath = fromStrings (contextPath ctx)
        contextualized = (consPath (contextPath ctx) path)
        global = (contextGlobalEnv ctx)
        -- Look up the module to see if we can actually use it.
        -- The reference might be contextual, if so, append the current context path strings.
        path' = case (searchValueBinder global path) of
          Right _ -> path
          _ -> contextualized
     in pure
          ( case modulePath of
              (SymPath [] "") -> updateGlobalUsePaths global path'
              _ -> case searchValueBinder global modulePath of
                Left err -> (evalError ctx (show err) (xobjInfo xobj))
                Right binder ->
                  updateModuleUsePaths global modulePath binder path'
          )
    where
      updateGlobalUsePaths :: Env -> SymPath -> (Context, Either EvalError XObj)
      updateGlobalUsePaths e spath =
        ((replaceGlobalEnv ctx (addUsePath e spath)), dynamicNil)
      updateModuleUsePaths :: Env -> SymPath -> Binder -> SymPath -> (Context, Either EvalError XObj)
      updateModuleUsePaths e p (Binder meta (XObj (Mod ev et) i t)) spath =
        either
          (\err -> (evalError ctx err (xobjInfo xobj)))
          (\newCtx -> (newCtx, dynamicNil))
          ( (unwrapErr (insert e p (Binder meta (XObj (Mod (addUsePath ev spath) et) i t))))
              >>= pure . replaceGlobalEnv ctx
          )
      updateModuleUsePaths _ _ _ _ =
        (evalError ctx "Context path pointed to non-module!" (xobjInfo xobj))
  primitiveUse _ ctx x =
    argumentErr ctx "use" "a symbol" "first" x
  
  -- | Get meta data for a Binder
  primitiveMeta :: BinaryPrimitiveCallback
  primitiveMeta (XObj _ i _) ctx (XObj (Sym path _) _ _) (XObj (Str key) _ _) =
    pure $ maybe errNotFound foundBinder lookup'
    where
      lookup' :: Maybe Binder
      lookup' = either (const Nothing) Just (lookupBinderInGlobalEnv ctx path <> lookupBinderInTypeEnv ctx path)
      foundBinder :: Binder -> (Context, Either EvalError XObj)
      foundBinder binder = (ctx, maybe dynamicNil Right (Meta.getBinderMetaValue key binder))
      errNotFound :: (Context, Either EvalError XObj)
      errNotFound = evalError ctx ("`meta` failed, I can’t find `" ++ show path ++ "`") i
  primitiveMeta _ ctx (XObj (Sym _ _) _ _) key =
    argumentErr ctx "meta" "a string" "second" key
  primitiveMeta _ ctx path _ =
    argumentErr ctx "meta" "a symbol" "first" path
  
  primitiveDefined :: UnaryPrimitiveCallback
  primitiveDefined _ ctx (XObj (Sym path _) _ _) =
    pure $ either (const (ctx, Right falseXObj)) (const (ctx, Right trueXObj)) (lookupBinderInContextEnv ctx path)
  primitiveDefined _ ctx arg =
    argumentErr ctx "defined" "a symbol" "first" arg
  
  primitiveDeftemplate :: QuaternaryPrimitiveCallback
  -- deftemplate can't receive a dependency function, as Ty aren't exposed in Carp
  primitiveDeftemplate _ ctx (XObj (Sym p@(SymPath [] _) _) _ _) ty (XObj (Str declTempl) _ _) (XObj (Str defTempl) _ _) =
    pure $ maybe invalidType (fromRight invalidType . fmap (\x -> (x, dynamicNil)) . validType) (xobjToTy ty)
    where
      typeEnv = contextTypeEnv ctx
      globalEnv = contextGlobalEnv ctx
      invalidType = evalError ctx ("I do not understand the type form in " ++ pretty ty) (xobjInfo ty)
      validType t = case defineTemplate (contextualize p ctx) t "" (toTemplate declTempl) (toTemplate defTempl) (const []) of
        (_, b@(Binder _ (XObj (Lst (XObj (Deftemplate template) _ _ : _)) _ _))) ->
          if isTypeGeneric t
            then
              let (Binder _ registration) = b
                  meta = fromRight emptyMeta (lookupMeta globalEnv (getPath registration))
               in insertInGlobalEnv ctx (qualifyPath ctx p) (Binder meta registration)
            else
              let templateCreator = getTemplateCreator template
                  (registration, _) = instantiateTemplate (contextualize p ctx) t (templateCreator typeEnv globalEnv)
                  meta = fromRight emptyMeta (lookupMeta globalEnv (getPath registration))
               in insertInGlobalEnv ctx (qualifyPath ctx p) (Binder meta registration)
        _ -> error "primitivedeftemplate1"
  primitiveDeftemplate _ ctx (XObj (Sym (SymPath [] _) _) _ _) _ (XObj (Str _) _ _) x =
    argumentErr ctx "deftemplate" "a string" "fourth" x
  primitiveDeftemplate _ ctx (XObj (Sym (SymPath [] _) _) _ _) _ x _ =
    argumentErr ctx "deftemplate" "a string" "third" x
  primitiveDeftemplate _ ctx s@(XObj (Sym (SymPath _ _) _) _ _) _ _ _ =
    argumentErr ctx "deftemplate" "a symbol without prefix" "first" s
  primitiveDeftemplate _ ctx x _ _ _ =
    argumentErr ctx "deftemplate" "a symbol" "first" x
  
  noTypeError :: Context -> XObj -> IO (Context, Either EvalError XObj)
  noTypeError ctx x = pure $ evalError ctx ("Can't get the type of: " ++ pretty x) (xobjInfo x)
  
  primitiveType :: UnaryPrimitiveCallback
  -- A special case, the type of the type of types (type (type (type 1))) => ()
  primitiveType _ ctx (XObj _ _ (Just Universe)) =
    pure (ctx, Right (XObj (Lst []) Nothing Nothing))
  primitiveType _ ctx (XObj _ _ (Just TypeTy)) = liftIO $ pure (ctx, Right $ reify TypeTy)
  primitiveType _ ctx x@(XObj (Sym path@(SymPath [] name) _) _ _) =
    fromRight otherDefs (second go (lookupBinderInGlobalEnv ctx path))
    where
      env = contextGlobalEnv ctx
      otherDefs = case lookupEverywhere env name of
        [] ->
          notFound ctx x path
        binders ->
          mapM (go . snd) binders
            >>= (\obj -> pure (ctx, Right (XObj obj Nothing Nothing)))
              . Lst
              . rights
              . map snd
      go binder =
        case xobjTy (binderXObj binder) of
          Nothing -> noTypeError ctx x
          Just t -> pure (ctx, Right (reify t))
  primitiveType _ ctx x@(XObj (Sym qualifiedPath _) _ _) =
    fromRight (notFound ctx x qualifiedPath) (second go (lookupBinderInGlobalEnv ctx qualifiedPath))
    where
      go binder =
        case xobjTy (binderXObj binder) of
          Nothing -> noTypeError ctx x
          Just t -> pure (ctx, Right $ reify t)
  -- As a special case, we force evaluation on sequences such as (type (type 1))
  -- Because primitives don't evaluate their arguments, passing (type 1) to type would result in an error
  -- However, such an invocation *is* meaningful, and returns Type (the type of types). (type (type 1)) => Type
  -- Note that simply making type a command as an alternative leads to inconsistent behaviors whereby
  -- (type 1) => Int
  -- (type '1) => Int
  -- (type (Pair.init 1 1)) => Error can't find symbol "type"
  -- (type '(Pair.init 1 1)) => (Pair Int Int)
  -- Contrarily the behavior is far more consistent as a primitive if we simply add this case, and from a user perspective, it makes more sense
  -- that this function would be one that *doesn't* evaluate its arguments.
  primitiveType any' ctx (XObj (Lst [XObj (Sym (SymPath [] "type") _) _ _, rest]) _ _) =
    primitiveType any' ctx rest
      >>= \result -> case snd result of
        Right xobj -> primitiveType any' (fst result) xobj
        Left e -> pure (ctx, Left e)
  primitiveType _ ctx x@XObj {} =
    let tenv = contextTypeEnv ctx
        typed = either (\_ -> annotate tenv (contextGlobalEnv ctx) (Qualified x) Nothing) (\q -> annotate tenv (contextGlobalEnv ctx) q Nothing) $ qualify ctx x
     in liftIO $ either fail' ok typed
    where
      fail' _ = pure (evalError ctx ("Can't get the type of: " ++ pretty x) (xobjInfo x))
      ok (XObj _ _ (Just t), _) = pure (ctx, Right $ reify t)
      ok (_, _) = pure (evalError ctx ("Can't get the type of: " ++ pretty x) (xobjInfo x))
  
  primitiveKind :: UnaryPrimitiveCallback
  primitiveKind _ ctx x@XObj {} =
    let tenv = contextTypeEnv ctx
        typed = either (\_ -> annotate tenv (contextGlobalEnv ctx) (Qualified x) Nothing) (\q -> annotate tenv (contextGlobalEnv ctx) q Nothing) $ qualify ctx x
     in pure (either fail' ok typed)
    where
      fail' _ = evalError ctx ("Can't get the kind of: " ++ pretty x) (xobjInfo x)
      ok (XObj _ _ (Just t), _) = (ctx, Right $ reify (tyToKind t))
      ok (_, _) = evalError ctx ("Can't get the kind of: " ++ pretty x) (xobjInfo x)
  
  -- | Primitive for printing help.
  primitiveHelp :: VariadicPrimitiveCallback
  primitiveHelp _ ctx [XObj (Sym (SymPath [] "about") _) _ _] =
    liftIO $ do
      putStrLn "Carp is an ongoing research project by Erik Svedäng, et al."
      putStrLn ""
      putStrLn
        "Licensed under the Apache License, Version 2.0 (the \"License\"); \n\
        \you may not use this file except in compliance with the License. \n\
        \You may obtain a copy of the License at \n\
        \http://www.apache.org/licenses/LICENSE-2.0"
      putStrLn ""
      putStrLn
        "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ``AS IS'' AND ANY \n\
        \EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE \n\
        \IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR \n\
        \PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE \n\
        \LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR \n\
        \CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF \n\
        \SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR \n\
        \BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, \n\
        \WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE \n\
        \OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN\n\
        \IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE."
      putStrLn ""
      return (ctx, dynamicNil)
  primitiveHelp _ ctx [XObj (Sym (SymPath [] "compiler") _) _ _] =
    openBrowserHelper ctx "https://github.com/carp-lang/Carp/blob/master/docs/Manual.md"
  primitiveHelp _ ctx [XObj (Sym (SymPath [] "language") _) _ _] =
    openBrowserHelper ctx "https://github.com/carp-lang/Carp/blob/master/docs/LanguageGuide.md"
  primitiveHelp _ ctx [XObj (Sym (SymPath [] "core") _) _ _] =
    openBrowserHelper ctx "https://carp-lang.github.io/carp-docs/core/core_index.html"
  primitiveHelp _ ctx [XObj (Sym (SymPath [] "gitter") _) _ _] =
    openBrowserHelper ctx "https://gitter.im/carp-lang/Carp"
  primitiveHelp _ ctx [XObj (Sym (SymPath [] "shortcuts") _) _ _] =
    liftIO $ do
      putStrLn ""
      putStrLn "(reload)       :r"
      putStrLn "(build)        :b"
      putStrLn "(run)          :x"
      putStrLn "(cat)          :c"
      putStrLn "(env)          :e"
      putStrLn "(help)         :h"
      putStrLn "(project)      :p"
      putStrLn "(quit)         :q"
      putStrLn "(type <arg>)   :t"
      putStrLn "(expand <arg>) :m"
      putStrLn "(info <arg>)   :i"
      putStrLn ""
      putStrLn "The shortcuts can be combined like this: \":rbx\""
      putStrLn ""
      return (ctx, dynamicNil)
  primitiveHelp _ ctx [] =
    liftIO $ do
      putStrLn "Don't panic - we can solve this!"
      putStrLn ""
      putStrLn "Evaluate (help <chapter>) to get to the relevant subchapter:"
      putStrLn ""
      putStrLn "compiler  - Learn how to use the compiler / repl        (web)"
      putStrLn "language  - Syntax and semantics of the language        (web)"
      putStrLn "core      - Core library API documentation              (web)"
      putStrLn "gitter    - Get help from the community                 (web)"
      putStrLn "shortcuts - Useful shortcuts in the REPL                     "
      putStrLn "about     - Print some information about this program        "
      putStrLn ""
      return (ctx, dynamicNil)
  primitiveHelp _ ctx args =
    return (evalError ctx ("Invalid args to `help`: " ++ joinWithComma (map pretty args)) Nothing)
  
  openBrowserHelper :: MonadIO m => Context -> String -> m (Context, Either EvalError XObj)
  openBrowserHelper ctx url =
    liftIO $ do
      _ <- openBrowser url
      return (ctx, dynamicNil)
  
  -- | Checks if a type is managed. Note that it probably could be implemented in terms
  -- of `(implements? <sym>)` but to be 100% sure that we use the same lookup as the
  -- type system, I've done it this way -- at least for now.
  primitiveIsManaged :: UnaryPrimitiveCallback
  primitiveIsManaged _ ctx xobj@(XObj (Sym _ _) i _) =
    let tenv = contextTypeEnv ctx
        genv = contextEnv ctx
     in case xobjToTy xobj of
          Just ty ->
            if isManaged tenv genv ty
              then pure (ctx, Right trueXObj)
              else pure (ctx, Right falseXObj)
          Nothing -> pure (evalError ctx ("Can't take type of " ++ pretty xobj) i)
  primitiveIsManaged _ _ _ = error "primitiveismanaged"
  