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