diff --git a/app/App.hs b/app/App.hs index 51683eac0..6674aaff8 100644 --- a/app/App.hs +++ b/app/App.hs @@ -62,7 +62,7 @@ reAppIO :: reAppIO args@RunAppIOArgs {..} = reinterpret $ \case AskPackageGlobal -> return (_runAppIOArgsRoot ^. rootPackageType `elem` [GlobalStdlib, GlobalPackageDescription, GlobalPackageBase]) - FromAppPathFile p -> embed (prepathToAbsFile invDir (p ^. pathPath)) + FromAppPathFile p -> prepathToAbsFile invDir (p ^. pathPath) GetMainFile m -> getMainFile' m FromAppPathDir p -> liftIO (prepathToAbsDir invDir (p ^. pathPath)) RenderStdOut t @@ -84,7 +84,7 @@ reAppIO args@RunAppIOArgs {..} = printErr e ExitJuvixError e -> do printErr e - embed exitFailure + exitFailure ExitMsg exitCode t -> exitMsg' (exitWith exitCode) t ExitFailMsg t -> exitMsg' exitFailure t SayRaw b -> embed (ByteString.putStr b) @@ -97,11 +97,11 @@ reAppIO args@RunAppIOArgs {..} = getMainFile' :: (Members '[SCache Package, EmbedIO] r') => Maybe (AppPath File) -> Sem r' (Path Abs File) getMainFile' = \case - Just p -> embed (prepathToAbsFile invDir (p ^. pathPath)) + Just p -> prepathToAbsFile invDir (p ^. pathPath) Nothing -> do pkg <- getPkg case pkg ^. packageMain of - Just p -> embed (prepathToAbsFile invDir p) + Just p -> prepathToAbsFile invDir p Nothing -> missingMainErr missingMainErr :: (Members '[EmbedIO] r') => Sem r' x @@ -116,7 +116,10 @@ reAppIO args@RunAppIOArgs {..} = g :: GlobalOptions g = _runAppIOArgsGlobalOptions printErr e = - embed $ hPutStrLn stderr $ run $ runReader (project' @GenericOptions g) $ Error.render (not (_runAppIOArgsGlobalOptions ^. globalNoColors)) (g ^. globalOnlyErrors) e + hPutStrLn stderr + . run + . runReader (project' @GenericOptions g) + $ Error.render (not (_runAppIOArgsGlobalOptions ^. globalNoColors)) (g ^. globalOnlyErrors) e getEntryPoint' :: (Members '[EmbedIO, TaggedLock] r) => RunAppIOArgs -> AppPath File -> Sem r EntryPoint getEntryPoint' RunAppIOArgs {..} inputFile = do diff --git a/app/Commands/Dev/Casm/Run.hs b/app/Commands/Dev/Casm/Run.hs index 3e56f25a7..4771ba536 100644 --- a/app/Commands/Dev/Casm/Run.hs +++ b/app/Commands/Dev/Casm/Run.hs @@ -15,7 +15,7 @@ runCommand opts = do Right (labi, code) -> case Casm.validate labi code of Left err -> exitJuvixError (JuvixError err) - Right () -> embed $ print (Casm.runCode labi code) + Right () -> print (Casm.runCode labi code) where file :: AppPath File file = opts ^. casmRunInputFile diff --git a/app/Commands/Dev/Core/Read.hs b/app/Commands/Dev/Core/Read.hs index 6dc57fa34..0aeaf90a5 100644 --- a/app/Commands/Dev/Core/Read.hs +++ b/app/Commands/Dev/Core/Read.hs @@ -27,7 +27,7 @@ runCommand opts = do let r = run $ runReader (project @GlobalOptions @Core.CoreOptions gopts) $ runError @JuvixError $ Core.applyTransformations (project opts ^. coreReadTransformations) (Core.moduleFromInfoTable tab) tab0 <- getRight $ mapLeft JuvixError r let tab' = Core.computeCombinedInfoTable $ if project opts ^. coreReadNoDisambiguate then tab0 else Core.disambiguateNames tab0 - embed (Scoper.scopeTrace tab') + Scoper.scopeTrace tab' unless (project opts ^. coreReadNoPrint) $ do renderStdOut (Pretty.ppOut opts tab') whenJust (tab' ^. Core.infoMain) $ \sym -> doEval gopts tab' (fromJust $ tab' ^. Core.identContext . at sym) diff --git a/app/Commands/Dev/Core/Repl.hs b/app/Commands/Dev/Core/Repl.hs index bcfea5de0..8e8a9087a 100644 --- a/app/Commands/Dev/Core/Repl.hs +++ b/app/Commands/Dev/Core/Repl.hs @@ -31,11 +31,11 @@ runRepl opts tab = do embed (hFlush stdout) done <- embed isEOF unless done $ do - s <- embed getLine + s <- getLine case fromText (strip s) of ":q" -> return () ":h" -> do - embed showReplHelp + showReplHelp runRepl opts tab ':' : 'p' : ' ' : s' -> case parseText tab (fromString s') of @@ -133,14 +133,14 @@ runRepl opts tab = do putStrLn "" runRepl opts tab' -showReplWelcome :: (Members '[EmbedIO, App] r) => Sem r () +showReplWelcome :: (MonadIO m) => m () showReplWelcome = do putStrLn "JuvixCore REPL" putStrLn "" putStrLn "Type \":h\" for help." putStrLn "" -showReplHelp :: IO () +showReplHelp :: (MonadIO m) => m () showReplHelp = do putStrLn "" putStrLn "JuvixCore REPL" diff --git a/app/Commands/Dev/Geb/Repl.hs b/app/Commands/Dev/Geb/Repl.hs index 983e0dd31..0fa669f9c 100644 --- a/app/Commands/Dev/Geb/Repl.hs +++ b/app/Commands/Dev/Geb/Repl.hs @@ -296,7 +296,7 @@ printError e = do . runReader (project' @GenericOptions opts) $ Error.render useAnsi False e ) - liftIO $ hPutStrLn stderr errorText + hPutStrLn stderr errorText printEvalResult :: Either JuvixError Geb.RunEvalResult -> Repl () printEvalResult = \case diff --git a/app/Commands/Extra/Compile.hs b/app/Commands/Extra/Compile.hs index d59b54fec..79822222b 100644 --- a/app/Commands/Extra/Compile.hs +++ b/app/Commands/Extra/Compile.hs @@ -242,9 +242,9 @@ findClangUsingEnvVar = do clangBinPath = fmap ( $(mkRelFile "bin/clang")) <$> llvmDistPath llvmDistPath :: Sem r (Maybe (Path Abs Dir)) - llvmDistPath = do - p <- embed (lookupEnv llvmDistEnvironmentVar) - embed (mapM parseAbsDir p) + llvmDistPath = liftIO $ do + p <- lookupEnv llvmDistEnvironmentVar + mapM parseAbsDir p data ClangPath = ClangSystemPath (Path Abs File) diff --git a/app/Commands/Format.hs b/app/Commands/Format.hs index ed499b0eb..2af3170a5 100644 --- a/app/Commands/Format.hs +++ b/app/Commands/Format.hs @@ -55,17 +55,14 @@ runCommand opts = do TargetStdin -> do entry <- getEntryPointStdin runReader entry formatStdin - - let exitFail :: IO a - exitFail = exitWith (ExitFailure 1) case res of - FormatResultFail -> embed exitFail + FormatResultFail -> exitFailure FormatResultNotFormatted -> {- use exit code 1 for * unformatted files when using --check * when running the formatter on a Juvix project -} - when (opts ^. formatCheck || isTargetProject target) (embed exitFail) + when (opts ^. formatCheck || isTargetProject target) exitFailure FormatResultOK -> pure () renderModeFromOptions :: FormatTarget -> FormatOptions -> FormattedFileInfo -> FormatRenderMode diff --git a/app/Commands/Init.hs b/app/Commands/Init.hs index 01520d883..08a9be4d1 100644 --- a/app/Commands/Init.hs +++ b/app/Commands/Init.hs @@ -57,7 +57,7 @@ checkNotInProject = err :: Sem r () err = do say "You are already in a Juvix project" - embed exitFailure + exitFailure checkPackage :: forall r. (Members '[EmbedIO] r) => Sem r () checkPackage = do @@ -66,7 +66,7 @@ checkPackage = do case ep of Left {} -> do say "Package.juvix is invalid. Please raise an issue at https://github.com/anoma/juvix/issues" - embed exitFailure + exitFailure Right {} -> return () getPackage :: forall r. (Members '[EmbedIO] r) => Sem r Package @@ -110,7 +110,7 @@ getProjName = do where go :: Sem r Text go = do - txt <- embed getLine + txt <- getLine if | Text.null txt, Just def' <- def -> return def' | otherwise -> @@ -137,7 +137,7 @@ tryAgain = say "Please, try again:" getVersion :: forall r. (Members '[EmbedIO] r) => Sem r SemVer getVersion = do - txt <- embed getLine + txt <- getLine if | Text.null txt -> return defaultVersion | otherwise -> case parse semver' txt of diff --git a/app/TopCommand.hs b/app/TopCommand.hs index 5a7f90261..d9a04ac06 100644 --- a/app/TopCommand.hs +++ b/app/TopCommand.hs @@ -17,19 +17,19 @@ import Juvix.Extra.Version import System.Environment (getProgName) import TopCommand.Options -showHelpText :: IO () +showHelpText :: (MonadIO m) => m () showHelpText = do let p = prefs showHelpOnEmpty - progn <- getProgName + progn <- liftIO getProgName let helpText = parserFailure p descr (ShowHelpText Nothing) [] (msg, _) = renderFailure helpText progn putStrLn (pack msg) runTopCommand :: forall r. (Members '[EmbedIO, App, Resource, TaggedLock] r) => TopCommand -> Sem r () runTopCommand = \case - DisplayVersion -> embed runDisplayVersion - DisplayNumericVersion -> embed runDisplayNumericVersion - DisplayHelp -> embed showHelpText + DisplayVersion -> runDisplayVersion + DisplayNumericVersion -> runDisplayNumericVersion + DisplayHelp -> showHelpText Doctor opts -> runLogIO (Doctor.runCommand opts) Init opts -> runLogIO (Init.init opts) Dev opts -> Dev.runCommand opts diff --git a/src/Juvix/Compiler/Asm/Interpreter/Runtime.hs b/src/Juvix/Compiler/Asm/Interpreter/Runtime.hs index 008a2b140..2c9e51152 100644 --- a/src/Juvix/Compiler/Asm/Interpreter/Runtime.hs +++ b/src/Juvix/Compiler/Asm/Interpreter/Runtime.hs @@ -116,7 +116,7 @@ runRuntime tab = runState (RuntimeState (CallStack []) emptyFrame [] Nothing tab hEvalRuntime :: forall r a. (Member EmbedIO r) => Handle -> InfoTable -> Sem (Runtime ': r) a -> Sem r a hEvalRuntime h tab r = do (s, a) <- runRuntime tab r - mapM_ (embed . hPutStrLn h) (reverse (s ^. runtimeMessages)) + mapM_ (hPutStrLn h) (reverse (s ^. runtimeMessages)) return a evalRuntime :: forall r a. (Member EmbedIO r) => InfoTable -> Sem (Runtime ': r) a -> Sem r a diff --git a/src/Juvix/Compiler/Casm/Translation/FromSource.hs b/src/Juvix/Compiler/Casm/Translation/FromSource.hs index 6a17bb91d..65aa3e3aa 100644 --- a/src/Juvix/Compiler/Casm/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Casm/Translation/FromSource.hs @@ -140,7 +140,7 @@ parseMemRef = do r <- register off <- parseOffset rbracket - return $ MemRef {_memRefReg = r, _memRefOff = off} + return MemRef {_memRefReg = r, _memRefOff = off} parseLabel :: (Member LabelInfoBuilder r) => ParsecS r LabelRef parseLabel = do diff --git a/src/Juvix/Compiler/Core/Scoper.hs b/src/Juvix/Compiler/Core/Scoper.hs index 17786ed49..9d03b586d 100644 --- a/src/Juvix/Compiler/Core/Scoper.hs +++ b/src/Juvix/Compiler/Core/Scoper.hs @@ -26,5 +26,5 @@ scopeErr msg = do throw @ScopeError ("Scope error in the definition of " <> show sym <> "\n" <> msg) -- | prints the scope error without exiting -scopeTrace :: InfoTable -> IO () +scopeTrace :: (MonadIO m) => InfoTable -> m () scopeTrace i = whenJust (scopeCheck i) putStrLn diff --git a/src/Juvix/Compiler/Nockma/Stdlib.hs b/src/Juvix/Compiler/Nockma/Stdlib.hs index a48f0087c..12a0a7458 100644 --- a/src/Juvix/Compiler/Nockma/Stdlib.hs +++ b/src/Juvix/Compiler/Nockma/Stdlib.hs @@ -1,7 +1,7 @@ module Juvix.Compiler.Nockma.Stdlib where import Juvix.Compiler.Nockma.Translation.FromSource.QQ -import Juvix.Prelude +import Juvix.Prelude.Base stdlib :: Term Natural stdlib = diff --git a/src/Juvix/Compiler/Nockma/StdlibFunction.hs b/src/Juvix/Compiler/Nockma/StdlibFunction.hs index 930a0d57d..f768bdb47 100644 --- a/src/Juvix/Compiler/Nockma/StdlibFunction.hs +++ b/src/Juvix/Compiler/Nockma/StdlibFunction.hs @@ -1,7 +1,7 @@ module Juvix.Compiler.Nockma.StdlibFunction where import Juvix.Compiler.Nockma.Translation.FromSource.QQ -import Juvix.Prelude hiding (Path) +import Juvix.Prelude.Base -- | The stdlib paths are obtained from the Urbit dojo -- * Load the stdlib file into the Urbit dojo diff --git a/src/Juvix/Compiler/Pipeline/Run.hs b/src/Juvix/Compiler/Pipeline/Run.hs index 02bd8205f..d71776b08 100644 --- a/src/Juvix/Compiler/Pipeline/Run.hs +++ b/src/Juvix/Compiler/Pipeline/Run.hs @@ -100,36 +100,40 @@ runIO opts entry = runIOEither entry >=> mayThrow where mayThrow :: (Members '[EmbedIO] r') => Either JuvixError x -> Sem r' x mayThrow = \case - Left err -> runReader opts $ printErrorAnsiSafe err >> embed exitFailure + Left err -> runReader opts $ printErrorAnsiSafe err >> exitFailure Right r -> return r -runReplPipelineIO :: EntryPoint -> IO Artifacts +runReplPipelineIO :: (MonadIO m) => EntryPoint -> m Artifacts runReplPipelineIO = runReplPipelineIO' defaultGenericOptions -runReplPipelineIO' :: GenericOptions -> EntryPoint -> IO Artifacts +runReplPipelineIO' :: forall m. (MonadIO m) => GenericOptions -> EntryPoint -> m Artifacts runReplPipelineIO' opts entry = runReplPipelineIOEither entry >>= mayThrow where - mayThrow :: Either JuvixError r -> IO r + mayThrow :: Either JuvixError r -> m r mayThrow = \case - Left err -> runM . runReader opts $ printErrorAnsiSafe err >> embed exitFailure + Left err -> liftIO . runM . runReader opts $ printErrorAnsiSafe err >> exitFailure Right r -> return r runReplPipelineIOEither :: + (MonadIO m) => EntryPoint -> - IO (Either JuvixError Artifacts) + m (Either JuvixError Artifacts) runReplPipelineIOEither = runReplPipelineIOEither' LockModePermissive runReplPipelineIOEither' :: + forall m. + (MonadIO m) => LockMode -> EntryPoint -> - IO (Either JuvixError Artifacts) + m (Either JuvixError Artifacts) runReplPipelineIOEither' lockMode entry = do let hasInternet = not (entry ^. entryPointOffline) runPathResolver' | mainIsPackageFile entry = runPackagePathResolverArtifacts (entry ^. entryPointResolverRoot) | otherwise = runPathResolverArtifacts eith <- - runFinal + liftIO + . runFinal . resourceToIOFinal . embedToFinal @IO . evalInternet hasInternet diff --git a/src/Juvix/Compiler/Reg/Interpreter.hs b/src/Juvix/Compiler/Reg/Interpreter.hs index 0e303e375..1263d8486 100644 --- a/src/Juvix/Compiler/Reg/Interpreter.hs +++ b/src/Juvix/Compiler/Reg/Interpreter.hs @@ -332,14 +332,14 @@ runIO hin hout infoTable = \case _regErrorLoc = Nothing } ValConstr (Constr (BuiltinTag TagWrite) [ValString s]) -> do - embed $ hPutStr hout s + hPutStr hout s return ValVoid ValConstr (Constr (BuiltinTag TagWrite) [arg]) -> do - embed $ hPutStr hout (ppPrint infoTable arg) + hPutStr hout (ppPrint infoTable arg) return ValVoid ValConstr (Constr (BuiltinTag TagReadLn) []) -> do - embed $ hFlush hout - s <- embed $ hGetLine hin + liftIO $ hFlush hout + s <- liftIO $ hGetLine hin return (ValString s) val -> return val diff --git a/src/Juvix/Compiler/Tree/Evaluator.hs b/src/Juvix/Compiler/Tree/Evaluator.hs index 952b6e337..e27e8d43a 100644 --- a/src/Juvix/Compiler/Tree/Evaluator.hs +++ b/src/Juvix/Compiler/Tree/Evaluator.hs @@ -257,10 +257,10 @@ hRunIO hin hout infoTable = \case !x'' = hEval hout infoTable code hRunIO hin hout infoTable x'' ValConstr (Constr (BuiltinTag TagWrite) [ValString s]) -> do - liftIO $ hPutStr hout s + hPutStr hout s return ValVoid ValConstr (Constr (BuiltinTag TagWrite) [arg]) -> do - liftIO $ hPutStr hout (ppPrint infoTable arg) + hPutStr hout (ppPrint infoTable arg) return ValVoid ValConstr (Constr (BuiltinTag TagReadLn) []) -> do liftIO $ hFlush hout diff --git a/src/Juvix/Compiler/Tree/EvaluatorEff.hs b/src/Juvix/Compiler/Tree/EvaluatorEff.hs index 6eb7a460d..22787e6bb 100644 --- a/src/Juvix/Compiler/Tree/EvaluatorEff.hs +++ b/src/Juvix/Compiler/Tree/EvaluatorEff.hs @@ -279,7 +279,7 @@ hEvalIOEither hin hout infoTable funInfo = do v <- eval infoTable (funInfo ^. functionCode) hRunIO hin hout infoTable v let handleTrace :: forall q. (MonadIO q) => Value -> q () - handleTrace = liftIO . hPutStrLn hout . printValue infoTable + handleTrace = hPutStrLn hout . printValue infoTable liftIO . runEff . runError @TreeError @@ -303,10 +303,10 @@ hRunIO hin hout infoTable = \case res <- eval infoTable code hRunIO hin hout infoTable res ValConstr (Constr (BuiltinTag TagWrite) [ValString s]) -> do - liftIO $ hPutStr hout s + hPutStr hout s return ValVoid ValConstr (Constr (BuiltinTag TagWrite) [arg]) -> do - liftIO $ hPutStr hout (ppPrint infoTable arg) + hPutStr hout (ppPrint infoTable arg) return ValVoid ValConstr (Constr (BuiltinTag TagReadLn) []) -> do liftIO $ hFlush hout diff --git a/src/Juvix/Extra/Version.hs b/src/Juvix/Extra/Version.hs index 9787a69cf..bb0330f4e 100644 --- a/src/Juvix/Extra/Version.hs +++ b/src/Juvix/Extra/Version.hs @@ -36,20 +36,20 @@ shortHash = projectOrUnknown (take 7 . giHash) versionTag :: Text versionTag = versionDoc <> "-" <> shortHash -progName :: IO Text -progName = pack . toUpperFirst <$> getProgName +progName :: (MonadIO m) => m Text +progName = pack . toUpperFirst <$> liftIO getProgName -progNameVersion :: IO Text +progNameVersion :: (MonadIO m) => m Text progNameVersion = do pName <- progName return (pName <> " version " <> versionDoc) -progNameVersionTag :: IO Text +progNameVersionTag :: (MonadIO m) => m Text progNameVersionTag = do progNameV <- progNameVersion return (progNameV <> "-" <> shortHash) -infoVersionRepo :: IO (Doc a) +infoVersionRepo :: (MonadIO m) => m (Doc a) infoVersionRepo = do pNameTag <- progNameVersionTag return @@ -69,10 +69,10 @@ infoVersionRepo = do <> line ) -runDisplayVersion :: IO () +runDisplayVersion :: (MonadIO m) => m () runDisplayVersion = do v <- layoutPretty defaultLayoutOptions <$> infoVersionRepo - renderIO stdout v + liftIO (renderIO stdout v) -runDisplayNumericVersion :: IO () +runDisplayNumericVersion :: (MonadIO m) => m () runDisplayNumericVersion = putStrLn versionDoc diff --git a/src/Juvix/Prelude/Base/Foundation.hs b/src/Juvix/Prelude/Base/Foundation.hs index 8bc320cc3..1969f9963 100644 --- a/src/Juvix/Prelude/Base/Foundation.hs +++ b/src/Juvix/Prelude/Base/Foundation.hs @@ -132,7 +132,7 @@ import Data.Text qualified as Text import Data.Text.Encoding import Data.Text.IO hiding (appendFile, getContents, getLine, hGetContents, hGetLine, hPutStr, hPutStrLn, interact, putStr, putStrLn, readFile, writeFile) import Data.Text.IO qualified as Text -import Data.Text.IO.Utf8 hiding (putStr, putStrLn, readFile, writeFile) +import Data.Text.IO.Utf8 hiding (getLine, hPutStr, hPutStrLn, putStr, putStrLn, readFile, writeFile) import Data.Text.IO.Utf8 qualified as Utf8 import Data.Traversable import Data.Tuple.Extra hiding (both) @@ -154,7 +154,8 @@ import Path.IO qualified as Path hiding (getCurrentDir, setCurrentDir, withCurre import Prettyprinter (Doc, (<+>)) import Safe.Exact import Safe.Foldable -import System.Exit +import System.Exit hiding (exitFailure, exitSuccess) +import System.Exit qualified as IO import System.FilePath (FilePath, dropTrailingPathSeparator, normalise, (<.>), ()) import System.IO hiding ( appendFile, @@ -167,12 +168,14 @@ import System.IO hiding interact, openBinaryTempFile, openTempFile, + print, putStr, putStrLn, readFile, readFile', writeFile, ) +import System.IO qualified as IO import System.IO.Error import Text.Read qualified as Text import Text.Show (Show) @@ -428,17 +431,35 @@ fromRightIO' :: (MonadIO m) => (e -> m ()) -> m (Either e r) -> m r fromRightIO' pp = do eitherM ifLeft return where - ifLeft e = pp e >> liftIO exitFailure + ifLeft e = pp e >> exitFailure fromRightIO :: (MonadIO m) => (e -> Text) -> m (Either e r) -> m r fromRightIO pp = fromRightIO' (putStrLn . pp) +exitSuccess :: (MonadIO m) => m x +exitSuccess = liftIO IO.exitSuccess + +exitFailure :: (MonadIO m) => m x +exitFailure = liftIO IO.exitFailure + +print :: (MonadIO m, Show a) => a -> m () +print = liftIO . IO.print + putStr :: (MonadIO m) => Text -> m () putStr = liftIO . Text.putStr putStrLn :: (MonadIO m) => Text -> m () putStrLn = liftIO . Text.putStrLn +getLine :: (MonadIO m) => m Text +getLine = liftIO Text.getLine + +hPutStr :: (MonadIO m) => Handle -> Text -> m () +hPutStr h = liftIO . Text.hPutStr h + +hPutStrLn :: (MonadIO m) => Handle -> Text -> m () +hPutStrLn h = liftIO . Text.hPutStrLn h + optional_ :: (Alternative m) => m a -> m () optional_ = void . optional diff --git a/src/Juvix/Prelude/Prepath.hs b/src/Juvix/Prelude/Prepath.hs index 774d14e3c..b3e0731e9 100644 --- a/src/Juvix/Prelude/Prepath.hs +++ b/src/Juvix/Prelude/Prepath.hs @@ -104,7 +104,7 @@ instance FromJSON (Prepath d) where instance Pretty (Prepath d) where pretty (Prepath p) = pretty p -prepathToAbsFile :: Path Abs Dir -> Prepath File -> IO (Path Abs File) +prepathToAbsFile :: (MonadIO m) => Path Abs Dir -> Prepath File -> m (Path Abs File) prepathToAbsFile root = fmap absFile . prepathToFilePath root prepathToAbsDir :: (MonadIO m) => Path Abs Dir -> Prepath Dir -> m (Path Abs Dir) @@ -115,10 +115,10 @@ prepathToFilePath root pre = do expandedPre <- expandPrepath pre liftIO (System.canonicalizePath (toFilePath root expandedPre)) -fromPreFileOrDir :: Path Abs Dir -> Prepath FileOrDir -> IO (Either (Path Abs File) (Path Abs Dir)) +fromPreFileOrDir :: (MonadIO m, MonadThrow m) => Path Abs Dir -> Prepath FileOrDir -> m (Either (Path Abs File) (Path Abs Dir)) fromPreFileOrDir cwd fp = do absPath <- prepathToFilePath cwd fp - isDirectory <- System.doesDirectoryExist absPath + isDirectory <- liftIO (System.doesDirectoryExist absPath) if | isDirectory -> Right <$> parseAbsDir absPath | otherwise -> Left <$> parseAbsFile absPath diff --git a/src/Juvix/Prelude/Pretty.hs b/src/Juvix/Prelude/Pretty.hs index 2d49538fc..6032c6bf7 100644 --- a/src/Juvix/Prelude/Pretty.hs +++ b/src/Juvix/Prelude/Pretty.hs @@ -109,13 +109,13 @@ instance Show AnsiText where instance Pretty AnsiText where pretty = pretty . ansiTextToText -renderIO :: (HasAnsiBackend a, HasTextBackend a) => Bool -> a -> IO () +renderIO :: (MonadIO m, HasAnsiBackend a, HasTextBackend a) => Bool -> a -> m () renderIO useColors = hRenderIO useColors stdout -hRenderIO :: (HasAnsiBackend a, HasTextBackend a) => Bool -> Handle -> a -> IO () +hRenderIO :: (MonadIO m, HasAnsiBackend a, HasTextBackend a) => Bool -> Handle -> a -> m () hRenderIO useColors h - | useColors = Ansi.renderIO h . toAnsiStream - | otherwise = Text.renderIO h . toTextStream + | useColors = liftIO . Ansi.renderIO h . toAnsiStream + | otherwise = liftIO . Text.renderIO h . toTextStream toAnsiText :: (HasAnsiBackend a, HasTextBackend a) => Bool -> a -> Text toAnsiText useColors diff --git a/test/Base.hs b/test/Base.hs index f7acb02ef..d15275c70 100644 --- a/test/Base.hs +++ b/test/Base.hs @@ -79,21 +79,23 @@ assertCmdExists cmd = . isJust =<< findExecutable cmd -testTaggedLockedToIO :: Sem PipelineAppEffects a -> IO a +testTaggedLockedToIO :: (MonadIO m) => Sem PipelineAppEffects a -> m a testTaggedLockedToIO = - runFinal + liftIO + . runFinal . resourceToIOFinal . embedToFinal @IO . runTaggedLock LockModeExclusive testRunIO :: - forall a. + forall a m. + (MonadIO m) => EntryPoint -> Sem (PipelineEff PipelineAppEffects) a -> - IO (ResolverState, PipelineResult a) + m (ResolverState, PipelineResult a) testRunIO e = testTaggedLockedToIO . runIO defaultGenericOptions e -testDefaultEntryPointIO :: Path Abs Dir -> Path Abs File -> IO EntryPoint +testDefaultEntryPointIO :: (MonadIO m) => Path Abs Dir -> Path Abs File -> m EntryPoint testDefaultEntryPointIO cwd mainFile = testTaggedLockedToIO (defaultEntryPointIO cwd mainFile) testDefaultEntryPointNoFileIO :: Path Abs Dir -> IO EntryPoint diff --git a/test/Formatter/Positive.hs b/test/Formatter/Positive.hs index 68a682afe..bffaa1ba8 100644 --- a/test/Formatter/Positive.hs +++ b/test/Formatter/Positive.hs @@ -8,10 +8,10 @@ import Scope.Positive qualified as Scope runScopeEffIO :: (Member EmbedIO r) => Path Abs Dir -> Sem (ScopeEff ': r) a -> Sem r a runScopeEffIO root = interpret $ \case ScopeFile p -> do - entry <- embed (testDefaultEntryPointIO root p) - embed ((^. pipelineResult) . snd <$> testRunIO entry upToScoping) + entry <- testDefaultEntryPointIO root p + ((^. pipelineResult) . snd <$> testRunIO entry upToScoping) ScopeStdin entry -> do - embed ((^. pipelineResult) . snd <$> testRunIO entry upToScoping) + ((^. pipelineResult) . snd <$> testRunIO entry upToScoping) makeFormatTest' :: Scope.PosTest -> TestDescr makeFormatTest' Scope.PosTest {..} = diff --git a/test/Nockma/Compile/Tree/Positive.hs b/test/Nockma/Compile/Tree/Positive.hs index 0b781996a..5458bc627 100644 --- a/test/Nockma/Compile/Tree/Positive.hs +++ b/test/Nockma/Compile/Tree/Positive.hs @@ -21,7 +21,7 @@ runNockmaAssertion hout _main tab = do res <- runM . runOutputSem @(Term Natural) - (embed . hPutStrLn hout . Nockma.ppPrint) + (hPutStrLn hout . Nockma.ppPrint) . runReader NockmaEval.defaultEvalOptions . evalCompiledNock' nockSubject $ nockMain diff --git a/test/Repl/Positive.hs b/test/Repl/Positive.hs index 3336b41f8..71efe23e3 100644 --- a/test/Repl/Positive.hs +++ b/test/Repl/Positive.hs @@ -24,7 +24,7 @@ loadPrelude rootDir = runTaggedLockIO' $ do runReader rootDir writeStdlib pkg <- readPackageRootIO root let ep = defaultEntryPoint pkg root (rootDir preludePath) - artif <- embed (runReplPipelineIO ep) + artif <- runReplPipelineIO ep return (artif, ep) where root :: Root