mirror of
https://github.com/anoma/juvix.git
synced 2024-10-27 02:04:29 +03:00
Promote use of MonadIO
to minimize embed
occurrences (#2694)
This commit is contained in:
parent
ff853b51ba
commit
b615fde186
13
app/App.hs
13
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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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"
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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 =
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
12
test/Base.hs
12
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
|
||||
|
@ -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 {..} =
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user