1
1
mirror of https://github.com/anoma/juvix.git synced 2024-12-15 01:52:11 +03:00
juvix/app/App.hs
Jan Mas Rovira 34719bbc4d
Report termination errors after typechecking (#2318)
- Closes #2293.
- Closes #2319 

I've added an effect for termination. It keeps track of which functions
failed the termination checker, which is run just after translating to
Internal. During typechecking, non-terminating functions are not
normalized. After typechecking, if there is at least one function which
failed the termination checker, an error is reported.
Additionally, we now properly check for termination of functions defined
in a let expression in the repl.
2023-08-30 16:38:59 +02:00

191 lines
6.8 KiB
Haskell

module App where
import CommonOptions
import Data.ByteString qualified as ByteString
import GlobalOptions
import Juvix.Compiler.Concrete.Translation.FromParsed.Analysis.PathResolver
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Checker
import Juvix.Compiler.Pipeline
import Juvix.Data.Error qualified as Error
import Juvix.Extra.Paths.Base
import Juvix.Prelude.Pretty hiding
( Doc,
)
import System.Console.ANSI qualified as Ansi
data App m a where
ExitMsg :: ExitCode -> Text -> App m a
ExitJuvixError :: JuvixError -> App m a
PrintJuvixError :: JuvixError -> App m ()
AskRoots :: App m Roots
AskInvokeDir :: App m (Path Abs Dir)
AskPkgDir :: App m (Path Abs Dir)
AskBuildDir :: App m (Path Abs Dir)
AskPackage :: App m Package
AskPackageGlobal :: App m Bool
AskGlobalOptions :: App m GlobalOptions
FromAppPathFile :: AppPath File -> App m (Path Abs File)
GetMainFile :: Maybe (AppPath File) -> App m (Path Abs File)
FromAppPathDir :: AppPath Dir -> App m (Path Abs Dir)
RenderStdOut :: (HasAnsiBackend a, HasTextBackend a) => a -> App m ()
RunPipelineEither :: AppPath File -> Sem PipelineEff a -> App m (Either JuvixError (ResolverState, a))
RunPipelineNoFileEither :: Sem PipelineEff a -> App m (Either JuvixError (ResolverState, a))
RunCorePipelineEither :: AppPath File -> App m (Either JuvixError Artifacts)
Say :: Text -> App m ()
SayRaw :: ByteString -> App m ()
makeSem ''App
data RunAppIOArgs = RunAppIOArgs
{ _runAppIOArgsGlobalOptions :: GlobalOptions,
_runAppIOArgsRoots :: Roots
}
runAppIO ::
forall r a.
(Member (Embed IO) r) =>
RunAppIOArgs ->
Sem (App ': r) a ->
Sem r a
runAppIO args@RunAppIOArgs {..} =
interpret $ \case
AskPackageGlobal -> return (_runAppIOArgsRoots ^. rootsPackageGlobal)
FromAppPathFile p -> embed (prepathToAbsFile invDir (p ^. pathPath))
GetMainFile m -> getMainFile' m
FromAppPathDir p -> embed (prepathToAbsDir invDir (p ^. pathPath))
RenderStdOut t
| _runAppIOArgsGlobalOptions ^. globalOnlyErrors -> return ()
| otherwise -> embed $ do
sup <- Ansi.hSupportsANSIColor stdout
renderIO (not (_runAppIOArgsGlobalOptions ^. globalNoColors) && sup) t
AskGlobalOptions -> return _runAppIOArgsGlobalOptions
AskPackage -> return (_runAppIOArgsRoots ^. rootsPackage)
AskRoots -> return _runAppIOArgsRoots
AskInvokeDir -> return invDir
AskPkgDir -> return (_runAppIOArgsRoots ^. rootsRootDir)
AskBuildDir -> return (_runAppIOArgsRoots ^. rootsBuildDir)
RunCorePipelineEither input -> do
entry <- embed (getEntryPoint' args input)
embed (corePipelineIOEither entry)
RunPipelineEither input p -> do
entry <- embed (getEntryPoint' args input)
embed (runIOEither entry p)
RunPipelineNoFileEither p -> do
entry <- embed (getEntryPointStdin' args)
embed (runIOEither entry p)
Say t
| g ^. globalOnlyErrors -> return ()
| otherwise -> embed (putStrLn t)
PrintJuvixError e -> do
printErr e
ExitJuvixError e -> do
printErr e
embed exitFailure
ExitMsg exitCode t -> exitMsg' exitCode t
SayRaw b -> embed (ByteString.putStr b)
where
exitMsg' :: ExitCode -> Text -> Sem r x
exitMsg' exitCode t = embed (putStrLn t >> hFlush stdout >> exitWith exitCode)
getMainFile' :: Maybe (AppPath File) -> Sem r (Path Abs File)
getMainFile' = \case
Just p -> embed (prepathToAbsFile invDir (p ^. pathPath))
Nothing -> case pkg ^. packageMain of
Just p -> embed (prepathToAbsFile invDir p)
Nothing -> missingMainErr
missingMainErr :: Sem r x
missingMainErr =
exitMsg'
(ExitFailure 1)
( "A path to the main file must be given in the CLI or specified in the `main` field of the "
<> pack (toFilePath juvixYamlFile)
<> " file"
)
invDir = _runAppIOArgsRoots ^. rootsInvokeDir
pkg :: Package
pkg = _runAppIOArgsRoots ^. rootsPackage
g :: GlobalOptions
g = _runAppIOArgsGlobalOptions
printErr e =
embed $ hPutStrLn stderr $ run $ runReader (project' @GenericOptions g) $ Error.render (not (_runAppIOArgsGlobalOptions ^. globalNoColors)) (g ^. globalOnlyErrors) e
getEntryPoint' :: RunAppIOArgs -> AppPath File -> IO EntryPoint
getEntryPoint' RunAppIOArgs {..} inputFile = do
let opts = _runAppIOArgsGlobalOptions
roots = _runAppIOArgsRoots
estdin <-
if
| opts ^. globalStdin -> Just <$> getContents
| otherwise -> return Nothing
set entryPointStdin estdin <$> entryPointFromGlobalOptionsPre roots (inputFile ^. pathPath) opts
getEntryPointStdin' :: RunAppIOArgs -> IO EntryPoint
getEntryPointStdin' RunAppIOArgs {..} = do
let opts = _runAppIOArgsGlobalOptions
roots = _runAppIOArgsRoots
estdin <-
if
| opts ^. globalStdin -> Just <$> getContents
| otherwise -> return Nothing
set entryPointStdin estdin <$> entryPointFromGlobalOptionsNoFile roots opts
someBaseToAbs' :: (Members '[App] r) => SomeBase a -> Sem r (Path Abs a)
someBaseToAbs' f = do
r <- askInvokeDir
return (someBaseToAbs r f)
filePathToAbs :: (Members '[Embed IO, App] r) => Prepath FileOrDir -> Sem r (Either (Path Abs File) (Path Abs Dir))
filePathToAbs fp = do
invokeDir <- askInvokeDir
embed (fromPreFileOrDir invokeDir fp)
askGenericOptions :: (Members '[App] r) => Sem r GenericOptions
askGenericOptions = project <$> askGlobalOptions
getEntryPoint :: (Members '[Embed IO, App] r) => AppPath File -> Sem r EntryPoint
getEntryPoint inputFile = do
_runAppIOArgsGlobalOptions <- askGlobalOptions
_runAppIOArgsRoots <- askRoots
embed (getEntryPoint' (RunAppIOArgs {..}) inputFile)
runPipelineTermination :: (Member App r) => AppPath File -> Sem (Termination ': PipelineEff) a -> Sem r a
runPipelineTermination input p = do
r <- runPipelineEither input (evalTermination iniTerminationState p)
case r of
Left err -> exitJuvixError err
Right res -> return (snd res)
runPipeline :: (Member App r) => AppPath File -> Sem PipelineEff a -> Sem r a
runPipeline input p = do
r <- runPipelineEither input p
case r of
Left err -> exitJuvixError err
Right res -> return (snd res)
runPipelineNoFile :: (Member App r) => Sem PipelineEff a -> Sem r a
runPipelineNoFile p = do
r <- runPipelineNoFileEither p
case r of
Left err -> exitJuvixError err
Right res -> return (snd res)
newline :: (Member App r) => Sem r ()
newline = say ""
printSuccessExit :: (Member App r) => Text -> Sem r a
printSuccessExit = exitMsg ExitSuccess
printFailureExit :: (Member App r) => Text -> Sem r a
printFailureExit = exitMsg (ExitFailure 1)
getRight :: (Members '[App] r, AppError e) => Either e a -> Sem r a
getRight = either appError return
instance AppError Text where
appError = printFailureExit
instance AppError JuvixError where
appError = exitJuvixError
class AppError e where
appError :: (Members '[App] r) => e -> Sem r a