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