mirror of
https://github.com/anoma/juvix.git
synced 2024-08-17 20:20:23 +03:00
Replace polysemy
by effectful
(#2663)
The following benchmark compares juvix 0.6.0 with polysemy and a new version (implemented in this pr) which replaces polysemy by effectful. # Typecheck standard library without caching ``` hyperfine --warmup 2 --prepare 'juvix-polysemy clean' 'juvix-polysemy typecheck Stdlib/Prelude.juvix' 'juvix-effectful typecheck Stdlib/Prelude.juvix' Benchmark 1: juvix-polysemy typecheck Stdlib/Prelude.juvix Time (mean ± σ): 3.924 s ± 0.143 s [User: 3.787 s, System: 0.084 s] Range (min … max): 3.649 s … 4.142 s 10 runs Benchmark 2: juvix-effectful typecheck Stdlib/Prelude.juvix Time (mean ± σ): 2.558 s ± 0.074 s [User: 2.430 s, System: 0.084 s] Range (min … max): 2.403 s … 2.646 s 10 runs Summary juvix-effectful typecheck Stdlib/Prelude.juvix ran 1.53 ± 0.07 times faster than juvix-polysemy typecheck Stdlib/Prelude.juvix ``` # Typecheck standard library with caching ``` hyperfine --warmup 1 'juvix-effectful typecheck Stdlib/Prelude.juvix' 'juvix-polysemy typecheck Stdlib/Prelude.juvix' --min-runs 20 Benchmark 1: juvix-effectful typecheck Stdlib/Prelude.juvix Time (mean ± σ): 1.194 s ± 0.068 s [User: 0.979 s, System: 0.211 s] Range (min … max): 1.113 s … 1.307 s 20 runs Benchmark 2: juvix-polysemy typecheck Stdlib/Prelude.juvix Time (mean ± σ): 1.237 s ± 0.083 s [User: 0.997 s, System: 0.231 s] Range (min … max): 1.061 s … 1.476 s 20 runs Summary juvix-effectful typecheck Stdlib/Prelude.juvix ran 1.04 ± 0.09 times faster than juvix-polysemy typecheck Stdlib/Prelude.juvix ```
This commit is contained in:
parent
923465858c
commit
3a4cbc742d
12
app/App.hs
12
app/App.hs
@ -15,7 +15,7 @@ import Juvix.Prelude.Pretty hiding
|
||||
)
|
||||
import System.Console.ANSI qualified as Ansi
|
||||
|
||||
data App m a where
|
||||
data App :: Effect where
|
||||
ExitMsg :: ExitCode -> Text -> App m a
|
||||
ExitFailMsg :: Text -> App m a
|
||||
ExitJuvixError :: JuvixError -> App m a
|
||||
@ -60,15 +60,15 @@ reAppIO ::
|
||||
Sem (App ': r) a ->
|
||||
Sem (SCache Package ': r) a
|
||||
reAppIO args@RunAppIOArgs {..} =
|
||||
reinterpret $ \case
|
||||
interpretTop $ \case
|
||||
AskPackageGlobal -> return (_runAppIOArgsRoot ^. rootPackageType `elem` [GlobalStdlib, GlobalPackageDescription, GlobalPackageBase])
|
||||
FromAppPathFile p -> prepathToAbsFile invDir (p ^. pathPath)
|
||||
GetMainFile m -> getMainFile' m
|
||||
FromAppPathDir p -> liftIO (prepathToAbsDir invDir (p ^. pathPath))
|
||||
RenderStdOut t
|
||||
| _runAppIOArgsGlobalOptions ^. globalOnlyErrors -> return ()
|
||||
| otherwise -> embed $ do
|
||||
sup <- Ansi.hSupportsANSIColor stdout
|
||||
| otherwise -> do
|
||||
sup <- liftIO (Ansi.hSupportsANSIColor stdout)
|
||||
renderIO (not (_runAppIOArgsGlobalOptions ^. globalNoColors) && sup) t
|
||||
AskGlobalOptions -> return _runAppIOArgsGlobalOptions
|
||||
AskPackage -> getPkg
|
||||
@ -87,7 +87,7 @@ reAppIO args@RunAppIOArgs {..} =
|
||||
exitFailure
|
||||
ExitMsg exitCode t -> exitMsg' (exitWith exitCode) t
|
||||
ExitFailMsg t -> exitMsg' exitFailure t
|
||||
SayRaw b -> embed (ByteString.putStr b)
|
||||
SayRaw b -> liftIO (ByteString.putStr b)
|
||||
where
|
||||
getPkg :: (Members '[SCache Package] r') => Sem r' Package
|
||||
getPkg = cacheSingletonGet
|
||||
@ -161,7 +161,7 @@ someBaseToAbs' f = do
|
||||
filePathToAbs :: (Members '[EmbedIO, App] r) => Prepath FileOrDir -> Sem r (Either (Path Abs File) (Path Abs Dir))
|
||||
filePathToAbs fp = do
|
||||
invokeDir <- askInvokeDir
|
||||
embed (fromPreFileOrDir invokeDir fp)
|
||||
fromPreFileOrDir invokeDir fp
|
||||
|
||||
askGenericOptions :: (Members '[App] r) => Sem r GenericOptions
|
||||
askGenericOptions = project <$> askGlobalOptions
|
||||
|
@ -34,4 +34,4 @@ runAsm bValidate tab =
|
||||
Asm.FunctionInfo ->
|
||||
Sem r (Either Asm.AsmError Asm.Val)
|
||||
doRun tab' funInfo =
|
||||
embed $ Asm.catchRunErrorIO (Asm.runCodeIO tab' funInfo)
|
||||
liftIO $ Asm.catchRunErrorIO (Asm.runCodeIO tab' funInfo)
|
||||
|
@ -160,7 +160,7 @@ runNockmaPipeline pa@PipelineArg {..} = do
|
||||
let code = Nockma.ppSerialize tab'
|
||||
writeFileEnsureLn nockmaFile code
|
||||
|
||||
runAnomaPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r ()
|
||||
runAnomaPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r ()
|
||||
runAnomaPipeline pa@PipelineArg {..} = do
|
||||
entryPoint <- getEntry pa
|
||||
nockmaFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile
|
||||
@ -173,7 +173,7 @@ runAnomaPipeline pa@PipelineArg {..} = do
|
||||
let code = Nockma.ppSerialize tab'
|
||||
writeFileEnsureLn nockmaFile code
|
||||
|
||||
runCasmPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r ()
|
||||
runCasmPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r ()
|
||||
runCasmPipeline pa@PipelineArg {..} = do
|
||||
entryPoint <- getEntry pa
|
||||
casmFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile
|
||||
|
@ -28,8 +28,8 @@ parseText = Core.runParser replPath defaultModuleId
|
||||
runRepl :: forall r. (Members '[EmbedIO, App] r) => CoreReplOptions -> Core.InfoTable -> Sem r ()
|
||||
runRepl opts tab = do
|
||||
putStr "> "
|
||||
embed (hFlush stdout)
|
||||
done <- embed isEOF
|
||||
liftIO (hFlush stdout)
|
||||
done <- liftIO isEOF
|
||||
unless done $ do
|
||||
s <- getLine
|
||||
case fromText (strip s) of
|
||||
|
@ -41,17 +41,15 @@ runCommand replOpts = do
|
||||
gopts <- State.gets (^. replStateGlobalOptions)
|
||||
absInputFile :: Path Abs File <- replMakeAbsolute inputFile
|
||||
set entryPointTarget Backend.TargetGeb
|
||||
<$> liftIO (runM (runTaggedLockPermissive (entryPointFromGlobalOptions root absInputFile gopts)))
|
||||
embed
|
||||
( State.evalStateT
|
||||
<$> runM (runTaggedLockPermissive (entryPointFromGlobalOptions root absInputFile gopts))
|
||||
liftIO
|
||||
. State.evalStateT
|
||||
(replAction replOpts getReplEntryPoint)
|
||||
( ReplState
|
||||
$ ReplState
|
||||
{ _replContextEntryPoint = Nothing,
|
||||
_replStateGlobalOptions = globalOptions,
|
||||
_replStateInvokeDir = invokeDir
|
||||
}
|
||||
)
|
||||
)
|
||||
|
||||
loadEntryPoint :: EntryPoint -> Repl ()
|
||||
loadEntryPoint ep = do
|
||||
|
@ -173,7 +173,7 @@ replAction =
|
||||
runCommand :: forall r. (Members '[EmbedIO, App] r) => NockmaReplOptions -> Sem r ()
|
||||
runCommand opts = do
|
||||
mt :: Maybe (Term Natural) <- mapM iniStack (opts ^. nockmaReplOptionsStackFile)
|
||||
embed . (`State.evalStateT` (iniState mt)) $ replAction
|
||||
liftIO . (`State.evalStateT` (iniState mt)) $ replAction
|
||||
where
|
||||
iniStack :: AppPath File -> Sem r (Term Natural)
|
||||
iniStack af = do
|
||||
|
@ -5,7 +5,7 @@ import Commands.Dev.Reg.Run.Options
|
||||
import Juvix.Compiler.Reg.Translation.FromSource qualified as Reg
|
||||
import RegInterpreter
|
||||
|
||||
runCommand :: forall r. (Members '[Embed IO, App] r) => RegRunOptions -> Sem r ()
|
||||
runCommand :: forall r. (Members '[EmbedIO, App] r) => RegRunOptions -> Sem r ()
|
||||
runCommand opts = do
|
||||
afile :: Path Abs File <- fromAppPathFile file
|
||||
s <- readFile afile
|
||||
|
@ -117,7 +117,7 @@ runNockmaPipeline pa@PipelineArg {..} = do
|
||||
let code = Nockma.ppSerialize tab'
|
||||
writeFileEnsureLn nockmaFile code
|
||||
|
||||
runAnomaPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r ()
|
||||
runAnomaPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r ()
|
||||
runAnomaPipeline pa@PipelineArg {..} = do
|
||||
entryPoint <- getEntry pa
|
||||
nockmaFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile
|
||||
@ -130,7 +130,7 @@ runAnomaPipeline pa@PipelineArg {..} = do
|
||||
let code = Nockma.ppSerialize tab'
|
||||
writeFileEnsureLn nockmaFile code
|
||||
|
||||
runCasmPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r ()
|
||||
runCasmPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r ()
|
||||
runCasmPipeline pa@PipelineArg {..} = do
|
||||
entryPoint <- getEntry pa
|
||||
casmFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile
|
||||
|
@ -6,7 +6,6 @@ import Prelude (show)
|
||||
|
||||
data Evaluator
|
||||
= EvalEffectful
|
||||
| EvalSem
|
||||
| EvalRaw
|
||||
deriving stock (Eq, Bounded, Enum, Data)
|
||||
|
||||
@ -16,7 +15,6 @@ defaultEvaluator = EvalEffectful
|
||||
instance Show Evaluator where
|
||||
show = \case
|
||||
EvalEffectful -> "effectful"
|
||||
EvalSem -> "polysemy"
|
||||
EvalRaw -> "raw"
|
||||
|
||||
instance Pretty Evaluator where
|
||||
|
@ -128,7 +128,7 @@ replAction =
|
||||
}
|
||||
|
||||
runCommand :: forall r. (Members '[EmbedIO, App] r) => TreeReplOptions -> Sem r ()
|
||||
runCommand _ = embed . (`State.evalStateT` iniState) $ replAction
|
||||
runCommand _ = liftIO . (`State.evalStateT` iniState) $ replAction
|
||||
where
|
||||
iniState :: ReplState
|
||||
iniState =
|
||||
|
@ -82,7 +82,7 @@ checkWasmLd clangPath errMsg =
|
||||
checkClangTargetSupported :: (Members DoctorEff r) => Path Abs File -> String -> [Text] -> Sem r ()
|
||||
checkClangTargetSupported clangPath target errMsg = do
|
||||
(code, _, _) <-
|
||||
embed
|
||||
liftIO
|
||||
( P.readProcessWithExitCode
|
||||
(toFilePath clangPath)
|
||||
["-target", target, "--print-supported-cpus"]
|
||||
@ -92,14 +92,14 @@ checkClangTargetSupported clangPath target errMsg = do
|
||||
|
||||
checkClangVersion :: (Members DoctorEff r) => Path Abs File -> Integer -> [Text] -> Sem r ()
|
||||
checkClangVersion clangPath expectedVersion errMsg = do
|
||||
versionString <- embed (P.readProcess (toFilePath clangPath) ["-dumpversion"] "")
|
||||
versionString <- liftIO (P.readProcess (toFilePath clangPath) ["-dumpversion"] "")
|
||||
case headMay (splitOn "." versionString) >>= readMaybe of
|
||||
Just majorVersion -> unless (majorVersion >= expectedVersion) (mapM_ warning errMsg)
|
||||
Nothing -> warning "Could not determine clang version"
|
||||
|
||||
checkEnvVarSet :: (Members DoctorEff r) => String -> [Text] -> Sem r ()
|
||||
checkEnvVarSet var errMsg = do
|
||||
whenM (isNothing <$> embed (E.lookupEnv var)) (mapM_ warning errMsg)
|
||||
whenM (isNothing <$> liftIO (E.lookupEnv var)) (mapM_ warning errMsg)
|
||||
|
||||
getLatestRelease :: (Members '[EmbedIO, Fail] r) => Sem r GithubRelease
|
||||
getLatestRelease = do
|
||||
@ -114,7 +114,7 @@ checkVersion = do
|
||||
let tagName = "v" <> V.versionDoc
|
||||
response <- runFail getLatestRelease
|
||||
case response of
|
||||
Just release -> case release ^. githubReleaseTagName of
|
||||
Just release' -> case release' ^. githubReleaseTagName of
|
||||
Just latestTagName -> unless (tagName == latestTagName) (warning ("Newer Juvix version is available from https://github.com/anoma/juvix/releases/tag/" <> latestTagName))
|
||||
Nothing -> warning "Tag name is not present in release JSON from Github API"
|
||||
Nothing -> warning "Network error when fetching data from Github API"
|
||||
|
@ -11,15 +11,14 @@ runCommand opts@EvalOptions {..} = do
|
||||
gopts <- askGlobalOptions
|
||||
Core.CoreResult {..} <- runPipeline _evalInputFile upToCore
|
||||
let r =
|
||||
run $
|
||||
runReader (project gopts) $
|
||||
runError @JuvixError $
|
||||
(Core.toStored' _coreResultModule :: Sem '[Error JuvixError, Reader Core.CoreOptions] Core.Module)
|
||||
run
|
||||
. runReader (project gopts)
|
||||
. runError @JuvixError
|
||||
$ (Core.toStored' _coreResultModule :: Sem '[Error JuvixError, Reader Core.CoreOptions] Core.Module)
|
||||
tab <- Core.computeCombinedInfoTable <$> getRight r
|
||||
let mevalNode =
|
||||
if
|
||||
| isJust _evalSymbolName -> getNode tab (selInfo tab)
|
||||
| otherwise -> getNode tab (mainInfo tab)
|
||||
let mevalNode
|
||||
| isJust _evalSymbolName = getNode tab (selInfo tab)
|
||||
| otherwise = getNode tab (mainInfo tab)
|
||||
case mevalNode of
|
||||
Just evalNode ->
|
||||
Eval.evalAndPrint gopts opts tab evalNode
|
||||
|
@ -73,7 +73,7 @@ prepareRuntime buildDir o = do
|
||||
|
||||
writeRuntime :: BS.ByteString -> Sem r ()
|
||||
writeRuntime =
|
||||
embed
|
||||
liftIO
|
||||
. BS.writeFile (toFilePath (buildDir <//> $(mkRelFile "libjuvix.a")))
|
||||
|
||||
headersDir :: [(Path Rel File, BS.ByteString)]
|
||||
@ -83,7 +83,7 @@ prepareRuntime buildDir o = do
|
||||
includeDir = juvixIncludeDir buildDir
|
||||
|
||||
writeHeader :: (Path Rel File, BS.ByteString) -> Sem r ()
|
||||
writeHeader (filePath, contents) = embed $ do
|
||||
writeHeader (filePath, contents) = liftIO $ do
|
||||
ensureDir (includeDir <//> parent filePath)
|
||||
BS.writeFile (toFilePath (includeDir <//> filePath)) contents
|
||||
|
||||
@ -160,7 +160,7 @@ clangWasmWasiCompile inputFile o = do
|
||||
sysrootEnvVar :: Sem r (Path Abs Dir)
|
||||
sysrootEnvVar =
|
||||
absDir
|
||||
<$> fromMaybeM (throw msg) (embed (lookupEnv "WASI_SYSROOT_PATH"))
|
||||
<$> fromMaybeM (throw msg) (liftIO (lookupEnv "WASI_SYSROOT_PATH"))
|
||||
where
|
||||
msg :: Text
|
||||
msg = "Missing environment variable WASI_SYSROOT_PATH"
|
||||
@ -240,7 +240,7 @@ findClangUsingEnvVar = do
|
||||
join <$> mapM checkExecutable p
|
||||
where
|
||||
checkExecutable :: Path Abs File -> Sem r (Maybe (Path Abs File))
|
||||
checkExecutable p = whenMaybeM (embed (isExecutable p)) (return p)
|
||||
checkExecutable p = whenMaybeM (liftIO (isExecutable p)) (return p)
|
||||
|
||||
clangBinPath :: Sem r (Maybe (Path Abs File))
|
||||
clangBinPath = fmap (<//> $(mkRelFile "bin/clang")) <$> llvmDistPath
|
||||
@ -274,7 +274,7 @@ runClang ::
|
||||
Sem r ()
|
||||
runClang args = do
|
||||
cp <- clangBinPath
|
||||
(exitCode, _, err) <- embed (P.readProcessWithExitCode cp args "")
|
||||
(exitCode, _, err) <- liftIO (P.readProcessWithExitCode cp args "")
|
||||
case exitCode of
|
||||
ExitSuccess -> return ()
|
||||
_ -> throw (pack err)
|
||||
|
@ -45,7 +45,7 @@ targetFromOptions opts = do
|
||||
"Use the --help option to display more usage information."
|
||||
]
|
||||
|
||||
runCommand :: forall r. (Members '[EmbedIO, App, TaggedLock, Resource, Files] r) => FormatOptions -> Sem r ()
|
||||
runCommand :: forall r. (Members '[EmbedIO, App, TaggedLock, Files] r) => FormatOptions -> Sem r ()
|
||||
runCommand opts = do
|
||||
target <- targetFromOptions opts
|
||||
runOutputSem (renderFormattedOutput target opts) $ runScopeFileApp $ do
|
||||
@ -79,7 +79,7 @@ renderModeFromOptions target opts formattedInfo
|
||||
| formattedInfo ^. formattedFileInfoContentsModified = res
|
||||
| otherwise = NoEdit Silent
|
||||
|
||||
renderFormattedOutput :: forall r. (Members '[EmbedIO, App, Resource, Files] r) => FormatTarget -> FormatOptions -> FormattedFileInfo -> Sem r ()
|
||||
renderFormattedOutput :: forall r. (Members '[EmbedIO, App, Files] r) => FormatTarget -> FormatOptions -> FormattedFileInfo -> Sem r ()
|
||||
renderFormattedOutput target opts fInfo = do
|
||||
let renderMode = renderModeFromOptions target opts fInfo
|
||||
outputResult renderMode
|
||||
|
@ -19,7 +19,7 @@ runGenOnlySourceHtml HtmlOptions {..} = do
|
||||
res <- runPipeline _htmlInputFile upToScoping
|
||||
let m = res ^. Scoper.resultModule
|
||||
outputDir <- fromAppPathDir _htmlOutputDir
|
||||
embed $
|
||||
liftIO $
|
||||
Html.genSourceHtml
|
||||
GenSourceHtmlArgs
|
||||
{ _genSourceHtmlArgsAssetsDir = _htmlAssetsPrefix,
|
||||
@ -80,13 +80,11 @@ runCommand HtmlOptions {..}
|
||||
when _htmlOpen $ case openCmd of
|
||||
Nothing -> say "Could not recognize the 'open' command for your OS"
|
||||
Just opencmd ->
|
||||
embed
|
||||
( void
|
||||
( Process.spawnProcess
|
||||
liftIO
|
||||
. void
|
||||
$ Process.spawnProcess
|
||||
opencmd
|
||||
[ toFilePath
|
||||
( outputDir <//> Html.indexFileName
|
||||
)
|
||||
]
|
||||
)
|
||||
)
|
||||
|
@ -519,7 +519,7 @@ runCommand opts = do
|
||||
_replStateGlobalOptions = globalOptions
|
||||
}
|
||||
e <-
|
||||
embed
|
||||
liftIO
|
||||
. Except.runExceptT
|
||||
. (`State.evalStateT` iniState)
|
||||
. (`Reader.runReaderT` env)
|
||||
@ -535,7 +535,7 @@ defaultPreludeEntryPoint = do
|
||||
let buildRoot = root ^. rootRootDir
|
||||
buildDir = resolveAbsBuildDir buildRoot (root ^. rootBuildDir)
|
||||
pkg <- Reader.asks (^. replPackage)
|
||||
mstdlibPath <- liftIO (runM (runFilesIO (packageStdlib buildRoot buildDir (pkg ^. packageDependencies))))
|
||||
mstdlibPath <- runM (runFilesIO (packageStdlib buildRoot buildDir (pkg ^. packageDependencies)))
|
||||
case mstdlibPath of
|
||||
Just stdlibPath ->
|
||||
Just
|
||||
@ -554,8 +554,7 @@ replExpressionUpToScopedAtoms :: Text -> Repl (Concrete.ExpressionAtoms 'Concret
|
||||
replExpressionUpToScopedAtoms txt = do
|
||||
ctx <- replGetContext
|
||||
x <-
|
||||
liftIO
|
||||
. runM
|
||||
runM
|
||||
. runError
|
||||
. evalState (ctx ^. replContextArtifacts)
|
||||
. runReader (ctx ^. replContextEntryPoint)
|
||||
@ -566,8 +565,7 @@ replExpressionUpToTyped :: Text -> Repl Internal.TypedExpression
|
||||
replExpressionUpToTyped txt = do
|
||||
ctx <- replGetContext
|
||||
x <-
|
||||
liftIO
|
||||
. runM
|
||||
runM
|
||||
. runError
|
||||
. evalState (ctx ^. replContextArtifacts)
|
||||
. runReader (ctx ^. replContextEntryPoint)
|
||||
|
@ -16,9 +16,7 @@ main = do
|
||||
mbuildDir <- mapM (prepathToAbsDir invokeDir) (_runAppIOArgsGlobalOptions ^? globalBuildDir . _Just . pathPath)
|
||||
mainFile <- topCommandInputPath cli
|
||||
mapM_ checkMainFile mainFile
|
||||
runFinal
|
||||
. resourceToIOFinal
|
||||
. embedToFinal @IO
|
||||
runM
|
||||
. runTaggedLockPermissive
|
||||
$ do
|
||||
_runAppIOArgsRoot <- findRootAndChangeDir (containingDir <$> mainFile) mbuildDir invokeDir
|
||||
|
@ -6,7 +6,7 @@ import Juvix.Compiler.Reg.Data.InfoTable qualified as Reg
|
||||
import Juvix.Compiler.Reg.Interpreter qualified as Reg
|
||||
import Juvix.Compiler.Reg.Pretty qualified as Reg
|
||||
|
||||
runReg :: forall r. (Members '[Embed IO, App] r) => Reg.InfoTable -> Sem r ()
|
||||
runReg :: forall r. (Members '[EmbedIO, App] r) => Reg.InfoTable -> Sem r ()
|
||||
runReg tab =
|
||||
case tab ^. Reg.infoMainFunction of
|
||||
Just sym -> do
|
||||
|
@ -25,7 +25,7 @@ showHelpText = do
|
||||
(msg, _) = renderFailure helpText progn
|
||||
putStrLn (pack msg)
|
||||
|
||||
runTopCommand :: forall r. (Members '[EmbedIO, App, Resource, TaggedLock] r) => TopCommand -> Sem r ()
|
||||
runTopCommand :: forall r. (Members '[EmbedIO, App, TaggedLock] r) => TopCommand -> Sem r ()
|
||||
runTopCommand = \case
|
||||
DisplayVersion -> runDisplayVersion
|
||||
DisplayNumericVersion -> runDisplayNumericVersion
|
||||
|
@ -11,7 +11,6 @@ import Juvix.Compiler.Tree.Data.InfoTable qualified as Tree
|
||||
import Juvix.Compiler.Tree.Error qualified as Tree
|
||||
import Juvix.Compiler.Tree.Evaluator qualified as Tree
|
||||
import Juvix.Compiler.Tree.EvaluatorEff qualified as Eff
|
||||
import Juvix.Compiler.Tree.EvaluatorSem qualified as TreeSem
|
||||
import Juvix.Compiler.Tree.Language.Value qualified as Tree
|
||||
import Juvix.Compiler.Tree.Pretty qualified as Tree
|
||||
|
||||
@ -47,7 +46,6 @@ doEval ::
|
||||
doEval = \case
|
||||
EvalEffectful -> doEvalEff
|
||||
EvalRaw -> doEvalRaw
|
||||
EvalSem -> doEvalSem
|
||||
|
||||
doEvalRaw ::
|
||||
(MonadIO m) =>
|
||||
@ -62,10 +60,3 @@ doEvalEff ::
|
||||
Tree.FunctionInfo ->
|
||||
m (Either Tree.TreeError Tree.Value)
|
||||
doEvalEff tab' funInfo = Eff.hEvalIOEither stdin stdout tab' funInfo
|
||||
|
||||
doEvalSem ::
|
||||
(MonadIO m) =>
|
||||
Tree.InfoTable ->
|
||||
Tree.FunctionInfo ->
|
||||
m (Either Tree.TreeError Tree.Value)
|
||||
doEvalSem tab' funInfo = TreeSem.hEvalIOEither stdin stdout tab' funInfo
|
||||
|
@ -1,8 +1,9 @@
|
||||
module Benchmark.Effect.EmbedIO where
|
||||
|
||||
import Juvix.Prelude
|
||||
import Juvix.Prelude.Effects (Eff)
|
||||
import Juvix.Prelude (withSystemTempFile)
|
||||
import Juvix.Prelude.Base.Foundation
|
||||
import Juvix.Prelude.Effects qualified as E
|
||||
import PolysemyPrelude qualified as P
|
||||
import Test.Tasty.Bench
|
||||
|
||||
bm :: Benchmark
|
||||
@ -30,9 +31,9 @@ countRaw n =
|
||||
a -> hPutChar h c >> go h (pred a)
|
||||
|
||||
countSem :: Natural -> IO ()
|
||||
countSem n = withSystemTempFile "tmp" $ \_ h -> runM (go h n)
|
||||
countSem n = withSystemTempFile "tmp" $ \_ h -> P.runM (go h n)
|
||||
where
|
||||
go :: Handle -> Natural -> Sem '[Embed IO] ()
|
||||
go :: Handle -> Natural -> P.Sem '[P.EmbedIO] ()
|
||||
go h = \case
|
||||
0 -> return ()
|
||||
a -> liftIO (hPutChar h c) >> go h (pred a)
|
||||
@ -40,7 +41,7 @@ countSem n = withSystemTempFile "tmp" $ \_ h -> runM (go h n)
|
||||
countEff :: Natural -> IO ()
|
||||
countEff n = withSystemTempFile "tmp" $ \_ h -> E.runEff (go h n)
|
||||
where
|
||||
go :: Handle -> Natural -> Eff '[E.IOE] ()
|
||||
go :: Handle -> Natural -> E.Sem '[E.IOE] ()
|
||||
go h = \case
|
||||
0 -> return ()
|
||||
a -> liftIO (hPutChar h c) >> go h (pred a)
|
||||
|
@ -1,8 +1,8 @@
|
||||
module Benchmark.Effect.Output where
|
||||
|
||||
import Juvix.Prelude
|
||||
import Juvix.Prelude.Effects (Eff, (:>))
|
||||
import Juvix.Prelude.Base.Foundation
|
||||
import Juvix.Prelude.Effects qualified as E
|
||||
import PolysemyPrelude qualified as P
|
||||
import Test.Tasty.Bench
|
||||
|
||||
bm :: Benchmark
|
||||
@ -29,7 +29,7 @@ countdownRaw = sum' . reverse . go []
|
||||
countdownAccum :: Natural -> Natural
|
||||
countdownAccum = sum' . E.runPureEff . E.execAccumList . go
|
||||
where
|
||||
go :: (E.Accum Natural :> r) => Natural -> Eff r ()
|
||||
go :: (E.Member (E.Accum Natural) r) => Natural -> E.Sem r ()
|
||||
go = \case
|
||||
0 -> return ()
|
||||
m -> E.accum m >> go (pred m)
|
||||
@ -37,15 +37,15 @@ countdownAccum = sum' . E.runPureEff . E.execAccumList . go
|
||||
countdownEff :: Natural -> Natural
|
||||
countdownEff = sum' . E.runPureEff . E.execOutputList . go
|
||||
where
|
||||
go :: (E.Output Natural :> r) => Natural -> Eff r ()
|
||||
go :: (E.Member (E.Output Natural) r) => Natural -> E.Sem r ()
|
||||
go = \case
|
||||
0 -> return ()
|
||||
m -> E.output m >> go (pred m)
|
||||
|
||||
countdownSem :: Natural -> Natural
|
||||
countdownSem = sum' . run . execOutputList . go
|
||||
countdownSem = sum' . P.run . P.execOutputList . go
|
||||
where
|
||||
go :: (Members '[Output Natural] r) => Natural -> Sem r ()
|
||||
go :: (P.Members '[P.Output Natural] r) => Natural -> P.Sem r ()
|
||||
go = \case
|
||||
0 -> return ()
|
||||
m -> output m >> go (pred m)
|
||||
m -> P.output m >> go (pred m)
|
||||
|
@ -1,8 +1,8 @@
|
||||
module Benchmark.Effect.Reader where
|
||||
|
||||
import Juvix.Prelude
|
||||
import Juvix.Prelude.Effects (Eff, (:>))
|
||||
import Juvix.Prelude.Base.Foundation
|
||||
import Juvix.Prelude.Effects qualified as E
|
||||
import PolysemyPrelude qualified as P
|
||||
import Test.Tasty.Bench
|
||||
|
||||
bm :: Benchmark
|
||||
@ -31,7 +31,7 @@ countRaw = sum' . go []
|
||||
countEff :: Natural -> Natural
|
||||
countEff = sum' . E.runPureEff . E.runReader c . go []
|
||||
where
|
||||
go :: (E.Reader Natural :> r) => [Natural] -> Natural -> Eff r [Natural]
|
||||
go :: (E.Member (E.Reader Natural) r) => [Natural] -> Natural -> E.Sem r [Natural]
|
||||
go acc = \case
|
||||
0 -> return acc
|
||||
n -> do
|
||||
@ -39,11 +39,11 @@ countEff = sum' . E.runPureEff . E.runReader c . go []
|
||||
go (i : acc) (pred n)
|
||||
|
||||
countSem :: Natural -> Natural
|
||||
countSem = sum' . run . runReader c . go []
|
||||
countSem = sum' . P.run . P.runReader c . go []
|
||||
where
|
||||
go :: (Member (Reader Natural) r) => [Natural] -> Natural -> Sem r [Natural]
|
||||
go :: (P.Member (P.Reader Natural) r) => [Natural] -> Natural -> P.Sem r [Natural]
|
||||
go acc = \case
|
||||
0 -> return acc
|
||||
n -> do
|
||||
i <- ask
|
||||
i <- P.ask
|
||||
go (i : acc) (pred n)
|
||||
|
@ -1,8 +1,8 @@
|
||||
module Benchmark.Effect.ReaderH where
|
||||
|
||||
import Juvix.Prelude
|
||||
import Juvix.Prelude.Effects (Eff, (:>))
|
||||
import Juvix.Prelude.Base.Foundation
|
||||
import Juvix.Prelude.Effects qualified as E
|
||||
import PolysemyPrelude qualified as P
|
||||
import Test.Tasty.Bench
|
||||
|
||||
bm :: Benchmark
|
||||
@ -28,7 +28,7 @@ countRaw = sum' . go []
|
||||
countEff :: Natural -> Natural
|
||||
countEff x = sum' . E.runPureEff . E.runReader x $ go []
|
||||
where
|
||||
go :: (E.Reader Natural :> r) => [Natural] -> Eff r [Natural]
|
||||
go :: (E.Member (E.Reader Natural) r) => [Natural] -> E.Sem r [Natural]
|
||||
go acc = do
|
||||
n <- E.ask
|
||||
case n of
|
||||
@ -36,11 +36,11 @@ countEff x = sum' . E.runPureEff . E.runReader x $ go []
|
||||
m -> E.local @Natural pred (go (m : acc))
|
||||
|
||||
countSem :: Natural -> Natural
|
||||
countSem x = sum . run . runReader x $ go []
|
||||
countSem x = sum . P.run . P.runReader x $ go []
|
||||
where
|
||||
go :: (Members '[Reader Natural] r) => [Natural] -> Sem r [Natural]
|
||||
go :: (P.Members '[P.Reader Natural] r) => [Natural] -> P.Sem r [Natural]
|
||||
go acc = do
|
||||
n :: Natural <- ask
|
||||
n :: Natural <- P.ask
|
||||
case n of
|
||||
0 -> return acc
|
||||
m -> local @Natural pred (go (m : acc))
|
||||
m -> P.local @Natural pred (go (m : acc))
|
||||
|
@ -1,8 +1,8 @@
|
||||
module Benchmark.Effect.State where
|
||||
|
||||
import Juvix.Prelude
|
||||
import Juvix.Prelude.Effects (Eff, (:>))
|
||||
import Juvix.Prelude.Base.Foundation
|
||||
import Juvix.Prelude.Effects qualified as E
|
||||
import PolysemyPrelude qualified as P
|
||||
import Test.Tasty.Bench
|
||||
|
||||
bm :: Benchmark
|
||||
@ -28,15 +28,15 @@ countRaw = go 0
|
||||
countEff :: Natural -> Natural
|
||||
countEff = E.runPureEff . E.execState 0 . go
|
||||
where
|
||||
go :: (E.State Natural :> r) => Natural -> Eff r ()
|
||||
go :: (E.Member (E.State Natural) r) => Natural -> E.Sem r ()
|
||||
go = \case
|
||||
0 -> return ()
|
||||
m -> E.modify (+ m) >> go (pred m)
|
||||
|
||||
countSem :: Natural -> Natural
|
||||
countSem = run . execState 0 . go
|
||||
countSem = P.run . P.execState 0 . go
|
||||
where
|
||||
go :: (Members '[State Natural] r) => Natural -> Sem r ()
|
||||
go :: (P.Members '[P.State Natural] r) => Natural -> P.Sem r ()
|
||||
go = \case
|
||||
0 -> return ()
|
||||
m -> modify (+ m) >> go (pred m)
|
||||
m -> P.modify (+ m) >> go (pred m)
|
||||
|
@ -1,5 +1,5 @@
|
||||
module Juvix.Prelude.Base.Polysemy
|
||||
( module Juvix.Prelude.Base.Polysemy,
|
||||
module PolysemyPrelude
|
||||
( module PolysemyPrelude,
|
||||
module Polysemy,
|
||||
module Polysemy.Error,
|
||||
module Polysemy.Input,
|
||||
@ -37,9 +37,6 @@ mapReader f s = do
|
||||
e <- ask
|
||||
runReader (f e) s
|
||||
|
||||
eassert :: Bool -> Sem r ()
|
||||
eassert b = assert b $ return ()
|
||||
|
||||
execOutputList :: Sem (Output o ': r) a -> Sem r [o]
|
||||
execOutputList = fmap fst . runOutputList
|
||||
|
@ -60,6 +60,7 @@ dependencies:
|
||||
- effectful-core == 2.3.*
|
||||
- effectful-th == 1.0.*
|
||||
- exceptions == 0.10.*
|
||||
- resourcet-effectful == 1.0.*
|
||||
- extra == 1.7.*
|
||||
- file-embed == 0.0.*
|
||||
- filelock == 0.1.*
|
||||
@ -76,11 +77,10 @@ dependencies:
|
||||
- parser-combinators == 1.3.*
|
||||
- path == 0.9.*
|
||||
- path-io == 1.8.*
|
||||
- polysemy == 1.9.*
|
||||
- polysemy-plugin == 0.4.*
|
||||
- pretty == 1.1.*
|
||||
- prettyprinter == 1.7.*
|
||||
- prettyprinter-ansi-terminal == 1.1.*
|
||||
- primitive == 0.8.*
|
||||
- process == 1.6.*
|
||||
- safe == 0.3.*
|
||||
- singletons == 3.0.*
|
||||
@ -169,6 +169,7 @@ executables:
|
||||
dependencies:
|
||||
- juvix
|
||||
- tasty-bench == 0.3.*
|
||||
- polysemy == 1.9.*
|
||||
verbatim:
|
||||
default-language: GHC2021
|
||||
|
||||
|
@ -14,7 +14,7 @@ import Juvix.Compiler.Asm.Interpreter.Error
|
||||
import Juvix.Compiler.Asm.Interpreter.RuntimeState
|
||||
import Juvix.Compiler.Asm.Pretty
|
||||
|
||||
data Runtime m a where
|
||||
data Runtime :: Effect where
|
||||
HasCaller :: Runtime m Bool -- is the call stack non-empty?
|
||||
PushCallStack :: Code -> Runtime m ()
|
||||
PopCallStack :: Runtime m Continuation
|
||||
@ -37,10 +37,19 @@ data Runtime m a where
|
||||
makeSem ''Runtime
|
||||
|
||||
runRuntime :: forall r a. InfoTable -> Sem (Runtime ': r) a -> Sem r (RuntimeState, a)
|
||||
runRuntime tab = runState (RuntimeState (CallStack []) emptyFrame [] Nothing tab) . interp
|
||||
runRuntime tab = interp
|
||||
where
|
||||
interp :: Sem (Runtime ': r) a -> Sem (State RuntimeState ': r) a
|
||||
interp = reinterpret $ \case
|
||||
iniState =
|
||||
RuntimeState
|
||||
{ _runtimeCallStack = AsmCallStack [],
|
||||
_runtimeFrame = emptyFrame,
|
||||
_runtimeMessages = [],
|
||||
_runtimeLocation = Nothing,
|
||||
_runtimeInfoTable = tab
|
||||
}
|
||||
|
||||
interp :: Sem (Runtime ': r) a -> Sem r (RuntimeState, a)
|
||||
interp = reinterpret (runState iniState) $ \case
|
||||
HasCaller ->
|
||||
not . null . (^. runtimeCallStack . callStack) <$> get
|
||||
PushCallStack code -> do
|
||||
|
@ -53,7 +53,7 @@ Memory consists of:
|
||||
-- The heap does not need to be modelled explicitly. Heap values are simply
|
||||
-- stored in the `Val` datastructure. Pointers are implicit.
|
||||
|
||||
newtype CallStack = CallStack
|
||||
newtype AsmCallStack = AsmCallStack
|
||||
{ _callStack :: [Continuation]
|
||||
}
|
||||
|
||||
@ -96,7 +96,7 @@ data Continuation = Continuation
|
||||
-- | JuvixAsm runtime state
|
||||
data RuntimeState = RuntimeState
|
||||
{ -- | global call stack
|
||||
_runtimeCallStack :: CallStack,
|
||||
_runtimeCallStack :: AsmCallStack,
|
||||
-- | current frame
|
||||
_runtimeFrame :: Frame,
|
||||
-- | debug messages generated so far
|
||||
@ -107,7 +107,7 @@ data RuntimeState = RuntimeState
|
||||
_runtimeInfoTable :: InfoTable
|
||||
}
|
||||
|
||||
makeLenses ''CallStack
|
||||
makeLenses ''AsmCallStack
|
||||
makeLenses ''Continuation
|
||||
makeLenses ''ArgumentArea
|
||||
makeLenses ''TemporaryStack
|
||||
|
@ -2,7 +2,7 @@ module Juvix.Compiler.Backend.C.Data.CBuilder where
|
||||
|
||||
import Juvix.Prelude
|
||||
|
||||
data CBuilder m a where
|
||||
data CBuilder :: Effect where
|
||||
FreshLabel :: CBuilder m Text
|
||||
|
||||
makeSem ''CBuilder
|
||||
@ -20,9 +20,7 @@ emptyCBuilderState =
|
||||
}
|
||||
|
||||
runCBuilder :: Sem (CBuilder ': r) a -> Sem r a
|
||||
runCBuilder =
|
||||
evalState emptyCBuilderState
|
||||
. reinterpret interp
|
||||
runCBuilder = reinterpret (evalState emptyCBuilderState) interp
|
||||
where
|
||||
interp :: CBuilder m a -> Sem (State CBuilderState ': r) a
|
||||
interp = \case
|
||||
|
@ -21,7 +21,6 @@ import Juvix.Compiler.Pipeline.EntryPoint
|
||||
import Juvix.Extra.Assets
|
||||
import Juvix.Extra.Strings qualified as Str
|
||||
import Juvix.Prelude
|
||||
import Juvix.Prelude qualified as Prelude
|
||||
import Juvix.Prelude.Pretty
|
||||
import Text.Blaze.Html.Renderer.Utf8 qualified as Html
|
||||
import Text.Blaze.Html5 as Html hiding (map)
|
||||
@ -172,7 +171,7 @@ createIndexFile ps = do
|
||||
<> ul (mconcatMap li c')
|
||||
|
||||
writeHtml :: (Members '[EmbedIO] r) => Path Abs File -> Html -> Sem r ()
|
||||
writeHtml f h = Prelude.embed $ do
|
||||
writeHtml f h = liftIO $ do
|
||||
ensureDir dir
|
||||
Builder.writeFile (toFilePath f) (Html.renderHtmlBuilder h)
|
||||
where
|
||||
@ -182,7 +181,7 @@ writeHtml f h = Prelude.embed $ do
|
||||
genJudocHtml :: (Members '[EmbedIO] r) => EntryPoint -> JudocArgs -> Sem r ()
|
||||
genJudocHtml entry JudocArgs {..} =
|
||||
runReader htmlOpts . runReader normTable . runReader entry $ do
|
||||
Prelude.embed (writeAssets _judocArgsOutputDir)
|
||||
liftIO (writeAssets _judocArgsOutputDir)
|
||||
mapM_ (goTopModule cs) allModules
|
||||
createIndexFile (map topModulePath (toList allModules))
|
||||
where
|
||||
@ -306,7 +305,7 @@ goTopModule cs m = do
|
||||
|
||||
srcHtml :: forall s. (Members '[Reader HtmlOptions, EmbedIO] s) => Sem s Html
|
||||
srcHtml = do
|
||||
utc <- Prelude.embed getCurrentTime
|
||||
utc <- liftIO getCurrentTime
|
||||
genModuleHtml
|
||||
GenModuleHtmlArgs
|
||||
{ _genModuleHtmlArgsConcreteOpts = defaultOptions,
|
||||
|
@ -9,7 +9,7 @@ import Juvix.Compiler.Internal.Extra
|
||||
import Juvix.Compiler.Internal.Pretty
|
||||
import Juvix.Prelude
|
||||
|
||||
data Builtins m a where
|
||||
data Builtins :: Effect where
|
||||
GetBuiltinName' :: Interval -> BuiltinPrim -> Builtins m Name
|
||||
RegisterBuiltin' :: BuiltinPrim -> Name -> Builtins m ()
|
||||
|
||||
@ -30,8 +30,8 @@ makeLenses ''BuiltinsState
|
||||
iniBuiltins :: BuiltinsState
|
||||
iniBuiltins = BuiltinsState mempty
|
||||
|
||||
re :: forall r a. (Member (Error JuvixError) r) => Sem (Builtins ': r) a -> Sem (State BuiltinsState ': r) a
|
||||
re = reinterpret $ \case
|
||||
runBuiltins :: forall r a. (Member (Error JuvixError) r) => BuiltinsState -> Sem (Builtins ': r) a -> Sem r (BuiltinsState, a)
|
||||
runBuiltins ini = reinterpret (runState ini) $ \case
|
||||
GetBuiltinName' i b -> fromMaybeM notDefined (gets (^. builtinsTable . at b))
|
||||
where
|
||||
notDefined :: Sem (State BuiltinsState ': r) x
|
||||
@ -61,9 +61,6 @@ re = reinterpret $ \case
|
||||
evalBuiltins :: (Member (Error JuvixError) r) => BuiltinsState -> Sem (Builtins ': r) a -> Sem r a
|
||||
evalBuiltins s = fmap snd . runBuiltins s
|
||||
|
||||
runBuiltins :: (Member (Error JuvixError) r) => BuiltinsState -> Sem (Builtins ': r) a -> Sem r (BuiltinsState, a)
|
||||
runBuiltins s = runState s . re
|
||||
|
||||
data FunInfo = FunInfo
|
||||
{ _funInfoDef :: FunctionDef,
|
||||
_funInfoBuiltin :: BuiltinFunction,
|
||||
|
@ -4,7 +4,7 @@ import Data.HashMap.Strict qualified as HashMap
|
||||
import Juvix.Compiler.Casm.Data.LabelInfo
|
||||
import Juvix.Compiler.Casm.Language
|
||||
|
||||
data LabelInfoBuilder m a where
|
||||
data LabelInfoBuilder :: Effect where
|
||||
FreshSymbol :: LabelInfoBuilder m Symbol
|
||||
RegisterLabelName :: Symbol -> Text -> LabelInfoBuilder m ()
|
||||
RegisterLabelAddress :: Symbol -> Int -> LabelInfoBuilder m ()
|
||||
@ -38,9 +38,7 @@ runLabelInfoBuilder :: Sem (LabelInfoBuilder ': r) a -> Sem r (LabelInfo, a)
|
||||
runLabelInfoBuilder = fmap (first (^. stateLabelInfo)) . runLabelInfoBuilder' emptyBuilderState
|
||||
|
||||
runLabelInfoBuilder' :: BuilderState -> Sem (LabelInfoBuilder ': r) a -> Sem r (BuilderState, a)
|
||||
runLabelInfoBuilder' bs =
|
||||
runState bs
|
||||
. reinterpret interp
|
||||
runLabelInfoBuilder' bs = reinterpret (runState bs) interp
|
||||
where
|
||||
interp :: LabelInfoBuilder m a -> Sem (State BuilderState ': r) a
|
||||
interp = \case
|
||||
|
@ -10,7 +10,7 @@ import Juvix.Compiler.Concrete.Language
|
||||
import Juvix.Compiler.Store.Scoped.Language
|
||||
import Juvix.Prelude
|
||||
|
||||
data InfoTableBuilder m a where
|
||||
data InfoTableBuilder :: Effect where
|
||||
RegisterAxiom :: AxiomDef 'Scoped -> InfoTableBuilder m ()
|
||||
RegisterConstructor :: ConstructorDef 'Scoped -> InfoTableBuilder m ()
|
||||
RegisterInductive :: InductiveDef 'Scoped -> InfoTableBuilder m ()
|
||||
@ -36,8 +36,8 @@ registerDoc k md = do
|
||||
modify (set (highlightDoc . at k) md)
|
||||
modify (set (infoHighlightDoc . at k) md)
|
||||
|
||||
toState :: (Member HighlightBuilder r) => Sem (InfoTableBuilder ': r) a -> Sem (State InfoTable ': r) a
|
||||
toState = reinterpret $ \case
|
||||
runInfoTableBuilder :: (Member HighlightBuilder r) => InfoTable -> Sem (InfoTableBuilder ': r) a -> Sem r (InfoTable, a)
|
||||
runInfoTableBuilder ini = reinterpret (runState ini) $ \case
|
||||
RegisterAxiom d ->
|
||||
let j = d ^. axiomDoc
|
||||
in do
|
||||
@ -94,11 +94,8 @@ toState = reinterpret $ \case
|
||||
runInfoTableBuilderRepl :: InfoTable -> Sem (InfoTableBuilder ': r) a -> Sem r (InfoTable, a)
|
||||
runInfoTableBuilderRepl tab = ignoreHighlightBuilder . runInfoTableBuilder tab . raiseUnder
|
||||
|
||||
runInfoTableBuilder :: (Member HighlightBuilder r) => InfoTable -> Sem (InfoTableBuilder ': r) a -> Sem r (InfoTable, a)
|
||||
runInfoTableBuilder tab = runState tab . toState
|
||||
|
||||
ignoreInfoTableBuilder :: (Member HighlightBuilder r) => Sem (InfoTableBuilder ': r) a -> Sem r a
|
||||
ignoreInfoTableBuilder = evalState mempty . toState
|
||||
ignoreInfoTableBuilder = fmap snd . runInfoTableBuilder mempty
|
||||
|
||||
anameFromScopedIden :: ScopedIden -> AName
|
||||
anameFromScopedIden s =
|
||||
|
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# OPTIONS_GHC -Wno-unused-type-patterns #-}
|
||||
|
||||
module Juvix.Compiler.Concrete.Data.NameSignature.Builder
|
||||
( mkNameSignature,
|
||||
@ -16,7 +17,7 @@ import Juvix.Compiler.Concrete.Gen qualified as Gen
|
||||
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error
|
||||
import Juvix.Prelude
|
||||
|
||||
data NameSignatureBuilder s m a where
|
||||
data NameSignatureBuilder s :: Effect where
|
||||
AddSymbol :: IsImplicit -> Maybe (ArgDefault s) -> SymbolType s -> ExpressionType s -> NameSignatureBuilder s m ()
|
||||
EndBuild :: Proxy s -> NameSignatureBuilder s m a
|
||||
-- | for debugging
|
||||
@ -179,7 +180,7 @@ re ::
|
||||
(SingI s) =>
|
||||
Sem (NameSignatureBuilder s ': r) a ->
|
||||
Sem (Re s r) a
|
||||
re = reinterpret3 $ \case
|
||||
re = interpretTop3 $ \case
|
||||
AddSymbol impl mdef k ty -> addSymbol' impl mdef k ty
|
||||
EndBuild {} -> endBuild'
|
||||
GetBuilder -> get
|
||||
|
@ -28,7 +28,7 @@ import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context qualified as
|
||||
import Juvix.Compiler.Pipeline.EntryPoint
|
||||
import Juvix.Compiler.Store.Scoped.Language as Store
|
||||
import Juvix.Data.FixityInfo qualified as FI
|
||||
import Juvix.Prelude hiding (scoped)
|
||||
import Juvix.Prelude
|
||||
|
||||
scopeCheck ::
|
||||
(Members '[HighlightBuilder, Error JuvixError, NameIdGen] r) =>
|
||||
|
@ -6,7 +6,7 @@ import Juvix.Compiler.Concrete.Language
|
||||
import Juvix.Compiler.Concrete.Translation.FromSource.Data.ParserState
|
||||
import Juvix.Prelude
|
||||
|
||||
data ParserResultBuilder m a where
|
||||
data ParserResultBuilder :: Effect where
|
||||
RegisterItem :: ParsedItem -> ParserResultBuilder m ()
|
||||
RegisterSpaceSpan :: SpaceSpan -> ParserResultBuilder m ()
|
||||
RegisterImport :: Import 'Parsed -> ParserResultBuilder m ()
|
||||
@ -70,9 +70,7 @@ registerItem' i = modify' (over parserStateParsedItems (i :))
|
||||
|
||||
runParserResultBuilder :: (Member HighlightBuilder r) => ParserState -> Sem (ParserResultBuilder ': r) a -> Sem r (ParserState, a)
|
||||
runParserResultBuilder s =
|
||||
runState s
|
||||
. reinterpret
|
||||
( \case
|
||||
reinterpret (runState s) $ \case
|
||||
RegisterImport i -> modify' (over parserStateImports (i :))
|
||||
RegisterItem i -> do
|
||||
modify' (over highlightParsed (i :))
|
||||
@ -85,4 +83,3 @@ runParserResultBuilder s =
|
||||
{ _parsedLoc = getLoc c,
|
||||
_parsedTag = ParsedTagComment
|
||||
}
|
||||
)
|
||||
|
@ -11,7 +11,7 @@ import Juvix.Compiler.Core.Extra.Base
|
||||
import Juvix.Compiler.Core.Info.NameInfo
|
||||
import Juvix.Compiler.Core.Language
|
||||
|
||||
data InfoTableBuilder m a where
|
||||
data InfoTableBuilder :: Effect where
|
||||
FreshSymbol :: InfoTableBuilder m Symbol
|
||||
FreshTag :: InfoTableBuilder m Tag
|
||||
RegisterIdent :: Text -> IdentifierInfo -> InfoTableBuilder m ()
|
||||
@ -89,9 +89,7 @@ mkBuilderState m =
|
||||
tab = computeCombinedInfoTable m
|
||||
|
||||
runInfoTableBuilder' :: BuilderState -> forall r a. Sem (InfoTableBuilder ': r) a -> Sem r (BuilderState, a)
|
||||
runInfoTableBuilder' st =
|
||||
runState st
|
||||
. reinterpret interp
|
||||
runInfoTableBuilder' st = reinterpret (runState st) interp
|
||||
where
|
||||
interp :: InfoTableBuilder m b -> Sem (State BuilderState ': r) b
|
||||
interp = \case
|
||||
|
@ -11,10 +11,11 @@ import Juvix.Compiler.Core.Transformation.Base
|
||||
unrollRecursion :: (Member (Reader CoreOptions) r) => Module -> Sem r Module
|
||||
unrollRecursion md = do
|
||||
(mp, md') <-
|
||||
runState @(HashMap Symbol Symbol) mempty $
|
||||
execInfoTableBuilder md $
|
||||
forM_ (buildSCCs (createCallGraph (md ^. moduleInfoTable))) goSCC
|
||||
return $ mapIdentSymbols mp $ pruneInfoTable md'
|
||||
runState @(HashMap Symbol Symbol) mempty
|
||||
. execInfoTableBuilder md
|
||||
. forM_ (buildSCCs (createCallGraph (md ^. moduleInfoTable)))
|
||||
$ goSCC
|
||||
return . mapIdentSymbols mp $ pruneInfoTable md'
|
||||
where
|
||||
mapIdentSymbols :: HashMap Symbol Symbol -> Module -> Module
|
||||
mapIdentSymbols mp = over (moduleInfoTable . infoMain) adjustMain . mapAllNodes (umap go)
|
||||
|
@ -22,7 +22,7 @@ import Juvix.Prelude
|
||||
class Scannable a where
|
||||
buildCallMap :: a -> CallMap
|
||||
|
||||
data Termination m a where
|
||||
data Termination :: Effect where
|
||||
CheckTerminationShallow :: (Scannable a) => a -> Termination m ()
|
||||
FunctionTermination :: FunctionRef -> Termination m IsTerminating
|
||||
|
||||
@ -33,7 +33,7 @@ functionSafeToNormalize = fmap safeToNormalize . functionTermination
|
||||
|
||||
runTermination :: forall r a. (Members '[Error JuvixError] r) => TerminationState -> Sem (Termination ': r) a -> Sem r (TerminationState, a)
|
||||
runTermination ini m = do
|
||||
res <- runState ini (re m)
|
||||
res <- runTerminationState ini m
|
||||
checkNonTerminating (fst res)
|
||||
return res
|
||||
where
|
||||
@ -60,8 +60,8 @@ instance Scannable Expression where
|
||||
. execState emptyCallMap
|
||||
. scanTopExpression
|
||||
|
||||
re :: Sem (Termination ': r) a -> Sem (State TerminationState ': r) a
|
||||
re = reinterpret $ \case
|
||||
runTerminationState :: TerminationState -> Sem (Termination ': r) a -> Sem r (TerminationState, a)
|
||||
runTerminationState ini = reinterpret (runState ini) $ \case
|
||||
CheckTerminationShallow m -> checkTerminationShallow' m
|
||||
FunctionTermination m -> functionTermination' m
|
||||
|
||||
|
@ -40,7 +40,7 @@ data MatchError = MatchError
|
||||
|
||||
makeLenses ''MatchError
|
||||
|
||||
data Inference m a where
|
||||
data Inference :: Effect where
|
||||
MatchTypes :: Expression -> Expression -> Inference m (Maybe MatchError)
|
||||
QueryMetavar :: Hole -> Inference m (Maybe Expression)
|
||||
RegisterIdenType :: Name -> Expression -> Inference m ()
|
||||
@ -294,11 +294,12 @@ queryMetavar' h = do
|
||||
Just Fresh -> return Nothing
|
||||
Just (Refined e) -> return (Just e)
|
||||
|
||||
re ::
|
||||
runInferenceState ::
|
||||
(Members '[State FunctionsTable, Error TypeCheckerError, NameIdGen] r) =>
|
||||
InferenceState ->
|
||||
Sem (Inference ': r) a ->
|
||||
Sem (State InferenceState ': r) a
|
||||
re = reinterpret $ \case
|
||||
Sem r (InferenceState, a)
|
||||
runInferenceState inis = reinterpret (runState inis) $ \case
|
||||
MatchTypes a b -> matchTypes' a b
|
||||
QueryMetavar h -> queryMetavar' h
|
||||
RememberFunctionDef f -> modify' (over inferenceFunctionsStash (f :))
|
||||
@ -487,7 +488,7 @@ runInferenceDefs ::
|
||||
Sem (Inference ': r) (NonEmpty funDef) ->
|
||||
Sem r (NonEmpty funDef)
|
||||
runInferenceDefs a = do
|
||||
(finalState, expr) <- runState iniState (re a)
|
||||
(finalState, expr) <- runInferenceState iniState a
|
||||
(subs, idens) <- closeState finalState
|
||||
idens' <- mapM (subsHoles subs) (idens ^. typesTable)
|
||||
stash' <- mapM (subsHoles subs) (finalState ^. inferenceFunctionsStash)
|
||||
|
@ -7,7 +7,7 @@ module Juvix.Compiler.Pipeline
|
||||
)
|
||||
where
|
||||
|
||||
import Data.List.Singletons
|
||||
import Data.List.Singletons (type (++))
|
||||
import Juvix.Compiler.Asm.Error qualified as Asm
|
||||
import Juvix.Compiler.Asm.Options qualified as Asm
|
||||
import Juvix.Compiler.Asm.Pipeline qualified as Asm
|
||||
@ -46,7 +46,7 @@ import Juvix.Data.Effect.Process
|
||||
import Juvix.Data.Effect.TaggedLock
|
||||
import Juvix.Data.Field
|
||||
|
||||
type PipelineAppEffects = '[TaggedLock, EmbedIO, Resource, Final IO]
|
||||
type PipelineAppEffects = '[TaggedLock, EmbedIO]
|
||||
|
||||
type PipelineLocalEff = '[PathResolver, EvalFileEff, Error PackageLoaderError, Error DependencyError, GitClone, Error GitProcessError, Process, Log, Reader EntryPoint, Files, Error JuvixError, HighlightBuilder, Internet]
|
||||
|
||||
|
@ -93,8 +93,8 @@ runStateLikeArtifacts ::
|
||||
Lens' Artifacts field ->
|
||||
Sem (stateEff ': r) a ->
|
||||
Sem r a
|
||||
runStateLikeArtifacts runEff l m = do
|
||||
runStateLikeArtifacts runner l m = do
|
||||
s <- gets (^. l)
|
||||
(s', a) <- runEff s m
|
||||
(s', a) <- runner s m
|
||||
modify' (set l s')
|
||||
return a
|
||||
|
@ -287,8 +287,7 @@ withPath' ::
|
||||
TopModulePath ->
|
||||
(Path Abs File -> Sem r a) ->
|
||||
Sem r a
|
||||
withPath' path a = withPathFile path (either throwError a)
|
||||
withPath' path a = withPathFile path (either throwErr a)
|
||||
where
|
||||
throwError :: PathResolverError -> Sem r a
|
||||
throwError e =
|
||||
mapError (JuvixError @PathResolverError) $ throw e
|
||||
throwErr :: PathResolverError -> Sem r a
|
||||
throwErr = mapError (JuvixError @PathResolverError) . throw
|
||||
|
@ -5,13 +5,13 @@ import Juvix.Compiler.Pipeline.Root
|
||||
import Juvix.Data.Effect.TaggedLock
|
||||
import Juvix.Prelude
|
||||
|
||||
defaultEntryPointIO :: (Members '[EmbedIO, TaggedLock, Final IO] r) => Path Abs Dir -> Path Abs File -> Sem r EntryPoint
|
||||
defaultEntryPointIO :: (Members '[EmbedIO, TaggedLock, EmbedIO] r) => Path Abs Dir -> Path Abs File -> Sem r EntryPoint
|
||||
defaultEntryPointIO cwd mainFile = do
|
||||
root <- findRootAndChangeDir (Just (parent mainFile)) Nothing cwd
|
||||
pkg <- readPackageRootIO root
|
||||
return (defaultEntryPoint pkg root mainFile)
|
||||
|
||||
defaultEntryPointNoFileIO :: (Members '[EmbedIO, TaggedLock, Final IO] r) => Path Abs Dir -> Sem r EntryPoint
|
||||
defaultEntryPointNoFileIO :: (Members '[EmbedIO, TaggedLock, EmbedIO] r) => Path Abs Dir -> Sem r EntryPoint
|
||||
defaultEntryPointNoFileIO cwd = do
|
||||
root <- findRootAndChangeDir Nothing Nothing cwd
|
||||
pkg <- readPackageRootIO root
|
||||
|
@ -142,7 +142,7 @@ resolveDependency i = case i ^. packageDepdendencyInfoDependency of
|
||||
{ _cloneArgsCloneDir = cloneDir,
|
||||
_cloneArgsRepoUrl = g ^. gitDependencyUrl
|
||||
}
|
||||
scoped cloneArgs $ do
|
||||
provideWith_ cloneArgs $ do
|
||||
fetchOnNoSuchRefAndRetry (errorHandler cloneDir) (`checkout` (g ^. gitDependencyRef))
|
||||
resolvedRef <- headRef (errorHandler cloneDir)
|
||||
return
|
||||
@ -196,9 +196,9 @@ registerPackageBase = do
|
||||
|
||||
registerDependencies' ::
|
||||
forall r.
|
||||
(Members '[TaggedLock, Reader EntryPoint, State ResolverState, Reader ResolverEnv, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) =>
|
||||
(Members '[TaggedLock, Reader EntryPoint, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) =>
|
||||
DependenciesConfig ->
|
||||
Sem r ()
|
||||
Sem (Reader ResolverEnv ': State ResolverState ': r) ()
|
||||
registerDependencies' conf = do
|
||||
e <- ask @EntryPoint
|
||||
registerPackageBase
|
||||
@ -215,7 +215,7 @@ registerDependencies' conf = do
|
||||
lockfilePath' <- lockfilePath
|
||||
writeLockfile lockfilePath' packageFileChecksum lockfile
|
||||
where
|
||||
shouldWriteLockfile :: Sem r Bool
|
||||
shouldWriteLockfile :: Sem ((Reader ResolverEnv ': State ResolverState ': r)) Bool
|
||||
shouldWriteLockfile = do
|
||||
lockfileExists <- lockfilePath >>= fileExists'
|
||||
hasRemoteDependencies <- gets (^. resolverHasRemoteDependencies)
|
||||
@ -226,7 +226,7 @@ registerDependencies' conf = do
|
||||
shouldUpdateLockfile = lockfileExists && shouldUpdateLockfile'
|
||||
return (shouldForce || shouldWriteInitialLockfile || shouldUpdateLockfile)
|
||||
|
||||
lockfilePath :: Sem r (Path Abs File)
|
||||
lockfilePath :: Sem ((Reader ResolverEnv ': State ResolverState ': r)) (Path Abs File)
|
||||
lockfilePath = do
|
||||
root <- asks (^. envRoot)
|
||||
return (mkPackageLockfilePath root)
|
||||
@ -401,33 +401,60 @@ expectedPath' m = do
|
||||
_pathInfoRootInfo = RootInfo {..}
|
||||
return PathInfoTopModule {..}
|
||||
|
||||
re ::
|
||||
forall r a.
|
||||
(Members '[TaggedLock, Reader EntryPoint, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) =>
|
||||
runPathResolver2 ::
|
||||
forall r a v.
|
||||
(v ~ '[TaggedLock, Reader EntryPoint, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff], Members v r) =>
|
||||
ResolverState ->
|
||||
ResolverEnv ->
|
||||
Sem (PathResolver ': r) a ->
|
||||
Sem (Reader ResolverEnv ': State ResolverState ': r) a
|
||||
re = reinterpret2H helper
|
||||
Sem r (ResolverState, a)
|
||||
runPathResolver2 st topEnv arg = do
|
||||
( reinterpretHCommon2
|
||||
( runState st
|
||||
. runReader topEnv
|
||||
)
|
||||
handler
|
||||
)
|
||||
arg
|
||||
where
|
||||
helper ::
|
||||
forall rInitial x.
|
||||
PathResolver (Sem rInitial) x ->
|
||||
Tactical PathResolver (Sem rInitial) (Reader ResolverEnv ': (State ResolverState ': r)) x
|
||||
helper = \case
|
||||
RegisterDependencies forceUpdateLockfile -> registerDependencies' forceUpdateLockfile >>= pureT
|
||||
ExpectedPathInfoTopModule m -> expectedPath' m >>= pureT
|
||||
WithPath m a -> do
|
||||
handler ::
|
||||
forall t localEs x.
|
||||
(Members v t) =>
|
||||
LocalEnv localEs (Reader ResolverEnv ': State ResolverState ': t) ->
|
||||
PathResolver (Sem localEs) x ->
|
||||
Sem (Reader ResolverEnv ': State ResolverState ': t) x
|
||||
handler localEnv = \case
|
||||
RegisterDependencies forceUpdateLockfile -> registerDependencies' forceUpdateLockfile
|
||||
ExpectedPathInfoTopModule m -> expectedPath' m
|
||||
WithPath
|
||||
m
|
||||
( a ::
|
||||
Either PathResolverError (Path Abs Dir, Path Rel File) ->
|
||||
Sem localEs x
|
||||
) -> do
|
||||
x :: Either PathResolverError (Path Abs Dir, Path Rel File) <- resolvePath' m
|
||||
let y :: Sem localEs x = a x
|
||||
oldroot <- asks (^. envRoot)
|
||||
x' <- pureT x
|
||||
a' <- bindT a
|
||||
st' <- get
|
||||
let root' = case x of
|
||||
Left {} -> oldroot
|
||||
Right (r, _) -> r
|
||||
raise (evalPathResolver' st' root' (a' x'))
|
||||
|
||||
evalPathResolver' :: (Members '[TaggedLock, Reader EntryPoint, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) => ResolverState -> Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r a
|
||||
evalPathResolver' st root = fmap snd . runPathResolver' st root
|
||||
e <- ask
|
||||
let _envSingleFile :: Maybe (Path Abs File)
|
||||
_envSingleFile
|
||||
| e ^. entryPointPackageType == GlobalStdlib = e ^. entryPointModulePath
|
||||
| otherwise = Nothing
|
||||
env' :: ResolverEnv
|
||||
env' =
|
||||
ResolverEnv
|
||||
{ _envRoot = root',
|
||||
_envLockfileInfo = Nothing,
|
||||
_envSingleFile
|
||||
}
|
||||
localSeqUnlift localEnv $ \unlift -> local (const env') $ do
|
||||
oldState <- get @ResolverState
|
||||
res <- unlift y
|
||||
put oldState
|
||||
return res
|
||||
|
||||
runPathResolver :: (Members '[TaggedLock, Reader EntryPoint, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) => Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r (ResolverState, a)
|
||||
runPathResolver = runPathResolver' iniResolverState
|
||||
@ -446,7 +473,7 @@ runPathResolver' st root x = do
|
||||
_envLockfileInfo = Nothing,
|
||||
_envSingleFile
|
||||
}
|
||||
runState st (runReader env (re x))
|
||||
runPathResolver2 st env x
|
||||
|
||||
runPathResolverPipe' :: (Members '[TaggedLock, Files, Reader EntryPoint, Error DependencyError, GitClone, Error JuvixError, EvalFileEff] r) => ResolverState -> Sem (PathResolver ': r) a -> Sem r (ResolverState, a)
|
||||
runPathResolverPipe' iniState a = do
|
||||
|
@ -26,7 +26,7 @@ data PathInfoTopModule = PathInfoTopModule
|
||||
}
|
||||
deriving stock (Show)
|
||||
|
||||
data PathResolver m a where
|
||||
data PathResolver :: Effect where
|
||||
RegisterDependencies :: DependenciesConfig -> PathResolver m ()
|
||||
ExpectedPathInfoTopModule :: TopModulePath -> PathResolver m PathInfoTopModule
|
||||
WithPath ::
|
||||
|
@ -40,7 +40,7 @@ renderPackageVersion v pkg = toPlainText (ppOutDefaultNoComments (toConcrete (ge
|
||||
-- | Load a package file in the context of the PackageDescription module and the global package stdlib.
|
||||
loadPackage :: (Members '[Files, EvalFileEff, Error PackageLoaderError] r) => BuildDir -> Path Abs File -> Sem r Package
|
||||
loadPackage buildDir packagePath = do
|
||||
scoped @(Path Abs File) @EvalEff packagePath $ do
|
||||
provideWith_ @EvalEff packagePath $ do
|
||||
(v, t) <- getPackageNode
|
||||
((getPackageType (t ^. typeSpecVersion)) ^. packageDescriptionTypeToPackage) buildDir packagePath =<< eval' v
|
||||
where
|
||||
|
@ -12,7 +12,7 @@ data TypeSpec = TypeSpec
|
||||
|
||||
makeLenses ''TypeSpec
|
||||
|
||||
data EvalEff m a where
|
||||
data EvalEff :: Effect where
|
||||
Eval' :: Node -> EvalEff m Value
|
||||
LookupIdentifier :: Text -> EvalEff m Node
|
||||
-- | Assert that the Node has a type given by one of the 'TypeSpec's
|
||||
@ -20,4 +20,4 @@ data EvalEff m a where
|
||||
|
||||
makeSem ''EvalEff
|
||||
|
||||
type EvalFileEff = Scoped (Path Abs File) EvalEff
|
||||
type EvalFileEff = Provider_ EvalEff (Path Abs File)
|
||||
|
@ -27,17 +27,22 @@ data LoaderResource = LoaderResource
|
||||
|
||||
makeLenses ''LoaderResource
|
||||
|
||||
runEvalFileEffIO :: forall r a. (Members '[TaggedLock, Files, EmbedIO, Error PackageLoaderError] r) => Sem (EvalFileEff ': r) a -> Sem r a
|
||||
runEvalFileEffIO = interpretScopedAs allocator handler
|
||||
runEvalFileEffIO ::
|
||||
forall r a.
|
||||
(Members '[TaggedLock, Files, EmbedIO, Error PackageLoaderError] r) =>
|
||||
Sem (EvalFileEff ': r) a ->
|
||||
Sem r a
|
||||
runEvalFileEffIO = runProvider_ helper
|
||||
where
|
||||
allocator :: Path Abs File -> Sem r LoaderResource
|
||||
allocator p = do
|
||||
helper :: forall x. Path Abs File -> Sem (EvalEff ': r) x -> Sem r x
|
||||
helper p m = do
|
||||
res <- loadPackage' p
|
||||
return
|
||||
let loaderRes :: LoaderResource =
|
||||
LoaderResource
|
||||
{ _loaderResourceResult = res,
|
||||
_loaderResourcePackagePath = p
|
||||
}
|
||||
interpret (handler loaderRes) m
|
||||
|
||||
handler :: LoaderResource -> EvalEff m x -> Sem r x
|
||||
handler res = \case
|
||||
@ -73,6 +78,7 @@ runEvalFileEffIO = interpretScopedAs allocator handler
|
||||
evalNode n = do
|
||||
n' <- doEval Nothing False packageLoc tab n
|
||||
case n' of
|
||||
Right resN -> return resN
|
||||
Left e -> do
|
||||
throw
|
||||
PackageLoaderError
|
||||
@ -83,7 +89,6 @@ runEvalFileEffIO = interpretScopedAs allocator handler
|
||||
{ _packageEvaluationErrorError = JuvixError e
|
||||
}
|
||||
}
|
||||
Right resN -> return resN
|
||||
where
|
||||
packageLoc :: Interval
|
||||
packageLoc = singletonInterval (mkInitialLoc packagePath)
|
||||
|
@ -34,24 +34,22 @@ runPackagePathResolver rootPath sem = do
|
||||
initFiles ds
|
||||
fs <- rootInfoFiles ds
|
||||
let mkRootInfo' = mkRootInfo ds fs
|
||||
( interpretH $ \case
|
||||
RegisterDependencies {} -> pureT ()
|
||||
(`interpretH` sem) $ \localEnv -> \case
|
||||
RegisterDependencies {} -> return ()
|
||||
ExpectedPathInfoTopModule m -> do
|
||||
let _pathInfoTopModule = m
|
||||
_pathInfoRootInfo =
|
||||
-- A Package file is a member of a package by definition.
|
||||
fromMaybe (error "runPackagePathResolver: expected root info") $
|
||||
mkRootInfo' (topModulePathToRelativePath' m)
|
||||
pureT PathInfoTopModule {..}
|
||||
return PathInfoTopModule {..}
|
||||
WithPath m a -> do
|
||||
let relPath = topModulePathToRelativePath' m
|
||||
x :: Either PathResolverError (Path Abs Dir, Path Rel File)
|
||||
x = case mkRootInfo' relPath of
|
||||
Just p -> Right (p ^. rootInfoPath, relPath)
|
||||
Nothing -> Left (ErrPackageInvalidImport PackageInvalidImport {_packageInvalidImport = m})
|
||||
runTSimple (return x) >>= bindTSimple a
|
||||
)
|
||||
sem
|
||||
runTSimpleEff localEnv (a x)
|
||||
where
|
||||
rootInfoDirs :: Sem r RootInfoDirs
|
||||
rootInfoDirs = do
|
||||
|
@ -4,8 +4,8 @@ module Juvix.Compiler.Pipeline.Root
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Exception (SomeException)
|
||||
import Control.Exception qualified as IO
|
||||
import Control.Monad.Catch qualified as M
|
||||
import Juvix.Compiler.Pipeline.Package.IO
|
||||
import Juvix.Compiler.Pipeline.Root.Base
|
||||
import Juvix.Data.Effect.TaggedLock
|
||||
@ -17,20 +17,20 @@ readPackageRootIO root = readPackageIO (root ^. rootRootDir) (root ^. rootBuildD
|
||||
|
||||
findRootAndChangeDir ::
|
||||
forall r.
|
||||
(Members '[TaggedLock, EmbedIO, Final IO] r) =>
|
||||
(Members '[TaggedLock, EmbedIO] r) =>
|
||||
Maybe (Path Abs Dir) ->
|
||||
Maybe (Path Abs Dir) ->
|
||||
Path Abs Dir ->
|
||||
Sem r Root
|
||||
findRootAndChangeDir minputFileDir mbuildDir _rootInvokeDir = do
|
||||
r <- runError (fromExceptionSem @SomeException go)
|
||||
runFilesIO ensureGlobalPackage
|
||||
case r of
|
||||
Left (err :: IO.SomeException) -> liftIO $ do
|
||||
let handleErr :: IO.SomeException -> Sem r x
|
||||
handleErr (err :: IO.SomeException) = do
|
||||
putStrLn "Something went wrong when looking for the root of the project"
|
||||
putStrLn (pack (IO.displayException err))
|
||||
exitFailure
|
||||
Right root -> return root
|
||||
r <- M.catch go handleErr
|
||||
runFilesIO ensureGlobalPackage
|
||||
return r
|
||||
where
|
||||
possiblePaths :: Path Abs Dir -> [Path Abs Dir]
|
||||
possiblePaths p = p : toList (parents p)
|
||||
@ -43,7 +43,7 @@ findRootAndChangeDir minputFileDir mbuildDir _rootInvokeDir = do
|
||||
pFile <- findPackageFile' Paths.packageFilePath
|
||||
return (pFile <|> yamlFile)
|
||||
|
||||
go :: Sem (Error SomeException ': r) Root
|
||||
go :: Sem r Root
|
||||
go = do
|
||||
l <- findPackageFile
|
||||
case l of
|
||||
|
@ -111,7 +111,7 @@ runReplPipelineIO' opts entry = runReplPipelineIOEither entry >>= mayThrow
|
||||
where
|
||||
mayThrow :: Either JuvixError r -> m r
|
||||
mayThrow = \case
|
||||
Left err -> liftIO . runM . runReader opts $ printErrorAnsiSafe err >> exitFailure
|
||||
Left err -> runM . runReader opts $ printErrorAnsiSafe err >> exitFailure
|
||||
Right r -> return r
|
||||
|
||||
runReplPipelineIOEither ::
|
||||
@ -132,10 +132,7 @@ runReplPipelineIOEither' lockMode entry = do
|
||||
| mainIsPackageFile entry = runPackagePathResolverArtifacts (entry ^. entryPointResolverRoot)
|
||||
| otherwise = runPathResolverArtifacts
|
||||
eith <-
|
||||
liftIO
|
||||
. runFinal
|
||||
. resourceToIOFinal
|
||||
. embedToFinal @IO
|
||||
runM
|
||||
. evalInternet hasInternet
|
||||
. ignoreHighlightBuilder
|
||||
. runError
|
||||
|
@ -22,7 +22,7 @@ type Vars s = MV.MVector s (Maybe Val)
|
||||
|
||||
type Args = Vec.Vector Val
|
||||
|
||||
runFunction :: forall r. (Members '[Error RegError, Embed IO] r) => Handle -> InfoTable -> [Val] -> FunctionInfo -> Sem r Val
|
||||
runFunction :: forall r. (Members '[Error RegError, EmbedIO] r) => Handle -> InfoTable -> [Val] -> FunctionInfo -> Sem r Val
|
||||
runFunction hout infoTable args0 info0 = do
|
||||
r <- catchRunError (runST (goFun args0 info0))
|
||||
case r of
|
||||
@ -305,7 +305,7 @@ runFunction hout infoTable args0 info0 = do
|
||||
ValString s -> s
|
||||
v -> ppPrint infoTable v
|
||||
|
||||
runIO :: forall r. (Members '[Error RegError, Embed IO] r) => Handle -> Handle -> InfoTable -> Val -> Sem r Val
|
||||
runIO :: forall r. (Members '[Error RegError, EmbedIO] r) => Handle -> Handle -> InfoTable -> Val -> Sem r Val
|
||||
runIO hin hout infoTable = \case
|
||||
ValConstr (Constr (BuiltinTag TagReturn) [x]) ->
|
||||
return x
|
||||
@ -335,7 +335,7 @@ runIO hin hout infoTable = \case
|
||||
val ->
|
||||
return val
|
||||
|
||||
runFunctionIO :: forall r. (Members '[Error RegError, Embed IO] r) => Handle -> Handle -> InfoTable -> [Val] -> FunctionInfo -> Sem r Val
|
||||
runFunctionIO :: forall r. (Members '[Error RegError, EmbedIO] r) => Handle -> Handle -> InfoTable -> [Val] -> FunctionInfo -> Sem r Val
|
||||
runFunctionIO hin hout tab args funInfo = do
|
||||
val <- runFunction hout tab args funInfo
|
||||
runIO hin hout tab val
|
||||
|
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
{-# OPTIONS_GHC -Wno-unused-type-patterns #-}
|
||||
|
||||
{-# HLINT ignore "Avoid restricted extensions" #-}
|
||||
{-# HLINT ignore "Avoid restricted flags" #-}
|
||||
@ -16,7 +17,7 @@ data IdentKind
|
||||
| IdentInd Symbol
|
||||
| IdentConstr Tag
|
||||
|
||||
data InfoTableBuilder' t e m a where
|
||||
data InfoTableBuilder' (t :: GHCType) (e :: GHCType) :: Effect where
|
||||
FreshSymbol' :: InfoTableBuilder' t e m Symbol
|
||||
FreshTag' :: InfoTableBuilder' t e m Tag
|
||||
RegisterFunction' :: FunctionInfo' t e -> InfoTableBuilder' t e m ()
|
||||
@ -67,10 +68,12 @@ runInfoTableBuilderWithInfoTable tab = fmap (first (^. stateInfoTable)) . runInf
|
||||
runInfoTableBuilder :: Sem (InfoTableBuilder' t e ': r) b -> Sem r (InfoTable' t e, b)
|
||||
runInfoTableBuilder = fmap (first (^. stateInfoTable)) . runInfoTableBuilder' emptyBuilderState
|
||||
|
||||
runInfoTableBuilder' :: forall t e b r. BuilderState' t e -> Sem (InfoTableBuilder' t e ': r) b -> Sem r (BuilderState' t e, b)
|
||||
runInfoTableBuilder' bs =
|
||||
runState bs
|
||||
. reinterpret interp
|
||||
runInfoTableBuilder' ::
|
||||
forall t e b r.
|
||||
BuilderState' t e ->
|
||||
Sem (InfoTableBuilder' t e ': r) b ->
|
||||
Sem r (BuilderState' t e, b)
|
||||
runInfoTableBuilder' bs = reinterpret (runState bs) interp
|
||||
where
|
||||
interp :: forall m b'. InfoTableBuilder' t e m b' -> Sem (State (BuilderState' t e) ': r) b'
|
||||
interp = \case
|
||||
|
@ -7,11 +7,10 @@ import Juvix.Compiler.Tree.Error
|
||||
import Juvix.Compiler.Tree.Evaluator (EvalError (..), toTreeError, valueToNode)
|
||||
import Juvix.Compiler.Tree.Evaluator.Builtins
|
||||
import Juvix.Compiler.Tree.Extra.Base
|
||||
import Juvix.Compiler.Tree.Language hiding (Output, ask, asks, mapError, output, runError)
|
||||
import Juvix.Compiler.Tree.Language hiding (Error, Members, Output, Reader, Sem, ask, asks, local, mapError, output, runError, runReader)
|
||||
import Juvix.Compiler.Tree.Language.Value
|
||||
import Juvix.Compiler.Tree.Pretty
|
||||
import Juvix.Prelude.Effects (Eff, IOE, runEff, (:>))
|
||||
import Juvix.Prelude.Effects qualified as E
|
||||
import Juvix.Prelude.BaseEffectful
|
||||
|
||||
data EvalCtx = EvalCtx
|
||||
{ _evalCtxArgs :: [Value],
|
||||
@ -27,10 +26,10 @@ emptyEvalCtx =
|
||||
_evalCtxTemp = mempty
|
||||
}
|
||||
|
||||
eval :: (E.Output Value :> r, E.Error EvalError :> r) => InfoTable -> Node -> Eff r Value
|
||||
eval tab = E.runReader emptyEvalCtx . eval'
|
||||
eval :: (Members '[Output Value, Error EvalError] r) => InfoTable -> Node -> Sem r Value
|
||||
eval tab = runReader emptyEvalCtx . eval'
|
||||
where
|
||||
eval' :: forall r'. (E.Output Value :> r', E.Reader EvalCtx :> r', E.Error EvalError :> r') => Node -> Eff r' Value
|
||||
eval' :: forall r'. (Members '[Output Value, Reader EvalCtx, Error EvalError] r') => Node -> Sem r' Value
|
||||
eval' node = case node of
|
||||
Binop x -> goBinop x
|
||||
Unop x -> goUnop x
|
||||
@ -45,16 +44,16 @@ eval tab = E.runReader emptyEvalCtx . eval'
|
||||
Case x -> goCase x
|
||||
Save x -> goSave x
|
||||
where
|
||||
evalError :: Text -> Eff r' a
|
||||
evalError :: Text -> Sem r' a
|
||||
evalError msg =
|
||||
Exception.throw (EvalError (getNodeLocation node) msg)
|
||||
|
||||
eitherToError :: Either Text Value -> Eff r' Value
|
||||
eitherToError :: Either Text Value -> Sem r' Value
|
||||
eitherToError = \case
|
||||
Left err -> evalError err
|
||||
Right v -> return v
|
||||
|
||||
goBinop :: NodeBinop -> Eff r' Value
|
||||
goBinop :: NodeBinop -> Sem r' Value
|
||||
goBinop NodeBinop {..} = do
|
||||
arg1 <- eval' _nodeBinopArg1
|
||||
arg2 <- eval' _nodeBinopArg2
|
||||
@ -62,7 +61,7 @@ eval tab = E.runReader emptyEvalCtx . eval'
|
||||
PrimBinop op -> eitherToError $ evalBinop op arg1 arg2
|
||||
OpSeq -> return arg2
|
||||
|
||||
goUnop :: NodeUnop -> Eff r' Value
|
||||
goUnop :: NodeUnop -> Sem r' Value
|
||||
goUnop NodeUnop {..} = do
|
||||
v <- eval' _nodeUnopArg
|
||||
case _nodeUnopOpcode of
|
||||
@ -70,41 +69,41 @@ eval tab = E.runReader emptyEvalCtx . eval'
|
||||
OpTrace -> goTrace v
|
||||
OpFail -> goFail v
|
||||
|
||||
goFail :: Value -> Eff r' Value
|
||||
goFail :: Value -> Sem r' Value
|
||||
goFail v = evalError ("failure: " <> printValue tab v)
|
||||
|
||||
goTrace :: Value -> Eff r' Value
|
||||
goTrace v = E.output v $> v
|
||||
goTrace :: Value -> Sem r' Value
|
||||
goTrace v = output v $> v
|
||||
|
||||
goConstant :: NodeConstant -> Value
|
||||
goConstant NodeConstant {..} = constantToValue _nodeConstant
|
||||
|
||||
askTemp :: Eff r' (BL.BinderList Value)
|
||||
askTemp = E.asks (^. evalCtxTemp)
|
||||
askTemp :: Sem r' (BL.BinderList Value)
|
||||
askTemp = asks (^. evalCtxTemp)
|
||||
|
||||
askArgs :: Eff r' [Value]
|
||||
askArgs = E.asks (^. evalCtxArgs)
|
||||
askArgs :: Sem r' [Value]
|
||||
askArgs = asks (^. evalCtxArgs)
|
||||
|
||||
goMemRef :: NodeMemRef -> Eff r' Value
|
||||
goMemRef :: NodeMemRef -> Sem r' Value
|
||||
goMemRef NodeMemRef {..} = case _nodeMemRef of
|
||||
DRef r -> goDirectRef r
|
||||
ConstrRef r -> goField r
|
||||
|
||||
goDirectRef :: DirectRef -> Eff r' Value
|
||||
goDirectRef :: DirectRef -> Sem r' Value
|
||||
goDirectRef = \case
|
||||
ArgRef OffsetRef {..} ->
|
||||
(!! _offsetRefOffset) <$> askArgs
|
||||
TempRef RefTemp {_refTempOffsetRef = OffsetRef {..}} ->
|
||||
BL.lookupLevel _offsetRefOffset <$> askTemp
|
||||
|
||||
goField :: Field -> Eff r' Value
|
||||
goField :: Field -> Sem r' Value
|
||||
goField Field {..} = do
|
||||
d <- goDirectRef _fieldRef
|
||||
case d of
|
||||
ValConstr Constr {..} -> return (_constrArgs !! _fieldOffset)
|
||||
_ -> evalError "expected a constructor"
|
||||
|
||||
goAllocConstr :: NodeAllocConstr -> Eff r' Value
|
||||
goAllocConstr :: NodeAllocConstr -> Sem r' Value
|
||||
goAllocConstr NodeAllocConstr {..} = do
|
||||
vs <- mapM eval' _nodeAllocConstrArgs
|
||||
return
|
||||
@ -115,7 +114,7 @@ eval tab = E.runReader emptyEvalCtx . eval'
|
||||
}
|
||||
)
|
||||
|
||||
goAllocClosure :: NodeAllocClosure -> Eff r' Value
|
||||
goAllocClosure :: NodeAllocClosure -> Sem r' Value
|
||||
goAllocClosure NodeAllocClosure {..} = do
|
||||
vs <- mapM eval' _nodeAllocClosureArgs
|
||||
return
|
||||
@ -126,7 +125,7 @@ eval tab = E.runReader emptyEvalCtx . eval'
|
||||
}
|
||||
)
|
||||
|
||||
goExtendClosure :: NodeExtendClosure -> Eff r' Value
|
||||
goExtendClosure :: NodeExtendClosure -> Sem r' Value
|
||||
goExtendClosure NodeExtendClosure {..} = do
|
||||
fun <- eval' _nodeExtendClosureFun
|
||||
case fun of
|
||||
@ -141,15 +140,15 @@ eval tab = E.runReader emptyEvalCtx . eval'
|
||||
)
|
||||
_ -> evalError "expected a closure"
|
||||
|
||||
goCall :: NodeCall -> Eff r' Value
|
||||
goCall :: NodeCall -> Sem r' Value
|
||||
goCall NodeCall {..} = case _nodeCallType of
|
||||
CallFun sym -> doCall sym [] _nodeCallArgs
|
||||
CallClosure cl -> doCallClosure cl _nodeCallArgs
|
||||
|
||||
withCtx :: EvalCtx -> Eff r' a -> Eff r' a
|
||||
withCtx = E.local . const
|
||||
withCtx :: EvalCtx -> Sem r' a -> Sem r' a
|
||||
withCtx = local . const
|
||||
|
||||
doCall :: Symbol -> [Value] -> [Node] -> Eff r' Value
|
||||
doCall :: Symbol -> [Value] -> [Node] -> Sem r' Value
|
||||
doCall sym clArgs as = do
|
||||
vs <- mapM eval' as
|
||||
let fi = lookupFunInfo tab sym
|
||||
@ -165,7 +164,7 @@ eval tab = E.runReader emptyEvalCtx . eval'
|
||||
| otherwise ->
|
||||
evalError "wrong number of arguments"
|
||||
|
||||
doCallClosure :: Node -> [Node] -> Eff r' Value
|
||||
doCallClosure :: Node -> [Node] -> Sem r' Value
|
||||
doCallClosure cl cargs = do
|
||||
cl' <- eval' cl
|
||||
case cl' of
|
||||
@ -174,13 +173,13 @@ eval tab = E.runReader emptyEvalCtx . eval'
|
||||
_ ->
|
||||
evalError "expected a closure"
|
||||
|
||||
goCallClosures :: NodeCallClosures -> Eff r' Value
|
||||
goCallClosures :: NodeCallClosures -> Sem r' Value
|
||||
goCallClosures NodeCallClosures {..} = do
|
||||
vs <- mapM eval' (toList _nodeCallClosuresArgs)
|
||||
cl' <- eval' _nodeCallClosuresFun
|
||||
go cl' vs
|
||||
where
|
||||
go :: Value -> [Value] -> Eff r' Value
|
||||
go :: Value -> [Value] -> Sem r' Value
|
||||
go cl vs = case cl of
|
||||
ValClosure Closure {..}
|
||||
| argsNum == n -> do
|
||||
@ -216,7 +215,7 @@ eval tab = E.runReader emptyEvalCtx . eval'
|
||||
_ ->
|
||||
evalError "expected a closure"
|
||||
|
||||
goBranch :: NodeBranch -> Eff r' Value
|
||||
goBranch :: NodeBranch -> Sem r' Value
|
||||
goBranch NodeBranch {..} = do
|
||||
arg' <- eval' _nodeBranchArg
|
||||
br <- case arg' of
|
||||
@ -225,7 +224,7 @@ eval tab = E.runReader emptyEvalCtx . eval'
|
||||
_ -> evalError "expected a boolean"
|
||||
eval' br
|
||||
|
||||
goCase :: NodeCase -> Eff r' Value
|
||||
goCase :: NodeCase -> Sem r' Value
|
||||
goCase NodeCase {..} = do
|
||||
arg' <- eval' _nodeCaseArg
|
||||
case arg' of
|
||||
@ -238,27 +237,21 @@ eval tab = E.runReader emptyEvalCtx . eval'
|
||||
_ ->
|
||||
evalError "expected a constructor"
|
||||
|
||||
withExtendedTemp :: Value -> Eff r' a -> Eff r' a
|
||||
withExtendedTemp :: Value -> Sem r' a -> Sem r' a
|
||||
withExtendedTemp v m = do
|
||||
ctx <- E.ask
|
||||
ctx <- ask
|
||||
withCtx (over evalCtxTemp (BL.cons v) ctx) m
|
||||
|
||||
goCaseBranch :: Value -> Bool -> Node -> Eff r' Value
|
||||
goCaseBranch :: Value -> Bool -> Node -> Sem r' Value
|
||||
goCaseBranch v bSave body
|
||||
| bSave = withExtendedTemp v (eval' body)
|
||||
| otherwise = eval' body
|
||||
|
||||
goSave :: NodeSave -> Eff r' Value
|
||||
goSave :: NodeSave -> Sem r' Value
|
||||
goSave NodeSave {..} = do
|
||||
v <- eval' _nodeSaveArg
|
||||
withExtendedTemp v (eval' _nodeSaveBody)
|
||||
|
||||
runError :: Eff (E.Error err ': r) x -> Eff r (Either err x)
|
||||
runError = fmap (mapLeft snd) . E.runError
|
||||
|
||||
mapError :: (E.Error b :> r) => (a -> b) -> Eff (E.Error a ': r) x -> Eff r x
|
||||
mapError f = E.runErrorWith (\_ e -> E.throwError (f e))
|
||||
|
||||
hEvalIOEither ::
|
||||
forall m.
|
||||
(MonadIO m) =>
|
||||
@ -268,7 +261,7 @@ hEvalIOEither ::
|
||||
FunctionInfo ->
|
||||
m (Either TreeError Value)
|
||||
hEvalIOEither hin hout infoTable funInfo = do
|
||||
let x :: Eff '[E.Output Value, E.Error EvalError, E.Error TreeError, IOE] Value
|
||||
let x :: Sem '[Output Value, Error EvalError, Error TreeError, IOE] Value
|
||||
x = do
|
||||
v <- eval infoTable (funInfo ^. functionCode)
|
||||
hRunIO hin hout infoTable v
|
||||
@ -278,11 +271,11 @@ hEvalIOEither hin hout infoTable funInfo = do
|
||||
. runEff
|
||||
. runError @TreeError
|
||||
. mapError toTreeError
|
||||
. E.runOutputEff handleTrace
|
||||
. runOutputSem handleTrace
|
||||
$ x
|
||||
|
||||
-- | Interpret IO actions.
|
||||
hRunIO :: forall r. (IOE :> r, E.Error EvalError :> r, E.Output Value :> r) => Handle -> Handle -> InfoTable -> Value -> Eff r Value
|
||||
hRunIO :: forall r. (Members '[IOE, Error EvalError, Output Value] r) => Handle -> Handle -> InfoTable -> Value -> Sem r Value
|
||||
hRunIO hin hout infoTable = \case
|
||||
ValConstr (Constr (BuiltinTag TagReturn) [x]) -> return x
|
||||
ValConstr (Constr (BuiltinTag TagBind) [x, f]) -> do
|
||||
|
@ -1,300 +0,0 @@
|
||||
module Juvix.Compiler.Tree.EvaluatorSem (eval, hEvalIOEither) where
|
||||
|
||||
import Control.Exception qualified as Exception
|
||||
import Juvix.Compiler.Core.Data.BinderList qualified as BL
|
||||
import Juvix.Compiler.Tree.Data.InfoTable
|
||||
import Juvix.Compiler.Tree.Error
|
||||
import Juvix.Compiler.Tree.Evaluator (EvalError (..), toTreeError, valueToNode)
|
||||
import Juvix.Compiler.Tree.Evaluator.Builtins
|
||||
import Juvix.Compiler.Tree.Extra.Base
|
||||
import Juvix.Compiler.Tree.Language
|
||||
import Juvix.Compiler.Tree.Language.Value
|
||||
import Juvix.Compiler.Tree.Pretty
|
||||
|
||||
data EvalCtx = EvalCtx
|
||||
{ _evalCtxArgs :: [Value],
|
||||
_evalCtxTemp :: BL.BinderList Value
|
||||
}
|
||||
|
||||
makeLenses ''EvalCtx
|
||||
|
||||
emptyEvalCtx :: EvalCtx
|
||||
emptyEvalCtx =
|
||||
EvalCtx
|
||||
{ _evalCtxArgs = [],
|
||||
_evalCtxTemp = mempty
|
||||
}
|
||||
|
||||
eval :: (Members '[Output Value, Error EvalError] r) => InfoTable -> Node -> Sem r Value
|
||||
eval tab = runReader emptyEvalCtx . eval'
|
||||
where
|
||||
eval' :: forall r'. (Members '[Output Value, Reader EvalCtx, Error EvalError] r') => Node -> Sem r' Value
|
||||
eval' node = case node of
|
||||
Binop x -> goBinop x
|
||||
Unop x -> goUnop x
|
||||
Constant c -> return (goConstant c)
|
||||
MemRef x -> goMemRef x
|
||||
AllocConstr x -> goAllocConstr x
|
||||
AllocClosure x -> goAllocClosure x
|
||||
ExtendClosure x -> goExtendClosure x
|
||||
Call x -> goCall x
|
||||
CallClosures x -> goCallClosures x
|
||||
Branch x -> goBranch x
|
||||
Case x -> goCase x
|
||||
Save x -> goSave x
|
||||
where
|
||||
evalError :: Text -> Sem r' a
|
||||
evalError msg =
|
||||
Exception.throw (EvalError (getNodeLocation node) msg)
|
||||
|
||||
eitherToError :: Either Text Value -> Sem r' Value
|
||||
eitherToError = \case
|
||||
Left err -> evalError err
|
||||
Right v -> return v
|
||||
|
||||
goBinop :: NodeBinop -> Sem r' Value
|
||||
goBinop NodeBinop {..} = do
|
||||
arg1 <- eval' _nodeBinopArg1
|
||||
arg2 <- eval' _nodeBinopArg2
|
||||
case _nodeBinopOpcode of
|
||||
PrimBinop op -> eitherToError $ evalBinop op arg1 arg2
|
||||
OpSeq -> return arg2
|
||||
|
||||
goUnop :: NodeUnop -> Sem r' Value
|
||||
goUnop NodeUnop {..} = do
|
||||
v <- eval' _nodeUnopArg
|
||||
case _nodeUnopOpcode of
|
||||
PrimUnop op -> eitherToError $ evalUnop tab op v
|
||||
OpTrace -> goTrace v
|
||||
OpFail -> goFail v
|
||||
|
||||
goFail :: Value -> Sem r' Value
|
||||
goFail v = evalError ("failure: " <> printValue tab v)
|
||||
|
||||
goTrace :: Value -> Sem r' Value
|
||||
goTrace v = output v $> v
|
||||
|
||||
goConstant :: NodeConstant -> Value
|
||||
goConstant NodeConstant {..} = constantToValue _nodeConstant
|
||||
|
||||
askTemp :: Sem r' (BL.BinderList Value)
|
||||
askTemp = asks (^. evalCtxTemp)
|
||||
|
||||
askArgs :: Sem r' [Value]
|
||||
askArgs = asks (^. evalCtxArgs)
|
||||
|
||||
goMemRef :: NodeMemRef -> Sem r' Value
|
||||
goMemRef NodeMemRef {..} = case _nodeMemRef of
|
||||
DRef r -> goDirectRef r
|
||||
ConstrRef r -> goField r
|
||||
|
||||
goDirectRef :: DirectRef -> Sem r' Value
|
||||
goDirectRef = \case
|
||||
ArgRef OffsetRef {..} ->
|
||||
(!! _offsetRefOffset) <$> askArgs
|
||||
TempRef RefTemp {_refTempOffsetRef = OffsetRef {..}} ->
|
||||
BL.lookupLevel _offsetRefOffset <$> askTemp
|
||||
|
||||
goField :: Field -> Sem r' Value
|
||||
goField Field {..} = do
|
||||
d <- goDirectRef _fieldRef
|
||||
case d of
|
||||
ValConstr Constr {..} -> return (_constrArgs !! _fieldOffset)
|
||||
_ -> evalError "expected a constructor"
|
||||
|
||||
goAllocConstr :: NodeAllocConstr -> Sem r' Value
|
||||
goAllocConstr NodeAllocConstr {..} = do
|
||||
vs <- mapM eval' _nodeAllocConstrArgs
|
||||
return
|
||||
( ValConstr
|
||||
Constr
|
||||
{ _constrTag = _nodeAllocConstrTag,
|
||||
_constrArgs = vs
|
||||
}
|
||||
)
|
||||
|
||||
goAllocClosure :: NodeAllocClosure -> Sem r' Value
|
||||
goAllocClosure NodeAllocClosure {..} = do
|
||||
vs <- mapM eval' _nodeAllocClosureArgs
|
||||
return
|
||||
( ValClosure
|
||||
Closure
|
||||
{ _closureSymbol = _nodeAllocClosureFunSymbol,
|
||||
_closureArgs = vs
|
||||
}
|
||||
)
|
||||
|
||||
goExtendClosure :: NodeExtendClosure -> Sem r' Value
|
||||
goExtendClosure NodeExtendClosure {..} = do
|
||||
fun <- eval' _nodeExtendClosureFun
|
||||
case fun of
|
||||
ValClosure Closure {..} -> do
|
||||
vs <- mapM eval' (toList _nodeExtendClosureArgs)
|
||||
return
|
||||
( ValClosure
|
||||
Closure
|
||||
{ _closureSymbol,
|
||||
_closureArgs = _closureArgs ++ vs
|
||||
}
|
||||
)
|
||||
_ -> evalError "expected a closure"
|
||||
|
||||
goCall :: NodeCall -> Sem r' Value
|
||||
goCall NodeCall {..} = case _nodeCallType of
|
||||
CallFun sym -> doCall sym [] _nodeCallArgs
|
||||
CallClosure cl -> doCallClosure cl _nodeCallArgs
|
||||
|
||||
withCtx :: EvalCtx -> Sem r' a -> Sem r' a
|
||||
withCtx = local . const
|
||||
|
||||
doCall :: Symbol -> [Value] -> [Node] -> Sem r' Value
|
||||
doCall sym clArgs as = do
|
||||
vs <- mapM eval' as
|
||||
let fi = lookupFunInfo tab sym
|
||||
vs' = clArgs ++ vs
|
||||
in if
|
||||
| length vs' == fi ^. functionArgsNum -> do
|
||||
let ctx' =
|
||||
EvalCtx
|
||||
{ _evalCtxArgs = vs',
|
||||
_evalCtxTemp = mempty
|
||||
}
|
||||
withCtx ctx' (eval' (fi ^. functionCode))
|
||||
| otherwise ->
|
||||
evalError "wrong number of arguments"
|
||||
|
||||
doCallClosure :: Node -> [Node] -> Sem r' Value
|
||||
doCallClosure cl cargs = do
|
||||
cl' <- eval' cl
|
||||
case cl' of
|
||||
ValClosure Closure {..} ->
|
||||
doCall _closureSymbol _closureArgs cargs
|
||||
_ ->
|
||||
evalError "expected a closure"
|
||||
|
||||
goCallClosures :: NodeCallClosures -> Sem r' Value
|
||||
goCallClosures NodeCallClosures {..} = do
|
||||
vs <- mapM eval' (toList _nodeCallClosuresArgs)
|
||||
cl' <- eval' _nodeCallClosuresFun
|
||||
go cl' vs
|
||||
where
|
||||
go :: Value -> [Value] -> Sem r' Value
|
||||
go cl vs = case cl of
|
||||
ValClosure Closure {..}
|
||||
| argsNum == n -> do
|
||||
let ctx' =
|
||||
EvalCtx
|
||||
{ _evalCtxArgs = vs',
|
||||
_evalCtxTemp = mempty
|
||||
}
|
||||
withCtx ctx' (eval' body)
|
||||
| argsNum < n -> do
|
||||
let ctx' =
|
||||
EvalCtx
|
||||
{ _evalCtxArgs = take argsNum vs',
|
||||
_evalCtxTemp = mempty
|
||||
}
|
||||
|
||||
body' <- withCtx ctx' (eval' body)
|
||||
go body' (drop argsNum vs')
|
||||
| otherwise ->
|
||||
return
|
||||
( ValClosure
|
||||
Closure
|
||||
{ _closureSymbol,
|
||||
_closureArgs = vs'
|
||||
}
|
||||
)
|
||||
where
|
||||
fi = lookupFunInfo tab _closureSymbol
|
||||
argsNum = fi ^. functionArgsNum
|
||||
vs' = _closureArgs ++ vs
|
||||
n = length vs'
|
||||
body = fi ^. functionCode
|
||||
_ ->
|
||||
evalError "expected a closure"
|
||||
|
||||
goBranch :: NodeBranch -> Sem r' Value
|
||||
goBranch NodeBranch {..} = do
|
||||
arg' <- eval' _nodeBranchArg
|
||||
br <- case arg' of
|
||||
ValBool True -> return _nodeBranchTrue
|
||||
ValBool False -> return _nodeBranchFalse
|
||||
_ -> evalError "expected a boolean"
|
||||
eval' br
|
||||
|
||||
goCase :: NodeCase -> Sem r' Value
|
||||
goCase NodeCase {..} = do
|
||||
arg' <- eval' _nodeCaseArg
|
||||
case arg' of
|
||||
v@(ValConstr Constr {..}) ->
|
||||
case find (\CaseBranch {..} -> _caseBranchTag == _constrTag) _nodeCaseBranches of
|
||||
Just CaseBranch {..} -> goCaseBranch v _caseBranchSave _caseBranchBody
|
||||
Nothing -> do
|
||||
def <- maybe (evalError "no matching branch") return _nodeCaseDefault
|
||||
goCaseBranch v False def
|
||||
_ ->
|
||||
evalError "expected a constructor"
|
||||
|
||||
withExtendedTemp :: Value -> Sem r' a -> Sem r' a
|
||||
withExtendedTemp v m = do
|
||||
ctx <- ask
|
||||
withCtx (over evalCtxTemp (BL.cons v) ctx) m
|
||||
|
||||
goCaseBranch :: Value -> Bool -> Node -> Sem r' Value
|
||||
goCaseBranch v bSave body
|
||||
| bSave = withExtendedTemp v (eval' body)
|
||||
| otherwise = eval' body
|
||||
|
||||
goSave :: NodeSave -> Sem r' Value
|
||||
goSave NodeSave {..} = do
|
||||
v <- eval' _nodeSaveArg
|
||||
withExtendedTemp v (eval' _nodeSaveBody)
|
||||
|
||||
hEvalIOEither ::
|
||||
forall m.
|
||||
(MonadIO m) =>
|
||||
Handle ->
|
||||
Handle ->
|
||||
InfoTable ->
|
||||
FunctionInfo ->
|
||||
m (Either TreeError Value)
|
||||
hEvalIOEither hin hout infoTable funInfo = do
|
||||
let x = do
|
||||
v <- eval infoTable (funInfo ^. functionCode)
|
||||
hRunIO hin hout infoTable v
|
||||
let handleTrace = liftIO . hPutStrLn hout . printValue infoTable
|
||||
liftIO
|
||||
. runM
|
||||
. runError @TreeError
|
||||
. mapError toTreeError
|
||||
. runOutputSem handleTrace
|
||||
$ x
|
||||
|
||||
-- | Interpret IO actions.
|
||||
hRunIO :: forall r. (Members '[EmbedIO, Error EvalError, Output Value] r) => Handle -> Handle -> InfoTable -> Value -> Sem r Value
|
||||
hRunIO hin hout infoTable = \case
|
||||
ValConstr (Constr (BuiltinTag TagReturn) [x]) -> return x
|
||||
ValConstr (Constr (BuiltinTag TagBind) [x, f]) -> do
|
||||
x' <- hRunIO hin hout infoTable x
|
||||
let code =
|
||||
CallClosures
|
||||
NodeCallClosures
|
||||
{ _nodeCallClosuresInfo = mempty,
|
||||
_nodeCallClosuresFun = valueToNode f,
|
||||
_nodeCallClosuresArgs = valueToNode x' :| []
|
||||
}
|
||||
res <- eval infoTable code
|
||||
hRunIO hin hout infoTable res
|
||||
ValConstr (Constr (BuiltinTag TagWrite) [ValString s]) -> do
|
||||
liftIO $ hPutStr hout s
|
||||
return ValVoid
|
||||
ValConstr (Constr (BuiltinTag TagWrite) [arg]) -> do
|
||||
liftIO $ hPutStr hout (ppPrint infoTable arg)
|
||||
return ValVoid
|
||||
ValConstr (Constr (BuiltinTag TagReadLn) []) -> do
|
||||
liftIO $ hFlush hout
|
||||
s <- liftIO $ hGetLine hin
|
||||
return (ValString s)
|
||||
val ->
|
||||
return val
|
@ -4,7 +4,7 @@ import Juvix.Compiler.Asm.Extra.Base (getCommandLocation)
|
||||
import Juvix.Compiler.Asm.Language
|
||||
import Juvix.Compiler.Tree.Error
|
||||
|
||||
data Translator m a where
|
||||
data Translator :: Effect where
|
||||
NextCommand :: Translator m Command
|
||||
HasNextCommand :: Translator m Bool
|
||||
|
||||
@ -22,7 +22,7 @@ runTranslator cs = runTranslator' (TranslatorState cs Nothing)
|
||||
|
||||
runTranslator' :: forall r a. (Member (Error TreeError) r) => TranslatorState -> Sem (Translator ': r) a -> Sem r a
|
||||
runTranslator' st m = do
|
||||
(st', a) <- runState st $ reinterpret interp m
|
||||
(st', a) <- reinterpret (runState st) interp m
|
||||
unless (null (st' ^. stateCode)) $
|
||||
throw
|
||||
TreeError
|
||||
|
@ -14,5 +14,5 @@ import Juvix.Data.Effect.Fail
|
||||
import Juvix.Data.Effect.Files
|
||||
import Juvix.Data.Effect.Internet
|
||||
import Juvix.Data.Effect.Log
|
||||
import Juvix.Data.Effect.NameIdGen hiding (toState)
|
||||
import Juvix.Data.Effect.NameIdGen
|
||||
import Juvix.Data.Effect.Visit
|
||||
|
@ -1,3 +1,5 @@
|
||||
{-# OPTIONS_GHC -Wno-unused-type-patterns #-}
|
||||
|
||||
module Juvix.Data.Effect.Cache
|
||||
( runCache,
|
||||
evalCache,
|
||||
@ -14,24 +16,24 @@ where
|
||||
|
||||
import Juvix.Prelude.Base
|
||||
|
||||
data Cache k v m a where
|
||||
data Cache (k :: GHCType) (v :: GHCType) :: Effect where
|
||||
CacheGet :: k -> Cache k v m v
|
||||
CacheLookup :: k -> Cache k v m (Maybe v)
|
||||
|
||||
makeSem ''Cache
|
||||
|
||||
-- | Singleton cache
|
||||
type SCache = Cache ()
|
||||
|
||||
makeSem ''Cache
|
||||
|
||||
-- | Run a 'Cache' effect purely.
|
||||
runCache ::
|
||||
forall k v r a.
|
||||
(Hashable k) =>
|
||||
(k -> Sem (Cache k v ': r) v) ->
|
||||
HashMap k v ->
|
||||
Sem (Cache k v ': r) a ->
|
||||
Sem r (HashMap k v, a)
|
||||
runCache f c = runState c . re f
|
||||
{-# INLINE runCache #-}
|
||||
|
||||
evalCache ::
|
||||
(Hashable k) =>
|
||||
@ -74,7 +76,9 @@ re ::
|
||||
(k -> Sem (Cache k v ': r) v) ->
|
||||
Sem (Cache k v ': r) a ->
|
||||
Sem (State (HashMap k v) ': r) a
|
||||
re f = reinterpret $ \case
|
||||
re f =
|
||||
interpretTop $
|
||||
\case
|
||||
CacheLookup k -> gets @(HashMap k v) (^. at k)
|
||||
CacheGet k -> do
|
||||
mv <- gets @(HashMap k v) (^. at k)
|
||||
@ -84,4 +88,3 @@ re f = reinterpret $ \case
|
||||
modify' @(HashMap k v) (set (at k) (Just x))
|
||||
return x
|
||||
Just v -> return v
|
||||
{-# INLINE re #-}
|
||||
|
@ -11,17 +11,6 @@ import Juvix.Data.Loc
|
||||
import Juvix.Prelude.Base
|
||||
import Prettyprinter qualified as P
|
||||
|
||||
data ExactPrint m a where
|
||||
NoLoc :: Doc Ann -> ExactPrint m ()
|
||||
-- | Used to print parentheses after comments.
|
||||
Enqueue :: Doc Ann -> ExactPrint m ()
|
||||
PrintCommentsUntil :: Interval -> ExactPrint m (Maybe SpaceSpan)
|
||||
EnsureEmptyLine :: ExactPrint m ()
|
||||
Region :: (Doc Ann -> Doc Ann) -> m b -> ExactPrint m b
|
||||
End :: ExactPrint m ()
|
||||
|
||||
makeSem ''ExactPrint
|
||||
|
||||
data Builder = Builder
|
||||
{ -- | comments sorted by starting location
|
||||
_builderComments :: [SpaceSpan],
|
||||
@ -32,13 +21,21 @@ data Builder = Builder
|
||||
_builderEnd :: FileLoc
|
||||
}
|
||||
|
||||
data ExactPrint :: Effect where
|
||||
NoLoc :: Doc Ann -> ExactPrint m ()
|
||||
-- | Used to print parentheses after comments.
|
||||
Enqueue :: Doc Ann -> ExactPrint m ()
|
||||
PrintCommentsUntil :: Interval -> ExactPrint m (Maybe SpaceSpan)
|
||||
EnsureEmptyLine :: ExactPrint m ()
|
||||
Region :: (Doc Ann -> Doc Ann) -> m b -> ExactPrint m b
|
||||
End :: ExactPrint m ()
|
||||
|
||||
makeSem ''ExactPrint
|
||||
|
||||
makeLenses ''Builder
|
||||
|
||||
runExactPrint :: Maybe FileComments -> Sem (ExactPrint ': r) x -> Sem r (Doc Ann, x)
|
||||
runExactPrint cs = fmap (first (^. builderDoc)) . runState ini . re
|
||||
where
|
||||
ini :: Builder
|
||||
ini =
|
||||
initialBuilder :: Maybe FileComments -> Builder
|
||||
initialBuilder cs =
|
||||
Builder
|
||||
{ _builderComments = fromMaybe [] (cs ^? _Just . fileCommentsSorted),
|
||||
_builderDoc = mempty,
|
||||
@ -50,27 +47,43 @@ runExactPrint cs = fmap (first (^. builderDoc)) . runState ini . re
|
||||
execExactPrint :: Maybe FileComments -> Sem (ExactPrint ': r) x -> Sem r (Doc Ann)
|
||||
execExactPrint cs = fmap fst . runExactPrint cs
|
||||
|
||||
re :: forall r a. Sem (ExactPrint ': r) a -> Sem (State Builder ': r) a
|
||||
re = reinterpretH h
|
||||
runExactPrint :: forall r a. Maybe FileComments -> Sem (ExactPrint ': r) a -> Sem r (Doc Ann, a)
|
||||
runExactPrint cs = reinterpretH (runPrivateStateAsDoc (initialBuilder cs)) handler
|
||||
where
|
||||
h ::
|
||||
forall rInitial x.
|
||||
ExactPrint (Sem rInitial) x ->
|
||||
Tactical ExactPrint (Sem rInitial) (State Builder ': r) x
|
||||
h = \case
|
||||
NoLoc p -> noLoc' p >>= pureT
|
||||
EnsureEmptyLine -> modify' (set builderEnsureEmptyLine True) >>= pureT
|
||||
End -> end' >>= pureT
|
||||
Enqueue d -> enqueue' d >>= pureT
|
||||
PrintCommentsUntil l -> printCommentsUntil' l >>= pureT
|
||||
Region f m -> do
|
||||
runPrivateStateAsDoc ::
|
||||
forall b.
|
||||
Builder ->
|
||||
Sem (State Builder ': r) b ->
|
||||
Sem r (Doc Ann, b)
|
||||
runPrivateStateAsDoc b = fmap (first (^. builderDoc)) . runState b
|
||||
|
||||
handler ::
|
||||
forall x (r' :: [Effect]) (localEs :: [Effect]).
|
||||
(Member ExactPrint localEs) =>
|
||||
LocalEnv localEs (State Builder ': r') ->
|
||||
ExactPrint (Sem localEs) x ->
|
||||
Sem (State Builder ': r') x
|
||||
handler locEnv = \case
|
||||
NoLoc p -> noLoc' p
|
||||
EnsureEmptyLine -> modify' (set builderEnsureEmptyLine True)
|
||||
End -> end'
|
||||
Enqueue d -> enqueue' d
|
||||
PrintCommentsUntil l -> printCommentsUntil' l
|
||||
Region regionModif (m :: Sem localEs x) -> do
|
||||
st0 :: Builder <- set builderDoc mempty <$> get
|
||||
m' <- runT m
|
||||
(st' :: Builder, fx) <- raise (evalExactPrint' st0 m')
|
||||
let runner :: Sem (State Builder ': localEs) x -> Sem localEs (Builder, x)
|
||||
runner = runState st0
|
||||
|
||||
helper :: (forall w. Sem localEs w -> Sem r' w) -> Sem r' (Builder, x)
|
||||
helper unlift = unlift (impose runner handler m)
|
||||
|
||||
inner :: Sem r' (Builder, x)
|
||||
inner = localSeqUnliftCommon locEnv helper
|
||||
(st' :: Builder, fx) <- raise inner
|
||||
doc' <- gets (^. builderDoc)
|
||||
put
|
||||
Builder
|
||||
{ _builderDoc = doc' <> f (st' ^. builderDoc),
|
||||
{ _builderDoc = doc' <> regionModif (st' ^. builderDoc),
|
||||
_builderComments = st' ^. builderComments,
|
||||
_builderEnd = st' ^. builderEnd,
|
||||
_builderQueue = st' ^. builderQueue,
|
||||
@ -78,9 +91,6 @@ re = reinterpretH h
|
||||
}
|
||||
return fx
|
||||
|
||||
evalExactPrint' :: Builder -> Sem (ExactPrint ': r) a -> Sem r (Builder, a)
|
||||
evalExactPrint' b = runState b . re
|
||||
|
||||
enqueue' :: forall r. (Members '[State Builder] r) => Doc Ann -> Sem r ()
|
||||
enqueue' d = modify (over builderQueue (d :))
|
||||
|
||||
|
@ -4,7 +4,8 @@ module Juvix.Data.Effect.Fail where
|
||||
import Control.Exception qualified as X
|
||||
import Juvix.Prelude.Base
|
||||
|
||||
data Fail m a = Fail
|
||||
data Fail :: Effect where
|
||||
Fail :: Fail m a
|
||||
|
||||
makeSem ''Fail
|
||||
|
||||
@ -12,7 +13,7 @@ makeSem ''Fail
|
||||
runFail ::
|
||||
Sem (Fail ': r) a ->
|
||||
Sem r (Maybe a)
|
||||
runFail = fmap (^? _Right) . runError @() . reinterpret (\Fail -> throw ())
|
||||
runFail = fmap (^? _Right) . reinterpret (runError @()) (\Fail -> throw ())
|
||||
{-# INLINE runFail #-}
|
||||
|
||||
-- | Run a 'Fail' effect purely with a default value.
|
||||
@ -28,11 +29,7 @@ runFailDefaultM ::
|
||||
Sem r a ->
|
||||
Sem (Fail ': r) a ->
|
||||
Sem r a
|
||||
runFailDefaultM defaultVal s = do
|
||||
x <- runError @() (reinterpret (\Fail -> throw ()) s)
|
||||
case x of
|
||||
Left {} -> defaultVal
|
||||
Right y -> return y
|
||||
runFailDefaultM defaultVal s = fromMaybeM defaultVal (runFail s)
|
||||
{-# INLINE runFailDefaultM #-}
|
||||
|
||||
ignoreFail ::
|
||||
@ -68,7 +65,7 @@ failFromException ::
|
||||
IO a ->
|
||||
Sem r a
|
||||
failFromException m = do
|
||||
r <- embed (X.try @X.SomeException m)
|
||||
r <- liftIO (X.try @X.SomeException m)
|
||||
case r of
|
||||
Left {} -> fail
|
||||
Right a -> return a
|
||||
|
@ -4,7 +4,7 @@ import Juvix.Prelude.Base
|
||||
import Juvix.Prelude.Path
|
||||
|
||||
-- | An effect for wrapping an action in file lock
|
||||
data FileLock m a where
|
||||
data FileLock :: Effect where
|
||||
WithFileLock' :: Path Abs File -> m a -> FileLock m a
|
||||
|
||||
makeSem ''FileLock
|
||||
|
@ -6,6 +6,6 @@ import Juvix.Prelude.Path
|
||||
import System.FileLock hiding (FileLock)
|
||||
|
||||
-- | Interpret `FileLock` using `System.FileLock`
|
||||
runFileLockIO :: (Members '[Resource, EmbedIO] r) => Sem (FileLock ': r) a -> Sem r a
|
||||
runFileLockIO = interpretH $ \case
|
||||
WithFileLock' p ma -> bracket (embed $ lockFile (toFilePath p) Exclusive) (embed . unlockFile) (const (runTSimple ma))
|
||||
runFileLockIO :: (Members '[EmbedIO] r) => Sem (FileLock ': r) a -> Sem r a
|
||||
runFileLockIO = interpretH $ \locEnv -> \case
|
||||
WithFileLock' p ma -> bracket (liftIO (lockFile (toFilePath p) Exclusive)) (liftIO . unlockFile) (const (runTSimpleEff locEnv ma))
|
||||
|
@ -4,6 +4,13 @@ import Juvix.Data.Effect.FileLock.Base
|
||||
import Juvix.Prelude.Base
|
||||
|
||||
-- | Interpret `FileLock` by executing all actions unconditionally
|
||||
runFileLockPermissive :: Sem (FileLock ': r) a -> Sem r a
|
||||
runFileLockPermissive = interpretH $ \case
|
||||
WithFileLock' _ ma -> runTSimple ma
|
||||
runFileLockPermissive :: forall r a. Sem (FileLock ': r) a -> Sem r a
|
||||
runFileLockPermissive = interpretH handler
|
||||
where
|
||||
handler ::
|
||||
forall x (localEs :: [Effect]).
|
||||
LocalEnv localEs r ->
|
||||
FileLock (Sem localEs) x ->
|
||||
Sem r x
|
||||
handler locEnv = \case
|
||||
WithFileLock' _ ma -> runTSimpleEff locEnv ma
|
||||
|
@ -91,7 +91,7 @@ relFiles root = walkDirRelAccum handler root mempty
|
||||
mkRel cd f = fromJust (stripProperPrefix root (cd <//> f))
|
||||
|
||||
-- | Restore the original contents of a file if an error occurs in an action.
|
||||
restoreFileOnError :: forall r a. (Members '[Resource, Files, TempFile] r) => Path Abs File -> Sem r a -> Sem r a
|
||||
restoreFileOnError :: forall r a. (Members '[EmbedIO, Files, TempFile] r) => Path Abs File -> Sem r a -> Sem r a
|
||||
restoreFileOnError p action = do
|
||||
t <- tempFilePath
|
||||
finally (restoreOnErrorAction t) (removeTempFile t)
|
||||
|
@ -21,13 +21,13 @@ data Recurse r
|
||||
|
||||
makeLenses ''RecursorArgs
|
||||
|
||||
data TempFile m a where
|
||||
data TempFile :: Effect where
|
||||
TempFilePath :: TempFile m (Path Abs File)
|
||||
RemoveTempFile :: Path Abs File -> TempFile m ()
|
||||
|
||||
makeSem ''TempFile
|
||||
|
||||
data Files m a where
|
||||
data Files :: Effect where
|
||||
EnsureDir' :: Path Abs Dir -> Files m ()
|
||||
DirectoryExists' :: Path Abs Dir -> Files m Bool
|
||||
FileExists' :: Path Abs File -> Files m Bool
|
||||
|
@ -26,7 +26,7 @@ runFilesIO ::
|
||||
runFilesIO = interpret helper
|
||||
where
|
||||
helper :: forall rInitial x. Files (Sem rInitial) x -> Sem r x
|
||||
helper = embed . helper'
|
||||
helper = liftIO . helper'
|
||||
|
||||
helper' :: forall rInitial x. Files (Sem rInitial) x -> IO x
|
||||
helper' = \case
|
||||
@ -62,8 +62,8 @@ runTempFileIO ::
|
||||
Sem (TempFile ': r) a ->
|
||||
Sem r a
|
||||
runTempFileIO = interpret $ \case
|
||||
TempFilePath -> embed (emptySystemTempFile "tmp" >>= parseAbsFile)
|
||||
RemoveTempFile p -> embed (ignoringIOErrors (Path.removeFile p))
|
||||
TempFilePath -> liftIO (emptySystemTempFile "tmp" >>= parseAbsFile)
|
||||
RemoveTempFile p -> liftIO (ignoringIOErrors (Path.removeFile p))
|
||||
where
|
||||
ignoringIOErrors :: IO () -> IO ()
|
||||
ignoringIOErrors ioe = MC.catch ioe (\(_ :: IOError) -> return ())
|
||||
|
@ -67,7 +67,7 @@ runFilesPure :: HashMap (Path Abs File) Text -> Path Abs Dir -> Sem (Files ': r)
|
||||
runFilesPure ini cwd a = evalState (mkFS ini) (re cwd a)
|
||||
|
||||
re :: Path Abs Dir -> Sem (Files ': r) a -> Sem (State FS ': r) a
|
||||
re cwd = reinterpret $ \case
|
||||
re cwd = interpretTop $ \case
|
||||
ReadFile' f -> lookupFile' f
|
||||
FileExists' f -> isJust <$> lookupFile f
|
||||
PathUid p -> return (Uid (toFilePath p))
|
||||
|
@ -19,23 +19,30 @@ data GitError
|
||||
= NotAClone
|
||||
| NoSuchRef GitRef
|
||||
|
||||
data Git m a where
|
||||
data Git :: Effect where
|
||||
Fetch :: (GitError -> m ()) -> Git m ()
|
||||
Checkout :: (GitError -> m ()) -> GitRef -> Git m ()
|
||||
NormalizeRef :: (GitError -> m GitRef) -> GitRef -> Git m GitRef
|
||||
|
||||
makeSem ''Git
|
||||
|
||||
type GitClone = Scoped CloneArgs Git
|
||||
type GitClone = Provider_ Git CloneArgs
|
||||
|
||||
headRef :: (Member Git r) => (GitError -> Sem r GitRef) -> Sem r GitRef
|
||||
headRef h = normalizeRef h "HEAD"
|
||||
|
||||
-- | If an action fails because a ref does not exist in the clone, first do a fetch and then retry.
|
||||
fetchOnNoSuchRefAndRetry :: forall r a. (Member Git r) => (GitError -> Sem r a) -> ((GitError -> Sem r a) -> Sem r a) -> Sem r a
|
||||
fetchOnNoSuchRefAndRetry ::
|
||||
forall r a.
|
||||
(Member Git r) =>
|
||||
(GitError -> Sem r a) ->
|
||||
((GitError -> Sem r a) -> Sem r a) ->
|
||||
Sem r a
|
||||
fetchOnNoSuchRefAndRetry handler action = action retryHandler
|
||||
where
|
||||
retryHandler :: GitError -> Sem r a
|
||||
retryHandler = \case
|
||||
NoSuchRef _ -> fetch (void . handler) >> action handler
|
||||
NoSuchRef _ -> do
|
||||
fetch (void . handler)
|
||||
action handler
|
||||
e -> handler e
|
||||
|
@ -6,7 +6,6 @@ import Juvix.Data.Effect.Git.Process.Error
|
||||
import Juvix.Data.Effect.Process
|
||||
import Juvix.Data.Effect.TaggedLock
|
||||
import Juvix.Prelude
|
||||
import Polysemy.Opaque
|
||||
|
||||
newtype CloneEnv = CloneEnv
|
||||
{_cloneEnvDir :: Path Abs Dir}
|
||||
@ -88,14 +87,22 @@ initGitRepo url = do
|
||||
withTaggedLockDir' (unlessM (directoryExists' p) (cloneGitRepo url))
|
||||
return p
|
||||
|
||||
handleNotACloneError :: (Member (Error GitProcessError) r, Monad m) => (GitError -> m x) -> Tactical e m r x -> Tactical e m r x
|
||||
handleNotACloneError errorHandler eff = catch @GitProcessError eff $ \case
|
||||
GitCmdError GitCmdErrorDetails {_gitCmdErrorDetailsExitCode = ExitFailure 128} -> runTSimple (return NotAClone) >>= bindTSimple errorHandler
|
||||
handleNotACloneError :: (Member (Error GitProcessError) r) => LocalEnv localEs r -> (GitError -> Sem localEs x) -> Sem r x -> Sem r x
|
||||
handleNotACloneError localEnv errorHandler eff = catch @GitProcessError eff $ \case
|
||||
GitCmdError
|
||||
GitCmdErrorDetails
|
||||
{ _gitCmdErrorDetailsExitCode = ExitFailure 128
|
||||
} ->
|
||||
runTSimpleEff localEnv (errorHandler NotAClone)
|
||||
e -> throw e
|
||||
|
||||
handleNormalizeRefError :: (Member (Error GitProcessError) r, Monad m) => (GitError -> m x) -> GitRef -> Tactical e m r x -> Tactical e m r x
|
||||
handleNormalizeRefError errorHandler ref eff = catch @GitProcessError eff $ \case
|
||||
GitCmdError GitCmdErrorDetails {_gitCmdErrorDetailsExitCode = ExitFailure 128} -> runTSimple (return (NoSuchRef ref)) >>= bindTSimple errorHandler
|
||||
handleNormalizeRefError :: (Member (Error GitProcessError) r) => LocalEnv localEs r -> (GitError -> Sem localEs x) -> GitRef -> Sem r x -> Sem r x
|
||||
handleNormalizeRefError localEnv errorHandler ref eff = catch @GitProcessError eff $ \case
|
||||
GitCmdError
|
||||
GitCmdErrorDetails
|
||||
{ _gitCmdErrorDetailsExitCode = ExitFailure 128
|
||||
} ->
|
||||
runTSimpleEff localEnv (errorHandler (NoSuchRef ref))
|
||||
e -> throw e
|
||||
|
||||
withTaggedLockDir' :: (Members '[TaggedLock, Reader CloneEnv] r) => Sem r a -> Sem r a
|
||||
@ -106,22 +113,19 @@ withTaggedLockDir' ma = do
|
||||
runGitProcess ::
|
||||
forall r a.
|
||||
(Members '[TaggedLock, Log, Files, Process, Error GitProcessError, Internet] r) =>
|
||||
Sem (Scoped CloneArgs Git ': r) a ->
|
||||
Sem (GitClone ': r) a ->
|
||||
Sem r a
|
||||
runGitProcess = interpretScopedH allocator handler
|
||||
runGitProcess = runProvider_ helper
|
||||
where
|
||||
allocator :: forall q x. CloneArgs -> (Path Abs Dir -> Sem (Opaque q ': r) x) -> Sem (Opaque q ': r) x
|
||||
allocator a use' = do
|
||||
let env = CloneEnv {_cloneEnvDir = a ^. cloneArgsCloneDir}
|
||||
use' =<< runReader env (initGitRepo (a ^. cloneArgsRepoUrl))
|
||||
|
||||
handler :: forall q r0 x. Path Abs Dir -> Git (Sem r0) x -> Tactical Git (Sem r0) (Opaque q ': r) x
|
||||
handler p eff = case eff of
|
||||
Fetch errorHandler -> handleNotACloneError errorHandler (runReader env gitFetch >>= pureT)
|
||||
helper :: forall x. CloneArgs -> Sem (Git ': r) x -> Sem r x
|
||||
helper cloneArgs m = do
|
||||
let env0 = CloneEnv {_cloneEnvDir = cloneArgs ^. cloneArgsCloneDir}
|
||||
clonePath <- runReader env0 (initGitRepo (cloneArgs ^. cloneArgsRepoUrl))
|
||||
let env :: CloneEnv
|
||||
env = CloneEnv {_cloneEnvDir = clonePath}
|
||||
(`interpretH` m) $ \localEnv -> \case
|
||||
Fetch errorHandler -> handleNotACloneError localEnv errorHandler (runReader env gitFetch)
|
||||
NormalizeRef errorHandler ref -> handleNormalizeRefError localEnv errorHandler ref (runReader env (gitNormalizeRef ref))
|
||||
Checkout errorHandler ref -> do
|
||||
void (handleNormalizeRefError errorHandler ref (runReader env (void (gitNormalizeRef ref)) >>= pureT))
|
||||
handleNotACloneError errorHandler (runReader env (gitCheckout ref) >>= pureT)
|
||||
NormalizeRef errorHandler ref -> handleNormalizeRefError errorHandler ref (runReader env (gitNormalizeRef ref) >>= pureT)
|
||||
where
|
||||
env :: CloneEnv
|
||||
env = CloneEnv {_cloneEnvDir = p}
|
||||
void (handleNormalizeRefError localEnv errorHandler ref (runReader env (void (gitNormalizeRef ref))))
|
||||
handleNotACloneError localEnv errorHandler (runReader env (gitCheckout ref))
|
||||
|
@ -18,7 +18,7 @@ data InternetWitness = InternetWitness
|
||||
|
||||
type Online = Reader InternetWitness
|
||||
|
||||
data Internet m a where
|
||||
data Internet :: Effect where
|
||||
-- | Returns `Nothing` if we are offline
|
||||
GetInternet :: Internet m (Maybe InternetWitness)
|
||||
|
||||
|
@ -1,24 +1,24 @@
|
||||
module Juvix.Data.Effect.Log where
|
||||
|
||||
import Data.Text.IO qualified as Text
|
||||
import Juvix.Prelude.Base
|
||||
|
||||
data Log m a where
|
||||
data Log :: Effect where
|
||||
Log :: Text -> Log m ()
|
||||
|
||||
makeSem ''Log
|
||||
|
||||
runLogIO ::
|
||||
(Member EmbedIO r) =>
|
||||
InterpreterFor Log r
|
||||
Sem (Log ': r) a ->
|
||||
Sem r a
|
||||
runLogIO sem = do
|
||||
embed (hSetBuffering stdout LineBuffering)
|
||||
liftIO (hSetBuffering stdout LineBuffering)
|
||||
interpret
|
||||
( \case
|
||||
Log txt -> embed (Text.hPutStrLn stdout txt)
|
||||
Log txt -> hPutStrLn stdout txt
|
||||
)
|
||||
sem
|
||||
|
||||
ignoreLog :: InterpreterFor Log r
|
||||
ignoreLog :: Sem (Log ': r) a -> Sem r a
|
||||
ignoreLog = interpret $ \case
|
||||
Log _ -> return ()
|
||||
|
@ -21,21 +21,19 @@ genNameIdState mid = NameIdGenState mid ids
|
||||
aux :: Word64 -> Stream Word64
|
||||
aux i = Cons i (aux (succ i))
|
||||
|
||||
data NameIdGen m a where
|
||||
data NameIdGen :: Effect where
|
||||
FreshNameId :: NameIdGen m NameId
|
||||
|
||||
makeSem ''NameIdGen
|
||||
|
||||
toState :: Sem (NameIdGen ': r) a -> Sem (State NameIdGenState ': r) a
|
||||
toState = reinterpret $ \case
|
||||
runNameIdGen :: NameIdGenState -> Sem (NameIdGen ': r) a -> Sem r (NameIdGenState, a)
|
||||
runNameIdGen s =
|
||||
reinterpret (runState s) $ \case
|
||||
FreshNameId -> do
|
||||
NameIdGenState mid (Cons fresh rest) <- get
|
||||
put (NameIdGenState mid rest)
|
||||
return (NameId fresh mid)
|
||||
|
||||
runNameIdGen :: NameIdGenState -> Sem (NameIdGen ': r) a -> Sem r (NameIdGenState, a)
|
||||
runNameIdGen s = runState s . toState
|
||||
|
||||
runTopNameIdGen :: ModuleId -> Sem (NameIdGen ': r) a -> Sem r (NameIdGenState, a)
|
||||
runTopNameIdGen mid = runNameIdGen (genNameIdState mid)
|
||||
|
||||
|
@ -13,7 +13,7 @@ data ProcessCall = ProcessCall
|
||||
_processCallArgs :: [Text]
|
||||
}
|
||||
|
||||
data Process m a where
|
||||
data Process :: Effect where
|
||||
FindExecutable' :: Path Rel File -> Process m (Maybe (Path Abs File))
|
||||
ReadProcess' :: ProcessCall -> Process m ProcessResult
|
||||
|
||||
|
@ -19,9 +19,7 @@ import Juvix.Prelude.Path
|
||||
-- Example:
|
||||
--
|
||||
-- @
|
||||
-- runFinal
|
||||
-- . resourceToIOFinal
|
||||
-- . embedToFinal @IO
|
||||
-- runM
|
||||
-- . runFilesIO
|
||||
-- . runTaggedLockIO
|
||||
-- $ withTaggedLockDir $(mkAbsDir "/a/b/c") (embed (putStrLn "Hello" >> hFlush stdout))
|
||||
@ -36,7 +34,7 @@ data LockMode
|
||||
= LockModePermissive
|
||||
| LockModeExclusive
|
||||
|
||||
runTaggedLock :: (Members '[Resource, EmbedIO] r) => LockMode -> Sem (TaggedLock ': r) a -> Sem r a
|
||||
runTaggedLock :: (Members '[EmbedIO] r) => LockMode -> Sem (TaggedLock ': r) a -> Sem r a
|
||||
runTaggedLock = \case
|
||||
LockModePermissive -> runTaggedLockPermissive
|
||||
LockModeExclusive -> runTaggedLockIO
|
||||
|
@ -7,7 +7,7 @@ import Juvix.Prelude.Path
|
||||
-- path.
|
||||
--
|
||||
-- The relative path does not need to exist in the filesystem.
|
||||
data TaggedLock m a where
|
||||
data TaggedLock :: Effect where
|
||||
WithTaggedLock :: Path Rel File -> m a -> TaggedLock m a
|
||||
|
||||
makeSem ''TaggedLock
|
||||
|
@ -10,14 +10,14 @@ import Juvix.Prelude.Path
|
||||
--
|
||||
-- When multiple processes or threads call `withTaggedLock` with the same tag,
|
||||
-- then only one of them can perform the action at a time.
|
||||
runTaggedLockIO :: forall r a. (Members '[Resource, EmbedIO] r) => Sem (TaggedLock ': r) a -> Sem r a
|
||||
runTaggedLockIO :: forall r a. (Members '[EmbedIO] r) => Sem (TaggedLock ': r) a -> Sem r a
|
||||
runTaggedLockIO sem = do
|
||||
rootLockPath <- (<//> $(mkRelDir "juvix-file-locks")) <$> getTempDir
|
||||
runFileLockIO (runFilesIO (go rootLockPath sem))
|
||||
where
|
||||
go :: Path Abs Dir -> Sem (TaggedLock ': r) a -> Sem (Files ': FileLock ': r) a
|
||||
go r = reinterpret2H $ \case
|
||||
go r = interpretTop2H $ \locEnv -> \case
|
||||
WithTaggedLock t ma -> do
|
||||
p <- normalizeFile (r <//> t)
|
||||
ensureDir' (parent p)
|
||||
withFileLock' p (runTSimple ma)
|
||||
withFileLock' p (runTSimpleEff locEnv ma)
|
||||
|
@ -4,5 +4,5 @@ import Juvix.Data.Effect.TaggedLock.Base
|
||||
import Juvix.Prelude.Base
|
||||
|
||||
runTaggedLockPermissive :: Sem (TaggedLock ': r) a -> Sem r a
|
||||
runTaggedLockPermissive = interpretH $ \case
|
||||
WithTaggedLock _ ma -> runTSimple ma
|
||||
runTaggedLockPermissive = interpretH $ \locEnv -> \case
|
||||
WithTaggedLock _ ma -> runTSimpleEff locEnv ma
|
||||
|
@ -1,3 +1,5 @@
|
||||
{-# OPTIONS_GHC -Wno-unused-type-patterns #-}
|
||||
|
||||
-- | Visit every key at most once
|
||||
module Juvix.Data.Effect.Visit
|
||||
( runVisit,
|
||||
@ -12,7 +14,7 @@ where
|
||||
import Data.HashSet qualified as HashSet
|
||||
import Juvix.Prelude.Base
|
||||
|
||||
data Visit k m a where
|
||||
data Visit (k :: GHCType) :: Effect where
|
||||
Visit :: k -> Visit k m ()
|
||||
|
||||
makeSem ''Visit
|
||||
@ -58,7 +60,7 @@ re ::
|
||||
(k -> Sem (Visit k ': r) ()) ->
|
||||
Sem (Visit k ': r) a ->
|
||||
Sem (State (HashSet k) ': r) a
|
||||
re vis = reinterpret $ \case
|
||||
re vis = interpretTop $ \case
|
||||
Visit k ->
|
||||
unlessM (HashSet.member k <$> get @(HashSet k)) $ do
|
||||
modify' (HashSet.insert k)
|
||||
|
@ -82,16 +82,16 @@ renderAnsiText :: (ToGenericError e, Member (Reader GenericOptions) r) => e -> S
|
||||
renderAnsiText = render True False
|
||||
|
||||
printErrorAnsi :: (ToGenericError e, Members '[EmbedIO, Reader GenericOptions] r) => e -> Sem r ()
|
||||
printErrorAnsi e = renderAnsiText e >>= \txt -> embed (hPutStrLn stderr txt)
|
||||
printErrorAnsi e = renderAnsiText e >>= \txt -> hPutStrLn stderr txt
|
||||
|
||||
-- | Print the error to stderr without formatting.
|
||||
printErrorText :: (ToGenericError e, Members '[EmbedIO, Reader GenericOptions] r) => e -> Sem r ()
|
||||
printErrorText e = renderText e >>= \txt -> embed (hPutStrLn stderr txt)
|
||||
printErrorText e = renderText e >>= \txt -> hPutStrLn stderr txt
|
||||
|
||||
printErrorAnsiSafe :: (ToGenericError e, Members '[EmbedIO, Reader GenericOptions] r) => e -> Sem r ()
|
||||
printErrorAnsiSafe e =
|
||||
ifM
|
||||
(embed (Ansi.hSupportsANSIColor stderr))
|
||||
(liftIO (Ansi.hSupportsANSIColor stderr))
|
||||
(printErrorAnsi e)
|
||||
(printErrorText e)
|
||||
|
||||
@ -101,7 +101,7 @@ runErrorIO ::
|
||||
Sem r b
|
||||
runErrorIO =
|
||||
runError >=> \case
|
||||
Left err -> printErrorAnsiSafe err >> embed exitFailure
|
||||
Left err -> printErrorAnsiSafe err >> exitFailure
|
||||
Right a -> return a
|
||||
|
||||
runErrorIO' ::
|
||||
|
@ -1,3 +1,5 @@
|
||||
{-# OPTIONS_GHC -Wno-unused-type-patterns #-}
|
||||
|
||||
module Juvix.Formatter where
|
||||
|
||||
import Juvix.Compiler.Concrete.Language
|
||||
@ -14,7 +16,7 @@ data FormattedFileInfo = FormattedFileInfo
|
||||
_formattedFileInfoContentsModified :: Bool
|
||||
}
|
||||
|
||||
data ScopeEff m a where
|
||||
data ScopeEff :: Effect where
|
||||
ScopeFile :: Path Abs File -> ScopeEff m Scoper.ScoperResult
|
||||
ScopeStdin :: EntryPoint -> ScopeEff m Scoper.ScoperResult
|
||||
|
||||
|
@ -5,7 +5,6 @@ module Juvix.Prelude
|
||||
module Juvix.Prelude.Trace,
|
||||
module Juvix.Prelude.Path,
|
||||
module Juvix.Prelude.Prepath,
|
||||
module Juvix.Prelude.Tagged,
|
||||
module Juvix.Data,
|
||||
)
|
||||
where
|
||||
@ -16,5 +15,4 @@ import Juvix.Prelude.Lens
|
||||
import Juvix.Prelude.Path
|
||||
import Juvix.Prelude.Prepath
|
||||
import Juvix.Prelude.Stream
|
||||
import Juvix.Prelude.Tagged
|
||||
import Juvix.Prelude.Trace
|
||||
|
@ -1,8 +1,8 @@
|
||||
module Juvix.Prelude.Base
|
||||
( module Juvix.Prelude.Base.Foundation,
|
||||
module Juvix.Prelude.Base.Polysemy,
|
||||
module Juvix.Prelude.Effects,
|
||||
)
|
||||
where
|
||||
|
||||
import Juvix.Prelude.Base.Foundation
|
||||
import Juvix.Prelude.Base.Polysemy
|
||||
import Juvix.Prelude.Effects
|
||||
|
@ -72,7 +72,7 @@ module Juvix.Prelude.Base.Foundation
|
||||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad.Catch (MonadMask, MonadThrow, throwM)
|
||||
import Control.Monad.Catch (ExitCase (..), MonadMask, MonadThrow, generalBracket, throwM)
|
||||
import Control.Monad.Extra hiding (fail, forM, mconcatMapM, whileJustM)
|
||||
import Control.Monad.Extra qualified as Monad
|
||||
import Control.Monad.Fix
|
||||
@ -100,6 +100,7 @@ import Data.Int
|
||||
import Data.IntMap.Strict (IntMap)
|
||||
import Data.IntMap.Strict qualified as IntMap
|
||||
import Data.IntSet (IntSet)
|
||||
import Data.Kind qualified as GHC
|
||||
import Data.List.Extra hiding (allSame, foldr1, groupSortOn, head, last, mconcatMap, replicate, unzip)
|
||||
import Data.List.Extra qualified as List
|
||||
import Data.List.NonEmpty qualified as NonEmpty
|
||||
@ -183,6 +184,10 @@ import Text.Show qualified as Show
|
||||
import Text.Show.Unicode (urecover, ushow)
|
||||
import Prelude (Double)
|
||||
|
||||
type GHCType = GHC.Type
|
||||
|
||||
type GHCConstraint = GHC.Constraint
|
||||
|
||||
traverseM ::
|
||||
(Monad m, Traversable m, Applicative f) =>
|
||||
(a1 -> f (m a2)) ->
|
||||
@ -467,6 +472,9 @@ optional_ = void . optional
|
||||
-- Misc
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
eassert :: (Applicative f) => Bool -> f ()
|
||||
eassert b = assert b (pure ())
|
||||
|
||||
-- | applies a function n times
|
||||
iterateN :: Int -> (a -> a) -> a -> a
|
||||
iterateN n f = (!! n) . iterate f
|
||||
|
@ -2,9 +2,13 @@ module Juvix.Prelude.Effects
|
||||
( module Juvix.Prelude.Effects.Output,
|
||||
module Juvix.Prelude.Effects.Base,
|
||||
module Juvix.Prelude.Effects.Accum,
|
||||
module Juvix.Prelude.Effects.Input,
|
||||
module Juvix.Prelude.Effects.Bracket,
|
||||
)
|
||||
where
|
||||
|
||||
import Juvix.Prelude.Effects.Accum
|
||||
import Juvix.Prelude.Effects.Base
|
||||
import Juvix.Prelude.Effects.Bracket
|
||||
import Juvix.Prelude.Effects.Input
|
||||
import Juvix.Prelude.Effects.Output
|
||||
|
@ -1,10 +1,16 @@
|
||||
module Juvix.Prelude.Effects.Accum where
|
||||
module Juvix.Prelude.Effects.Accum
|
||||
( Accum,
|
||||
runAccumList,
|
||||
execAccumList,
|
||||
ignoreAccum,
|
||||
accum,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Kind qualified as GHC
|
||||
import Juvix.Prelude.Base.Foundation
|
||||
import Juvix.Prelude.Effects.Base
|
||||
|
||||
data Accum (o :: GHC.Type) :: Effect
|
||||
data Accum (o :: GHCType) :: Effect
|
||||
|
||||
type instance DispatchOf (Accum _) = 'Static 'NoSideEffects
|
||||
|
||||
@ -12,16 +18,16 @@ newtype instance StaticRep (Accum o) = Accum
|
||||
{ _unAccum :: [o]
|
||||
}
|
||||
|
||||
runAccumList :: Eff (Accum o ': r) a -> Eff r ([o], a)
|
||||
accum :: (Member (Accum o) r) => o -> Sem r ()
|
||||
accum o = overStaticRep (\(Accum l) -> Accum (o : l))
|
||||
|
||||
runAccumList :: Sem (Accum o ': r) a -> Sem r ([o], a)
|
||||
runAccumList m = do
|
||||
(a, Accum s) <- runStaticRep (Accum mempty) m
|
||||
return (reverse s, a)
|
||||
|
||||
execAccumList :: Eff (Accum o ': r) a -> Eff r [o]
|
||||
execAccumList :: Sem (Accum o ': r) a -> Sem r [o]
|
||||
execAccumList = fmap fst . runAccumList
|
||||
|
||||
ignoreAccum :: Eff (Accum o ': r) a -> Eff r a
|
||||
ignoreAccum :: Sem (Accum o ': r) a -> Sem r a
|
||||
ignoreAccum m = snd <$> runAccumList m
|
||||
|
||||
accum :: (Accum o :> r) => o -> Eff r ()
|
||||
accum o = overStaticRep (\(Accum l) -> Accum (o : l))
|
||||
|
@ -4,21 +4,242 @@ module Juvix.Prelude.Effects.Base
|
||||
module Effectful.Reader.Static,
|
||||
module Effectful.State.Static.Local,
|
||||
module Effectful.Error.Static,
|
||||
module Effectful.Dispatch.Dynamic,
|
||||
module Effectful.TH,
|
||||
module Effectful.Dispatch.Static,
|
||||
module Effectful.Provider,
|
||||
)
|
||||
where
|
||||
|
||||
import Effectful
|
||||
import Data.Kind qualified as GHC
|
||||
import Effectful hiding (Eff, (:>))
|
||||
import Effectful qualified as E
|
||||
import Effectful.Dispatch.Dynamic (LocalEnv, SharedSuffix, impose, interpose, localLift, localLiftUnlift, localLiftUnliftIO, localSeqLift, localSeqUnlift, localSeqUnliftIO, localUnlift, localUnliftIO, withLiftMap, withLiftMapIO)
|
||||
import Effectful.Dispatch.Dynamic qualified as E
|
||||
import Effectful.Dispatch.Static
|
||||
import Effectful.Error.Static
|
||||
import Effectful.Error.Static hiding (runError)
|
||||
import Effectful.Internal.Env (getEnv, putEnv)
|
||||
import Effectful.Provider
|
||||
import Effectful.Reader.Static
|
||||
import Effectful.State.Static.Local
|
||||
import Effectful.State.Static.Local hiding (runState, state)
|
||||
import Effectful.State.Static.Local qualified as State
|
||||
import Effectful.TH
|
||||
import Juvix.Prelude.Base.Foundation
|
||||
import Language.Haskell.TH.Syntax qualified as GHC
|
||||
|
||||
overStaticRep :: (DispatchOf e ~ 'Static sideEffects, e :> r) => (StaticRep e -> StaticRep e) -> Eff r ()
|
||||
overStaticRep f = unsafeEff $ \r -> do
|
||||
e' <- f <$> getEnv r
|
||||
putEnv r e'
|
||||
type Sem = E.Eff
|
||||
|
||||
type EmbedIO = IOE
|
||||
|
||||
type Member (e :: Effect) (r :: [Effect]) = e E.:> r
|
||||
|
||||
-- | First order effect handler
|
||||
type EffectHandlerFO (e :: Effect) (r :: [Effect]) =
|
||||
forall a localEs.
|
||||
(HasCallStack, Member e localEs) =>
|
||||
e (Sem localEs) a ->
|
||||
Sem r a
|
||||
|
||||
-- | Type signature of the effect handler.
|
||||
type EffectHandler e es =
|
||||
forall a localEs.
|
||||
(HasCallStack, Member e localEs) =>
|
||||
-- | Capture of the local environment for handling local 'Eff' computations
|
||||
-- when @e@ is a higher order effect.
|
||||
LocalEnv localEs es ->
|
||||
-- | The effect performed in the local environment.
|
||||
e (Sem localEs) a ->
|
||||
Sem es a
|
||||
|
||||
type Members :: [Effect] -> [Effect] -> GHC.Constraint
|
||||
type family Members es r where
|
||||
Members '[] _ = ()
|
||||
Members (e ': es) r = (Member e r, Members es r)
|
||||
|
||||
makeSem :: GHC.Name -> Q [GHC.Dec]
|
||||
makeSem = makeEffect
|
||||
|
||||
overStaticRep ::
|
||||
forall e r sideEffects.
|
||||
( DispatchOf e ~ 'Static sideEffects,
|
||||
Member e r
|
||||
) =>
|
||||
(StaticRep e -> StaticRep e) ->
|
||||
Sem r ()
|
||||
overStaticRep f = unsafeEff $ \r -> f <$> getEnv r >>= putEnv r
|
||||
|
||||
mapReader ::
|
||||
(Member (Reader e1) r) => (e1 -> e2) -> Sem (Reader e2 ': r) a -> Sem r a
|
||||
mapReader f s = do
|
||||
e <- ask
|
||||
runReader (f e) s
|
||||
|
||||
runState :: forall s r a. s -> Sem (State s ': r) a -> Sem r (s, a)
|
||||
runState s = fmap swap . State.runState s
|
||||
|
||||
-- | TODO can we make it strict?
|
||||
modify' :: (Member (State s) r) => (s -> s) -> Sem r ()
|
||||
modify' = State.modify
|
||||
|
||||
mapError :: (Member (Error b) r) => (a -> b) -> Sem (Error a ': r) x -> Sem r x
|
||||
mapError f = runErrorWith (\_ e -> throwError (f e))
|
||||
|
||||
runM :: (MonadIO m) => Sem '[EmbedIO] a -> m a
|
||||
runM = liftIO . E.runEff
|
||||
|
||||
run :: Sem ('[] :: [Effect]) a -> a
|
||||
run = E.runPureEff
|
||||
|
||||
throw :: (Member (Error err) r) => err -> Sem r a
|
||||
throw = throwError
|
||||
|
||||
runError :: Sem (Error err ': r) x -> Sem r (Either err x)
|
||||
runError = runErrorNoCallStack
|
||||
|
||||
catch ::
|
||||
forall e r a.
|
||||
(Member (Error e) r) =>
|
||||
Sem r a ->
|
||||
(e -> Sem r a) ->
|
||||
Sem r a
|
||||
catch m handler = catchError m (const handler)
|
||||
|
||||
raiseUnder :: forall (e1 :: Effect) (e2 :: Effect) (r :: [Effect]) a. Sem (e1 ': r) a -> Sem (e1 ': e2 ': r) a
|
||||
raiseUnder = inject
|
||||
|
||||
interpretTop3H ::
|
||||
forall (e1 :: Effect) (e2 :: Effect) (e3 :: Effect) (e4 :: Effect) (r :: [Effect]) a.
|
||||
(DispatchOf e1 ~ 'Dynamic) =>
|
||||
EffectHandler e1 (e4 ': e3 ': e2 ': r) ->
|
||||
Sem (e1 ': r) a ->
|
||||
Sem (e4 ': e3 ': e2 ': r) a
|
||||
interpretTop3H i = E.interpret i . inject
|
||||
|
||||
interpretTop2H ::
|
||||
forall (e1 :: Effect) (e2 :: Effect) (e3 :: Effect) (r :: [Effect]) a.
|
||||
(DispatchOf e1 ~ 'Dynamic) =>
|
||||
EffectHandler e1 (e3 ': e2 ': r) ->
|
||||
Sem (e1 ': r) a ->
|
||||
Sem (e3 ': e2 ': r) a
|
||||
interpretTop2H i = E.interpret i . inject
|
||||
|
||||
interpretTopH ::
|
||||
forall (e1 :: Effect) (e2 :: Effect) (r :: [Effect]) a.
|
||||
(DispatchOf e1 ~ 'Dynamic) =>
|
||||
EffectHandler e1 (e2 ': r) ->
|
||||
Sem (e1 ': r) a ->
|
||||
Sem (e2 ': r) a
|
||||
interpretTopH i = E.interpret i . raiseUnder
|
||||
|
||||
interpretTop3 ::
|
||||
forall (e1 :: Effect) (e2 :: Effect) (e3 :: Effect) (e4 :: Effect) (r :: [Effect]) a.
|
||||
(DispatchOf e1 ~ 'Dynamic) =>
|
||||
EffectHandlerFO e1 (e4 ': e3 ': e2 ': r) ->
|
||||
Sem (e1 ': r) a ->
|
||||
Sem (e4 ': e3 ': e2 ': r) a
|
||||
interpretTop3 i = interpretTop3H (const i)
|
||||
|
||||
interpretTop ::
|
||||
forall (e1 :: Effect) (e2 :: Effect) (r :: [Effect]) a.
|
||||
(DispatchOf e1 ~ 'Dynamic) =>
|
||||
EffectHandlerFO e1 (e2 ': r) ->
|
||||
Sem (e1 ': r) a ->
|
||||
Sem (e2 ': r) a
|
||||
interpretTop i = interpretTopH (const i)
|
||||
|
||||
interpret ::
|
||||
forall (e1 :: Effect) (r :: [Effect]) a.
|
||||
(DispatchOf e1 ~ 'Dynamic) =>
|
||||
EffectHandlerFO e1 r ->
|
||||
Sem (e1 ': r) a ->
|
||||
Sem r a
|
||||
interpret i = E.interpret (const i)
|
||||
|
||||
interpretH ::
|
||||
forall (e1 :: Effect) (r :: [Effect]) a.
|
||||
(DispatchOf e1 ~ 'Dynamic) =>
|
||||
EffectHandler e1 r ->
|
||||
Sem (e1 ': r) a ->
|
||||
Sem r a
|
||||
interpretH = E.interpret
|
||||
|
||||
-- | Type signature of the effect handler.
|
||||
-- type EffectHandler e es
|
||||
-- = forall a localEs. (HasCallStack, Member e localEs)
|
||||
-- => LocalEnv localEs es
|
||||
-- -- ^ Capture of the local environment for handling local 'Eff' computations
|
||||
-- -- when @e@ is a higher order effect.
|
||||
-- -> e (Sem localEs) a
|
||||
-- -- ^ The effect performed in the local environment.
|
||||
-- -> Sem es a
|
||||
reinterpretHCommon2 ::
|
||||
(DispatchOf e ~ 'Dynamic) =>
|
||||
(Sem (e2 ': e1 ': r) a -> Sem r b) ->
|
||||
EffectHandler e (e2 ': e1 ': r) ->
|
||||
Sem (e ': r) a ->
|
||||
Sem r b
|
||||
reinterpretHCommon2 = E.reinterpret
|
||||
|
||||
reinterpretH ::
|
||||
(DispatchOf e ~ 'Dynamic) =>
|
||||
(Sem handlerEs a -> Sem r b) ->
|
||||
EffectHandler e handlerEs ->
|
||||
Sem (e ': r) a ->
|
||||
Sem r b
|
||||
reinterpretH = E.reinterpret
|
||||
|
||||
reinterpret ::
|
||||
(DispatchOf e ~ 'Dynamic) =>
|
||||
(Sem handlerEs a -> Sem r b) ->
|
||||
EffectHandlerFO e handlerEs ->
|
||||
Sem (e ': r) a ->
|
||||
Sem r b
|
||||
reinterpret re i = reinterpretH re (const i)
|
||||
|
||||
-- TODO maybe think of a better name
|
||||
runTSimpleEff ::
|
||||
forall (handlerEs :: [Effect]) (localEs :: [Effect]) (r :: [Effect]) x.
|
||||
(SharedSuffix r handlerEs) =>
|
||||
LocalEnv localEs handlerEs ->
|
||||
Sem localEs x ->
|
||||
Sem r x
|
||||
runTSimpleEff locEnv ma =
|
||||
let lifter :: (forall y. Sem localEs y -> Sem r y) -> Sem r x
|
||||
lifter f = f ma
|
||||
in localSeqUnlift locEnv lifter
|
||||
|
||||
imposeCommon ::
|
||||
forall e r e' a b.
|
||||
(DispatchOf e ~ 'Dynamic, Member e r) =>
|
||||
-- | Introduction of effects encapsulated within the handler.
|
||||
(Sem (e' ': r) a -> Sem r b) ->
|
||||
-- | The effect handler.
|
||||
EffectHandler e (e' ': r) ->
|
||||
Sem r a ->
|
||||
Sem r b
|
||||
imposeCommon = impose
|
||||
|
||||
imposeCommon2 ::
|
||||
forall e r e2 e1 a b.
|
||||
(DispatchOf e ~ 'Dynamic, Member e r) =>
|
||||
-- | Introduction of effects encapsulated within the handler.
|
||||
(Sem (e2 ': e1 ': r) a -> Sem r b) ->
|
||||
-- | The effect handler.
|
||||
EffectHandler e (e2 ': e1 ': r) ->
|
||||
Sem r a ->
|
||||
Sem r b
|
||||
imposeCommon2 = impose
|
||||
|
||||
localSeqUnliftCommon ::
|
||||
forall r' e1 localEs b.
|
||||
LocalEnv localEs (e1 ': r') ->
|
||||
((forall y. Sem localEs y -> Sem r' y) -> Sem r' b) ->
|
||||
Sem r' b
|
||||
localSeqUnliftCommon = localSeqUnlift
|
||||
|
||||
localSeqUnliftCommon2 ::
|
||||
forall r' e2 e1 localEs b.
|
||||
LocalEnv localEs (e2 ': e1 ': r') ->
|
||||
((forall y. Sem localEs y -> Sem r' y) -> Sem r' b) ->
|
||||
Sem r' b
|
||||
localSeqUnliftCommon2 = localSeqUnlift
|
||||
|
57
src/Juvix/Prelude/Effects/Bracket.hs
Normal file
57
src/Juvix/Prelude/Effects/Bracket.hs
Normal file
@ -0,0 +1,57 @@
|
||||
module Juvix.Prelude.Effects.Bracket
|
||||
( module Juvix.Prelude.Effects.Bracket,
|
||||
module Juvix.Prelude.Effects.Bracket.Base,
|
||||
)
|
||||
where
|
||||
|
||||
import Juvix.Prelude.Base.Foundation
|
||||
import Juvix.Prelude.Effects.Base
|
||||
import Juvix.Prelude.Effects.Bracket.Base
|
||||
|
||||
bracket ::
|
||||
forall r a b.
|
||||
(Member EmbedIO r) =>
|
||||
Sem r a ->
|
||||
(a -> Sem r ()) ->
|
||||
(a -> Sem r b) ->
|
||||
Sem r b
|
||||
bracket alloc dealloc useRes = fst <$> generalBracketSem alloc dealloc' useRes
|
||||
where
|
||||
dealloc' a = const (dealloc a)
|
||||
|
||||
bracketOnError ::
|
||||
forall r a b.
|
||||
(Member EmbedIO r) =>
|
||||
-- | Action to allocate a resource.
|
||||
Sem r a ->
|
||||
-- | Action to cleanup the resource. This will only be called if the
|
||||
-- "use" block fails.
|
||||
(a -> Sem r ()) ->
|
||||
-- | Action which uses the resource.
|
||||
(a -> Sem r b) ->
|
||||
Sem r b
|
||||
bracketOnError alloc dealloc useRes = fst <$> generalBracketSem alloc dealloc' useRes
|
||||
where
|
||||
dealloc' :: a -> ExitCase b -> Sem r ()
|
||||
dealloc' a = \case
|
||||
ExitCaseSuccess {} -> return ()
|
||||
ExitCaseException {} -> dealloc a
|
||||
ExitCaseAbort {} -> dealloc a
|
||||
|
||||
finally ::
|
||||
(Member EmbedIO r) =>
|
||||
-- | computation to run first
|
||||
Sem r a ->
|
||||
-- | computation to run afterward (even if an exception was raised)
|
||||
Sem r () ->
|
||||
Sem r a
|
||||
finally act end = bracket (pure ()) (const end) (const act)
|
||||
|
||||
onException ::
|
||||
(Member EmbedIO r) =>
|
||||
-- | computation to run first
|
||||
Sem r a ->
|
||||
-- | computation to run afterward if an exception was raised
|
||||
Sem r () ->
|
||||
Sem r a
|
||||
onException act end = bracketOnError (pure ()) (const end) (const act)
|
19
src/Juvix/Prelude/Effects/Bracket/Base.hs
Normal file
19
src/Juvix/Prelude/Effects/Bracket/Base.hs
Normal file
@ -0,0 +1,19 @@
|
||||
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
|
||||
|
||||
module Juvix.Prelude.Effects.Bracket.Base where
|
||||
|
||||
import Juvix.Prelude.Base.Foundation
|
||||
import Juvix.Prelude.Effects.Base
|
||||
|
||||
-- | We have the `EmbedIO` constraint because the `MonadMask` instance for Sem
|
||||
-- does side effects.
|
||||
generalBracketSem ::
|
||||
(Member EmbedIO r) =>
|
||||
-- | aquire
|
||||
Sem r a ->
|
||||
-- | release
|
||||
(a -> ExitCase b -> Sem r c) ->
|
||||
-- | use
|
||||
(a -> Sem r b) ->
|
||||
Sem r (b, c)
|
||||
generalBracketSem = generalBracket
|
34
src/Juvix/Prelude/Effects/Input.hs
Normal file
34
src/Juvix/Prelude/Effects/Input.hs
Normal file
@ -0,0 +1,34 @@
|
||||
{-# OPTIONS_GHC -Wno-unused-type-patterns #-}
|
||||
|
||||
module Juvix.Prelude.Effects.Input where
|
||||
|
||||
import Data.Stream qualified as Stream
|
||||
import Juvix.Prelude.Base.Foundation
|
||||
import Juvix.Prelude.Effects.Base
|
||||
import Juvix.Prelude.Stream
|
||||
|
||||
-- TODO make static versions. Finite and infinite.
|
||||
data Input (i :: GHCType) :: Effect where
|
||||
Input :: Input i m i
|
||||
|
||||
makeEffect ''Input
|
||||
|
||||
runInputList :: forall i r a. [i] -> Sem (Input (Maybe i) ': r) a -> Sem r a
|
||||
runInputList s = reinterpret (evalState s) $ \case
|
||||
Input -> do
|
||||
x <- gets @[i] nonEmpty
|
||||
case x of
|
||||
Nothing -> return Nothing
|
||||
Just (a :| as) -> do
|
||||
put as
|
||||
return (Just a)
|
||||
|
||||
runInputStream :: forall i r a. Stream i -> Sem (Input i ': r) a -> Sem r a
|
||||
runInputStream s = reinterpret (evalState s) $ \case
|
||||
Input -> do
|
||||
Stream.Cons a as <- get @(Stream i)
|
||||
put as
|
||||
return a
|
||||
|
||||
runInputNaturals :: Sem (Input Natural ': r) a -> Sem r a
|
||||
runInputNaturals = runInputStream allNaturals
|
@ -2,29 +2,38 @@
|
||||
|
||||
module Juvix.Prelude.Effects.Output where
|
||||
|
||||
import Data.Kind qualified as GHC
|
||||
import Effectful.Dispatch.Dynamic
|
||||
import Juvix.Prelude.Base hiding (Effect, Output, State, interpret, modify, output, reinterpret, runOutputList, runState)
|
||||
import Juvix.Prelude.Base.Foundation
|
||||
import Juvix.Prelude.Effects.Accum
|
||||
import Juvix.Prelude.Effects.Base
|
||||
|
||||
data Output (o :: GHC.Type) :: Effect where
|
||||
data Output (o :: GHCType) :: Effect where
|
||||
Output :: o -> Output o m ()
|
||||
|
||||
makeEffect ''Output
|
||||
|
||||
runOutputEff :: (o -> Eff r ()) -> Eff (Output o ': r) a -> Eff r a
|
||||
runOutputEff handle =
|
||||
interpret $ \_ -> \case
|
||||
runOutputFold :: o -> (o -> o -> o) -> Sem (Output o ': r) a -> Sem r (o, a)
|
||||
runOutputFold ini f =
|
||||
reinterpret (runState ini) $ \case
|
||||
Output x -> modify (\acc -> f acc x)
|
||||
|
||||
runOutputMonoidL :: (Monoid o) => Sem (Output o ': r) a -> Sem r (o, a)
|
||||
runOutputMonoidL = runOutputFold mempty (\acc x -> x <> acc)
|
||||
|
||||
runOutputMonoidR :: (Monoid o) => Sem (Output o ': r) a -> Sem r (o, a)
|
||||
runOutputMonoidR = runOutputFold mempty (\acc x -> acc <> x)
|
||||
|
||||
runOutputSem :: (o -> Sem r ()) -> Sem (Output o ': r) a -> Sem r a
|
||||
runOutputSem handle =
|
||||
interpret $ \case
|
||||
Output x -> handle x
|
||||
|
||||
runOutputList :: Eff (Output o ': r) a -> Eff r ([o], a)
|
||||
runOutputList = reinterpret runAccumList $ \_ -> \case
|
||||
runOutputList :: Sem (Output o ': r) a -> Sem r ([o], a)
|
||||
runOutputList = reinterpret runAccumList $ \case
|
||||
Output x -> accum x
|
||||
|
||||
execOutputList :: Eff (Output o ': r) a -> Eff r [o]
|
||||
execOutputList :: Sem (Output o ': r) a -> Sem r [o]
|
||||
execOutputList = fmap fst . runOutputList
|
||||
|
||||
ignoreOutput :: Eff (Output o ': r) a -> Eff r a
|
||||
ignoreOutput = interpret $ \_ -> \case
|
||||
ignoreOutput :: Sem (Output o ': r) a -> Sem r a
|
||||
ignoreOutput = interpret $ \case
|
||||
Output {} -> return ()
|
||||
|
@ -1,7 +1,7 @@
|
||||
module Juvix.Prelude.Stream where
|
||||
|
||||
import Data.Stream qualified as Stream
|
||||
import Juvix.Prelude.Base
|
||||
import Juvix.Prelude.Base.Foundation
|
||||
|
||||
allNaturals :: Stream Natural
|
||||
allNaturals = Stream.iterate succ 0
|
||||
@ -25,6 +25,3 @@ allFiniteSequences elems = build 0 []
|
||||
seq <- ofLength (n - 1)
|
||||
e <- elems
|
||||
return (pure e <> seq)
|
||||
|
||||
runInputNaturals :: Sem (Input Natural ': r) a -> Sem r a
|
||||
runInputNaturals = runInputInfinite allNaturals
|
||||
|
@ -1,12 +0,0 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
|
||||
-- | This module requires AllowAmbiguousTypes, so it is separated from Base
|
||||
module Juvix.Prelude.Tagged where
|
||||
|
||||
import Polysemy
|
||||
import Polysemy.Tagged hiding (tag)
|
||||
import Polysemy.Tagged qualified as Polysemy
|
||||
|
||||
-- | We rename it to ptag to avoid clashes with the commonly used `tag` identifier.
|
||||
ptag :: forall k e r a. (Member (Tagged k e) r) => Sem (e ': r) a -> Sem r a
|
||||
ptag = Polysemy.tag @k
|
@ -2,8 +2,14 @@ ghc-options:
|
||||
"$locals": -optP-Wno-nonportable-include-path
|
||||
resolver: nightly-2024-02-06
|
||||
extra-deps:
|
||||
- resourcet-effectful-1.0.1.0
|
||||
- git: https://github.com/haskell-effectful/effectful.git
|
||||
commit: 2037be9a4f4e8f8fd280d9359b1bc7feff9b29b9
|
||||
subdirs:
|
||||
- effectful-th
|
||||
- git: https://github.com/Vekhir/aeson-better-errors.git
|
||||
commit: 1ec49ab7d1472046b680b5a64ae2930515b47714
|
||||
allow-newer: true
|
||||
allow-newer-deps:
|
||||
- aeson-better-errors
|
||||
- effectful-th
|
||||
|
@ -81,10 +81,7 @@ assertCmdExists cmd =
|
||||
|
||||
testTaggedLockedToIO :: (MonadIO m) => Sem PipelineAppEffects a -> m a
|
||||
testTaggedLockedToIO =
|
||||
liftIO
|
||||
. runFinal
|
||||
. resourceToIOFinal
|
||||
. embedToFinal @IO
|
||||
runM
|
||||
. runTaggedLock LockModeExclusive
|
||||
|
||||
testRunIO ::
|
||||
|
@ -25,9 +25,7 @@ testDescr NegTest {..} =
|
||||
_testAssertion = Single $ do
|
||||
res <-
|
||||
withTempDir'
|
||||
( runFinal
|
||||
. resourceToIOFinal
|
||||
. embedToFinal @IO
|
||||
( runM
|
||||
. runError
|
||||
. runFilesIO
|
||||
. mapError (JuvixError @PackageLoaderError)
|
||||
|
@ -29,9 +29,7 @@ testDescr root PosTest {..} =
|
||||
withTempDir' $ \d -> do
|
||||
let buildDir = CustomBuildDir (Abs d)
|
||||
res <-
|
||||
runFinal
|
||||
. resourceToIOFinal
|
||||
. embedToFinal @IO
|
||||
runM
|
||||
. runError @JuvixError
|
||||
. runFilesIO
|
||||
. mapError (JuvixError @PackageLoaderError)
|
||||
|
@ -93,7 +93,6 @@ doRun ::
|
||||
FunctionInfo ->
|
||||
IO (Either RegError Val)
|
||||
doRun hout tab funInfo =
|
||||
runFinal
|
||||
. embedToFinal @IO
|
||||
runM
|
||||
. runError
|
||||
$ runFunctionIO stdin hout tab [] funInfo
|
||||
|
@ -13,7 +13,7 @@ import Juvix.Extra.Stdlib
|
||||
import Repl.Assertions
|
||||
import Repl.Value
|
||||
|
||||
runTaggedLockIO' :: Sem '[Files, TaggedLock, Embed IO] a -> IO a
|
||||
runTaggedLockIO' :: Sem '[Files, TaggedLock, EmbedIO] a -> IO a
|
||||
runTaggedLockIO' =
|
||||
runM
|
||||
. runTaggedLockPermissive
|
||||
|
Loading…
Reference in New Issue
Block a user