mirror of
https://github.com/anoma/juvix.git
synced 2024-12-15 10:03:22 +03:00
491f7f7508
Updates ormolu to 0.5.3.0 and formats the project
644 lines
24 KiB
Haskell
644 lines
24 KiB
Haskell
{-# 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.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.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)
|
|
-- The following is needed to ensure that the default location of the
|
|
-- standard library exists
|
|
void
|
|
. liftIO
|
|
. runM
|
|
. runFilesIO
|
|
. runError @Text
|
|
. runReader e
|
|
. 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
|