mirror of
https://github.com/anoma/juvix.git
synced 2025-01-05 22:46:08 +03:00
807b3b1770
This PR adds some maintenance at different levels to the CI config, the Make file, and formatting. - Most of the actions used by the CI related to haskell, ormolu, hlint and pre-commit have been updated because Github requires NodeJS 16. This change removes all the old warnings related to nodeJs. In the case of ormolu, the new version makes us format some files that were not formatted before, similarly with hlint. - The CI has been updated to use the latest version of the Smoke testing framework, which introduced installation of the dependencies for Linux (libicu66) and macOS (icu4c) in the CI. In the case of macOS, the CI uses a binary for smoke. For Linux, we use stack to build smoke from the source. The source here is in a fork of [the official Smoke repo](https://github.com/SamirTalwar/smoke). Such includes some features/changes that are not yet in the official repo. - The Makefile runs the ormolu and hlint targets using as a path for the binaries the environment variables ORMOLU and HLINT. Thus, export those variables in your environment before running `make check,` `make format` or `make hlint`. Otherwise, the Makefile will use the binaries provided by `stack`. Co-authored-by: Paul Cadman <git@paulcadman.dev>
139 lines
4.6 KiB
Haskell
139 lines
4.6 KiB
Haskell
module App where
|
|
|
|
import CommonOptions
|
|
import Data.ByteString qualified as ByteString
|
|
import GlobalOptions
|
|
import Juvix.Compiler.Builtins.Effect
|
|
import Juvix.Compiler.Pipeline
|
|
import Juvix.Data.Error qualified as Error
|
|
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 ()
|
|
AskInvokeDir :: App m (Path Abs Dir)
|
|
AskPkgDir :: App m (Path Abs Dir)
|
|
AskBuildDir :: App m (Path Abs Dir)
|
|
AskPackage :: App m Package
|
|
AskGlobalOptions :: App m GlobalOptions
|
|
RenderStdOut :: (HasAnsiBackend a, HasTextBackend a) => a -> App m ()
|
|
RunPipelineEither :: AppPath File -> Sem PipelineEff a -> App m (Either JuvixError (Artifacts, a))
|
|
Say :: Text -> App m ()
|
|
SayRaw :: ByteString -> App m ()
|
|
|
|
makeSem ''App
|
|
|
|
data RunAppIOArgs = RunAppIOArgs
|
|
{ _runAppIOArgsGlobalOptions :: GlobalOptions,
|
|
_runAppIOArgsInvokeDir :: Path Abs Dir,
|
|
_runAppIOArgsBuildDir :: Path Abs Dir,
|
|
_runAppIOArgsPkgDir :: Path Abs Dir,
|
|
_runAppIOArgsPkg :: Package
|
|
}
|
|
|
|
runAppIO ::
|
|
forall r a.
|
|
(Member (Embed IO) r) =>
|
|
RunAppIOArgs ->
|
|
Sem (App ': r) a ->
|
|
Sem r a
|
|
runAppIO args@RunAppIOArgs {..} =
|
|
interpret $ \case
|
|
RenderStdOut t
|
|
| _runAppIOArgsGlobalOptions ^. globalOnlyErrors -> return ()
|
|
| otherwise -> embed $ do
|
|
sup <- Ansi.hSupportsANSIColor stdout
|
|
renderIO (not (_runAppIOArgsGlobalOptions ^. globalNoColors) && sup) t
|
|
AskGlobalOptions -> return _runAppIOArgsGlobalOptions
|
|
AskPackage -> return _runAppIOArgsPkg
|
|
AskInvokeDir -> return _runAppIOArgsInvokeDir
|
|
AskPkgDir -> return _runAppIOArgsPkgDir
|
|
AskBuildDir -> return _runAppIOArgsBuildDir
|
|
RunPipelineEither input p -> do
|
|
entry <- embed (getEntryPoint' args input)
|
|
embed (runIOEither iniState 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 -> embed (putStrLn t >> exitWith exitCode)
|
|
SayRaw b -> embed (ByteString.putStr b)
|
|
where
|
|
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
|
|
root = _runAppIOArgsPkgDir
|
|
estdin <-
|
|
if
|
|
| opts ^. globalStdin -> Just <$> getContents
|
|
| otherwise -> return Nothing
|
|
return
|
|
EntryPoint
|
|
{ _entryPointRoot = root,
|
|
_entryPointResolverRoot = root,
|
|
_entryPointBuildDir = _runAppIOArgsBuildDir,
|
|
_entryPointNoTermination = opts ^. globalNoTermination,
|
|
_entryPointNoPositivity = opts ^. globalNoPositivity,
|
|
_entryPointNoStdlib = opts ^. globalNoStdlib,
|
|
_entryPointPackage = _runAppIOArgsPkg,
|
|
_entryPointModulePaths = pure (someBaseToAbs _runAppIOArgsInvokeDir (inputFile ^. pathPath)),
|
|
_entryPointGenericOptions = project opts,
|
|
_entryPointStdin = estdin
|
|
}
|
|
|
|
someBaseToAbs' :: (Members '[App] r) => SomeBase a -> Sem r (Path Abs a)
|
|
someBaseToAbs' f = do
|
|
r <- askInvokeDir
|
|
return (someBaseToAbs r f)
|
|
|
|
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
|
|
_runAppIOArgsPkgDir <- askPkgDir
|
|
_runAppIOArgsPkg <- askPackage
|
|
_runAppIOArgsBuildDir <- askBuildDir
|
|
_runAppIOArgsInvokeDir <- askInvokeDir
|
|
embed (getEntryPoint' (RunAppIOArgs {..}) inputFile)
|
|
|
|
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)
|
|
|
|
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
|