From 3a4cbc742dd3e7f7be0575d67a53e566fcf2e433 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Thu, 21 Mar 2024 13:09:34 +0100 Subject: [PATCH] Replace `polysemy` by `effectful` (#2663) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 ``` --- app/App.hs | 12 +- app/AsmInterpreter.hs | 2 +- app/Commands/Dev/Core/Compile/Base.hs | 4 +- app/Commands/Dev/Core/Repl.hs | 4 +- app/Commands/Dev/Geb/Repl.hs | 20 +- app/Commands/Dev/Nockma/Repl.hs | 2 +- app/Commands/Dev/Reg/Run.hs | 2 +- app/Commands/Dev/Tree/Compile/Base.hs | 4 +- app/Commands/Dev/Tree/Eval/Options.hs | 2 - app/Commands/Dev/Tree/Repl.hs | 2 +- app/Commands/Doctor.hs | 8 +- app/Commands/Eval.hs | 15 +- app/Commands/Extra/Compile.hs | 10 +- app/Commands/Format.hs | 4 +- app/Commands/Html.hs | 20 +- app/Commands/Repl.hs | 10 +- app/Main.hs | 4 +- app/RegInterpreter.hs | 2 +- app/TopCommand.hs | 2 +- app/TreeEvaluator.hs | 9 - bench2/Benchmark/Effect/EmbedIO.hs | 11 +- bench2/Benchmark/Effect/Output.hs | 14 +- bench2/Benchmark/Effect/Reader.hs | 12 +- bench2/Benchmark/Effect/ReaderH.hs | 14 +- bench2/Benchmark/Effect/State.hs | 12 +- .../Polysemy.hs => bench2/PolysemyPrelude.hs | 7 +- package.yaml | 5 +- src/Juvix/Compiler/Asm/Interpreter/Runtime.hs | 17 +- .../Compiler/Asm/Interpreter/RuntimeState.hs | 6 +- src/Juvix/Compiler/Backend/C/Data/CBuilder.hs | 6 +- .../Backend/Html/Translation/FromTyped.hs | 7 +- src/Juvix/Compiler/Builtins/Effect.hs | 9 +- .../Compiler/Casm/Data/LabelInfoBuilder.hs | 6 +- .../Concrete/Data/InfoTableBuilder.hs | 11 +- .../Concrete/Data/NameSignature/Builder.hs | 5 +- .../FromParsed/Analysis/Scoping.hs | 2 +- .../FromSource/ParserResultBuilder.hs | 31 +- .../Compiler/Core/Data/InfoTableBuilder.hs | 6 +- .../Core/Transformation/UnrollRecursion.hs | 9 +- .../Analysis/Termination/Checker.hs | 8 +- .../Analysis/TypeChecking/Data/Inference.hs | 11 +- src/Juvix/Compiler/Pipeline.hs | 4 +- src/Juvix/Compiler/Pipeline/Artifacts.hs | 4 +- src/Juvix/Compiler/Pipeline/Driver.hs | 7 +- src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs | 4 +- .../Compiler/Pipeline/Loader/PathResolver.hs | 89 ++++-- .../Pipeline/Loader/PathResolver/Base.hs | 2 +- src/Juvix/Compiler/Pipeline/Package/Loader.hs | 2 +- .../Pipeline/Package/Loader/EvalEff.hs | 4 +- .../Pipeline/Package/Loader/EvalEff/IO.hs | 25 +- .../Pipeline/Package/Loader/PathResolver.hs | 34 +- src/Juvix/Compiler/Pipeline/Root.hs | 20 +- src/Juvix/Compiler/Pipeline/Run.hs | 7 +- src/Juvix/Compiler/Reg/Interpreter.hs | 6 +- .../Tree/Data/InfoTableBuilder/Base.hs | 13 +- src/Juvix/Compiler/Tree/EvaluatorEff.hs | 83 +++-- src/Juvix/Compiler/Tree/EvaluatorSem.hs | 300 ------------------ .../Tree/Translation/FromAsm/Translator.hs | 4 +- src/Juvix/Data/Effect.hs | 2 +- src/Juvix/Data/Effect/Cache.hs | 33 +- src/Juvix/Data/Effect/ExactPrint/Base.hs | 94 +++--- src/Juvix/Data/Effect/Fail.hs | 13 +- src/Juvix/Data/Effect/FileLock/Base.hs | 2 +- src/Juvix/Data/Effect/FileLock/IO.hs | 6 +- src/Juvix/Data/Effect/FileLock/Permissive.hs | 13 +- src/Juvix/Data/Effect/Files.hs | 2 +- src/Juvix/Data/Effect/Files/Base.hs | 4 +- src/Juvix/Data/Effect/Files/IO.hs | 6 +- src/Juvix/Data/Effect/Files/Pure.hs | 2 +- src/Juvix/Data/Effect/Git/Base.hs | 15 +- src/Juvix/Data/Effect/Git/Process.hs | 52 +-- src/Juvix/Data/Effect/Internet.hs | 2 +- src/Juvix/Data/Effect/Log.hs | 12 +- src/Juvix/Data/Effect/NameIdGen.hs | 16 +- src/Juvix/Data/Effect/Process/Base.hs | 2 +- src/Juvix/Data/Effect/TaggedLock.hs | 6 +- src/Juvix/Data/Effect/TaggedLock/Base.hs | 2 +- src/Juvix/Data/Effect/TaggedLock/IO.hs | 6 +- .../Data/Effect/TaggedLock/Permissive.hs | 4 +- src/Juvix/Data/Effect/Visit.hs | 6 +- src/Juvix/Data/Error/GenericError.hs | 8 +- src/Juvix/Formatter.hs | 4 +- src/Juvix/Prelude.hs | 2 - src/Juvix/Prelude/Base.hs | 4 +- src/Juvix/Prelude/Base/Foundation.hs | 10 +- src/Juvix/Prelude/Effects.hs | 4 + src/Juvix/Prelude/Effects/Accum.hs | 24 +- src/Juvix/Prelude/Effects/Base.hs | 235 +++++++++++++- src/Juvix/Prelude/Effects/Bracket.hs | 57 ++++ src/Juvix/Prelude/Effects/Bracket/Base.hs | 19 ++ src/Juvix/Prelude/Effects/Input.hs | 34 ++ src/Juvix/Prelude/Effects/Output.hs | 33 +- src/Juvix/Prelude/Stream.hs | 5 +- src/Juvix/Prelude/Tagged.hs | 12 - stack.yaml | 6 + test/Base.hs | 5 +- test/Package/Negative.hs | 4 +- test/Package/Positive.hs | 4 +- test/Reg/Run/Base.hs | 3 +- test/Repl/Positive.hs | 2 +- 100 files changed, 897 insertions(+), 833 deletions(-) rename src/Juvix/Prelude/Base/Polysemy.hs => bench2/PolysemyPrelude.hs (90%) delete mode 100644 src/Juvix/Compiler/Tree/EvaluatorSem.hs create mode 100644 src/Juvix/Prelude/Effects/Bracket.hs create mode 100644 src/Juvix/Prelude/Effects/Bracket/Base.hs create mode 100644 src/Juvix/Prelude/Effects/Input.hs delete mode 100644 src/Juvix/Prelude/Tagged.hs diff --git a/app/App.hs b/app/App.hs index 6674aaff80..02fac0a841 100644 --- a/app/App.hs +++ b/app/App.hs @@ -15,7 +15,7 @@ import Juvix.Prelude.Pretty hiding ) import System.Console.ANSI qualified as Ansi -data App m a where +data App :: Effect where ExitMsg :: ExitCode -> Text -> App m a ExitFailMsg :: Text -> App m a ExitJuvixError :: JuvixError -> App m a @@ -60,15 +60,15 @@ reAppIO :: Sem (App ': r) a -> Sem (SCache Package ': r) a reAppIO args@RunAppIOArgs {..} = - reinterpret $ \case + interpretTop $ \case AskPackageGlobal -> return (_runAppIOArgsRoot ^. rootPackageType `elem` [GlobalStdlib, GlobalPackageDescription, GlobalPackageBase]) FromAppPathFile p -> prepathToAbsFile invDir (p ^. pathPath) GetMainFile m -> getMainFile' m FromAppPathDir p -> liftIO (prepathToAbsDir invDir (p ^. pathPath)) RenderStdOut t | _runAppIOArgsGlobalOptions ^. globalOnlyErrors -> return () - | otherwise -> embed $ do - sup <- Ansi.hSupportsANSIColor stdout + | otherwise -> do + sup <- liftIO (Ansi.hSupportsANSIColor stdout) renderIO (not (_runAppIOArgsGlobalOptions ^. globalNoColors) && sup) t AskGlobalOptions -> return _runAppIOArgsGlobalOptions AskPackage -> getPkg @@ -87,7 +87,7 @@ reAppIO args@RunAppIOArgs {..} = exitFailure ExitMsg exitCode t -> exitMsg' (exitWith exitCode) t ExitFailMsg t -> exitMsg' exitFailure t - SayRaw b -> embed (ByteString.putStr b) + SayRaw b -> liftIO (ByteString.putStr b) where getPkg :: (Members '[SCache Package] r') => Sem r' Package getPkg = cacheSingletonGet @@ -161,7 +161,7 @@ someBaseToAbs' f = do filePathToAbs :: (Members '[EmbedIO, App] r) => Prepath FileOrDir -> Sem r (Either (Path Abs File) (Path Abs Dir)) filePathToAbs fp = do invokeDir <- askInvokeDir - embed (fromPreFileOrDir invokeDir fp) + fromPreFileOrDir invokeDir fp askGenericOptions :: (Members '[App] r) => Sem r GenericOptions askGenericOptions = project <$> askGlobalOptions diff --git a/app/AsmInterpreter.hs b/app/AsmInterpreter.hs index 0105e95492..db9fb41699 100644 --- a/app/AsmInterpreter.hs +++ b/app/AsmInterpreter.hs @@ -34,4 +34,4 @@ runAsm bValidate tab = Asm.FunctionInfo -> Sem r (Either Asm.AsmError Asm.Val) doRun tab' funInfo = - embed $ Asm.catchRunErrorIO (Asm.runCodeIO tab' funInfo) + liftIO $ Asm.catchRunErrorIO (Asm.runCodeIO tab' funInfo) diff --git a/app/Commands/Dev/Core/Compile/Base.hs b/app/Commands/Dev/Core/Compile/Base.hs index 27c21d65ec..d25399f103 100644 --- a/app/Commands/Dev/Core/Compile/Base.hs +++ b/app/Commands/Dev/Core/Compile/Base.hs @@ -160,7 +160,7 @@ runNockmaPipeline pa@PipelineArg {..} = do let code = Nockma.ppSerialize tab' writeFileEnsureLn nockmaFile code -runAnomaPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r () +runAnomaPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r () runAnomaPipeline pa@PipelineArg {..} = do entryPoint <- getEntry pa nockmaFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile @@ -173,7 +173,7 @@ runAnomaPipeline pa@PipelineArg {..} = do let code = Nockma.ppSerialize tab' writeFileEnsureLn nockmaFile code -runCasmPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r () +runCasmPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r () runCasmPipeline pa@PipelineArg {..} = do entryPoint <- getEntry pa casmFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile diff --git a/app/Commands/Dev/Core/Repl.hs b/app/Commands/Dev/Core/Repl.hs index 8e8a9087a9..650d8d81bf 100644 --- a/app/Commands/Dev/Core/Repl.hs +++ b/app/Commands/Dev/Core/Repl.hs @@ -28,8 +28,8 @@ parseText = Core.runParser replPath defaultModuleId runRepl :: forall r. (Members '[EmbedIO, App] r) => CoreReplOptions -> Core.InfoTable -> Sem r () runRepl opts tab = do putStr "> " - embed (hFlush stdout) - done <- embed isEOF + liftIO (hFlush stdout) + done <- liftIO isEOF unless done $ do s <- getLine case fromText (strip s) of diff --git a/app/Commands/Dev/Geb/Repl.hs b/app/Commands/Dev/Geb/Repl.hs index 0fa669f9c7..035f76cb0e 100644 --- a/app/Commands/Dev/Geb/Repl.hs +++ b/app/Commands/Dev/Geb/Repl.hs @@ -41,17 +41,15 @@ runCommand replOpts = do gopts <- State.gets (^. replStateGlobalOptions) absInputFile :: Path Abs File <- replMakeAbsolute inputFile set entryPointTarget Backend.TargetGeb - <$> liftIO (runM (runTaggedLockPermissive (entryPointFromGlobalOptions root absInputFile gopts))) - embed - ( State.evalStateT - (replAction replOpts getReplEntryPoint) - ( ReplState - { _replContextEntryPoint = Nothing, - _replStateGlobalOptions = globalOptions, - _replStateInvokeDir = invokeDir - } - ) - ) + <$> runM (runTaggedLockPermissive (entryPointFromGlobalOptions root absInputFile gopts)) + liftIO + . State.evalStateT + (replAction replOpts getReplEntryPoint) + $ ReplState + { _replContextEntryPoint = Nothing, + _replStateGlobalOptions = globalOptions, + _replStateInvokeDir = invokeDir + } loadEntryPoint :: EntryPoint -> Repl () loadEntryPoint ep = do diff --git a/app/Commands/Dev/Nockma/Repl.hs b/app/Commands/Dev/Nockma/Repl.hs index f281030760..8ebbe19971 100644 --- a/app/Commands/Dev/Nockma/Repl.hs +++ b/app/Commands/Dev/Nockma/Repl.hs @@ -173,7 +173,7 @@ replAction = runCommand :: forall r. (Members '[EmbedIO, App] r) => NockmaReplOptions -> Sem r () runCommand opts = do mt :: Maybe (Term Natural) <- mapM iniStack (opts ^. nockmaReplOptionsStackFile) - embed . (`State.evalStateT` (iniState mt)) $ replAction + liftIO . (`State.evalStateT` (iniState mt)) $ replAction where iniStack :: AppPath File -> Sem r (Term Natural) iniStack af = do diff --git a/app/Commands/Dev/Reg/Run.hs b/app/Commands/Dev/Reg/Run.hs index b4270c49d7..32d5d89186 100644 --- a/app/Commands/Dev/Reg/Run.hs +++ b/app/Commands/Dev/Reg/Run.hs @@ -5,7 +5,7 @@ import Commands.Dev.Reg.Run.Options import Juvix.Compiler.Reg.Translation.FromSource qualified as Reg import RegInterpreter -runCommand :: forall r. (Members '[Embed IO, App] r) => RegRunOptions -> Sem r () +runCommand :: forall r. (Members '[EmbedIO, App] r) => RegRunOptions -> Sem r () runCommand opts = do afile :: Path Abs File <- fromAppPathFile file s <- readFile afile diff --git a/app/Commands/Dev/Tree/Compile/Base.hs b/app/Commands/Dev/Tree/Compile/Base.hs index 5cd3391760..7a2c3425cd 100644 --- a/app/Commands/Dev/Tree/Compile/Base.hs +++ b/app/Commands/Dev/Tree/Compile/Base.hs @@ -117,7 +117,7 @@ runNockmaPipeline pa@PipelineArg {..} = do let code = Nockma.ppSerialize tab' writeFileEnsureLn nockmaFile code -runAnomaPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r () +runAnomaPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r () runAnomaPipeline pa@PipelineArg {..} = do entryPoint <- getEntry pa nockmaFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile @@ -130,7 +130,7 @@ runAnomaPipeline pa@PipelineArg {..} = do let code = Nockma.ppSerialize tab' writeFileEnsureLn nockmaFile code -runCasmPipeline :: (Members '[Embed IO, App, TaggedLock] r) => PipelineArg -> Sem r () +runCasmPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r () runCasmPipeline pa@PipelineArg {..} = do entryPoint <- getEntry pa casmFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile diff --git a/app/Commands/Dev/Tree/Eval/Options.hs b/app/Commands/Dev/Tree/Eval/Options.hs index 5fef943ada..9c2ec5d02e 100644 --- a/app/Commands/Dev/Tree/Eval/Options.hs +++ b/app/Commands/Dev/Tree/Eval/Options.hs @@ -6,7 +6,6 @@ import Prelude (show) data Evaluator = EvalEffectful - | EvalSem | EvalRaw deriving stock (Eq, Bounded, Enum, Data) @@ -16,7 +15,6 @@ defaultEvaluator = EvalEffectful instance Show Evaluator where show = \case EvalEffectful -> "effectful" - EvalSem -> "polysemy" EvalRaw -> "raw" instance Pretty Evaluator where diff --git a/app/Commands/Dev/Tree/Repl.hs b/app/Commands/Dev/Tree/Repl.hs index a3d4a5241a..81d1e0ba41 100644 --- a/app/Commands/Dev/Tree/Repl.hs +++ b/app/Commands/Dev/Tree/Repl.hs @@ -128,7 +128,7 @@ replAction = } runCommand :: forall r. (Members '[EmbedIO, App] r) => TreeReplOptions -> Sem r () -runCommand _ = embed . (`State.evalStateT` iniState) $ replAction +runCommand _ = liftIO . (`State.evalStateT` iniState) $ replAction where iniState :: ReplState iniState = diff --git a/app/Commands/Doctor.hs b/app/Commands/Doctor.hs index 3255c6c668..dd6dfba443 100644 --- a/app/Commands/Doctor.hs +++ b/app/Commands/Doctor.hs @@ -82,7 +82,7 @@ checkWasmLd clangPath errMsg = checkClangTargetSupported :: (Members DoctorEff r) => Path Abs File -> String -> [Text] -> Sem r () checkClangTargetSupported clangPath target errMsg = do (code, _, _) <- - embed + liftIO ( P.readProcessWithExitCode (toFilePath clangPath) ["-target", target, "--print-supported-cpus"] @@ -92,14 +92,14 @@ checkClangTargetSupported clangPath target errMsg = do checkClangVersion :: (Members DoctorEff r) => Path Abs File -> Integer -> [Text] -> Sem r () checkClangVersion clangPath expectedVersion errMsg = do - versionString <- embed (P.readProcess (toFilePath clangPath) ["-dumpversion"] "") + versionString <- liftIO (P.readProcess (toFilePath clangPath) ["-dumpversion"] "") case headMay (splitOn "." versionString) >>= readMaybe of Just majorVersion -> unless (majorVersion >= expectedVersion) (mapM_ warning errMsg) Nothing -> warning "Could not determine clang version" checkEnvVarSet :: (Members DoctorEff r) => String -> [Text] -> Sem r () checkEnvVarSet var errMsg = do - whenM (isNothing <$> embed (E.lookupEnv var)) (mapM_ warning errMsg) + whenM (isNothing <$> liftIO (E.lookupEnv var)) (mapM_ warning errMsg) getLatestRelease :: (Members '[EmbedIO, Fail] r) => Sem r GithubRelease getLatestRelease = do @@ -114,7 +114,7 @@ checkVersion = do let tagName = "v" <> V.versionDoc response <- runFail getLatestRelease case response of - Just release -> case release ^. githubReleaseTagName of + Just release' -> case release' ^. githubReleaseTagName of Just latestTagName -> unless (tagName == latestTagName) (warning ("Newer Juvix version is available from https://github.com/anoma/juvix/releases/tag/" <> latestTagName)) Nothing -> warning "Tag name is not present in release JSON from Github API" Nothing -> warning "Network error when fetching data from Github API" diff --git a/app/Commands/Eval.hs b/app/Commands/Eval.hs index b037d2093a..caf429dcf2 100644 --- a/app/Commands/Eval.hs +++ b/app/Commands/Eval.hs @@ -11,15 +11,14 @@ runCommand opts@EvalOptions {..} = do gopts <- askGlobalOptions Core.CoreResult {..} <- runPipeline _evalInputFile upToCore let r = - run $ - runReader (project gopts) $ - runError @JuvixError $ - (Core.toStored' _coreResultModule :: Sem '[Error JuvixError, Reader Core.CoreOptions] Core.Module) + run + . runReader (project gopts) + . runError @JuvixError + $ (Core.toStored' _coreResultModule :: Sem '[Error JuvixError, Reader Core.CoreOptions] Core.Module) tab <- Core.computeCombinedInfoTable <$> getRight r - let mevalNode = - if - | isJust _evalSymbolName -> getNode tab (selInfo tab) - | otherwise -> getNode tab (mainInfo tab) + let mevalNode + | isJust _evalSymbolName = getNode tab (selInfo tab) + | otherwise = getNode tab (mainInfo tab) case mevalNode of Just evalNode -> Eval.evalAndPrint gopts opts tab evalNode diff --git a/app/Commands/Extra/Compile.hs b/app/Commands/Extra/Compile.hs index 9bb2b91e5f..f3c1a03f2d 100644 --- a/app/Commands/Extra/Compile.hs +++ b/app/Commands/Extra/Compile.hs @@ -73,7 +73,7 @@ prepareRuntime buildDir o = do writeRuntime :: BS.ByteString -> Sem r () writeRuntime = - embed + liftIO . BS.writeFile (toFilePath (buildDir $(mkRelFile "libjuvix.a"))) headersDir :: [(Path Rel File, BS.ByteString)] @@ -83,7 +83,7 @@ prepareRuntime buildDir o = do includeDir = juvixIncludeDir buildDir writeHeader :: (Path Rel File, BS.ByteString) -> Sem r () - writeHeader (filePath, contents) = embed $ do + writeHeader (filePath, contents) = liftIO $ do ensureDir (includeDir parent filePath) BS.writeFile (toFilePath (includeDir filePath)) contents @@ -160,7 +160,7 @@ clangWasmWasiCompile inputFile o = do sysrootEnvVar :: Sem r (Path Abs Dir) sysrootEnvVar = absDir - <$> fromMaybeM (throw msg) (embed (lookupEnv "WASI_SYSROOT_PATH")) + <$> fromMaybeM (throw msg) (liftIO (lookupEnv "WASI_SYSROOT_PATH")) where msg :: Text msg = "Missing environment variable WASI_SYSROOT_PATH" @@ -240,7 +240,7 @@ findClangUsingEnvVar = do join <$> mapM checkExecutable p where checkExecutable :: Path Abs File -> Sem r (Maybe (Path Abs File)) - checkExecutable p = whenMaybeM (embed (isExecutable p)) (return p) + checkExecutable p = whenMaybeM (liftIO (isExecutable p)) (return p) clangBinPath :: Sem r (Maybe (Path Abs File)) clangBinPath = fmap ( $(mkRelFile "bin/clang")) <$> llvmDistPath @@ -274,7 +274,7 @@ runClang :: Sem r () runClang args = do cp <- clangBinPath - (exitCode, _, err) <- embed (P.readProcessWithExitCode cp args "") + (exitCode, _, err) <- liftIO (P.readProcessWithExitCode cp args "") case exitCode of ExitSuccess -> return () _ -> throw (pack err) diff --git a/app/Commands/Format.hs b/app/Commands/Format.hs index 2af3170a53..0605453c0c 100644 --- a/app/Commands/Format.hs +++ b/app/Commands/Format.hs @@ -45,7 +45,7 @@ targetFromOptions opts = do "Use the --help option to display more usage information." ] -runCommand :: forall r. (Members '[EmbedIO, App, TaggedLock, Resource, Files] r) => FormatOptions -> Sem r () +runCommand :: forall r. (Members '[EmbedIO, App, TaggedLock, Files] r) => FormatOptions -> Sem r () runCommand opts = do target <- targetFromOptions opts runOutputSem (renderFormattedOutput target opts) $ runScopeFileApp $ do @@ -79,7 +79,7 @@ renderModeFromOptions target opts formattedInfo | formattedInfo ^. formattedFileInfoContentsModified = res | otherwise = NoEdit Silent -renderFormattedOutput :: forall r. (Members '[EmbedIO, App, Resource, Files] r) => FormatTarget -> FormatOptions -> FormattedFileInfo -> Sem r () +renderFormattedOutput :: forall r. (Members '[EmbedIO, App, Files] r) => FormatTarget -> FormatOptions -> FormattedFileInfo -> Sem r () renderFormattedOutput target opts fInfo = do let renderMode = renderModeFromOptions target opts fInfo outputResult renderMode diff --git a/app/Commands/Html.hs b/app/Commands/Html.hs index 832daf29d9..7419ac0898 100644 --- a/app/Commands/Html.hs +++ b/app/Commands/Html.hs @@ -19,7 +19,7 @@ runGenOnlySourceHtml HtmlOptions {..} = do res <- runPipeline _htmlInputFile upToScoping let m = res ^. Scoper.resultModule outputDir <- fromAppPathDir _htmlOutputDir - embed $ + liftIO $ Html.genSourceHtml GenSourceHtmlArgs { _genSourceHtmlArgsAssetsDir = _htmlAssetsPrefix, @@ -80,13 +80,11 @@ runCommand HtmlOptions {..} when _htmlOpen $ case openCmd of Nothing -> say "Could not recognize the 'open' command for your OS" Just opencmd -> - embed - ( void - ( Process.spawnProcess - opencmd - [ toFilePath - ( outputDir Html.indexFileName - ) - ] - ) - ) + liftIO + . void + $ Process.spawnProcess + opencmd + [ toFilePath + ( outputDir Html.indexFileName + ) + ] diff --git a/app/Commands/Repl.hs b/app/Commands/Repl.hs index 0e8e142782..29dac2b0d7 100644 --- a/app/Commands/Repl.hs +++ b/app/Commands/Repl.hs @@ -519,7 +519,7 @@ runCommand opts = do _replStateGlobalOptions = globalOptions } e <- - embed + liftIO . Except.runExceptT . (`State.evalStateT` iniState) . (`Reader.runReaderT` env) @@ -535,7 +535,7 @@ defaultPreludeEntryPoint = do let buildRoot = root ^. rootRootDir buildDir = resolveAbsBuildDir buildRoot (root ^. rootBuildDir) pkg <- Reader.asks (^. replPackage) - mstdlibPath <- liftIO (runM (runFilesIO (packageStdlib buildRoot buildDir (pkg ^. packageDependencies)))) + mstdlibPath <- runM (runFilesIO (packageStdlib buildRoot buildDir (pkg ^. packageDependencies))) case mstdlibPath of Just stdlibPath -> Just @@ -554,8 +554,7 @@ replExpressionUpToScopedAtoms :: Text -> Repl (Concrete.ExpressionAtoms 'Concret replExpressionUpToScopedAtoms txt = do ctx <- replGetContext x <- - liftIO - . runM + runM . runError . evalState (ctx ^. replContextArtifacts) . runReader (ctx ^. replContextEntryPoint) @@ -566,8 +565,7 @@ replExpressionUpToTyped :: Text -> Repl Internal.TypedExpression replExpressionUpToTyped txt = do ctx <- replGetContext x <- - liftIO - . runM + runM . runError . evalState (ctx ^. replContextArtifacts) . runReader (ctx ^. replContextEntryPoint) diff --git a/app/Main.hs b/app/Main.hs index 5e4eb728e5..5c95f092cf 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -16,9 +16,7 @@ main = do mbuildDir <- mapM (prepathToAbsDir invokeDir) (_runAppIOArgsGlobalOptions ^? globalBuildDir . _Just . pathPath) mainFile <- topCommandInputPath cli mapM_ checkMainFile mainFile - runFinal - . resourceToIOFinal - . embedToFinal @IO + runM . runTaggedLockPermissive $ do _runAppIOArgsRoot <- findRootAndChangeDir (containingDir <$> mainFile) mbuildDir invokeDir diff --git a/app/RegInterpreter.hs b/app/RegInterpreter.hs index a164c2149d..60b8e27c82 100644 --- a/app/RegInterpreter.hs +++ b/app/RegInterpreter.hs @@ -6,7 +6,7 @@ import Juvix.Compiler.Reg.Data.InfoTable qualified as Reg import Juvix.Compiler.Reg.Interpreter qualified as Reg import Juvix.Compiler.Reg.Pretty qualified as Reg -runReg :: forall r. (Members '[Embed IO, App] r) => Reg.InfoTable -> Sem r () +runReg :: forall r. (Members '[EmbedIO, App] r) => Reg.InfoTable -> Sem r () runReg tab = case tab ^. Reg.infoMainFunction of Just sym -> do diff --git a/app/TopCommand.hs b/app/TopCommand.hs index d9a04ac068..c6fc7bfaf0 100644 --- a/app/TopCommand.hs +++ b/app/TopCommand.hs @@ -25,7 +25,7 @@ showHelpText = do (msg, _) = renderFailure helpText progn putStrLn (pack msg) -runTopCommand :: forall r. (Members '[EmbedIO, App, Resource, TaggedLock] r) => TopCommand -> Sem r () +runTopCommand :: forall r. (Members '[EmbedIO, App, TaggedLock] r) => TopCommand -> Sem r () runTopCommand = \case DisplayVersion -> runDisplayVersion DisplayNumericVersion -> runDisplayNumericVersion diff --git a/app/TreeEvaluator.hs b/app/TreeEvaluator.hs index db64f6e944..25f75408c0 100644 --- a/app/TreeEvaluator.hs +++ b/app/TreeEvaluator.hs @@ -11,7 +11,6 @@ import Juvix.Compiler.Tree.Data.InfoTable qualified as Tree import Juvix.Compiler.Tree.Error qualified as Tree import Juvix.Compiler.Tree.Evaluator qualified as Tree import Juvix.Compiler.Tree.EvaluatorEff qualified as Eff -import Juvix.Compiler.Tree.EvaluatorSem qualified as TreeSem import Juvix.Compiler.Tree.Language.Value qualified as Tree import Juvix.Compiler.Tree.Pretty qualified as Tree @@ -47,7 +46,6 @@ doEval :: doEval = \case EvalEffectful -> doEvalEff EvalRaw -> doEvalRaw - EvalSem -> doEvalSem doEvalRaw :: (MonadIO m) => @@ -62,10 +60,3 @@ doEvalEff :: Tree.FunctionInfo -> m (Either Tree.TreeError Tree.Value) doEvalEff tab' funInfo = Eff.hEvalIOEither stdin stdout tab' funInfo - -doEvalSem :: - (MonadIO m) => - Tree.InfoTable -> - Tree.FunctionInfo -> - m (Either Tree.TreeError Tree.Value) -doEvalSem tab' funInfo = TreeSem.hEvalIOEither stdin stdout tab' funInfo diff --git a/bench2/Benchmark/Effect/EmbedIO.hs b/bench2/Benchmark/Effect/EmbedIO.hs index 494edc69e9..963981ce12 100644 --- a/bench2/Benchmark/Effect/EmbedIO.hs +++ b/bench2/Benchmark/Effect/EmbedIO.hs @@ -1,8 +1,9 @@ module Benchmark.Effect.EmbedIO where -import Juvix.Prelude -import Juvix.Prelude.Effects (Eff) +import Juvix.Prelude (withSystemTempFile) +import Juvix.Prelude.Base.Foundation import Juvix.Prelude.Effects qualified as E +import PolysemyPrelude qualified as P import Test.Tasty.Bench bm :: Benchmark @@ -30,9 +31,9 @@ countRaw n = a -> hPutChar h c >> go h (pred a) countSem :: Natural -> IO () -countSem n = withSystemTempFile "tmp" $ \_ h -> runM (go h n) +countSem n = withSystemTempFile "tmp" $ \_ h -> P.runM (go h n) where - go :: Handle -> Natural -> Sem '[Embed IO] () + go :: Handle -> Natural -> P.Sem '[P.EmbedIO] () go h = \case 0 -> return () a -> liftIO (hPutChar h c) >> go h (pred a) @@ -40,7 +41,7 @@ countSem n = withSystemTempFile "tmp" $ \_ h -> runM (go h n) countEff :: Natural -> IO () countEff n = withSystemTempFile "tmp" $ \_ h -> E.runEff (go h n) where - go :: Handle -> Natural -> Eff '[E.IOE] () + go :: Handle -> Natural -> E.Sem '[E.IOE] () go h = \case 0 -> return () a -> liftIO (hPutChar h c) >> go h (pred a) diff --git a/bench2/Benchmark/Effect/Output.hs b/bench2/Benchmark/Effect/Output.hs index 4789f049ce..2ee866a009 100644 --- a/bench2/Benchmark/Effect/Output.hs +++ b/bench2/Benchmark/Effect/Output.hs @@ -1,8 +1,8 @@ module Benchmark.Effect.Output where -import Juvix.Prelude -import Juvix.Prelude.Effects (Eff, (:>)) +import Juvix.Prelude.Base.Foundation import Juvix.Prelude.Effects qualified as E +import PolysemyPrelude qualified as P import Test.Tasty.Bench bm :: Benchmark @@ -29,7 +29,7 @@ countdownRaw = sum' . reverse . go [] countdownAccum :: Natural -> Natural countdownAccum = sum' . E.runPureEff . E.execAccumList . go where - go :: (E.Accum Natural :> r) => Natural -> Eff r () + go :: (E.Member (E.Accum Natural) r) => Natural -> E.Sem r () go = \case 0 -> return () m -> E.accum m >> go (pred m) @@ -37,15 +37,15 @@ countdownAccum = sum' . E.runPureEff . E.execAccumList . go countdownEff :: Natural -> Natural countdownEff = sum' . E.runPureEff . E.execOutputList . go where - go :: (E.Output Natural :> r) => Natural -> Eff r () + go :: (E.Member (E.Output Natural) r) => Natural -> E.Sem r () go = \case 0 -> return () m -> E.output m >> go (pred m) countdownSem :: Natural -> Natural -countdownSem = sum' . run . execOutputList . go +countdownSem = sum' . P.run . P.execOutputList . go where - go :: (Members '[Output Natural] r) => Natural -> Sem r () + go :: (P.Members '[P.Output Natural] r) => Natural -> P.Sem r () go = \case 0 -> return () - m -> output m >> go (pred m) + m -> P.output m >> go (pred m) diff --git a/bench2/Benchmark/Effect/Reader.hs b/bench2/Benchmark/Effect/Reader.hs index c2c5220448..55a0504f98 100644 --- a/bench2/Benchmark/Effect/Reader.hs +++ b/bench2/Benchmark/Effect/Reader.hs @@ -1,8 +1,8 @@ module Benchmark.Effect.Reader where -import Juvix.Prelude -import Juvix.Prelude.Effects (Eff, (:>)) +import Juvix.Prelude.Base.Foundation import Juvix.Prelude.Effects qualified as E +import PolysemyPrelude qualified as P import Test.Tasty.Bench bm :: Benchmark @@ -31,7 +31,7 @@ countRaw = sum' . go [] countEff :: Natural -> Natural countEff = sum' . E.runPureEff . E.runReader c . go [] where - go :: (E.Reader Natural :> r) => [Natural] -> Natural -> Eff r [Natural] + go :: (E.Member (E.Reader Natural) r) => [Natural] -> Natural -> E.Sem r [Natural] go acc = \case 0 -> return acc n -> do @@ -39,11 +39,11 @@ countEff = sum' . E.runPureEff . E.runReader c . go [] go (i : acc) (pred n) countSem :: Natural -> Natural -countSem = sum' . run . runReader c . go [] +countSem = sum' . P.run . P.runReader c . go [] where - go :: (Member (Reader Natural) r) => [Natural] -> Natural -> Sem r [Natural] + go :: (P.Member (P.Reader Natural) r) => [Natural] -> Natural -> P.Sem r [Natural] go acc = \case 0 -> return acc n -> do - i <- ask + i <- P.ask go (i : acc) (pred n) diff --git a/bench2/Benchmark/Effect/ReaderH.hs b/bench2/Benchmark/Effect/ReaderH.hs index e6a0d73d8a..ee57eae4e3 100644 --- a/bench2/Benchmark/Effect/ReaderH.hs +++ b/bench2/Benchmark/Effect/ReaderH.hs @@ -1,8 +1,8 @@ module Benchmark.Effect.ReaderH where -import Juvix.Prelude -import Juvix.Prelude.Effects (Eff, (:>)) +import Juvix.Prelude.Base.Foundation import Juvix.Prelude.Effects qualified as E +import PolysemyPrelude qualified as P import Test.Tasty.Bench bm :: Benchmark @@ -28,7 +28,7 @@ countRaw = sum' . go [] countEff :: Natural -> Natural countEff x = sum' . E.runPureEff . E.runReader x $ go [] where - go :: (E.Reader Natural :> r) => [Natural] -> Eff r [Natural] + go :: (E.Member (E.Reader Natural) r) => [Natural] -> E.Sem r [Natural] go acc = do n <- E.ask case n of @@ -36,11 +36,11 @@ countEff x = sum' . E.runPureEff . E.runReader x $ go [] m -> E.local @Natural pred (go (m : acc)) countSem :: Natural -> Natural -countSem x = sum . run . runReader x $ go [] +countSem x = sum . P.run . P.runReader x $ go [] where - go :: (Members '[Reader Natural] r) => [Natural] -> Sem r [Natural] + go :: (P.Members '[P.Reader Natural] r) => [Natural] -> P.Sem r [Natural] go acc = do - n :: Natural <- ask + n :: Natural <- P.ask case n of 0 -> return acc - m -> local @Natural pred (go (m : acc)) + m -> P.local @Natural pred (go (m : acc)) diff --git a/bench2/Benchmark/Effect/State.hs b/bench2/Benchmark/Effect/State.hs index 6424bf8391..e220e3ec35 100644 --- a/bench2/Benchmark/Effect/State.hs +++ b/bench2/Benchmark/Effect/State.hs @@ -1,8 +1,8 @@ module Benchmark.Effect.State where -import Juvix.Prelude -import Juvix.Prelude.Effects (Eff, (:>)) +import Juvix.Prelude.Base.Foundation import Juvix.Prelude.Effects qualified as E +import PolysemyPrelude qualified as P import Test.Tasty.Bench bm :: Benchmark @@ -28,15 +28,15 @@ countRaw = go 0 countEff :: Natural -> Natural countEff = E.runPureEff . E.execState 0 . go where - go :: (E.State Natural :> r) => Natural -> Eff r () + go :: (E.Member (E.State Natural) r) => Natural -> E.Sem r () go = \case 0 -> return () m -> E.modify (+ m) >> go (pred m) countSem :: Natural -> Natural -countSem = run . execState 0 . go +countSem = P.run . P.execState 0 . go where - go :: (Members '[State Natural] r) => Natural -> Sem r () + go :: (P.Members '[P.State Natural] r) => Natural -> P.Sem r () go = \case 0 -> return () - m -> modify (+ m) >> go (pred m) + m -> P.modify (+ m) >> go (pred m) diff --git a/src/Juvix/Prelude/Base/Polysemy.hs b/bench2/PolysemyPrelude.hs similarity index 90% rename from src/Juvix/Prelude/Base/Polysemy.hs rename to bench2/PolysemyPrelude.hs index ad0f38ab51..b264df4ec0 100644 --- a/src/Juvix/Prelude/Base/Polysemy.hs +++ b/bench2/PolysemyPrelude.hs @@ -1,5 +1,5 @@ -module Juvix.Prelude.Base.Polysemy - ( module Juvix.Prelude.Base.Polysemy, +module PolysemyPrelude + ( module PolysemyPrelude, module Polysemy, module Polysemy.Error, module Polysemy.Input, @@ -37,9 +37,6 @@ mapReader f s = do e <- ask runReader (f e) s -eassert :: Bool -> Sem r () -eassert b = assert b $ return () - execOutputList :: Sem (Output o ': r) a -> Sem r [o] execOutputList = fmap fst . runOutputList diff --git a/package.yaml b/package.yaml index 1b17e4f0e1..34929fc902 100644 --- a/package.yaml +++ b/package.yaml @@ -60,6 +60,7 @@ dependencies: - effectful-core == 2.3.* - effectful-th == 1.0.* - exceptions == 0.10.* + - resourcet-effectful == 1.0.* - extra == 1.7.* - file-embed == 0.0.* - filelock == 0.1.* @@ -76,11 +77,10 @@ dependencies: - parser-combinators == 1.3.* - path == 0.9.* - path-io == 1.8.* - - polysemy == 1.9.* - - polysemy-plugin == 0.4.* - pretty == 1.1.* - prettyprinter == 1.7.* - prettyprinter-ansi-terminal == 1.1.* + - primitive == 0.8.* - process == 1.6.* - safe == 0.3.* - singletons == 3.0.* @@ -169,6 +169,7 @@ executables: dependencies: - juvix - tasty-bench == 0.3.* + - polysemy == 1.9.* verbatim: default-language: GHC2021 diff --git a/src/Juvix/Compiler/Asm/Interpreter/Runtime.hs b/src/Juvix/Compiler/Asm/Interpreter/Runtime.hs index 2c9e51152d..0784ea1b41 100644 --- a/src/Juvix/Compiler/Asm/Interpreter/Runtime.hs +++ b/src/Juvix/Compiler/Asm/Interpreter/Runtime.hs @@ -14,7 +14,7 @@ import Juvix.Compiler.Asm.Interpreter.Error import Juvix.Compiler.Asm.Interpreter.RuntimeState import Juvix.Compiler.Asm.Pretty -data Runtime m a where +data Runtime :: Effect where HasCaller :: Runtime m Bool -- is the call stack non-empty? PushCallStack :: Code -> Runtime m () PopCallStack :: Runtime m Continuation @@ -37,10 +37,19 @@ data Runtime m a where makeSem ''Runtime runRuntime :: forall r a. InfoTable -> Sem (Runtime ': r) a -> Sem r (RuntimeState, a) -runRuntime tab = runState (RuntimeState (CallStack []) emptyFrame [] Nothing tab) . interp +runRuntime tab = interp where - interp :: Sem (Runtime ': r) a -> Sem (State RuntimeState ': r) a - interp = reinterpret $ \case + iniState = + RuntimeState + { _runtimeCallStack = AsmCallStack [], + _runtimeFrame = emptyFrame, + _runtimeMessages = [], + _runtimeLocation = Nothing, + _runtimeInfoTable = tab + } + + interp :: Sem (Runtime ': r) a -> Sem r (RuntimeState, a) + interp = reinterpret (runState iniState) $ \case HasCaller -> not . null . (^. runtimeCallStack . callStack) <$> get PushCallStack code -> do diff --git a/src/Juvix/Compiler/Asm/Interpreter/RuntimeState.hs b/src/Juvix/Compiler/Asm/Interpreter/RuntimeState.hs index 07755c859b..13f0829264 100644 --- a/src/Juvix/Compiler/Asm/Interpreter/RuntimeState.hs +++ b/src/Juvix/Compiler/Asm/Interpreter/RuntimeState.hs @@ -53,7 +53,7 @@ Memory consists of: -- The heap does not need to be modelled explicitly. Heap values are simply -- stored in the `Val` datastructure. Pointers are implicit. -newtype CallStack = CallStack +newtype AsmCallStack = AsmCallStack { _callStack :: [Continuation] } @@ -96,7 +96,7 @@ data Continuation = Continuation -- | JuvixAsm runtime state data RuntimeState = RuntimeState { -- | global call stack - _runtimeCallStack :: CallStack, + _runtimeCallStack :: AsmCallStack, -- | current frame _runtimeFrame :: Frame, -- | debug messages generated so far @@ -107,7 +107,7 @@ data RuntimeState = RuntimeState _runtimeInfoTable :: InfoTable } -makeLenses ''CallStack +makeLenses ''AsmCallStack makeLenses ''Continuation makeLenses ''ArgumentArea makeLenses ''TemporaryStack diff --git a/src/Juvix/Compiler/Backend/C/Data/CBuilder.hs b/src/Juvix/Compiler/Backend/C/Data/CBuilder.hs index 0ad62c147e..3447336d32 100644 --- a/src/Juvix/Compiler/Backend/C/Data/CBuilder.hs +++ b/src/Juvix/Compiler/Backend/C/Data/CBuilder.hs @@ -2,7 +2,7 @@ module Juvix.Compiler.Backend.C.Data.CBuilder where import Juvix.Prelude -data CBuilder m a where +data CBuilder :: Effect where FreshLabel :: CBuilder m Text makeSem ''CBuilder @@ -20,9 +20,7 @@ emptyCBuilderState = } runCBuilder :: Sem (CBuilder ': r) a -> Sem r a -runCBuilder = - evalState emptyCBuilderState - . reinterpret interp +runCBuilder = reinterpret (evalState emptyCBuilderState) interp where interp :: CBuilder m a -> Sem (State CBuilderState ': r) a interp = \case diff --git a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs index d16431a662..61983cfbe7 100644 --- a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs +++ b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs @@ -21,7 +21,6 @@ import Juvix.Compiler.Pipeline.EntryPoint import Juvix.Extra.Assets import Juvix.Extra.Strings qualified as Str import Juvix.Prelude -import Juvix.Prelude qualified as Prelude import Juvix.Prelude.Pretty import Text.Blaze.Html.Renderer.Utf8 qualified as Html import Text.Blaze.Html5 as Html hiding (map) @@ -172,7 +171,7 @@ createIndexFile ps = do <> ul (mconcatMap li c') writeHtml :: (Members '[EmbedIO] r) => Path Abs File -> Html -> Sem r () -writeHtml f h = Prelude.embed $ do +writeHtml f h = liftIO $ do ensureDir dir Builder.writeFile (toFilePath f) (Html.renderHtmlBuilder h) where @@ -182,7 +181,7 @@ writeHtml f h = Prelude.embed $ do genJudocHtml :: (Members '[EmbedIO] r) => EntryPoint -> JudocArgs -> Sem r () genJudocHtml entry JudocArgs {..} = runReader htmlOpts . runReader normTable . runReader entry $ do - Prelude.embed (writeAssets _judocArgsOutputDir) + liftIO (writeAssets _judocArgsOutputDir) mapM_ (goTopModule cs) allModules createIndexFile (map topModulePath (toList allModules)) where @@ -306,7 +305,7 @@ goTopModule cs m = do srcHtml :: forall s. (Members '[Reader HtmlOptions, EmbedIO] s) => Sem s Html srcHtml = do - utc <- Prelude.embed getCurrentTime + utc <- liftIO getCurrentTime genModuleHtml GenModuleHtmlArgs { _genModuleHtmlArgsConcreteOpts = defaultOptions, diff --git a/src/Juvix/Compiler/Builtins/Effect.hs b/src/Juvix/Compiler/Builtins/Effect.hs index c9b2f08085..f68e3758cc 100644 --- a/src/Juvix/Compiler/Builtins/Effect.hs +++ b/src/Juvix/Compiler/Builtins/Effect.hs @@ -9,7 +9,7 @@ import Juvix.Compiler.Internal.Extra import Juvix.Compiler.Internal.Pretty import Juvix.Prelude -data Builtins m a where +data Builtins :: Effect where GetBuiltinName' :: Interval -> BuiltinPrim -> Builtins m Name RegisterBuiltin' :: BuiltinPrim -> Name -> Builtins m () @@ -30,8 +30,8 @@ makeLenses ''BuiltinsState iniBuiltins :: BuiltinsState iniBuiltins = BuiltinsState mempty -re :: forall r a. (Member (Error JuvixError) r) => Sem (Builtins ': r) a -> Sem (State BuiltinsState ': r) a -re = reinterpret $ \case +runBuiltins :: forall r a. (Member (Error JuvixError) r) => BuiltinsState -> Sem (Builtins ': r) a -> Sem r (BuiltinsState, a) +runBuiltins ini = reinterpret (runState ini) $ \case GetBuiltinName' i b -> fromMaybeM notDefined (gets (^. builtinsTable . at b)) where notDefined :: Sem (State BuiltinsState ': r) x @@ -61,9 +61,6 @@ re = reinterpret $ \case evalBuiltins :: (Member (Error JuvixError) r) => BuiltinsState -> Sem (Builtins ': r) a -> Sem r a evalBuiltins s = fmap snd . runBuiltins s -runBuiltins :: (Member (Error JuvixError) r) => BuiltinsState -> Sem (Builtins ': r) a -> Sem r (BuiltinsState, a) -runBuiltins s = runState s . re - data FunInfo = FunInfo { _funInfoDef :: FunctionDef, _funInfoBuiltin :: BuiltinFunction, diff --git a/src/Juvix/Compiler/Casm/Data/LabelInfoBuilder.hs b/src/Juvix/Compiler/Casm/Data/LabelInfoBuilder.hs index 58d68dcda9..4a10bb326b 100644 --- a/src/Juvix/Compiler/Casm/Data/LabelInfoBuilder.hs +++ b/src/Juvix/Compiler/Casm/Data/LabelInfoBuilder.hs @@ -4,7 +4,7 @@ import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Casm.Data.LabelInfo import Juvix.Compiler.Casm.Language -data LabelInfoBuilder m a where +data LabelInfoBuilder :: Effect where FreshSymbol :: LabelInfoBuilder m Symbol RegisterLabelName :: Symbol -> Text -> LabelInfoBuilder m () RegisterLabelAddress :: Symbol -> Int -> LabelInfoBuilder m () @@ -38,9 +38,7 @@ runLabelInfoBuilder :: Sem (LabelInfoBuilder ': r) a -> Sem r (LabelInfo, a) runLabelInfoBuilder = fmap (first (^. stateLabelInfo)) . runLabelInfoBuilder' emptyBuilderState runLabelInfoBuilder' :: BuilderState -> Sem (LabelInfoBuilder ': r) a -> Sem r (BuilderState, a) -runLabelInfoBuilder' bs = - runState bs - . reinterpret interp +runLabelInfoBuilder' bs = reinterpret (runState bs) interp where interp :: LabelInfoBuilder m a -> Sem (State BuilderState ': r) a interp = \case diff --git a/src/Juvix/Compiler/Concrete/Data/InfoTableBuilder.hs b/src/Juvix/Compiler/Concrete/Data/InfoTableBuilder.hs index 53fe87de33..ba39f766d7 100644 --- a/src/Juvix/Compiler/Concrete/Data/InfoTableBuilder.hs +++ b/src/Juvix/Compiler/Concrete/Data/InfoTableBuilder.hs @@ -10,7 +10,7 @@ import Juvix.Compiler.Concrete.Language import Juvix.Compiler.Store.Scoped.Language import Juvix.Prelude -data InfoTableBuilder m a where +data InfoTableBuilder :: Effect where RegisterAxiom :: AxiomDef 'Scoped -> InfoTableBuilder m () RegisterConstructor :: ConstructorDef 'Scoped -> InfoTableBuilder m () RegisterInductive :: InductiveDef 'Scoped -> InfoTableBuilder m () @@ -36,8 +36,8 @@ registerDoc k md = do modify (set (highlightDoc . at k) md) modify (set (infoHighlightDoc . at k) md) -toState :: (Member HighlightBuilder r) => Sem (InfoTableBuilder ': r) a -> Sem (State InfoTable ': r) a -toState = reinterpret $ \case +runInfoTableBuilder :: (Member HighlightBuilder r) => InfoTable -> Sem (InfoTableBuilder ': r) a -> Sem r (InfoTable, a) +runInfoTableBuilder ini = reinterpret (runState ini) $ \case RegisterAxiom d -> let j = d ^. axiomDoc in do @@ -94,11 +94,8 @@ toState = reinterpret $ \case runInfoTableBuilderRepl :: InfoTable -> Sem (InfoTableBuilder ': r) a -> Sem r (InfoTable, a) runInfoTableBuilderRepl tab = ignoreHighlightBuilder . runInfoTableBuilder tab . raiseUnder -runInfoTableBuilder :: (Member HighlightBuilder r) => InfoTable -> Sem (InfoTableBuilder ': r) a -> Sem r (InfoTable, a) -runInfoTableBuilder tab = runState tab . toState - ignoreInfoTableBuilder :: (Member HighlightBuilder r) => Sem (InfoTableBuilder ': r) a -> Sem r a -ignoreInfoTableBuilder = evalState mempty . toState +ignoreInfoTableBuilder = fmap snd . runInfoTableBuilder mempty anameFromScopedIden :: ScopedIden -> AName anameFromScopedIden s = diff --git a/src/Juvix/Compiler/Concrete/Data/NameSignature/Builder.hs b/src/Juvix/Compiler/Concrete/Data/NameSignature/Builder.hs index 018ece554c..47584e82ce 100644 --- a/src/Juvix/Compiler/Concrete/Data/NameSignature/Builder.hs +++ b/src/Juvix/Compiler/Concrete/Data/NameSignature/Builder.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FunctionalDependencies #-} +{-# OPTIONS_GHC -Wno-unused-type-patterns #-} module Juvix.Compiler.Concrete.Data.NameSignature.Builder ( mkNameSignature, @@ -16,7 +17,7 @@ import Juvix.Compiler.Concrete.Gen qualified as Gen import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.Scoping.Error import Juvix.Prelude -data NameSignatureBuilder s m a where +data NameSignatureBuilder s :: Effect where AddSymbol :: IsImplicit -> Maybe (ArgDefault s) -> SymbolType s -> ExpressionType s -> NameSignatureBuilder s m () EndBuild :: Proxy s -> NameSignatureBuilder s m a -- | for debugging @@ -179,7 +180,7 @@ re :: (SingI s) => Sem (NameSignatureBuilder s ': r) a -> Sem (Re s r) a -re = reinterpret3 $ \case +re = interpretTop3 $ \case AddSymbol impl mdef k ty -> addSymbol' impl mdef k ty EndBuild {} -> endBuild' GetBuilder -> get diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs index e0aeabf5a1..4cb14685e7 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs @@ -28,7 +28,7 @@ import Juvix.Compiler.Concrete.Translation.FromSource.Data.Context qualified as import Juvix.Compiler.Pipeline.EntryPoint import Juvix.Compiler.Store.Scoped.Language as Store import Juvix.Data.FixityInfo qualified as FI -import Juvix.Prelude hiding (scoped) +import Juvix.Prelude scopeCheck :: (Members '[HighlightBuilder, Error JuvixError, NameIdGen] r) => diff --git a/src/Juvix/Compiler/Concrete/Translation/FromSource/ParserResultBuilder.hs b/src/Juvix/Compiler/Concrete/Translation/FromSource/ParserResultBuilder.hs index ee474a6ba9..f30b2aaab1 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromSource/ParserResultBuilder.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromSource/ParserResultBuilder.hs @@ -6,7 +6,7 @@ import Juvix.Compiler.Concrete.Language import Juvix.Compiler.Concrete.Translation.FromSource.Data.ParserState import Juvix.Prelude -data ParserResultBuilder m a where +data ParserResultBuilder :: Effect where RegisterItem :: ParsedItem -> ParserResultBuilder m () RegisterSpaceSpan :: SpaceSpan -> ParserResultBuilder m () RegisterImport :: Import 'Parsed -> ParserResultBuilder m () @@ -70,19 +70,16 @@ registerItem' i = modify' (over parserStateParsedItems (i :)) runParserResultBuilder :: (Member HighlightBuilder r) => ParserState -> Sem (ParserResultBuilder ': r) a -> Sem r (ParserState, a) runParserResultBuilder s = - runState s - . reinterpret - ( \case - RegisterImport i -> modify' (over parserStateImports (i :)) - RegisterItem i -> do - modify' (over highlightParsed (i :)) - registerItem' i - RegisterSpaceSpan g -> do - modify' (over parserStateComments (g :)) - forM_ (g ^.. spaceSpan . each . _SpaceComment) $ \c -> - registerItem' - ParsedItem - { _parsedLoc = getLoc c, - _parsedTag = ParsedTagComment - } - ) + reinterpret (runState s) $ \case + RegisterImport i -> modify' (over parserStateImports (i :)) + RegisterItem i -> do + modify' (over highlightParsed (i :)) + registerItem' i + RegisterSpaceSpan g -> do + modify' (over parserStateComments (g :)) + forM_ (g ^.. spaceSpan . each . _SpaceComment) $ \c -> + registerItem' + ParsedItem + { _parsedLoc = getLoc c, + _parsedTag = ParsedTagComment + } diff --git a/src/Juvix/Compiler/Core/Data/InfoTableBuilder.hs b/src/Juvix/Compiler/Core/Data/InfoTableBuilder.hs index f09d6ee697..fc29750433 100644 --- a/src/Juvix/Compiler/Core/Data/InfoTableBuilder.hs +++ b/src/Juvix/Compiler/Core/Data/InfoTableBuilder.hs @@ -11,7 +11,7 @@ import Juvix.Compiler.Core.Extra.Base import Juvix.Compiler.Core.Info.NameInfo import Juvix.Compiler.Core.Language -data InfoTableBuilder m a where +data InfoTableBuilder :: Effect where FreshSymbol :: InfoTableBuilder m Symbol FreshTag :: InfoTableBuilder m Tag RegisterIdent :: Text -> IdentifierInfo -> InfoTableBuilder m () @@ -89,9 +89,7 @@ mkBuilderState m = tab = computeCombinedInfoTable m runInfoTableBuilder' :: BuilderState -> forall r a. Sem (InfoTableBuilder ': r) a -> Sem r (BuilderState, a) -runInfoTableBuilder' st = - runState st - . reinterpret interp +runInfoTableBuilder' st = reinterpret (runState st) interp where interp :: InfoTableBuilder m b -> Sem (State BuilderState ': r) b interp = \case diff --git a/src/Juvix/Compiler/Core/Transformation/UnrollRecursion.hs b/src/Juvix/Compiler/Core/Transformation/UnrollRecursion.hs index 075e5cb3ff..61a6555d32 100644 --- a/src/Juvix/Compiler/Core/Transformation/UnrollRecursion.hs +++ b/src/Juvix/Compiler/Core/Transformation/UnrollRecursion.hs @@ -11,10 +11,11 @@ import Juvix.Compiler.Core.Transformation.Base unrollRecursion :: (Member (Reader CoreOptions) r) => Module -> Sem r Module unrollRecursion md = do (mp, md') <- - runState @(HashMap Symbol Symbol) mempty $ - execInfoTableBuilder md $ - forM_ (buildSCCs (createCallGraph (md ^. moduleInfoTable))) goSCC - return $ mapIdentSymbols mp $ pruneInfoTable md' + runState @(HashMap Symbol Symbol) mempty + . execInfoTableBuilder md + . forM_ (buildSCCs (createCallGraph (md ^. moduleInfoTable))) + $ goSCC + return . mapIdentSymbols mp $ pruneInfoTable md' where mapIdentSymbols :: HashMap Symbol Symbol -> Module -> Module mapIdentSymbols mp = over (moduleInfoTable . infoMain) adjustMain . mapAllNodes (umap go) diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/Termination/Checker.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/Termination/Checker.hs index aa6a389f70..f3b3c739c2 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/Termination/Checker.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/Termination/Checker.hs @@ -22,7 +22,7 @@ import Juvix.Prelude class Scannable a where buildCallMap :: a -> CallMap -data Termination m a where +data Termination :: Effect where CheckTerminationShallow :: (Scannable a) => a -> Termination m () FunctionTermination :: FunctionRef -> Termination m IsTerminating @@ -33,7 +33,7 @@ functionSafeToNormalize = fmap safeToNormalize . functionTermination runTermination :: forall r a. (Members '[Error JuvixError] r) => TerminationState -> Sem (Termination ': r) a -> Sem r (TerminationState, a) runTermination ini m = do - res <- runState ini (re m) + res <- runTerminationState ini m checkNonTerminating (fst res) return res where @@ -60,8 +60,8 @@ instance Scannable Expression where . execState emptyCallMap . scanTopExpression -re :: Sem (Termination ': r) a -> Sem (State TerminationState ': r) a -re = reinterpret $ \case +runTerminationState :: TerminationState -> Sem (Termination ': r) a -> Sem r (TerminationState, a) +runTerminationState ini = reinterpret (runState ini) $ \case CheckTerminationShallow m -> checkTerminationShallow' m FunctionTermination m -> functionTermination' m diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Inference.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Inference.hs index b7f625edd0..e1d2915596 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Inference.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromInternal/Analysis/TypeChecking/Data/Inference.hs @@ -40,7 +40,7 @@ data MatchError = MatchError makeLenses ''MatchError -data Inference m a where +data Inference :: Effect where MatchTypes :: Expression -> Expression -> Inference m (Maybe MatchError) QueryMetavar :: Hole -> Inference m (Maybe Expression) RegisterIdenType :: Name -> Expression -> Inference m () @@ -294,11 +294,12 @@ queryMetavar' h = do Just Fresh -> return Nothing Just (Refined e) -> return (Just e) -re :: +runInferenceState :: (Members '[State FunctionsTable, Error TypeCheckerError, NameIdGen] r) => + InferenceState -> Sem (Inference ': r) a -> - Sem (State InferenceState ': r) a -re = reinterpret $ \case + Sem r (InferenceState, a) +runInferenceState inis = reinterpret (runState inis) $ \case MatchTypes a b -> matchTypes' a b QueryMetavar h -> queryMetavar' h RememberFunctionDef f -> modify' (over inferenceFunctionsStash (f :)) @@ -487,7 +488,7 @@ runInferenceDefs :: Sem (Inference ': r) (NonEmpty funDef) -> Sem r (NonEmpty funDef) runInferenceDefs a = do - (finalState, expr) <- runState iniState (re a) + (finalState, expr) <- runInferenceState iniState a (subs, idens) <- closeState finalState idens' <- mapM (subsHoles subs) (idens ^. typesTable) stash' <- mapM (subsHoles subs) (finalState ^. inferenceFunctionsStash) diff --git a/src/Juvix/Compiler/Pipeline.hs b/src/Juvix/Compiler/Pipeline.hs index c4522599c2..e19030096e 100644 --- a/src/Juvix/Compiler/Pipeline.hs +++ b/src/Juvix/Compiler/Pipeline.hs @@ -7,7 +7,7 @@ module Juvix.Compiler.Pipeline ) where -import Data.List.Singletons +import Data.List.Singletons (type (++)) import Juvix.Compiler.Asm.Error qualified as Asm import Juvix.Compiler.Asm.Options qualified as Asm import Juvix.Compiler.Asm.Pipeline qualified as Asm @@ -46,7 +46,7 @@ import Juvix.Data.Effect.Process import Juvix.Data.Effect.TaggedLock import Juvix.Data.Field -type PipelineAppEffects = '[TaggedLock, EmbedIO, Resource, Final IO] +type PipelineAppEffects = '[TaggedLock, EmbedIO] type PipelineLocalEff = '[PathResolver, EvalFileEff, Error PackageLoaderError, Error DependencyError, GitClone, Error GitProcessError, Process, Log, Reader EntryPoint, Files, Error JuvixError, HighlightBuilder, Internet] diff --git a/src/Juvix/Compiler/Pipeline/Artifacts.hs b/src/Juvix/Compiler/Pipeline/Artifacts.hs index d97f2167a1..1001fe5973 100644 --- a/src/Juvix/Compiler/Pipeline/Artifacts.hs +++ b/src/Juvix/Compiler/Pipeline/Artifacts.hs @@ -93,8 +93,8 @@ runStateLikeArtifacts :: Lens' Artifacts field -> Sem (stateEff ': r) a -> Sem r a -runStateLikeArtifacts runEff l m = do +runStateLikeArtifacts runner l m = do s <- gets (^. l) - (s', a) <- runEff s m + (s', a) <- runner s m modify' (set l s') return a diff --git a/src/Juvix/Compiler/Pipeline/Driver.hs b/src/Juvix/Compiler/Pipeline/Driver.hs index 437aca246c..a81bbdf3fa 100644 --- a/src/Juvix/Compiler/Pipeline/Driver.hs +++ b/src/Juvix/Compiler/Pipeline/Driver.hs @@ -287,8 +287,7 @@ withPath' :: TopModulePath -> (Path Abs File -> Sem r a) -> Sem r a -withPath' path a = withPathFile path (either throwError a) +withPath' path a = withPathFile path (either throwErr a) where - throwError :: PathResolverError -> Sem r a - throwError e = - mapError (JuvixError @PathResolverError) $ throw e + throwErr :: PathResolverError -> Sem r a + throwErr = mapError (JuvixError @PathResolverError) . throw diff --git a/src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs b/src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs index f08dd93765..a202c0534e 100644 --- a/src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs +++ b/src/Juvix/Compiler/Pipeline/EntryPoint/IO.hs @@ -5,13 +5,13 @@ import Juvix.Compiler.Pipeline.Root import Juvix.Data.Effect.TaggedLock import Juvix.Prelude -defaultEntryPointIO :: (Members '[EmbedIO, TaggedLock, Final IO] r) => Path Abs Dir -> Path Abs File -> Sem r EntryPoint +defaultEntryPointIO :: (Members '[EmbedIO, TaggedLock, EmbedIO] r) => Path Abs Dir -> Path Abs File -> Sem r EntryPoint defaultEntryPointIO cwd mainFile = do root <- findRootAndChangeDir (Just (parent mainFile)) Nothing cwd pkg <- readPackageRootIO root return (defaultEntryPoint pkg root mainFile) -defaultEntryPointNoFileIO :: (Members '[EmbedIO, TaggedLock, Final IO] r) => Path Abs Dir -> Sem r EntryPoint +defaultEntryPointNoFileIO :: (Members '[EmbedIO, TaggedLock, EmbedIO] r) => Path Abs Dir -> Sem r EntryPoint defaultEntryPointNoFileIO cwd = do root <- findRootAndChangeDir Nothing Nothing cwd pkg <- readPackageRootIO root diff --git a/src/Juvix/Compiler/Pipeline/Loader/PathResolver.hs b/src/Juvix/Compiler/Pipeline/Loader/PathResolver.hs index 583883ff98..aa27c2265d 100644 --- a/src/Juvix/Compiler/Pipeline/Loader/PathResolver.hs +++ b/src/Juvix/Compiler/Pipeline/Loader/PathResolver.hs @@ -142,7 +142,7 @@ resolveDependency i = case i ^. packageDepdendencyInfoDependency of { _cloneArgsCloneDir = cloneDir, _cloneArgsRepoUrl = g ^. gitDependencyUrl } - scoped cloneArgs $ do + provideWith_ cloneArgs $ do fetchOnNoSuchRefAndRetry (errorHandler cloneDir) (`checkout` (g ^. gitDependencyRef)) resolvedRef <- headRef (errorHandler cloneDir) return @@ -196,9 +196,9 @@ registerPackageBase = do registerDependencies' :: forall r. - (Members '[TaggedLock, Reader EntryPoint, State ResolverState, Reader ResolverEnv, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) => + (Members '[TaggedLock, Reader EntryPoint, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) => DependenciesConfig -> - Sem r () + Sem (Reader ResolverEnv ': State ResolverState ': r) () registerDependencies' conf = do e <- ask @EntryPoint registerPackageBase @@ -215,7 +215,7 @@ registerDependencies' conf = do lockfilePath' <- lockfilePath writeLockfile lockfilePath' packageFileChecksum lockfile where - shouldWriteLockfile :: Sem r Bool + shouldWriteLockfile :: Sem ((Reader ResolverEnv ': State ResolverState ': r)) Bool shouldWriteLockfile = do lockfileExists <- lockfilePath >>= fileExists' hasRemoteDependencies <- gets (^. resolverHasRemoteDependencies) @@ -226,7 +226,7 @@ registerDependencies' conf = do shouldUpdateLockfile = lockfileExists && shouldUpdateLockfile' return (shouldForce || shouldWriteInitialLockfile || shouldUpdateLockfile) - lockfilePath :: Sem r (Path Abs File) + lockfilePath :: Sem ((Reader ResolverEnv ': State ResolverState ': r)) (Path Abs File) lockfilePath = do root <- asks (^. envRoot) return (mkPackageLockfilePath root) @@ -401,33 +401,60 @@ expectedPath' m = do _pathInfoRootInfo = RootInfo {..} return PathInfoTopModule {..} -re :: - forall r a. - (Members '[TaggedLock, Reader EntryPoint, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) => +runPathResolver2 :: + forall r a v. + (v ~ '[TaggedLock, Reader EntryPoint, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff], Members v r) => + ResolverState -> + ResolverEnv -> Sem (PathResolver ': r) a -> - Sem (Reader ResolverEnv ': State ResolverState ': r) a -re = reinterpret2H helper + Sem r (ResolverState, a) +runPathResolver2 st topEnv arg = do + ( reinterpretHCommon2 + ( runState st + . runReader topEnv + ) + handler + ) + arg where - helper :: - forall rInitial x. - PathResolver (Sem rInitial) x -> - Tactical PathResolver (Sem rInitial) (Reader ResolverEnv ': (State ResolverState ': r)) x - helper = \case - RegisterDependencies forceUpdateLockfile -> registerDependencies' forceUpdateLockfile >>= pureT - ExpectedPathInfoTopModule m -> expectedPath' m >>= pureT - WithPath m a -> do - x :: Either PathResolverError (Path Abs Dir, Path Rel File) <- resolvePath' m - oldroot <- asks (^. envRoot) - x' <- pureT x - a' <- bindT a - st' <- get - let root' = case x of - Left {} -> oldroot - Right (r, _) -> r - raise (evalPathResolver' st' root' (a' x')) - -evalPathResolver' :: (Members '[TaggedLock, Reader EntryPoint, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) => ResolverState -> Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r a -evalPathResolver' st root = fmap snd . runPathResolver' st root + handler :: + forall t localEs x. + (Members v t) => + LocalEnv localEs (Reader ResolverEnv ': State ResolverState ': t) -> + PathResolver (Sem localEs) x -> + Sem (Reader ResolverEnv ': State ResolverState ': t) x + handler localEnv = \case + RegisterDependencies forceUpdateLockfile -> registerDependencies' forceUpdateLockfile + ExpectedPathInfoTopModule m -> expectedPath' m + WithPath + m + ( a :: + Either PathResolverError (Path Abs Dir, Path Rel File) -> + Sem localEs x + ) -> do + x :: Either PathResolverError (Path Abs Dir, Path Rel File) <- resolvePath' m + let y :: Sem localEs x = a x + oldroot <- asks (^. envRoot) + let root' = case x of + Left {} -> oldroot + Right (r, _) -> r + e <- ask + let _envSingleFile :: Maybe (Path Abs File) + _envSingleFile + | e ^. entryPointPackageType == GlobalStdlib = e ^. entryPointModulePath + | otherwise = Nothing + env' :: ResolverEnv + env' = + ResolverEnv + { _envRoot = root', + _envLockfileInfo = Nothing, + _envSingleFile + } + localSeqUnlift localEnv $ \unlift -> local (const env') $ do + oldState <- get @ResolverState + res <- unlift y + put oldState + return res runPathResolver :: (Members '[TaggedLock, Reader EntryPoint, Files, Error JuvixError, Error DependencyError, GitClone, EvalFileEff] r) => Path Abs Dir -> Sem (PathResolver ': r) a -> Sem r (ResolverState, a) runPathResolver = runPathResolver' iniResolverState @@ -446,7 +473,7 @@ runPathResolver' st root x = do _envLockfileInfo = Nothing, _envSingleFile } - runState st (runReader env (re x)) + runPathResolver2 st env x runPathResolverPipe' :: (Members '[TaggedLock, Files, Reader EntryPoint, Error DependencyError, GitClone, Error JuvixError, EvalFileEff] r) => ResolverState -> Sem (PathResolver ': r) a -> Sem r (ResolverState, a) runPathResolverPipe' iniState a = do diff --git a/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Base.hs b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Base.hs index 03c787287c..20a231e86b 100644 --- a/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Base.hs +++ b/src/Juvix/Compiler/Pipeline/Loader/PathResolver/Base.hs @@ -26,7 +26,7 @@ data PathInfoTopModule = PathInfoTopModule } deriving stock (Show) -data PathResolver m a where +data PathResolver :: Effect where RegisterDependencies :: DependenciesConfig -> PathResolver m () ExpectedPathInfoTopModule :: TopModulePath -> PathResolver m PathInfoTopModule WithPath :: diff --git a/src/Juvix/Compiler/Pipeline/Package/Loader.hs b/src/Juvix/Compiler/Pipeline/Package/Loader.hs index 5c4f01fc98..7ca4f06bab 100644 --- a/src/Juvix/Compiler/Pipeline/Package/Loader.hs +++ b/src/Juvix/Compiler/Pipeline/Package/Loader.hs @@ -40,7 +40,7 @@ renderPackageVersion v pkg = toPlainText (ppOutDefaultNoComments (toConcrete (ge -- | Load a package file in the context of the PackageDescription module and the global package stdlib. loadPackage :: (Members '[Files, EvalFileEff, Error PackageLoaderError] r) => BuildDir -> Path Abs File -> Sem r Package loadPackage buildDir packagePath = do - scoped @(Path Abs File) @EvalEff packagePath $ do + provideWith_ @EvalEff packagePath $ do (v, t) <- getPackageNode ((getPackageType (t ^. typeSpecVersion)) ^. packageDescriptionTypeToPackage) buildDir packagePath =<< eval' v where diff --git a/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff.hs b/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff.hs index 6a3dabc6bf..40c5125d82 100644 --- a/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff.hs +++ b/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff.hs @@ -12,7 +12,7 @@ data TypeSpec = TypeSpec makeLenses ''TypeSpec -data EvalEff m a where +data EvalEff :: Effect where Eval' :: Node -> EvalEff m Value LookupIdentifier :: Text -> EvalEff m Node -- | Assert that the Node has a type given by one of the 'TypeSpec's @@ -20,4 +20,4 @@ data EvalEff m a where makeSem ''EvalEff -type EvalFileEff = Scoped (Path Abs File) EvalEff +type EvalFileEff = Provider_ EvalEff (Path Abs File) diff --git a/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs b/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs index bb172926af..5194549ccf 100644 --- a/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs +++ b/src/Juvix/Compiler/Pipeline/Package/Loader/EvalEff/IO.hs @@ -27,17 +27,22 @@ data LoaderResource = LoaderResource makeLenses ''LoaderResource -runEvalFileEffIO :: forall r a. (Members '[TaggedLock, Files, EmbedIO, Error PackageLoaderError] r) => Sem (EvalFileEff ': r) a -> Sem r a -runEvalFileEffIO = interpretScopedAs allocator handler +runEvalFileEffIO :: + forall r a. + (Members '[TaggedLock, Files, EmbedIO, Error PackageLoaderError] r) => + Sem (EvalFileEff ': r) a -> + Sem r a +runEvalFileEffIO = runProvider_ helper where - allocator :: Path Abs File -> Sem r LoaderResource - allocator p = do + helper :: forall x. Path Abs File -> Sem (EvalEff ': r) x -> Sem r x + helper p m = do res <- loadPackage' p - return - LoaderResource - { _loaderResourceResult = res, - _loaderResourcePackagePath = p - } + let loaderRes :: LoaderResource = + LoaderResource + { _loaderResourceResult = res, + _loaderResourcePackagePath = p + } + interpret (handler loaderRes) m handler :: LoaderResource -> EvalEff m x -> Sem r x handler res = \case @@ -73,6 +78,7 @@ runEvalFileEffIO = interpretScopedAs allocator handler evalNode n = do n' <- doEval Nothing False packageLoc tab n case n' of + Right resN -> return resN Left e -> do throw PackageLoaderError @@ -83,7 +89,6 @@ runEvalFileEffIO = interpretScopedAs allocator handler { _packageEvaluationErrorError = JuvixError e } } - Right resN -> return resN where packageLoc :: Interval packageLoc = singletonInterval (mkInitialLoc packagePath) diff --git a/src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs b/src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs index 7f5a584282..57ab081309 100644 --- a/src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs +++ b/src/Juvix/Compiler/Pipeline/Package/Loader/PathResolver.hs @@ -34,24 +34,22 @@ runPackagePathResolver rootPath sem = do initFiles ds fs <- rootInfoFiles ds let mkRootInfo' = mkRootInfo ds fs - ( interpretH $ \case - RegisterDependencies {} -> pureT () - ExpectedPathInfoTopModule m -> do - let _pathInfoTopModule = m - _pathInfoRootInfo = - -- A Package file is a member of a package by definition. - fromMaybe (error "runPackagePathResolver: expected root info") $ - mkRootInfo' (topModulePathToRelativePath' m) - pureT PathInfoTopModule {..} - WithPath m a -> do - let relPath = topModulePathToRelativePath' m - x :: Either PathResolverError (Path Abs Dir, Path Rel File) - x = case mkRootInfo' relPath of - Just p -> Right (p ^. rootInfoPath, relPath) - Nothing -> Left (ErrPackageInvalidImport PackageInvalidImport {_packageInvalidImport = m}) - runTSimple (return x) >>= bindTSimple a - ) - sem + (`interpretH` sem) $ \localEnv -> \case + RegisterDependencies {} -> return () + ExpectedPathInfoTopModule m -> do + let _pathInfoTopModule = m + _pathInfoRootInfo = + -- A Package file is a member of a package by definition. + fromMaybe (error "runPackagePathResolver: expected root info") $ + mkRootInfo' (topModulePathToRelativePath' m) + return PathInfoTopModule {..} + WithPath m a -> do + let relPath = topModulePathToRelativePath' m + x :: Either PathResolverError (Path Abs Dir, Path Rel File) + x = case mkRootInfo' relPath of + Just p -> Right (p ^. rootInfoPath, relPath) + Nothing -> Left (ErrPackageInvalidImport PackageInvalidImport {_packageInvalidImport = m}) + runTSimpleEff localEnv (a x) where rootInfoDirs :: Sem r RootInfoDirs rootInfoDirs = do diff --git a/src/Juvix/Compiler/Pipeline/Root.hs b/src/Juvix/Compiler/Pipeline/Root.hs index 2a3f289a25..2a9ce8f406 100644 --- a/src/Juvix/Compiler/Pipeline/Root.hs +++ b/src/Juvix/Compiler/Pipeline/Root.hs @@ -4,8 +4,8 @@ module Juvix.Compiler.Pipeline.Root ) where -import Control.Exception (SomeException) import Control.Exception qualified as IO +import Control.Monad.Catch qualified as M import Juvix.Compiler.Pipeline.Package.IO import Juvix.Compiler.Pipeline.Root.Base import Juvix.Data.Effect.TaggedLock @@ -17,20 +17,20 @@ readPackageRootIO root = readPackageIO (root ^. rootRootDir) (root ^. rootBuildD findRootAndChangeDir :: forall r. - (Members '[TaggedLock, EmbedIO, Final IO] r) => + (Members '[TaggedLock, EmbedIO] r) => Maybe (Path Abs Dir) -> Maybe (Path Abs Dir) -> Path Abs Dir -> Sem r Root findRootAndChangeDir minputFileDir mbuildDir _rootInvokeDir = do - r <- runError (fromExceptionSem @SomeException go) + let handleErr :: IO.SomeException -> Sem r x + handleErr (err :: IO.SomeException) = do + putStrLn "Something went wrong when looking for the root of the project" + putStrLn (pack (IO.displayException err)) + exitFailure + r <- M.catch go handleErr runFilesIO ensureGlobalPackage - case r of - Left (err :: IO.SomeException) -> liftIO $ do - putStrLn "Something went wrong when looking for the root of the project" - putStrLn (pack (IO.displayException err)) - exitFailure - Right root -> return root + return r where possiblePaths :: Path Abs Dir -> [Path Abs Dir] possiblePaths p = p : toList (parents p) @@ -43,7 +43,7 @@ findRootAndChangeDir minputFileDir mbuildDir _rootInvokeDir = do pFile <- findPackageFile' Paths.packageFilePath return (pFile <|> yamlFile) - go :: Sem (Error SomeException ': r) Root + go :: Sem r Root go = do l <- findPackageFile case l of diff --git a/src/Juvix/Compiler/Pipeline/Run.hs b/src/Juvix/Compiler/Pipeline/Run.hs index d71776b089..45b9f0a0ce 100644 --- a/src/Juvix/Compiler/Pipeline/Run.hs +++ b/src/Juvix/Compiler/Pipeline/Run.hs @@ -111,7 +111,7 @@ runReplPipelineIO' opts entry = runReplPipelineIOEither entry >>= mayThrow where mayThrow :: Either JuvixError r -> m r mayThrow = \case - Left err -> liftIO . runM . runReader opts $ printErrorAnsiSafe err >> exitFailure + Left err -> runM . runReader opts $ printErrorAnsiSafe err >> exitFailure Right r -> return r runReplPipelineIOEither :: @@ -132,10 +132,7 @@ runReplPipelineIOEither' lockMode entry = do | mainIsPackageFile entry = runPackagePathResolverArtifacts (entry ^. entryPointResolverRoot) | otherwise = runPathResolverArtifacts eith <- - liftIO - . runFinal - . resourceToIOFinal - . embedToFinal @IO + runM . evalInternet hasInternet . ignoreHighlightBuilder . runError diff --git a/src/Juvix/Compiler/Reg/Interpreter.hs b/src/Juvix/Compiler/Reg/Interpreter.hs index 8a4d9e5aa8..ce7ea916e7 100644 --- a/src/Juvix/Compiler/Reg/Interpreter.hs +++ b/src/Juvix/Compiler/Reg/Interpreter.hs @@ -22,7 +22,7 @@ type Vars s = MV.MVector s (Maybe Val) type Args = Vec.Vector Val -runFunction :: forall r. (Members '[Error RegError, Embed IO] r) => Handle -> InfoTable -> [Val] -> FunctionInfo -> Sem r Val +runFunction :: forall r. (Members '[Error RegError, EmbedIO] r) => Handle -> InfoTable -> [Val] -> FunctionInfo -> Sem r Val runFunction hout infoTable args0 info0 = do r <- catchRunError (runST (goFun args0 info0)) case r of @@ -305,7 +305,7 @@ runFunction hout infoTable args0 info0 = do ValString s -> s v -> ppPrint infoTable v -runIO :: forall r. (Members '[Error RegError, Embed IO] r) => Handle -> Handle -> InfoTable -> Val -> Sem r Val +runIO :: forall r. (Members '[Error RegError, EmbedIO] r) => Handle -> Handle -> InfoTable -> Val -> Sem r Val runIO hin hout infoTable = \case ValConstr (Constr (BuiltinTag TagReturn) [x]) -> return x @@ -335,7 +335,7 @@ runIO hin hout infoTable = \case val -> return val -runFunctionIO :: forall r. (Members '[Error RegError, Embed IO] r) => Handle -> Handle -> InfoTable -> [Val] -> FunctionInfo -> Sem r Val +runFunctionIO :: forall r. (Members '[Error RegError, EmbedIO] r) => Handle -> Handle -> InfoTable -> [Val] -> FunctionInfo -> Sem r Val runFunctionIO hin hout tab args funInfo = do val <- runFunction hout tab args funInfo runIO hin hout tab val diff --git a/src/Juvix/Compiler/Tree/Data/InfoTableBuilder/Base.hs b/src/Juvix/Compiler/Tree/Data/InfoTableBuilder/Base.hs index 53b74356e8..31395ed875 100644 --- a/src/Juvix/Compiler/Tree/Data/InfoTableBuilder/Base.hs +++ b/src/Juvix/Compiler/Tree/Data/InfoTableBuilder/Base.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# OPTIONS_GHC -Wno-unused-type-patterns #-} {-# HLINT ignore "Avoid restricted extensions" #-} {-# HLINT ignore "Avoid restricted flags" #-} @@ -16,7 +17,7 @@ data IdentKind | IdentInd Symbol | IdentConstr Tag -data InfoTableBuilder' t e m a where +data InfoTableBuilder' (t :: GHCType) (e :: GHCType) :: Effect where FreshSymbol' :: InfoTableBuilder' t e m Symbol FreshTag' :: InfoTableBuilder' t e m Tag RegisterFunction' :: FunctionInfo' t e -> InfoTableBuilder' t e m () @@ -67,10 +68,12 @@ runInfoTableBuilderWithInfoTable tab = fmap (first (^. stateInfoTable)) . runInf runInfoTableBuilder :: Sem (InfoTableBuilder' t e ': r) b -> Sem r (InfoTable' t e, b) runInfoTableBuilder = fmap (first (^. stateInfoTable)) . runInfoTableBuilder' emptyBuilderState -runInfoTableBuilder' :: forall t e b r. BuilderState' t e -> Sem (InfoTableBuilder' t e ': r) b -> Sem r (BuilderState' t e, b) -runInfoTableBuilder' bs = - runState bs - . reinterpret interp +runInfoTableBuilder' :: + forall t e b r. + BuilderState' t e -> + Sem (InfoTableBuilder' t e ': r) b -> + Sem r (BuilderState' t e, b) +runInfoTableBuilder' bs = reinterpret (runState bs) interp where interp :: forall m b'. InfoTableBuilder' t e m b' -> Sem (State (BuilderState' t e) ': r) b' interp = \case diff --git a/src/Juvix/Compiler/Tree/EvaluatorEff.hs b/src/Juvix/Compiler/Tree/EvaluatorEff.hs index de9d3237d0..03a25519b7 100644 --- a/src/Juvix/Compiler/Tree/EvaluatorEff.hs +++ b/src/Juvix/Compiler/Tree/EvaluatorEff.hs @@ -7,11 +7,10 @@ import Juvix.Compiler.Tree.Error import Juvix.Compiler.Tree.Evaluator (EvalError (..), toTreeError, valueToNode) import Juvix.Compiler.Tree.Evaluator.Builtins import Juvix.Compiler.Tree.Extra.Base -import Juvix.Compiler.Tree.Language hiding (Output, ask, asks, mapError, output, runError) +import Juvix.Compiler.Tree.Language hiding (Error, Members, Output, Reader, Sem, ask, asks, local, mapError, output, runError, runReader) import Juvix.Compiler.Tree.Language.Value import Juvix.Compiler.Tree.Pretty -import Juvix.Prelude.Effects (Eff, IOE, runEff, (:>)) -import Juvix.Prelude.Effects qualified as E +import Juvix.Prelude.BaseEffectful data EvalCtx = EvalCtx { _evalCtxArgs :: [Value], @@ -27,10 +26,10 @@ emptyEvalCtx = _evalCtxTemp = mempty } -eval :: (E.Output Value :> r, E.Error EvalError :> r) => InfoTable -> Node -> Eff r Value -eval tab = E.runReader emptyEvalCtx . eval' +eval :: (Members '[Output Value, Error EvalError] r) => InfoTable -> Node -> Sem r Value +eval tab = runReader emptyEvalCtx . eval' where - eval' :: forall r'. (E.Output Value :> r', E.Reader EvalCtx :> r', E.Error EvalError :> r') => Node -> Eff r' Value + eval' :: forall r'. (Members '[Output Value, Reader EvalCtx, Error EvalError] r') => Node -> Sem r' Value eval' node = case node of Binop x -> goBinop x Unop x -> goUnop x @@ -45,16 +44,16 @@ eval tab = E.runReader emptyEvalCtx . eval' Case x -> goCase x Save x -> goSave x where - evalError :: Text -> Eff r' a + evalError :: Text -> Sem r' a evalError msg = Exception.throw (EvalError (getNodeLocation node) msg) - eitherToError :: Either Text Value -> Eff r' Value + eitherToError :: Either Text Value -> Sem r' Value eitherToError = \case Left err -> evalError err Right v -> return v - goBinop :: NodeBinop -> Eff r' Value + goBinop :: NodeBinop -> Sem r' Value goBinop NodeBinop {..} = do arg1 <- eval' _nodeBinopArg1 arg2 <- eval' _nodeBinopArg2 @@ -62,7 +61,7 @@ eval tab = E.runReader emptyEvalCtx . eval' PrimBinop op -> eitherToError $ evalBinop op arg1 arg2 OpSeq -> return arg2 - goUnop :: NodeUnop -> Eff r' Value + goUnop :: NodeUnop -> Sem r' Value goUnop NodeUnop {..} = do v <- eval' _nodeUnopArg case _nodeUnopOpcode of @@ -70,41 +69,41 @@ eval tab = E.runReader emptyEvalCtx . eval' OpTrace -> goTrace v OpFail -> goFail v - goFail :: Value -> Eff r' Value + goFail :: Value -> Sem r' Value goFail v = evalError ("failure: " <> printValue tab v) - goTrace :: Value -> Eff r' Value - goTrace v = E.output v $> v + goTrace :: Value -> Sem r' Value + goTrace v = output v $> v goConstant :: NodeConstant -> Value goConstant NodeConstant {..} = constantToValue _nodeConstant - askTemp :: Eff r' (BL.BinderList Value) - askTemp = E.asks (^. evalCtxTemp) + askTemp :: Sem r' (BL.BinderList Value) + askTemp = asks (^. evalCtxTemp) - askArgs :: Eff r' [Value] - askArgs = E.asks (^. evalCtxArgs) + askArgs :: Sem r' [Value] + askArgs = asks (^. evalCtxArgs) - goMemRef :: NodeMemRef -> Eff r' Value + goMemRef :: NodeMemRef -> Sem r' Value goMemRef NodeMemRef {..} = case _nodeMemRef of DRef r -> goDirectRef r ConstrRef r -> goField r - goDirectRef :: DirectRef -> Eff r' Value + goDirectRef :: DirectRef -> Sem r' Value goDirectRef = \case ArgRef OffsetRef {..} -> (!! _offsetRefOffset) <$> askArgs TempRef RefTemp {_refTempOffsetRef = OffsetRef {..}} -> BL.lookupLevel _offsetRefOffset <$> askTemp - goField :: Field -> Eff r' Value + goField :: Field -> Sem r' Value goField Field {..} = do d <- goDirectRef _fieldRef case d of ValConstr Constr {..} -> return (_constrArgs !! _fieldOffset) _ -> evalError "expected a constructor" - goAllocConstr :: NodeAllocConstr -> Eff r' Value + goAllocConstr :: NodeAllocConstr -> Sem r' Value goAllocConstr NodeAllocConstr {..} = do vs <- mapM eval' _nodeAllocConstrArgs return @@ -115,7 +114,7 @@ eval tab = E.runReader emptyEvalCtx . eval' } ) - goAllocClosure :: NodeAllocClosure -> Eff r' Value + goAllocClosure :: NodeAllocClosure -> Sem r' Value goAllocClosure NodeAllocClosure {..} = do vs <- mapM eval' _nodeAllocClosureArgs return @@ -126,7 +125,7 @@ eval tab = E.runReader emptyEvalCtx . eval' } ) - goExtendClosure :: NodeExtendClosure -> Eff r' Value + goExtendClosure :: NodeExtendClosure -> Sem r' Value goExtendClosure NodeExtendClosure {..} = do fun <- eval' _nodeExtendClosureFun case fun of @@ -141,15 +140,15 @@ eval tab = E.runReader emptyEvalCtx . eval' ) _ -> evalError "expected a closure" - goCall :: NodeCall -> Eff r' Value + goCall :: NodeCall -> Sem r' Value goCall NodeCall {..} = case _nodeCallType of CallFun sym -> doCall sym [] _nodeCallArgs CallClosure cl -> doCallClosure cl _nodeCallArgs - withCtx :: EvalCtx -> Eff r' a -> Eff r' a - withCtx = E.local . const + withCtx :: EvalCtx -> Sem r' a -> Sem r' a + withCtx = local . const - doCall :: Symbol -> [Value] -> [Node] -> Eff r' Value + doCall :: Symbol -> [Value] -> [Node] -> Sem r' Value doCall sym clArgs as = do vs <- mapM eval' as let fi = lookupFunInfo tab sym @@ -165,7 +164,7 @@ eval tab = E.runReader emptyEvalCtx . eval' | otherwise -> evalError "wrong number of arguments" - doCallClosure :: Node -> [Node] -> Eff r' Value + doCallClosure :: Node -> [Node] -> Sem r' Value doCallClosure cl cargs = do cl' <- eval' cl case cl' of @@ -174,13 +173,13 @@ eval tab = E.runReader emptyEvalCtx . eval' _ -> evalError "expected a closure" - goCallClosures :: NodeCallClosures -> Eff r' Value + goCallClosures :: NodeCallClosures -> Sem r' Value goCallClosures NodeCallClosures {..} = do vs <- mapM eval' (toList _nodeCallClosuresArgs) cl' <- eval' _nodeCallClosuresFun go cl' vs where - go :: Value -> [Value] -> Eff r' Value + go :: Value -> [Value] -> Sem r' Value go cl vs = case cl of ValClosure Closure {..} | argsNum == n -> do @@ -216,7 +215,7 @@ eval tab = E.runReader emptyEvalCtx . eval' _ -> evalError "expected a closure" - goBranch :: NodeBranch -> Eff r' Value + goBranch :: NodeBranch -> Sem r' Value goBranch NodeBranch {..} = do arg' <- eval' _nodeBranchArg br <- case arg' of @@ -225,7 +224,7 @@ eval tab = E.runReader emptyEvalCtx . eval' _ -> evalError "expected a boolean" eval' br - goCase :: NodeCase -> Eff r' Value + goCase :: NodeCase -> Sem r' Value goCase NodeCase {..} = do arg' <- eval' _nodeCaseArg case arg' of @@ -238,27 +237,21 @@ eval tab = E.runReader emptyEvalCtx . eval' _ -> evalError "expected a constructor" - withExtendedTemp :: Value -> Eff r' a -> Eff r' a + withExtendedTemp :: Value -> Sem r' a -> Sem r' a withExtendedTemp v m = do - ctx <- E.ask + ctx <- ask withCtx (over evalCtxTemp (BL.cons v) ctx) m - goCaseBranch :: Value -> Bool -> Node -> Eff r' Value + goCaseBranch :: Value -> Bool -> Node -> Sem r' Value goCaseBranch v bSave body | bSave = withExtendedTemp v (eval' body) | otherwise = eval' body - goSave :: NodeSave -> Eff r' Value + goSave :: NodeSave -> Sem r' Value goSave NodeSave {..} = do v <- eval' _nodeSaveArg withExtendedTemp v (eval' _nodeSaveBody) -runError :: Eff (E.Error err ': r) x -> Eff r (Either err x) -runError = fmap (mapLeft snd) . E.runError - -mapError :: (E.Error b :> r) => (a -> b) -> Eff (E.Error a ': r) x -> Eff r x -mapError f = E.runErrorWith (\_ e -> E.throwError (f e)) - hEvalIOEither :: forall m. (MonadIO m) => @@ -268,7 +261,7 @@ hEvalIOEither :: FunctionInfo -> m (Either TreeError Value) hEvalIOEither hin hout infoTable funInfo = do - let x :: Eff '[E.Output Value, E.Error EvalError, E.Error TreeError, IOE] Value + let x :: Sem '[Output Value, Error EvalError, Error TreeError, IOE] Value x = do v <- eval infoTable (funInfo ^. functionCode) hRunIO hin hout infoTable v @@ -278,11 +271,11 @@ hEvalIOEither hin hout infoTable funInfo = do . runEff . runError @TreeError . mapError toTreeError - . E.runOutputEff handleTrace + . runOutputSem handleTrace $ x -- | Interpret IO actions. -hRunIO :: forall r. (IOE :> r, E.Error EvalError :> r, E.Output Value :> r) => Handle -> Handle -> InfoTable -> Value -> Eff r Value +hRunIO :: forall r. (Members '[IOE, Error EvalError, Output Value] r) => Handle -> Handle -> InfoTable -> Value -> Sem r Value hRunIO hin hout infoTable = \case ValConstr (Constr (BuiltinTag TagReturn) [x]) -> return x ValConstr (Constr (BuiltinTag TagBind) [x, f]) -> do diff --git a/src/Juvix/Compiler/Tree/EvaluatorSem.hs b/src/Juvix/Compiler/Tree/EvaluatorSem.hs deleted file mode 100644 index 3b4e0c172b..0000000000 --- a/src/Juvix/Compiler/Tree/EvaluatorSem.hs +++ /dev/null @@ -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 diff --git a/src/Juvix/Compiler/Tree/Translation/FromAsm/Translator.hs b/src/Juvix/Compiler/Tree/Translation/FromAsm/Translator.hs index 44fb5fcb4a..f64b10b813 100644 --- a/src/Juvix/Compiler/Tree/Translation/FromAsm/Translator.hs +++ b/src/Juvix/Compiler/Tree/Translation/FromAsm/Translator.hs @@ -4,7 +4,7 @@ import Juvix.Compiler.Asm.Extra.Base (getCommandLocation) import Juvix.Compiler.Asm.Language import Juvix.Compiler.Tree.Error -data Translator m a where +data Translator :: Effect where NextCommand :: Translator m Command HasNextCommand :: Translator m Bool @@ -22,7 +22,7 @@ runTranslator cs = runTranslator' (TranslatorState cs Nothing) runTranslator' :: forall r a. (Member (Error TreeError) r) => TranslatorState -> Sem (Translator ': r) a -> Sem r a runTranslator' st m = do - (st', a) <- runState st $ reinterpret interp m + (st', a) <- reinterpret (runState st) interp m unless (null (st' ^. stateCode)) $ throw TreeError diff --git a/src/Juvix/Data/Effect.hs b/src/Juvix/Data/Effect.hs index e0dcf1673e..3849b086cd 100644 --- a/src/Juvix/Data/Effect.hs +++ b/src/Juvix/Data/Effect.hs @@ -14,5 +14,5 @@ import Juvix.Data.Effect.Fail import Juvix.Data.Effect.Files import Juvix.Data.Effect.Internet import Juvix.Data.Effect.Log -import Juvix.Data.Effect.NameIdGen hiding (toState) +import Juvix.Data.Effect.NameIdGen import Juvix.Data.Effect.Visit diff --git a/src/Juvix/Data/Effect/Cache.hs b/src/Juvix/Data/Effect/Cache.hs index efb3b7c4ea..1982aeb358 100644 --- a/src/Juvix/Data/Effect/Cache.hs +++ b/src/Juvix/Data/Effect/Cache.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-unused-type-patterns #-} + module Juvix.Data.Effect.Cache ( runCache, evalCache, @@ -14,24 +16,24 @@ where import Juvix.Prelude.Base -data Cache k v m a where +data Cache (k :: GHCType) (v :: GHCType) :: Effect where CacheGet :: k -> Cache k v m v CacheLookup :: k -> Cache k v m (Maybe v) +makeSem ''Cache + -- | Singleton cache type SCache = Cache () -makeSem ''Cache - -- | Run a 'Cache' effect purely. runCache :: + forall k v r a. (Hashable k) => (k -> Sem (Cache k v ': r) v) -> HashMap k v -> Sem (Cache k v ': r) a -> Sem r (HashMap k v, a) runCache f c = runState c . re f -{-# INLINE runCache #-} evalCache :: (Hashable k) => @@ -74,14 +76,15 @@ re :: (k -> Sem (Cache k v ': r) v) -> Sem (Cache k v ': r) a -> Sem (State (HashMap k v) ': r) a -re f = reinterpret $ \case - CacheLookup k -> gets @(HashMap k v) (^. at k) - CacheGet k -> do - mv <- gets @(HashMap k v) (^. at k) - case mv of - Nothing -> do - x <- re f (f k) - modify' @(HashMap k v) (set (at k) (Just x)) - return x - Just v -> return v -{-# INLINE re #-} +re f = + interpretTop $ + \case + CacheLookup k -> gets @(HashMap k v) (^. at k) + CacheGet k -> do + mv <- gets @(HashMap k v) (^. at k) + case mv of + Nothing -> do + x <- re f (f k) + modify' @(HashMap k v) (set (at k) (Just x)) + return x + Just v -> return v diff --git a/src/Juvix/Data/Effect/ExactPrint/Base.hs b/src/Juvix/Data/Effect/ExactPrint/Base.hs index 66e1990bd5..f441e6f43e 100644 --- a/src/Juvix/Data/Effect/ExactPrint/Base.hs +++ b/src/Juvix/Data/Effect/ExactPrint/Base.hs @@ -11,17 +11,6 @@ import Juvix.Data.Loc import Juvix.Prelude.Base import Prettyprinter qualified as P -data ExactPrint m a where - NoLoc :: Doc Ann -> ExactPrint m () - -- | Used to print parentheses after comments. - Enqueue :: Doc Ann -> ExactPrint m () - PrintCommentsUntil :: Interval -> ExactPrint m (Maybe SpaceSpan) - EnsureEmptyLine :: ExactPrint m () - Region :: (Doc Ann -> Doc Ann) -> m b -> ExactPrint m b - End :: ExactPrint m () - -makeSem ''ExactPrint - data Builder = Builder { -- | comments sorted by starting location _builderComments :: [SpaceSpan], @@ -32,45 +21,69 @@ data Builder = Builder _builderEnd :: FileLoc } +data ExactPrint :: Effect where + NoLoc :: Doc Ann -> ExactPrint m () + -- | Used to print parentheses after comments. + Enqueue :: Doc Ann -> ExactPrint m () + PrintCommentsUntil :: Interval -> ExactPrint m (Maybe SpaceSpan) + EnsureEmptyLine :: ExactPrint m () + Region :: (Doc Ann -> Doc Ann) -> m b -> ExactPrint m b + End :: ExactPrint m () + +makeSem ''ExactPrint + makeLenses ''Builder -runExactPrint :: Maybe FileComments -> Sem (ExactPrint ': r) x -> Sem r (Doc Ann, x) -runExactPrint cs = fmap (first (^. builderDoc)) . runState ini . re - where - ini :: Builder - ini = - Builder - { _builderComments = fromMaybe [] (cs ^? _Just . fileCommentsSorted), - _builderDoc = mempty, - _builderQueue = mempty, - _builderEnsureEmptyLine = False, - _builderEnd = FileLoc 0 0 0 - } +initialBuilder :: Maybe FileComments -> Builder +initialBuilder cs = + Builder + { _builderComments = fromMaybe [] (cs ^? _Just . fileCommentsSorted), + _builderDoc = mempty, + _builderQueue = mempty, + _builderEnsureEmptyLine = False, + _builderEnd = FileLoc 0 0 0 + } execExactPrint :: Maybe FileComments -> Sem (ExactPrint ': r) x -> Sem r (Doc Ann) execExactPrint cs = fmap fst . runExactPrint cs -re :: forall r a. Sem (ExactPrint ': r) a -> Sem (State Builder ': r) a -re = reinterpretH h +runExactPrint :: forall r a. Maybe FileComments -> Sem (ExactPrint ': r) a -> Sem r (Doc Ann, a) +runExactPrint cs = reinterpretH (runPrivateStateAsDoc (initialBuilder cs)) handler where - h :: - forall rInitial x. - ExactPrint (Sem rInitial) x -> - Tactical ExactPrint (Sem rInitial) (State Builder ': r) x - h = \case - NoLoc p -> noLoc' p >>= pureT - EnsureEmptyLine -> modify' (set builderEnsureEmptyLine True) >>= pureT - End -> end' >>= pureT - Enqueue d -> enqueue' d >>= pureT - PrintCommentsUntil l -> printCommentsUntil' l >>= pureT - Region f m -> do + runPrivateStateAsDoc :: + forall b. + Builder -> + Sem (State Builder ': r) b -> + Sem r (Doc Ann, b) + runPrivateStateAsDoc b = fmap (first (^. builderDoc)) . runState b + + handler :: + forall x (r' :: [Effect]) (localEs :: [Effect]). + (Member ExactPrint localEs) => + LocalEnv localEs (State Builder ': r') -> + ExactPrint (Sem localEs) x -> + Sem (State Builder ': r') x + handler locEnv = \case + NoLoc p -> noLoc' p + EnsureEmptyLine -> modify' (set builderEnsureEmptyLine True) + End -> end' + Enqueue d -> enqueue' d + PrintCommentsUntil l -> printCommentsUntil' l + Region regionModif (m :: Sem localEs x) -> do st0 :: Builder <- set builderDoc mempty <$> get - m' <- runT m - (st' :: Builder, fx) <- raise (evalExactPrint' st0 m') + let runner :: Sem (State Builder ': localEs) x -> Sem localEs (Builder, x) + runner = runState st0 + + helper :: (forall w. Sem localEs w -> Sem r' w) -> Sem r' (Builder, x) + helper unlift = unlift (impose runner handler m) + + inner :: Sem r' (Builder, x) + inner = localSeqUnliftCommon locEnv helper + (st' :: Builder, fx) <- raise inner doc' <- gets (^. builderDoc) put Builder - { _builderDoc = doc' <> f (st' ^. builderDoc), + { _builderDoc = doc' <> regionModif (st' ^. builderDoc), _builderComments = st' ^. builderComments, _builderEnd = st' ^. builderEnd, _builderQueue = st' ^. builderQueue, @@ -78,9 +91,6 @@ re = reinterpretH h } return fx -evalExactPrint' :: Builder -> Sem (ExactPrint ': r) a -> Sem r (Builder, a) -evalExactPrint' b = runState b . re - enqueue' :: forall r. (Members '[State Builder] r) => Doc Ann -> Sem r () enqueue' d = modify (over builderQueue (d :)) diff --git a/src/Juvix/Data/Effect/Fail.hs b/src/Juvix/Data/Effect/Fail.hs index 78374fb779..ecd07a7e49 100644 --- a/src/Juvix/Data/Effect/Fail.hs +++ b/src/Juvix/Data/Effect/Fail.hs @@ -4,7 +4,8 @@ module Juvix.Data.Effect.Fail where import Control.Exception qualified as X import Juvix.Prelude.Base -data Fail m a = Fail +data Fail :: Effect where + Fail :: Fail m a makeSem ''Fail @@ -12,7 +13,7 @@ makeSem ''Fail runFail :: Sem (Fail ': r) a -> Sem r (Maybe a) -runFail = fmap (^? _Right) . runError @() . reinterpret (\Fail -> throw ()) +runFail = fmap (^? _Right) . reinterpret (runError @()) (\Fail -> throw ()) {-# INLINE runFail #-} -- | Run a 'Fail' effect purely with a default value. @@ -28,11 +29,7 @@ runFailDefaultM :: Sem r a -> Sem (Fail ': r) a -> Sem r a -runFailDefaultM defaultVal s = do - x <- runError @() (reinterpret (\Fail -> throw ()) s) - case x of - Left {} -> defaultVal - Right y -> return y +runFailDefaultM defaultVal s = fromMaybeM defaultVal (runFail s) {-# INLINE runFailDefaultM #-} ignoreFail :: @@ -68,7 +65,7 @@ failFromException :: IO a -> Sem r a failFromException m = do - r <- embed (X.try @X.SomeException m) + r <- liftIO (X.try @X.SomeException m) case r of Left {} -> fail Right a -> return a diff --git a/src/Juvix/Data/Effect/FileLock/Base.hs b/src/Juvix/Data/Effect/FileLock/Base.hs index c8f669e662..295b36f56d 100644 --- a/src/Juvix/Data/Effect/FileLock/Base.hs +++ b/src/Juvix/Data/Effect/FileLock/Base.hs @@ -4,7 +4,7 @@ import Juvix.Prelude.Base import Juvix.Prelude.Path -- | An effect for wrapping an action in file lock -data FileLock m a where +data FileLock :: Effect where WithFileLock' :: Path Abs File -> m a -> FileLock m a makeSem ''FileLock diff --git a/src/Juvix/Data/Effect/FileLock/IO.hs b/src/Juvix/Data/Effect/FileLock/IO.hs index 4cd272b032..8818ef4622 100644 --- a/src/Juvix/Data/Effect/FileLock/IO.hs +++ b/src/Juvix/Data/Effect/FileLock/IO.hs @@ -6,6 +6,6 @@ import Juvix.Prelude.Path import System.FileLock hiding (FileLock) -- | Interpret `FileLock` using `System.FileLock` -runFileLockIO :: (Members '[Resource, EmbedIO] r) => Sem (FileLock ': r) a -> Sem r a -runFileLockIO = interpretH $ \case - WithFileLock' p ma -> bracket (embed $ lockFile (toFilePath p) Exclusive) (embed . unlockFile) (const (runTSimple ma)) +runFileLockIO :: (Members '[EmbedIO] r) => Sem (FileLock ': r) a -> Sem r a +runFileLockIO = interpretH $ \locEnv -> \case + WithFileLock' p ma -> bracket (liftIO (lockFile (toFilePath p) Exclusive)) (liftIO . unlockFile) (const (runTSimpleEff locEnv ma)) diff --git a/src/Juvix/Data/Effect/FileLock/Permissive.hs b/src/Juvix/Data/Effect/FileLock/Permissive.hs index fdad56123f..ebc3959a65 100644 --- a/src/Juvix/Data/Effect/FileLock/Permissive.hs +++ b/src/Juvix/Data/Effect/FileLock/Permissive.hs @@ -4,6 +4,13 @@ import Juvix.Data.Effect.FileLock.Base import Juvix.Prelude.Base -- | Interpret `FileLock` by executing all actions unconditionally -runFileLockPermissive :: Sem (FileLock ': r) a -> Sem r a -runFileLockPermissive = interpretH $ \case - WithFileLock' _ ma -> runTSimple ma +runFileLockPermissive :: forall r a. Sem (FileLock ': r) a -> Sem r a +runFileLockPermissive = interpretH handler + where + handler :: + forall x (localEs :: [Effect]). + LocalEnv localEs r -> + FileLock (Sem localEs) x -> + Sem r x + handler locEnv = \case + WithFileLock' _ ma -> runTSimpleEff locEnv ma diff --git a/src/Juvix/Data/Effect/Files.hs b/src/Juvix/Data/Effect/Files.hs index 07a682dd35..c6a55670a9 100644 --- a/src/Juvix/Data/Effect/Files.hs +++ b/src/Juvix/Data/Effect/Files.hs @@ -91,7 +91,7 @@ relFiles root = walkDirRelAccum handler root mempty mkRel cd f = fromJust (stripProperPrefix root (cd f)) -- | Restore the original contents of a file if an error occurs in an action. -restoreFileOnError :: forall r a. (Members '[Resource, Files, TempFile] r) => Path Abs File -> Sem r a -> Sem r a +restoreFileOnError :: forall r a. (Members '[EmbedIO, Files, TempFile] r) => Path Abs File -> Sem r a -> Sem r a restoreFileOnError p action = do t <- tempFilePath finally (restoreOnErrorAction t) (removeTempFile t) diff --git a/src/Juvix/Data/Effect/Files/Base.hs b/src/Juvix/Data/Effect/Files/Base.hs index 5f2d22a414..706c2a2ce9 100644 --- a/src/Juvix/Data/Effect/Files/Base.hs +++ b/src/Juvix/Data/Effect/Files/Base.hs @@ -21,13 +21,13 @@ data Recurse r makeLenses ''RecursorArgs -data TempFile m a where +data TempFile :: Effect where TempFilePath :: TempFile m (Path Abs File) RemoveTempFile :: Path Abs File -> TempFile m () makeSem ''TempFile -data Files m a where +data Files :: Effect where EnsureDir' :: Path Abs Dir -> Files m () DirectoryExists' :: Path Abs Dir -> Files m Bool FileExists' :: Path Abs File -> Files m Bool diff --git a/src/Juvix/Data/Effect/Files/IO.hs b/src/Juvix/Data/Effect/Files/IO.hs index 517a5014cf..f644906670 100644 --- a/src/Juvix/Data/Effect/Files/IO.hs +++ b/src/Juvix/Data/Effect/Files/IO.hs @@ -26,7 +26,7 @@ runFilesIO :: runFilesIO = interpret helper where helper :: forall rInitial x. Files (Sem rInitial) x -> Sem r x - helper = embed . helper' + helper = liftIO . helper' helper' :: forall rInitial x. Files (Sem rInitial) x -> IO x helper' = \case @@ -62,8 +62,8 @@ runTempFileIO :: Sem (TempFile ': r) a -> Sem r a runTempFileIO = interpret $ \case - TempFilePath -> embed (emptySystemTempFile "tmp" >>= parseAbsFile) - RemoveTempFile p -> embed (ignoringIOErrors (Path.removeFile p)) + TempFilePath -> liftIO (emptySystemTempFile "tmp" >>= parseAbsFile) + RemoveTempFile p -> liftIO (ignoringIOErrors (Path.removeFile p)) where ignoringIOErrors :: IO () -> IO () ignoringIOErrors ioe = MC.catch ioe (\(_ :: IOError) -> return ()) diff --git a/src/Juvix/Data/Effect/Files/Pure.hs b/src/Juvix/Data/Effect/Files/Pure.hs index 2007e116ba..d02276700c 100644 --- a/src/Juvix/Data/Effect/Files/Pure.hs +++ b/src/Juvix/Data/Effect/Files/Pure.hs @@ -67,7 +67,7 @@ runFilesPure :: HashMap (Path Abs File) Text -> Path Abs Dir -> Sem (Files ': r) runFilesPure ini cwd a = evalState (mkFS ini) (re cwd a) re :: Path Abs Dir -> Sem (Files ': r) a -> Sem (State FS ': r) a -re cwd = reinterpret $ \case +re cwd = interpretTop $ \case ReadFile' f -> lookupFile' f FileExists' f -> isJust <$> lookupFile f PathUid p -> return (Uid (toFilePath p)) diff --git a/src/Juvix/Data/Effect/Git/Base.hs b/src/Juvix/Data/Effect/Git/Base.hs index c7696468d4..3da959fbe7 100644 --- a/src/Juvix/Data/Effect/Git/Base.hs +++ b/src/Juvix/Data/Effect/Git/Base.hs @@ -19,23 +19,30 @@ data GitError = NotAClone | NoSuchRef GitRef -data Git m a where +data Git :: Effect where Fetch :: (GitError -> m ()) -> Git m () Checkout :: (GitError -> m ()) -> GitRef -> Git m () NormalizeRef :: (GitError -> m GitRef) -> GitRef -> Git m GitRef makeSem ''Git -type GitClone = Scoped CloneArgs Git +type GitClone = Provider_ Git CloneArgs headRef :: (Member Git r) => (GitError -> Sem r GitRef) -> Sem r GitRef headRef h = normalizeRef h "HEAD" -- | If an action fails because a ref does not exist in the clone, first do a fetch and then retry. -fetchOnNoSuchRefAndRetry :: forall r a. (Member Git r) => (GitError -> Sem r a) -> ((GitError -> Sem r a) -> Sem r a) -> Sem r a +fetchOnNoSuchRefAndRetry :: + forall r a. + (Member Git r) => + (GitError -> Sem r a) -> + ((GitError -> Sem r a) -> Sem r a) -> + Sem r a fetchOnNoSuchRefAndRetry handler action = action retryHandler where retryHandler :: GitError -> Sem r a retryHandler = \case - NoSuchRef _ -> fetch (void . handler) >> action handler + NoSuchRef _ -> do + fetch (void . handler) + action handler e -> handler e diff --git a/src/Juvix/Data/Effect/Git/Process.hs b/src/Juvix/Data/Effect/Git/Process.hs index 8993fbf3c6..209339385a 100644 --- a/src/Juvix/Data/Effect/Git/Process.hs +++ b/src/Juvix/Data/Effect/Git/Process.hs @@ -6,7 +6,6 @@ import Juvix.Data.Effect.Git.Process.Error import Juvix.Data.Effect.Process import Juvix.Data.Effect.TaggedLock import Juvix.Prelude -import Polysemy.Opaque newtype CloneEnv = CloneEnv {_cloneEnvDir :: Path Abs Dir} @@ -88,14 +87,22 @@ initGitRepo url = do withTaggedLockDir' (unlessM (directoryExists' p) (cloneGitRepo url)) return p -handleNotACloneError :: (Member (Error GitProcessError) r, Monad m) => (GitError -> m x) -> Tactical e m r x -> Tactical e m r x -handleNotACloneError errorHandler eff = catch @GitProcessError eff $ \case - GitCmdError GitCmdErrorDetails {_gitCmdErrorDetailsExitCode = ExitFailure 128} -> runTSimple (return NotAClone) >>= bindTSimple errorHandler +handleNotACloneError :: (Member (Error GitProcessError) r) => LocalEnv localEs r -> (GitError -> Sem localEs x) -> Sem r x -> Sem r x +handleNotACloneError localEnv errorHandler eff = catch @GitProcessError eff $ \case + GitCmdError + GitCmdErrorDetails + { _gitCmdErrorDetailsExitCode = ExitFailure 128 + } -> + runTSimpleEff localEnv (errorHandler NotAClone) e -> throw e -handleNormalizeRefError :: (Member (Error GitProcessError) r, Monad m) => (GitError -> m x) -> GitRef -> Tactical e m r x -> Tactical e m r x -handleNormalizeRefError errorHandler ref eff = catch @GitProcessError eff $ \case - GitCmdError GitCmdErrorDetails {_gitCmdErrorDetailsExitCode = ExitFailure 128} -> runTSimple (return (NoSuchRef ref)) >>= bindTSimple errorHandler +handleNormalizeRefError :: (Member (Error GitProcessError) r) => LocalEnv localEs r -> (GitError -> Sem localEs x) -> GitRef -> Sem r x -> Sem r x +handleNormalizeRefError localEnv errorHandler ref eff = catch @GitProcessError eff $ \case + GitCmdError + GitCmdErrorDetails + { _gitCmdErrorDetailsExitCode = ExitFailure 128 + } -> + runTSimpleEff localEnv (errorHandler (NoSuchRef ref)) e -> throw e withTaggedLockDir' :: (Members '[TaggedLock, Reader CloneEnv] r) => Sem r a -> Sem r a @@ -106,22 +113,19 @@ withTaggedLockDir' ma = do runGitProcess :: forall r a. (Members '[TaggedLock, Log, Files, Process, Error GitProcessError, Internet] r) => - Sem (Scoped CloneArgs Git ': r) a -> + Sem (GitClone ': r) a -> Sem r a -runGitProcess = interpretScopedH allocator handler +runGitProcess = runProvider_ helper where - allocator :: forall q x. CloneArgs -> (Path Abs Dir -> Sem (Opaque q ': r) x) -> Sem (Opaque q ': r) x - allocator a use' = do - let env = CloneEnv {_cloneEnvDir = a ^. cloneArgsCloneDir} - use' =<< runReader env (initGitRepo (a ^. cloneArgsRepoUrl)) - - handler :: forall q r0 x. Path Abs Dir -> Git (Sem r0) x -> Tactical Git (Sem r0) (Opaque q ': r) x - handler p eff = case eff of - Fetch errorHandler -> handleNotACloneError errorHandler (runReader env gitFetch >>= pureT) - Checkout errorHandler ref -> do - void (handleNormalizeRefError errorHandler ref (runReader env (void (gitNormalizeRef ref)) >>= pureT)) - handleNotACloneError errorHandler (runReader env (gitCheckout ref) >>= pureT) - NormalizeRef errorHandler ref -> handleNormalizeRefError errorHandler ref (runReader env (gitNormalizeRef ref) >>= pureT) - where - env :: CloneEnv - env = CloneEnv {_cloneEnvDir = p} + helper :: forall x. CloneArgs -> Sem (Git ': r) x -> Sem r x + helper cloneArgs m = do + let env0 = CloneEnv {_cloneEnvDir = cloneArgs ^. cloneArgsCloneDir} + clonePath <- runReader env0 (initGitRepo (cloneArgs ^. cloneArgsRepoUrl)) + let env :: CloneEnv + env = CloneEnv {_cloneEnvDir = clonePath} + (`interpretH` m) $ \localEnv -> \case + Fetch errorHandler -> handleNotACloneError localEnv errorHandler (runReader env gitFetch) + NormalizeRef errorHandler ref -> handleNormalizeRefError localEnv errorHandler ref (runReader env (gitNormalizeRef ref)) + Checkout errorHandler ref -> do + void (handleNormalizeRefError localEnv errorHandler ref (runReader env (void (gitNormalizeRef ref)))) + handleNotACloneError localEnv errorHandler (runReader env (gitCheckout ref)) diff --git a/src/Juvix/Data/Effect/Internet.hs b/src/Juvix/Data/Effect/Internet.hs index 4cef7bface..be0e117dfa 100644 --- a/src/Juvix/Data/Effect/Internet.hs +++ b/src/Juvix/Data/Effect/Internet.hs @@ -18,7 +18,7 @@ data InternetWitness = InternetWitness type Online = Reader InternetWitness -data Internet m a where +data Internet :: Effect where -- | Returns `Nothing` if we are offline GetInternet :: Internet m (Maybe InternetWitness) diff --git a/src/Juvix/Data/Effect/Log.hs b/src/Juvix/Data/Effect/Log.hs index 914904b354..d24fb140e5 100644 --- a/src/Juvix/Data/Effect/Log.hs +++ b/src/Juvix/Data/Effect/Log.hs @@ -1,24 +1,24 @@ module Juvix.Data.Effect.Log where -import Data.Text.IO qualified as Text import Juvix.Prelude.Base -data Log m a where +data Log :: Effect where Log :: Text -> Log m () makeSem ''Log runLogIO :: (Member EmbedIO r) => - InterpreterFor Log r + Sem (Log ': r) a -> + Sem r a runLogIO sem = do - embed (hSetBuffering stdout LineBuffering) + liftIO (hSetBuffering stdout LineBuffering) interpret ( \case - Log txt -> embed (Text.hPutStrLn stdout txt) + Log txt -> hPutStrLn stdout txt ) sem -ignoreLog :: InterpreterFor Log r +ignoreLog :: Sem (Log ': r) a -> Sem r a ignoreLog = interpret $ \case Log _ -> return () diff --git a/src/Juvix/Data/Effect/NameIdGen.hs b/src/Juvix/Data/Effect/NameIdGen.hs index 8d0c05ae57..4a19514cfb 100644 --- a/src/Juvix/Data/Effect/NameIdGen.hs +++ b/src/Juvix/Data/Effect/NameIdGen.hs @@ -21,20 +21,18 @@ genNameIdState mid = NameIdGenState mid ids aux :: Word64 -> Stream Word64 aux i = Cons i (aux (succ i)) -data NameIdGen m a where +data NameIdGen :: Effect where FreshNameId :: NameIdGen m NameId makeSem ''NameIdGen -toState :: Sem (NameIdGen ': r) a -> Sem (State NameIdGenState ': r) a -toState = reinterpret $ \case - FreshNameId -> do - NameIdGenState mid (Cons fresh rest) <- get - put (NameIdGenState mid rest) - return (NameId fresh mid) - runNameIdGen :: NameIdGenState -> Sem (NameIdGen ': r) a -> Sem r (NameIdGenState, a) -runNameIdGen s = runState s . toState +runNameIdGen s = + reinterpret (runState s) $ \case + FreshNameId -> do + NameIdGenState mid (Cons fresh rest) <- get + put (NameIdGenState mid rest) + return (NameId fresh mid) runTopNameIdGen :: ModuleId -> Sem (NameIdGen ': r) a -> Sem r (NameIdGenState, a) runTopNameIdGen mid = runNameIdGen (genNameIdState mid) diff --git a/src/Juvix/Data/Effect/Process/Base.hs b/src/Juvix/Data/Effect/Process/Base.hs index c2077ad28c..f22f37063b 100644 --- a/src/Juvix/Data/Effect/Process/Base.hs +++ b/src/Juvix/Data/Effect/Process/Base.hs @@ -13,7 +13,7 @@ data ProcessCall = ProcessCall _processCallArgs :: [Text] } -data Process m a where +data Process :: Effect where FindExecutable' :: Path Rel File -> Process m (Maybe (Path Abs File)) ReadProcess' :: ProcessCall -> Process m ProcessResult diff --git a/src/Juvix/Data/Effect/TaggedLock.hs b/src/Juvix/Data/Effect/TaggedLock.hs index ece6185c37..b2bce9c91d 100644 --- a/src/Juvix/Data/Effect/TaggedLock.hs +++ b/src/Juvix/Data/Effect/TaggedLock.hs @@ -19,9 +19,7 @@ import Juvix.Prelude.Path -- Example: -- -- @ --- runFinal --- . resourceToIOFinal --- . embedToFinal @IO +-- runM -- . runFilesIO -- . runTaggedLockIO -- $ withTaggedLockDir $(mkAbsDir "/a/b/c") (embed (putStrLn "Hello" >> hFlush stdout)) @@ -36,7 +34,7 @@ data LockMode = LockModePermissive | LockModeExclusive -runTaggedLock :: (Members '[Resource, EmbedIO] r) => LockMode -> Sem (TaggedLock ': r) a -> Sem r a +runTaggedLock :: (Members '[EmbedIO] r) => LockMode -> Sem (TaggedLock ': r) a -> Sem r a runTaggedLock = \case LockModePermissive -> runTaggedLockPermissive LockModeExclusive -> runTaggedLockIO diff --git a/src/Juvix/Data/Effect/TaggedLock/Base.hs b/src/Juvix/Data/Effect/TaggedLock/Base.hs index 74180407cb..55eb11aa42 100644 --- a/src/Juvix/Data/Effect/TaggedLock/Base.hs +++ b/src/Juvix/Data/Effect/TaggedLock/Base.hs @@ -7,7 +7,7 @@ import Juvix.Prelude.Path -- path. -- -- The relative path does not need to exist in the filesystem. -data TaggedLock m a where +data TaggedLock :: Effect where WithTaggedLock :: Path Rel File -> m a -> TaggedLock m a makeSem ''TaggedLock diff --git a/src/Juvix/Data/Effect/TaggedLock/IO.hs b/src/Juvix/Data/Effect/TaggedLock/IO.hs index 0a8176d32e..bfb11ccfd8 100644 --- a/src/Juvix/Data/Effect/TaggedLock/IO.hs +++ b/src/Juvix/Data/Effect/TaggedLock/IO.hs @@ -10,14 +10,14 @@ import Juvix.Prelude.Path -- -- When multiple processes or threads call `withTaggedLock` with the same tag, -- then only one of them can perform the action at a time. -runTaggedLockIO :: forall r a. (Members '[Resource, EmbedIO] r) => Sem (TaggedLock ': r) a -> Sem r a +runTaggedLockIO :: forall r a. (Members '[EmbedIO] r) => Sem (TaggedLock ': r) a -> Sem r a runTaggedLockIO sem = do rootLockPath <- ( $(mkRelDir "juvix-file-locks")) <$> getTempDir runFileLockIO (runFilesIO (go rootLockPath sem)) where go :: Path Abs Dir -> Sem (TaggedLock ': r) a -> Sem (Files ': FileLock ': r) a - go r = reinterpret2H $ \case + go r = interpretTop2H $ \locEnv -> \case WithTaggedLock t ma -> do p <- normalizeFile (r t) ensureDir' (parent p) - withFileLock' p (runTSimple ma) + withFileLock' p (runTSimpleEff locEnv ma) diff --git a/src/Juvix/Data/Effect/TaggedLock/Permissive.hs b/src/Juvix/Data/Effect/TaggedLock/Permissive.hs index 108eab67a1..eccb1a9498 100644 --- a/src/Juvix/Data/Effect/TaggedLock/Permissive.hs +++ b/src/Juvix/Data/Effect/TaggedLock/Permissive.hs @@ -4,5 +4,5 @@ import Juvix.Data.Effect.TaggedLock.Base import Juvix.Prelude.Base runTaggedLockPermissive :: Sem (TaggedLock ': r) a -> Sem r a -runTaggedLockPermissive = interpretH $ \case - WithTaggedLock _ ma -> runTSimple ma +runTaggedLockPermissive = interpretH $ \locEnv -> \case + WithTaggedLock _ ma -> runTSimpleEff locEnv ma diff --git a/src/Juvix/Data/Effect/Visit.hs b/src/Juvix/Data/Effect/Visit.hs index fe7ed79700..cf921622a9 100644 --- a/src/Juvix/Data/Effect/Visit.hs +++ b/src/Juvix/Data/Effect/Visit.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-unused-type-patterns #-} + -- | Visit every key at most once module Juvix.Data.Effect.Visit ( runVisit, @@ -12,7 +14,7 @@ where import Data.HashSet qualified as HashSet import Juvix.Prelude.Base -data Visit k m a where +data Visit (k :: GHCType) :: Effect where Visit :: k -> Visit k m () makeSem ''Visit @@ -58,7 +60,7 @@ re :: (k -> Sem (Visit k ': r) ()) -> Sem (Visit k ': r) a -> Sem (State (HashSet k) ': r) a -re vis = reinterpret $ \case +re vis = interpretTop $ \case Visit k -> unlessM (HashSet.member k <$> get @(HashSet k)) $ do modify' (HashSet.insert k) diff --git a/src/Juvix/Data/Error/GenericError.hs b/src/Juvix/Data/Error/GenericError.hs index ec39f52807..d643118a33 100644 --- a/src/Juvix/Data/Error/GenericError.hs +++ b/src/Juvix/Data/Error/GenericError.hs @@ -82,16 +82,16 @@ renderAnsiText :: (ToGenericError e, Member (Reader GenericOptions) r) => e -> S renderAnsiText = render True False printErrorAnsi :: (ToGenericError e, Members '[EmbedIO, Reader GenericOptions] r) => e -> Sem r () -printErrorAnsi e = renderAnsiText e >>= \txt -> embed (hPutStrLn stderr txt) +printErrorAnsi e = renderAnsiText e >>= \txt -> hPutStrLn stderr txt -- | Print the error to stderr without formatting. printErrorText :: (ToGenericError e, Members '[EmbedIO, Reader GenericOptions] r) => e -> Sem r () -printErrorText e = renderText e >>= \txt -> embed (hPutStrLn stderr txt) +printErrorText e = renderText e >>= \txt -> hPutStrLn stderr txt printErrorAnsiSafe :: (ToGenericError e, Members '[EmbedIO, Reader GenericOptions] r) => e -> Sem r () printErrorAnsiSafe e = ifM - (embed (Ansi.hSupportsANSIColor stderr)) + (liftIO (Ansi.hSupportsANSIColor stderr)) (printErrorAnsi e) (printErrorText e) @@ -101,7 +101,7 @@ runErrorIO :: Sem r b runErrorIO = runError >=> \case - Left err -> printErrorAnsiSafe err >> embed exitFailure + Left err -> printErrorAnsiSafe err >> exitFailure Right a -> return a runErrorIO' :: diff --git a/src/Juvix/Formatter.hs b/src/Juvix/Formatter.hs index 721a5f80f6..680059af96 100644 --- a/src/Juvix/Formatter.hs +++ b/src/Juvix/Formatter.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-unused-type-patterns #-} + module Juvix.Formatter where import Juvix.Compiler.Concrete.Language @@ -14,7 +16,7 @@ data FormattedFileInfo = FormattedFileInfo _formattedFileInfoContentsModified :: Bool } -data ScopeEff m a where +data ScopeEff :: Effect where ScopeFile :: Path Abs File -> ScopeEff m Scoper.ScoperResult ScopeStdin :: EntryPoint -> ScopeEff m Scoper.ScoperResult diff --git a/src/Juvix/Prelude.hs b/src/Juvix/Prelude.hs index 2ce7f2a97c..27593976a7 100644 --- a/src/Juvix/Prelude.hs +++ b/src/Juvix/Prelude.hs @@ -5,7 +5,6 @@ module Juvix.Prelude module Juvix.Prelude.Trace, module Juvix.Prelude.Path, module Juvix.Prelude.Prepath, - module Juvix.Prelude.Tagged, module Juvix.Data, ) where @@ -16,5 +15,4 @@ import Juvix.Prelude.Lens import Juvix.Prelude.Path import Juvix.Prelude.Prepath import Juvix.Prelude.Stream -import Juvix.Prelude.Tagged import Juvix.Prelude.Trace diff --git a/src/Juvix/Prelude/Base.hs b/src/Juvix/Prelude/Base.hs index 5357f22b27..fd6fbe733c 100644 --- a/src/Juvix/Prelude/Base.hs +++ b/src/Juvix/Prelude/Base.hs @@ -1,8 +1,8 @@ module Juvix.Prelude.Base ( module Juvix.Prelude.Base.Foundation, - module Juvix.Prelude.Base.Polysemy, + module Juvix.Prelude.Effects, ) where import Juvix.Prelude.Base.Foundation -import Juvix.Prelude.Base.Polysemy +import Juvix.Prelude.Effects diff --git a/src/Juvix/Prelude/Base/Foundation.hs b/src/Juvix/Prelude/Base/Foundation.hs index 1969f99634..831acc99ad 100644 --- a/src/Juvix/Prelude/Base/Foundation.hs +++ b/src/Juvix/Prelude/Base/Foundation.hs @@ -72,7 +72,7 @@ module Juvix.Prelude.Base.Foundation where import Control.Applicative -import Control.Monad.Catch (MonadMask, MonadThrow, throwM) +import Control.Monad.Catch (ExitCase (..), MonadMask, MonadThrow, generalBracket, throwM) import Control.Monad.Extra hiding (fail, forM, mconcatMapM, whileJustM) import Control.Monad.Extra qualified as Monad import Control.Monad.Fix @@ -100,6 +100,7 @@ import Data.Int import Data.IntMap.Strict (IntMap) import Data.IntMap.Strict qualified as IntMap import Data.IntSet (IntSet) +import Data.Kind qualified as GHC import Data.List.Extra hiding (allSame, foldr1, groupSortOn, head, last, mconcatMap, replicate, unzip) import Data.List.Extra qualified as List import Data.List.NonEmpty qualified as NonEmpty @@ -183,6 +184,10 @@ import Text.Show qualified as Show import Text.Show.Unicode (urecover, ushow) import Prelude (Double) +type GHCType = GHC.Type + +type GHCConstraint = GHC.Constraint + traverseM :: (Monad m, Traversable m, Applicative f) => (a1 -> f (m a2)) -> @@ -467,6 +472,9 @@ optional_ = void . optional -- Misc -------------------------------------------------------------------------------- +eassert :: (Applicative f) => Bool -> f () +eassert b = assert b (pure ()) + -- | applies a function n times iterateN :: Int -> (a -> a) -> a -> a iterateN n f = (!! n) . iterate f diff --git a/src/Juvix/Prelude/Effects.hs b/src/Juvix/Prelude/Effects.hs index 67cff4a905..f50b4a09ed 100644 --- a/src/Juvix/Prelude/Effects.hs +++ b/src/Juvix/Prelude/Effects.hs @@ -2,9 +2,13 @@ module Juvix.Prelude.Effects ( module Juvix.Prelude.Effects.Output, module Juvix.Prelude.Effects.Base, module Juvix.Prelude.Effects.Accum, + module Juvix.Prelude.Effects.Input, + module Juvix.Prelude.Effects.Bracket, ) where import Juvix.Prelude.Effects.Accum import Juvix.Prelude.Effects.Base +import Juvix.Prelude.Effects.Bracket +import Juvix.Prelude.Effects.Input import Juvix.Prelude.Effects.Output diff --git a/src/Juvix/Prelude/Effects/Accum.hs b/src/Juvix/Prelude/Effects/Accum.hs index 00b27e30cd..7ceda3aca9 100644 --- a/src/Juvix/Prelude/Effects/Accum.hs +++ b/src/Juvix/Prelude/Effects/Accum.hs @@ -1,10 +1,16 @@ -module Juvix.Prelude.Effects.Accum where +module Juvix.Prelude.Effects.Accum + ( Accum, + runAccumList, + execAccumList, + ignoreAccum, + accum, + ) +where -import Data.Kind qualified as GHC import Juvix.Prelude.Base.Foundation import Juvix.Prelude.Effects.Base -data Accum (o :: GHC.Type) :: Effect +data Accum (o :: GHCType) :: Effect type instance DispatchOf (Accum _) = 'Static 'NoSideEffects @@ -12,16 +18,16 @@ newtype instance StaticRep (Accum o) = Accum { _unAccum :: [o] } -runAccumList :: Eff (Accum o ': r) a -> Eff r ([o], a) +accum :: (Member (Accum o) r) => o -> Sem r () +accum o = overStaticRep (\(Accum l) -> Accum (o : l)) + +runAccumList :: Sem (Accum o ': r) a -> Sem r ([o], a) runAccumList m = do (a, Accum s) <- runStaticRep (Accum mempty) m return (reverse s, a) -execAccumList :: Eff (Accum o ': r) a -> Eff r [o] +execAccumList :: Sem (Accum o ': r) a -> Sem r [o] execAccumList = fmap fst . runAccumList -ignoreAccum :: Eff (Accum o ': r) a -> Eff r a +ignoreAccum :: Sem (Accum o ': r) a -> Sem r a ignoreAccum m = snd <$> runAccumList m - -accum :: (Accum o :> r) => o -> Eff r () -accum o = overStaticRep (\(Accum l) -> Accum (o : l)) diff --git a/src/Juvix/Prelude/Effects/Base.hs b/src/Juvix/Prelude/Effects/Base.hs index 2b746ddb6f..a34c113f7d 100644 --- a/src/Juvix/Prelude/Effects/Base.hs +++ b/src/Juvix/Prelude/Effects/Base.hs @@ -4,21 +4,242 @@ module Juvix.Prelude.Effects.Base module Effectful.Reader.Static, module Effectful.State.Static.Local, module Effectful.Error.Static, + module Effectful.Dispatch.Dynamic, module Effectful.TH, module Effectful.Dispatch.Static, + module Effectful.Provider, ) where -import Effectful +import Data.Kind qualified as GHC +import Effectful hiding (Eff, (:>)) +import Effectful qualified as E +import Effectful.Dispatch.Dynamic (LocalEnv, SharedSuffix, impose, interpose, localLift, localLiftUnlift, localLiftUnliftIO, localSeqLift, localSeqUnlift, localSeqUnliftIO, localUnlift, localUnliftIO, withLiftMap, withLiftMapIO) +import Effectful.Dispatch.Dynamic qualified as E import Effectful.Dispatch.Static -import Effectful.Error.Static +import Effectful.Error.Static hiding (runError) import Effectful.Internal.Env (getEnv, putEnv) +import Effectful.Provider import Effectful.Reader.Static -import Effectful.State.Static.Local +import Effectful.State.Static.Local hiding (runState, state) +import Effectful.State.Static.Local qualified as State import Effectful.TH import Juvix.Prelude.Base.Foundation +import Language.Haskell.TH.Syntax qualified as GHC -overStaticRep :: (DispatchOf e ~ 'Static sideEffects, e :> r) => (StaticRep e -> StaticRep e) -> Eff r () -overStaticRep f = unsafeEff $ \r -> do - e' <- f <$> getEnv r - putEnv r e' +type Sem = E.Eff + +type EmbedIO = IOE + +type Member (e :: Effect) (r :: [Effect]) = e E.:> r + +-- | First order effect handler +type EffectHandlerFO (e :: Effect) (r :: [Effect]) = + forall a localEs. + (HasCallStack, Member e localEs) => + e (Sem localEs) a -> + Sem r a + +-- | Type signature of the effect handler. +type EffectHandler e es = + forall a localEs. + (HasCallStack, Member e localEs) => + -- | Capture of the local environment for handling local 'Eff' computations + -- when @e@ is a higher order effect. + LocalEnv localEs es -> + -- | The effect performed in the local environment. + e (Sem localEs) a -> + Sem es a + +type Members :: [Effect] -> [Effect] -> GHC.Constraint +type family Members es r where + Members '[] _ = () + Members (e ': es) r = (Member e r, Members es r) + +makeSem :: GHC.Name -> Q [GHC.Dec] +makeSem = makeEffect + +overStaticRep :: + forall e r sideEffects. + ( DispatchOf e ~ 'Static sideEffects, + Member e r + ) => + (StaticRep e -> StaticRep e) -> + Sem r () +overStaticRep f = unsafeEff $ \r -> f <$> getEnv r >>= putEnv r + +mapReader :: + (Member (Reader e1) r) => (e1 -> e2) -> Sem (Reader e2 ': r) a -> Sem r a +mapReader f s = do + e <- ask + runReader (f e) s + +runState :: forall s r a. s -> Sem (State s ': r) a -> Sem r (s, a) +runState s = fmap swap . State.runState s + +-- | TODO can we make it strict? +modify' :: (Member (State s) r) => (s -> s) -> Sem r () +modify' = State.modify + +mapError :: (Member (Error b) r) => (a -> b) -> Sem (Error a ': r) x -> Sem r x +mapError f = runErrorWith (\_ e -> throwError (f e)) + +runM :: (MonadIO m) => Sem '[EmbedIO] a -> m a +runM = liftIO . E.runEff + +run :: Sem ('[] :: [Effect]) a -> a +run = E.runPureEff + +throw :: (Member (Error err) r) => err -> Sem r a +throw = throwError + +runError :: Sem (Error err ': r) x -> Sem r (Either err x) +runError = runErrorNoCallStack + +catch :: + forall e r a. + (Member (Error e) r) => + Sem r a -> + (e -> Sem r a) -> + Sem r a +catch m handler = catchError m (const handler) + +raiseUnder :: forall (e1 :: Effect) (e2 :: Effect) (r :: [Effect]) a. Sem (e1 ': r) a -> Sem (e1 ': e2 ': r) a +raiseUnder = inject + +interpretTop3H :: + forall (e1 :: Effect) (e2 :: Effect) (e3 :: Effect) (e4 :: Effect) (r :: [Effect]) a. + (DispatchOf e1 ~ 'Dynamic) => + EffectHandler e1 (e4 ': e3 ': e2 ': r) -> + Sem (e1 ': r) a -> + Sem (e4 ': e3 ': e2 ': r) a +interpretTop3H i = E.interpret i . inject + +interpretTop2H :: + forall (e1 :: Effect) (e2 :: Effect) (e3 :: Effect) (r :: [Effect]) a. + (DispatchOf e1 ~ 'Dynamic) => + EffectHandler e1 (e3 ': e2 ': r) -> + Sem (e1 ': r) a -> + Sem (e3 ': e2 ': r) a +interpretTop2H i = E.interpret i . inject + +interpretTopH :: + forall (e1 :: Effect) (e2 :: Effect) (r :: [Effect]) a. + (DispatchOf e1 ~ 'Dynamic) => + EffectHandler e1 (e2 ': r) -> + Sem (e1 ': r) a -> + Sem (e2 ': r) a +interpretTopH i = E.interpret i . raiseUnder + +interpretTop3 :: + forall (e1 :: Effect) (e2 :: Effect) (e3 :: Effect) (e4 :: Effect) (r :: [Effect]) a. + (DispatchOf e1 ~ 'Dynamic) => + EffectHandlerFO e1 (e4 ': e3 ': e2 ': r) -> + Sem (e1 ': r) a -> + Sem (e4 ': e3 ': e2 ': r) a +interpretTop3 i = interpretTop3H (const i) + +interpretTop :: + forall (e1 :: Effect) (e2 :: Effect) (r :: [Effect]) a. + (DispatchOf e1 ~ 'Dynamic) => + EffectHandlerFO e1 (e2 ': r) -> + Sem (e1 ': r) a -> + Sem (e2 ': r) a +interpretTop i = interpretTopH (const i) + +interpret :: + forall (e1 :: Effect) (r :: [Effect]) a. + (DispatchOf e1 ~ 'Dynamic) => + EffectHandlerFO e1 r -> + Sem (e1 ': r) a -> + Sem r a +interpret i = E.interpret (const i) + +interpretH :: + forall (e1 :: Effect) (r :: [Effect]) a. + (DispatchOf e1 ~ 'Dynamic) => + EffectHandler e1 r -> + Sem (e1 ': r) a -> + Sem r a +interpretH = E.interpret + +-- | Type signature of the effect handler. +-- type EffectHandler e es +-- = forall a localEs. (HasCallStack, Member e localEs) +-- => LocalEnv localEs es +-- -- ^ Capture of the local environment for handling local 'Eff' computations +-- -- when @e@ is a higher order effect. +-- -> e (Sem localEs) a +-- -- ^ The effect performed in the local environment. +-- -> Sem es a +reinterpretHCommon2 :: + (DispatchOf e ~ 'Dynamic) => + (Sem (e2 ': e1 ': r) a -> Sem r b) -> + EffectHandler e (e2 ': e1 ': r) -> + Sem (e ': r) a -> + Sem r b +reinterpretHCommon2 = E.reinterpret + +reinterpretH :: + (DispatchOf e ~ 'Dynamic) => + (Sem handlerEs a -> Sem r b) -> + EffectHandler e handlerEs -> + Sem (e ': r) a -> + Sem r b +reinterpretH = E.reinterpret + +reinterpret :: + (DispatchOf e ~ 'Dynamic) => + (Sem handlerEs a -> Sem r b) -> + EffectHandlerFO e handlerEs -> + Sem (e ': r) a -> + Sem r b +reinterpret re i = reinterpretH re (const i) + +-- TODO maybe think of a better name +runTSimpleEff :: + forall (handlerEs :: [Effect]) (localEs :: [Effect]) (r :: [Effect]) x. + (SharedSuffix r handlerEs) => + LocalEnv localEs handlerEs -> + Sem localEs x -> + Sem r x +runTSimpleEff locEnv ma = + let lifter :: (forall y. Sem localEs y -> Sem r y) -> Sem r x + lifter f = f ma + in localSeqUnlift locEnv lifter + +imposeCommon :: + forall e r e' a b. + (DispatchOf e ~ 'Dynamic, Member e r) => + -- | Introduction of effects encapsulated within the handler. + (Sem (e' ': r) a -> Sem r b) -> + -- | The effect handler. + EffectHandler e (e' ': r) -> + Sem r a -> + Sem r b +imposeCommon = impose + +imposeCommon2 :: + forall e r e2 e1 a b. + (DispatchOf e ~ 'Dynamic, Member e r) => + -- | Introduction of effects encapsulated within the handler. + (Sem (e2 ': e1 ': r) a -> Sem r b) -> + -- | The effect handler. + EffectHandler e (e2 ': e1 ': r) -> + Sem r a -> + Sem r b +imposeCommon2 = impose + +localSeqUnliftCommon :: + forall r' e1 localEs b. + LocalEnv localEs (e1 ': r') -> + ((forall y. Sem localEs y -> Sem r' y) -> Sem r' b) -> + Sem r' b +localSeqUnliftCommon = localSeqUnlift + +localSeqUnliftCommon2 :: + forall r' e2 e1 localEs b. + LocalEnv localEs (e2 ': e1 ': r') -> + ((forall y. Sem localEs y -> Sem r' y) -> Sem r' b) -> + Sem r' b +localSeqUnliftCommon2 = localSeqUnlift diff --git a/src/Juvix/Prelude/Effects/Bracket.hs b/src/Juvix/Prelude/Effects/Bracket.hs new file mode 100644 index 0000000000..31d1f1a3f6 --- /dev/null +++ b/src/Juvix/Prelude/Effects/Bracket.hs @@ -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) diff --git a/src/Juvix/Prelude/Effects/Bracket/Base.hs b/src/Juvix/Prelude/Effects/Bracket/Base.hs new file mode 100644 index 0000000000..df051d7521 --- /dev/null +++ b/src/Juvix/Prelude/Effects/Bracket/Base.hs @@ -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 diff --git a/src/Juvix/Prelude/Effects/Input.hs b/src/Juvix/Prelude/Effects/Input.hs new file mode 100644 index 0000000000..5f63aa475e --- /dev/null +++ b/src/Juvix/Prelude/Effects/Input.hs @@ -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 diff --git a/src/Juvix/Prelude/Effects/Output.hs b/src/Juvix/Prelude/Effects/Output.hs index 0758685b4d..eb0081f87b 100644 --- a/src/Juvix/Prelude/Effects/Output.hs +++ b/src/Juvix/Prelude/Effects/Output.hs @@ -2,29 +2,38 @@ module Juvix.Prelude.Effects.Output where -import Data.Kind qualified as GHC -import Effectful.Dispatch.Dynamic -import Juvix.Prelude.Base hiding (Effect, Output, State, interpret, modify, output, reinterpret, runOutputList, runState) +import Juvix.Prelude.Base.Foundation import Juvix.Prelude.Effects.Accum import Juvix.Prelude.Effects.Base -data Output (o :: GHC.Type) :: Effect where +data Output (o :: GHCType) :: Effect where Output :: o -> Output o m () makeEffect ''Output -runOutputEff :: (o -> Eff r ()) -> Eff (Output o ': r) a -> Eff r a -runOutputEff handle = - interpret $ \_ -> \case +runOutputFold :: o -> (o -> o -> o) -> Sem (Output o ': r) a -> Sem r (o, a) +runOutputFold ini f = + reinterpret (runState ini) $ \case + Output x -> modify (\acc -> f acc x) + +runOutputMonoidL :: (Monoid o) => Sem (Output o ': r) a -> Sem r (o, a) +runOutputMonoidL = runOutputFold mempty (\acc x -> x <> acc) + +runOutputMonoidR :: (Monoid o) => Sem (Output o ': r) a -> Sem r (o, a) +runOutputMonoidR = runOutputFold mempty (\acc x -> acc <> x) + +runOutputSem :: (o -> Sem r ()) -> Sem (Output o ': r) a -> Sem r a +runOutputSem handle = + interpret $ \case Output x -> handle x -runOutputList :: Eff (Output o ': r) a -> Eff r ([o], a) -runOutputList = reinterpret runAccumList $ \_ -> \case +runOutputList :: Sem (Output o ': r) a -> Sem r ([o], a) +runOutputList = reinterpret runAccumList $ \case Output x -> accum x -execOutputList :: Eff (Output o ': r) a -> Eff r [o] +execOutputList :: Sem (Output o ': r) a -> Sem r [o] execOutputList = fmap fst . runOutputList -ignoreOutput :: Eff (Output o ': r) a -> Eff r a -ignoreOutput = interpret $ \_ -> \case +ignoreOutput :: Sem (Output o ': r) a -> Sem r a +ignoreOutput = interpret $ \case Output {} -> return () diff --git a/src/Juvix/Prelude/Stream.hs b/src/Juvix/Prelude/Stream.hs index bea8ada198..34ea7b8162 100644 --- a/src/Juvix/Prelude/Stream.hs +++ b/src/Juvix/Prelude/Stream.hs @@ -1,7 +1,7 @@ module Juvix.Prelude.Stream where import Data.Stream qualified as Stream -import Juvix.Prelude.Base +import Juvix.Prelude.Base.Foundation allNaturals :: Stream Natural allNaturals = Stream.iterate succ 0 @@ -25,6 +25,3 @@ allFiniteSequences elems = build 0 [] seq <- ofLength (n - 1) e <- elems return (pure e <> seq) - -runInputNaturals :: Sem (Input Natural ': r) a -> Sem r a -runInputNaturals = runInputInfinite allNaturals diff --git a/src/Juvix/Prelude/Tagged.hs b/src/Juvix/Prelude/Tagged.hs deleted file mode 100644 index ba1f52adcd..0000000000 --- a/src/Juvix/Prelude/Tagged.hs +++ /dev/null @@ -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 diff --git a/stack.yaml b/stack.yaml index a9ced06748..9d142757d9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,8 +2,14 @@ ghc-options: "$locals": -optP-Wno-nonportable-include-path resolver: nightly-2024-02-06 extra-deps: + - resourcet-effectful-1.0.1.0 + - git: https://github.com/haskell-effectful/effectful.git + commit: 2037be9a4f4e8f8fd280d9359b1bc7feff9b29b9 + subdirs: + - effectful-th - git: https://github.com/Vekhir/aeson-better-errors.git commit: 1ec49ab7d1472046b680b5a64ae2930515b47714 allow-newer: true allow-newer-deps: - aeson-better-errors + - effectful-th diff --git a/test/Base.hs b/test/Base.hs index d15275c70f..ea0a0c61ff 100644 --- a/test/Base.hs +++ b/test/Base.hs @@ -81,10 +81,7 @@ assertCmdExists cmd = testTaggedLockedToIO :: (MonadIO m) => Sem PipelineAppEffects a -> m a testTaggedLockedToIO = - liftIO - . runFinal - . resourceToIOFinal - . embedToFinal @IO + runM . runTaggedLock LockModeExclusive testRunIO :: diff --git a/test/Package/Negative.hs b/test/Package/Negative.hs index ce3db58bef..07ca7fd898 100644 --- a/test/Package/Negative.hs +++ b/test/Package/Negative.hs @@ -25,9 +25,7 @@ testDescr NegTest {..} = _testAssertion = Single $ do res <- withTempDir' - ( runFinal - . resourceToIOFinal - . embedToFinal @IO + ( runM . runError . runFilesIO . mapError (JuvixError @PackageLoaderError) diff --git a/test/Package/Positive.hs b/test/Package/Positive.hs index f7a3d8bb28..91c68cce7f 100644 --- a/test/Package/Positive.hs +++ b/test/Package/Positive.hs @@ -29,9 +29,7 @@ testDescr root PosTest {..} = withTempDir' $ \d -> do let buildDir = CustomBuildDir (Abs d) res <- - runFinal - . resourceToIOFinal - . embedToFinal @IO + runM . runError @JuvixError . runFilesIO . mapError (JuvixError @PackageLoaderError) diff --git a/test/Reg/Run/Base.hs b/test/Reg/Run/Base.hs index 1b94755154..ab429fb5a2 100644 --- a/test/Reg/Run/Base.hs +++ b/test/Reg/Run/Base.hs @@ -93,7 +93,6 @@ doRun :: FunctionInfo -> IO (Either RegError Val) doRun hout tab funInfo = - runFinal - . embedToFinal @IO + runM . runError $ runFunctionIO stdin hout tab [] funInfo diff --git a/test/Repl/Positive.hs b/test/Repl/Positive.hs index 71efe23e3b..b0b09b92be 100644 --- a/test/Repl/Positive.hs +++ b/test/Repl/Positive.hs @@ -13,7 +13,7 @@ import Juvix.Extra.Stdlib import Repl.Assertions import Repl.Value -runTaggedLockIO' :: Sem '[Files, TaggedLock, Embed IO] a -> IO a +runTaggedLockIO' :: Sem '[Files, TaggedLock, EmbedIO] a -> IO a runTaggedLockIO' = runM . runTaggedLockPermissive