juvix/app/Commands/Repl.hs

{-# LANGUAGE QuasiQuotes #-}

module Commands.Repl where

import Commands.Base hiding
  ( command,
  )
import Commands.Repl.Base
import Commands.Repl.Options
import Control.Exception (throwIO)
import Control.Monad.Except qualified as Except
import Control.Monad.Reader qualified as Reader
import Control.Monad.State.Strict qualified as State
import Control.Monad.Trans.Class (lift)
import Data.String.Interpolate (i, __i)
import Evaluator
import Juvix.Compiler.Concrete.Data.InfoTable qualified as Scoped
import Juvix.Compiler.Concrete.Data.Scope (scopePath)
import Juvix.Compiler.Concrete.Data.ScopedName (absTopModulePath)
import Juvix.Compiler.Concrete.Data.ScopedName qualified as Scoped
import Juvix.Compiler.Concrete.Language qualified as Concrete
import Juvix.Compiler.Concrete.Pretty qualified as Concrete
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver (runPathResolver)
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver.Error
import Juvix.Compiler.Core qualified as Core
import Juvix.Compiler.Core.Extra.Value
import Juvix.Compiler.Core.Info qualified as Info
import Juvix.Compiler.Core.Info.NoDisplayInfo qualified as Info
import Juvix.Compiler.Core.Pretty qualified as Core
import Juvix.Compiler.Core.Transformation qualified as Core
import Juvix.Compiler.Core.Transformation.DisambiguateNames (disambiguateNames)
import Juvix.Compiler.Internal.Language qualified as Internal
import Juvix.Compiler.Internal.Pretty qualified as Internal
import Juvix.Compiler.Pipeline.Repl
import Juvix.Compiler.Pipeline.Setup (entrySetup)
import Juvix.Data.Effect.Git
import Juvix.Data.Effect.Process
import Juvix.Data.Error.GenericError qualified as Error
import Juvix.Data.NameKind
import Juvix.Extra.Paths
import Juvix.Extra.Stdlib
import Juvix.Extra.Version
import Juvix.Prelude.Pretty
import Juvix.Prelude.Pretty qualified as P
import System.Console.ANSI qualified as Ansi
import System.Console.Haskeline
import System.Console.Repline
import System.Console.Repline qualified as Repline

printHelpTxt :: ReplOptions -> Repl ()
printHelpTxt opts = do
  liftIO $ do
    putStrLn normalCmds
    let isDev = opts ^. replIsDev
    when isDev (putStrLn devCmds)
  where
    normalCmds :: Text
    normalCmds =
      [__i|
  EXPRESSION                Evaluate an expression in the context of the currently loaded module
  :help                     Print help text and describe options
  :load       FILE          Load a file into the REPL
  :reload                   Reload the currently loaded file
  :type       EXPRESSION    Infer the type of an expression
  :def        IDENTIFIER    Print the definition of the identifier
  :doc        IDENTIFIER    Print the documentation of the identifier
  :core       EXPRESSION    Translate the expression to JuvixCore
  :multiline                Start a multi-line input. Submit with <Ctrl-D>
  :root                     Print the current project root
  :version                  Display the Juvix version
  :quit                     Exit the REPL
  |]

    devCmds :: Text
    devCmds =
      [__i|
  :dev        DEV CMD       Command reserved for debugging
  |]

replDefaultLoc :: Interval
replDefaultLoc = singletonInterval (mkInitialLoc replPath)

replFromJust :: Repl a -> Maybe a -> Repl a
replFromJust err = maybe err return

replFromEither :: Either JuvixError a -> Repl a
replFromEither = either (lift . Except.throwError) return

replGetContext :: Repl ReplContext
replGetContext = State.gets (^. replStateContext) >>= replFromJust noFileLoadedErr

replError :: AnsiText -> Repl a
replError msg =
  lift
    . Except.throwError
    . JuvixError
    $ GenericError
      { _genericErrorLoc = replDefaultLoc,
        _genericErrorMessage = msg,
        _genericErrorIntervals = [replDefaultLoc]
      }

noFileLoadedErr :: Repl a
noFileLoadedErr = replError (mkAnsiText @Text "No file loaded. Load a file using the `:load FILE` command.")

welcomeMsg :: (MonadIO m) => m ()
welcomeMsg = liftIO (putStrLn [i|Juvix REPL version #{versionTag}: https://juvix.org. Run :help for help|])

multilineCmd :: String
multilineCmd = "multiline"

quit :: String -> Repl ()
quit _ = liftIO (throwIO Interrupt)

loadEntryPoint :: EntryPoint -> Repl ()
loadEntryPoint ep = do
  artif <- liftIO (corePipelineIO' ep)
  let newCtx =
        ReplContext
          { _replContextArtifacts = artif,
            _replContextEntryPoint = ep
          }
  State.modify (set replStateContext (Just newCtx))
  let epPath :: Maybe (Path Abs File) = ep ^? entryPointModulePaths . _head
  whenJust epPath $ \path -> liftIO (putStrLn [i|OK loaded: #{toFilePath path}|])

reloadFile :: String -> Repl ()
reloadFile _ = replGetContext >>= loadEntryPoint . (^. replContextEntryPoint)

pSomeFile :: String -> Prepath File
pSomeFile = mkPrepath

loadFile :: Prepath File -> Repl ()
loadFile f = do
  entryPoint <- getReplEntryPointFromPrepath f
  loadEntryPoint entryPoint

loadDefaultPrelude :: Repl ()
loadDefaultPrelude = whenJustM defaultPreludeEntryPoint $ \e -> do
  root <- Reader.asks (^. replRoots . rootsRootDir)
  let hasInternet = not (e ^. entryPointOffline)
  -- The following is needed to ensure that the default location of the
  -- standard library exists
  void
    . liftIO
    . runM
    . evalInternet hasInternet
    . runFilesIO
    . runError @Text
    . runReader e
    . runLogIO
    . runProcessIO
    . runError @GitProcessError
    . runGitProcess
    . runError @DependencyError
    . runPathResolver root
    $ entrySetup
  loadEntryPoint e

getReplEntryPoint :: (Roots -> a -> GlobalOptions -> IO EntryPoint) -> a -> Repl EntryPoint
getReplEntryPoint f inputFile = do
  roots <- Reader.asks (^. replRoots)
  gopts <- State.gets (^. replStateGlobalOptions)
  liftIO (set entryPointSymbolPruningMode KeepAll <$> f roots inputFile gopts)

getReplEntryPointFromPrepath :: Prepath File -> Repl EntryPoint
getReplEntryPointFromPrepath = getReplEntryPoint entryPointFromGlobalOptionsPre

getReplEntryPointFromPath :: Path Abs File -> Repl EntryPoint
getReplEntryPointFromPath = getReplEntryPoint entryPointFromGlobalOptions

displayVersion :: String -> Repl ()
displayVersion _ = liftIO (putStrLn versionTag)

replCommand :: ReplOptions -> String -> Repl ()
replCommand opts input = catchAll $ do
  ctx <- replGetContext
  let tab = ctx ^. replContextArtifacts . artifactCoreTable
  evalRes <- compileThenEval ctx input
  whenJust evalRes $ \n ->
    if
        | Info.member Info.kNoDisplayInfo (Core.getInfo n) -> return ()
        | opts ^. replPrintValues ->
            renderOutLn (Core.ppOut opts (toValue tab n))
        | otherwise -> renderOutLn (Core.ppOut opts n)
  where
    compileThenEval :: ReplContext -> String -> Repl (Maybe Core.Node)
    compileThenEval ctx s = compileString >>= mapM eval
      where
        artif :: Artifacts
        artif = ctx ^. replContextArtifacts

        eval :: Core.Node -> Repl Core.Node
        eval n = do
          ep <- getReplEntryPointFromPrepath (mkPrepath (toFilePath replPath))
          let shouldDisambiguate :: Bool
              shouldDisambiguate = not (opts ^. replNoDisambiguate)
          (artif', n') <-
            replFromEither
              . run
              . runReader ep
              . runError @JuvixError
              . runState artif
              . runTransformations shouldDisambiguate (opts ^. replTransformations)
              $ n
          liftIO (doEvalIO' artif' n') >>= replFromEither

        doEvalIO' :: Artifacts -> Core.Node -> IO (Either JuvixError Core.Node)
        doEvalIO' artif' n =
          mapLeft (JuvixError @Core.CoreError)
            <$> doEvalIO False replDefaultLoc (artif' ^. artifactCoreTable) n

        compileString :: Repl (Maybe Core.Node)
        compileString = do
          (artifacts, res) <- liftIO $ compileReplInputIO' ctx (strip (pack s))
          res' <- replFromEither res
          State.modify (over (replStateContext . _Just) (set replContextArtifacts artifacts))
          return res'

core :: String -> Repl ()
core input = do
  ctx <- replGetContext
  opts <- Reader.asks (^. replOptions)
  compileRes <- liftIO (compileReplInputIO' ctx (strip (pack input))) >>= replFromEither . snd
  whenJust compileRes (renderOutLn . Core.ppOut opts)

dev :: String -> Repl ()
dev input = do
  ctx <- replGetContext
  if
      | input == scoperStateCmd -> do
          renderOutLn (Concrete.ppTrace (ctx ^. replContextArtifacts . artifactScoperState))
      | otherwise ->
          renderOutLn
            ( "Unrecognized command "
                <> input
                <> "\nAvailable commands: "
                <> unwords cmds
            )
  where
    cmds :: [String]
    cmds = [scoperStateCmd]
    scoperStateCmd :: String
    scoperStateCmd = "scoperState"

ppConcrete :: (Concrete.PrettyPrint a) => a -> Repl AnsiText
ppConcrete a = do
  gopts <- State.gets (^. replStateGlobalOptions)
  let popts :: GenericOptions = project' gopts
  return (Concrete.ppOut popts a)

printConcrete :: (Concrete.PrettyPrint a) => a -> Repl ()
printConcrete = ppConcrete >=> renderOut

printConcreteLn :: (Concrete.PrettyPrint a) => a -> Repl ()
printConcreteLn = ppConcrete >=> renderOutLn

replParseIdentifiers :: String -> Repl (NonEmpty Concrete.ScopedIden)
replParseIdentifiers input =
  replExpressionUpToScopedAtoms (strip (pack input))
    >>= getIdentifiers
  where
    getIdentifiers :: Concrete.ExpressionAtoms 'Concrete.Scoped -> Repl (NonEmpty Concrete.ScopedIden)
    getIdentifiers as = mapM getIdentifier (as ^. Concrete.expressionAtoms)
      where
        getIdentifier :: Concrete.ExpressionAtom 'Concrete.Scoped -> Repl (Concrete.ScopedIden)
        getIdentifier = \case
          Concrete.AtomIdentifier a -> return a
          Concrete.AtomParens p
            | Concrete.ExpressionIdentifier a <- p -> return a
            | Concrete.ExpressionParensIdentifier a <- p -> return a
          _ -> err
          where
            err :: Repl a
            err = replError (mkAnsiText @Text ":def expects one or more identifiers")

printDocumentation :: String -> Repl ()
printDocumentation = replParseIdentifiers >=> printIdentifiers
  where
    printIdentifiers :: NonEmpty Concrete.ScopedIden -> Repl ()
    printIdentifiers (d :| ds) = do
      printIdentifier d
      whenJust (nonEmpty ds) $ \ds' -> replNewline >> printIdentifiers ds'
      where
        getInfoTable :: Repl Scoped.InfoTable
        getInfoTable = (^. replContextArtifacts . artifactScopeTable) <$> replGetContext

        printIdentifier :: Concrete.ScopedIden -> Repl ()
        printIdentifier s = do
          let n = s ^. Concrete.scopedIdenFinal . Scoped.nameId
          mdoc <- case getNameKind s of
            KNameAxiom -> getDocAxiom n
            KNameInductive -> getDocInductive n
            KNameLocal -> return Nothing
            KNameFunction -> getDocFunction n
            KNameConstructor -> getDocConstructor n
            KNameLocalModule -> impossible
            KNameTopModule -> impossible
            KNameAlias -> impossible
            KNameFixity -> impossible
          printDoc mdoc
          where
            printDoc :: Maybe (Concrete.Judoc 'Concrete.Scoped) -> Repl ()
            printDoc = \case
              Nothing -> do
                s' <- ppConcrete s
                renderOut (mkAnsiText @Text "No documentation available for ")
                renderOutLn s'
              Just ju -> printConcrete ju

            getDocFunction :: Scoped.NameId -> Repl (Maybe (Concrete.Judoc 'Concrete.Scoped))
            getDocFunction fun = do
              tbl :: Scoped.InfoTable <- getInfoTable
              let def :: Scoped.FunctionInfo = tbl ^?! Scoped.infoFunctions . at fun . _Just
              return (def ^. Scoped.functionInfoDoc)

            getDocInductive :: Scoped.NameId -> Repl (Maybe (Concrete.Judoc 'Concrete.Scoped))
            getDocInductive ind = do
              tbl :: Scoped.InfoTable <- (^. replContextArtifacts . artifactScopeTable) <$> replGetContext
              let def :: Concrete.InductiveDef 'Concrete.Scoped = tbl ^?! Scoped.infoInductives . at ind . _Just . Scoped.inductiveInfoDef
              return (def ^. Concrete.inductiveDoc)

            getDocAxiom :: Scoped.NameId -> Repl (Maybe (Concrete.Judoc 'Concrete.Scoped))
            getDocAxiom ax = do
              tbl :: Scoped.InfoTable <- (^. replContextArtifacts . artifactScopeTable) <$> replGetContext
              let def :: Concrete.AxiomDef 'Concrete.Scoped = tbl ^?! Scoped.infoAxioms . at ax . _Just . Scoped.axiomInfoDef
              return (def ^. Concrete.axiomDoc)

            getDocConstructor :: Scoped.NameId -> Repl (Maybe (Concrete.Judoc 'Concrete.Scoped))
            getDocConstructor c = do
              tbl :: Scoped.InfoTable <- (^. replContextArtifacts . artifactScopeTable) <$> replGetContext
              let def :: Scoped.ConstructorInfo = tbl ^?! Scoped.infoConstructors . at c . _Just
              return (def ^. Scoped.constructorInfoDef . Concrete.constructorDoc)

printDefinition :: String -> Repl ()
printDefinition = replParseIdentifiers >=> printIdentifiers
  where
    printIdentifiers :: NonEmpty Concrete.ScopedIden -> Repl ()
    printIdentifiers (d :| ds) = do
      printIdentifier d
      whenJust (nonEmpty ds) $ \ds' -> replNewline >> printIdentifiers ds'
      where
        getInfoTable :: Repl Scoped.InfoTable
        getInfoTable = (^. replContextArtifacts . artifactScopeTable) <$> replGetContext

        printIdentifier :: Concrete.ScopedIden -> Repl ()
        printIdentifier s =
          let n = s ^. Concrete.scopedIdenFinal . Scoped.nameId
           in case getNameKind s of
                KNameAxiom -> printAxiom n
                KNameInductive -> printInductive n
                KNameLocal -> return ()
                KNameFunction -> printFunction n
                KNameConstructor -> printConstructor n
                KNameLocalModule -> impossible
                KNameTopModule -> impossible
                KNameFixity -> impossible
                KNameAlias -> impossible
          where
            printLocation :: (HasLoc s) => s -> Repl ()
            printLocation def = do
              s' <- ppConcrete s
              let txt :: Text = " is " <> prettyText (nameKindWithArticle (getNameKind s)) <> " defined at " <> prettyText (getLoc def)
              renderOutLn (s' <> mkAnsiText txt)

            printFunction :: Scoped.NameId -> Repl ()
            printFunction fun = do
              tbl :: Scoped.InfoTable <- getInfoTable
              let def :: Scoped.FunctionInfo = tbl ^?! Scoped.infoFunctions . at fun . _Just
              printLocation def
              printConcreteLn def

            printInductive :: Scoped.NameId -> Repl ()
            printInductive ind = do
              tbl :: Scoped.InfoTable <- (^. replContextArtifacts . artifactScopeTable) <$> replGetContext
              let def :: Concrete.InductiveDef 'Concrete.Scoped = tbl ^?! Scoped.infoInductives . at ind . _Just . Scoped.inductiveInfoDef
              printLocation def
              printConcreteLn def

            printAxiom :: Scoped.NameId -> Repl ()
            printAxiom ax = do
              tbl :: Scoped.InfoTable <- (^. replContextArtifacts . artifactScopeTable) <$> replGetContext
              let def :: Concrete.AxiomDef 'Concrete.Scoped = tbl ^?! Scoped.infoAxioms . at ax . _Just . Scoped.axiomInfoDef
              printLocation def
              printConcreteLn def

            printConstructor :: Scoped.NameId -> Repl ()
            printConstructor c = do
              tbl :: Scoped.InfoTable <- (^. replContextArtifacts . artifactScopeTable) <$> replGetContext
              let ind :: Scoped.Symbol = tbl ^?! Scoped.infoConstructors . at c . _Just . Scoped.constructorInfoTypeName
              printInductive (ind ^. Scoped.nameId)

inferType :: String -> Repl ()
inferType input = do
  gopts <- State.gets (^. replStateGlobalOptions)
  n <- replExpressionUpToTyped (strip (pack input))
  renderOutLn (Internal.ppOut (project' @GenericOptions gopts) (n ^. Internal.typedType))

replCommands :: ReplOptions -> [(String, String -> Repl ())]
replCommands opts = catchable ++ nonCatchable
  where
    nonCatchable :: [(String, String -> Repl ())]
    nonCatchable =
      [ ("quit", quit)
      ]
    catchable :: [(String, String -> Repl ())]
    catchable =
      map
        (second (catchAll .))
        [ ("help", const (printHelpTxt opts)),
          -- `multiline` is included here for auto-completion purposes only.
          -- `repline`'s `multilineCommand` logic overrides this no-op.
          (multilineCmd, const (return ())),
          ("load", loadFile . pSomeFile),
          ("reload", reloadFile),
          ("root", printRoot),
          ("def", printDefinition),
          ("doc", printDocumentation),
          ("type", inferType),
          ("version", displayVersion),
          ("core", core),
          ("dev", dev)
        ]

catchAll :: Repl () -> Repl ()
catchAll = Repline.dontCrash . catchJuvixError
  where
    catchJuvixError :: Repl () -> Repl ()
    catchJuvixError (HaskelineT m) = HaskelineT (mapInputT_ catchErrorS m)
      where
        catchErrorS :: ReplS () -> ReplS ()
        catchErrorS = (`Except.catchError` printErrorS)

defaultMatcher :: [(String, CompletionFunc ReplS)]
defaultMatcher = [(":load", fileCompleter)]

optsCompleter :: WordCompleter ReplS
optsCompleter n = do
  opts <- Reader.asks (^. replOptions)
  let names = (":" <>) . fst <$> replCommands opts
  return (filter (isPrefixOf n) names)

replBanner :: MultiLine -> Repl String
replBanner = \case
  MultiLine -> return "... "
  SingleLine -> do
    mmodulePath <-
      State.gets
        ( ^?
            replStateContext
              . _Just
              . replContextArtifacts
              . artifactMainModuleScope
              . _Just
              . scopePath
              . absTopModulePath
        )
    return $ case mmodulePath of
      Just path -> [i|#{unpack (P.prettyText path)}> |]
      Nothing -> "juvix> "

replPrefix :: Maybe Char
replPrefix = Just ':'

replMultilineCommand :: Maybe String
replMultilineCommand = Just multilineCmd

replInitialiser :: Repl ()
replInitialiser = do
  gopts <- State.gets (^. replStateGlobalOptions)
  opts <- Reader.asks (^. replOptions)
  welcomeMsg
  unless
    (opts ^. replNoPrelude || gopts ^. globalNoStdlib)
    (maybe loadDefaultPrelude (loadFile . (^. pathPath)) (opts ^. replInputFile))

replFinaliser :: Repl ExitDecision
replFinaliser = return Exit

replTabComplete :: CompleterStyle ReplS
replTabComplete = Prefix (wordCompleter optsCompleter) defaultMatcher

printRoot :: String -> Repl ()
printRoot _ = do
  r <- State.gets (^. replStateRoots . rootsRootDir)
  liftIO $ putStrLn (pack (toFilePath r))

runCommand :: (Members '[Embed IO, App] r) => ReplOptions -> Sem r ()
runCommand opts = do
  roots <- askRoots
  let replAction :: ReplS ()
      replAction = do
        evalReplOpts
          ReplOpts
            { prefix = replPrefix,
              multilineCommand = replMultilineCommand,
              initialiser = replInitialiser,
              finaliser = replFinaliser,
              tabComplete = replTabComplete,
              command = replCommand opts,
              options = replCommands opts,
              banner = replBanner
            }
  globalOptions <- askGlobalOptions
  let env =
        ReplEnv
          { _replRoots = roots,
            _replOptions = opts
          }
      iniState =
        ReplState
          { _replStateRoots = roots,
            _replStateContext = Nothing,
            _replStateGlobalOptions = globalOptions
          }
  e <-
    embed
      . Except.runExceptT
      . (`State.evalStateT` iniState)
      . (`Reader.runReaderT` env)
      $ replAction
  case e of
    Left {} -> error "impossible: uncaught exception"
    Right () -> return ()

-- | If the package contains the stdlib as a dependency, loads the Prelude
defaultPreludeEntryPoint :: Repl (Maybe EntryPoint)
defaultPreludeEntryPoint = do
  roots <- State.gets (^. replStateRoots)
  let buildDir = roots ^. rootsBuildDir
      root = roots ^. rootsRootDir
      pkg = roots ^. rootsPackage
  mstdlibPath <- liftIO (runM (runFilesIO (packageStdlib root buildDir (pkg ^. packageDependencies))))
  case mstdlibPath of
    Just stdlibPath ->
      Just
        . set entryPointResolverRoot stdlibPath
        <$> getReplEntryPointFromPath (stdlibPath <//> preludePath)
    Nothing -> return Nothing

replMakeAbsolute :: SomeBase b -> Repl (Path Abs b)
replMakeAbsolute = \case
  Abs p -> return p
  Rel r -> do
    invokeDir <- State.gets (^. replStateRoots . rootsInvokeDir)
    return (invokeDir <//> r)

replExpressionUpToScopedAtoms :: Text -> Repl (Concrete.ExpressionAtoms 'Concrete.Scoped)
replExpressionUpToScopedAtoms txt = do
  ctx <- replGetContext
  x <-
    liftIO
      . runM
      . runError
      . evalState (ctx ^. replContextArtifacts)
      . runReader (ctx ^. replContextEntryPoint)
      $ expressionUpToAtomsScoped replPath txt
  replFromEither x

replExpressionUpToTyped :: Text -> Repl Internal.TypedExpression
replExpressionUpToTyped txt = do
  ctx <- replGetContext
  x <-
    liftIO
      . runM
      . runError
      . evalState (ctx ^. replContextArtifacts)
      . runReader (ctx ^. replContextEntryPoint)
      $ expressionUpToTyped replPath txt
  replFromEither x

compileReplInputIO' :: ReplContext -> Text -> IO (Artifacts, (Either JuvixError (Maybe Core.Node)))
compileReplInputIO' ctx txt =
  runM
    . runState (ctx ^. replContextArtifacts)
    . runReader (ctx ^. replContextEntryPoint)
    $ do
      r <- compileReplInputIO replPath txt
      return (extractNode <$> r)
  where
    extractNode :: ReplPipelineResult -> Maybe Core.Node
    extractNode = \case
      ReplPipelineResultNode n -> Just n
      ReplPipelineResultImport {} -> Nothing
      ReplPipelineResultOpenImport {} -> Nothing

render' :: (P.HasAnsiBackend a, P.HasTextBackend a) => a -> Repl ()
render' t = do
  opts <- State.gets (^. replStateGlobalOptions)
  hasAnsi <- liftIO (Ansi.hSupportsANSIColor stdout)
  liftIO (P.renderIO (not (opts ^. globalNoColors) && hasAnsi) t)

replNewline :: Repl ()
replNewline = liftIO (putStrLn "")

renderOut :: (P.HasAnsiBackend a, P.HasTextBackend a) => a -> Repl ()
renderOut = render'

renderOutLn :: (P.HasAnsiBackend a, P.HasTextBackend a) => a -> Repl ()
renderOutLn t = renderOut t >> replNewline

printErrorS :: JuvixError -> ReplS ()
printErrorS e = do
  opts <- State.gets (^. replStateGlobalOptions)
  hasAnsi <- liftIO (Ansi.hSupportsANSIColor stderr)
  liftIO $ hPutStrLn stderr $ run (runReader (project' @GenericOptions opts) (Error.render (not (opts ^. globalNoColors) && hasAnsi) False e))

runTransformations ::
  forall r.
  (Members '[State Artifacts, Error JuvixError, Reader EntryPoint] r) =>
  Bool ->
  [Core.TransformationId] ->
  Core.Node ->
  Sem r Core.Node
runTransformations shouldDisambiguate ts n = runCoreInfoTableBuilderArtifacts $ do
  sym <- addNode n
  applyTransforms shouldDisambiguate ts
  getNode sym
  where
    addNode :: Core.Node -> Sem (Core.InfoTableBuilder ': r) Core.Symbol
    addNode node = do
      sym <- Core.freshSymbol
      Core.registerIdentNode sym node
      -- `n` will get filtered out by the transformations unless it has a
      -- corresponding entry in `infoIdentifiers`
      tab <- Core.getInfoTable
      let name = Core.freshIdentName tab "_repl"
          idenInfo =
            Core.IdentifierInfo
              { _identifierName = name,
                _identifierSymbol = sym,
                _identifierLocation = Nothing,
                _identifierArgsNum = 0,
                _identifierType = Core.mkDynamic',
                _identifierIsExported = False,
                _identifierBuiltin = Nothing,
                _identifierPragmas = mempty,
                _identifierArgNames = []
              }
      Core.registerIdent name idenInfo
      return sym

    applyTransforms :: Bool -> [Core.TransformationId] -> Sem (Core.InfoTableBuilder ': r) ()
    applyTransforms shouldDisambiguate' ts' = do
      tab <- Core.getInfoTable
      tab' <- mapReader Core.fromEntryPoint $ Core.applyTransformations ts' tab
      let tab'' =
            if
                | shouldDisambiguate' -> disambiguateNames tab'
                | otherwise -> tab'
      Core.setInfoTable tab''

    getNode :: Core.Symbol -> Sem (Core.InfoTableBuilder ': r) Core.Node
    getNode sym = fromMaybe impossible . flip Core.lookupIdentifierNode' sym <$> Core.getInfoTable