mirror of
https://github.com/anoma/juvix.git
synced 2024-12-13 19:49:20 +03:00
6d66d0ab13
* Adds a major mode for juvix-repl * juvix-mode: C-c C-l loads file into REPL, if the REPL is running * Detect ANSI support in Emacs REPL / shell by using hSupportsANSIColor API * Disable comint echo handling. Juvix REPL does not echo * repl: whitespace strip input to compile/eval/infer commands
109 lines
3.5 KiB
Haskell
109 lines
3.5 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 ()
|
|
AskRoot :: App m FilePath
|
|
AskPackage :: App m Package
|
|
AskGlobalOptions :: App m GlobalOptions
|
|
RenderStdOut :: (HasAnsiBackend a, HasTextBackend a) => a -> App m ()
|
|
RunPipelineEither :: Path -> Sem PipelineEff a -> App m (Either JuvixError (BuiltinsState, a))
|
|
Say :: Text -> App m ()
|
|
Raw :: ByteString -> App m ()
|
|
|
|
makeSem ''App
|
|
|
|
runAppIO :: forall r a. Member (Embed IO) r => GlobalOptions -> FilePath -> Package -> Sem (App ': r) a -> Sem r a
|
|
runAppIO g root pkg = interpret $ \case
|
|
RenderStdOut t
|
|
| g ^. globalOnlyErrors -> return ()
|
|
| otherwise -> embed $ do
|
|
sup <- Ansi.hSupportsANSIColor stdout
|
|
renderIO (not (g ^. globalNoColors) && sup) t
|
|
AskGlobalOptions -> return g
|
|
AskPackage -> return pkg
|
|
AskRoot -> return root
|
|
RunPipelineEither input p -> do
|
|
entry <- embed (getEntryPoint' g root pkg 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)
|
|
Raw b -> embed (ByteString.putStr b)
|
|
where
|
|
printErr e =
|
|
embed $ hPutStrLn stderr $ run $ runReader (project' @GenericOptions g) $ Error.render (not (g ^. globalNoColors)) (g ^. globalOnlyErrors) e
|
|
|
|
getEntryPoint' :: GlobalOptions -> FilePath -> Package -> Path -> IO EntryPoint
|
|
getEntryPoint' opts root pkg inputFile = do
|
|
estdin <-
|
|
if
|
|
| opts ^. globalStdin -> Just <$> getContents
|
|
| otherwise -> return Nothing
|
|
return
|
|
EntryPoint
|
|
{ _entryPointRoot = root,
|
|
_entryPointNoTermination = opts ^. globalNoTermination,
|
|
_entryPointNoPositivity = opts ^. globalNoPositivity,
|
|
_entryPointNoStdlib = opts ^. globalNoStdlib,
|
|
_entryPointStdlibPath = opts ^. globalStdlibPath,
|
|
_entryPointPackage = pkg,
|
|
_entryPointModulePaths = pure (inputFile ^. pathPath),
|
|
_entryPointGenericOptions = project opts,
|
|
_entryPointStdin = estdin
|
|
}
|
|
|
|
askGenericOptions :: Members '[App] r => Sem r GenericOptions
|
|
askGenericOptions = project <$> askGlobalOptions
|
|
|
|
getEntryPoint :: Members '[Embed IO, App] r => Path -> Sem r EntryPoint
|
|
getEntryPoint inputFile = do
|
|
opts <- askGlobalOptions
|
|
root <- askRoot
|
|
pkg <- askPackage
|
|
embed (getEntryPoint' opts root pkg inputFile)
|
|
|
|
runPipeline :: Member App r => Path -> 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
|