diff --git a/app/App.hs b/app/App.hs index 0f61308be5..2bf3965352 100644 --- a/app/App.hs +++ b/app/App.hs @@ -321,5 +321,8 @@ instance AppError Text where instance AppError JuvixError where appError = exitJuvixError +instance AppError SimpleError where + appError = exitFailMsg . toPlainText + class AppError e where appError :: (Members '[App] r) => e -> Sem r a diff --git a/app/Commands/Compile/Anoma.hs b/app/Commands/Compile/Anoma.hs index b6b62da809..e86b7132df 100644 --- a/app/Commands/Compile/Anoma.hs +++ b/app/Commands/Compile/Anoma.hs @@ -12,19 +12,31 @@ runCommand opts = do let opts' = opts ^. anomaCompileCommonOptions inputFile = opts' ^. compileInputFile moutputFile = opts' ^. compileOutputFile + nockmaFile :: Path Abs File <- getOutputFile FileExtNockma inputFile moutputFile + res <- compileAnomaOpts opts' + outputAnomaResult (opts' ^. compileDebug) nockmaFile res + +compileAnoma :: (Members AppEffects r) => Maybe (AppPath File) -> Sem r Nockma.AnomaResult +compileAnoma inputFile = do + let opts' = + defaultCompileCommonOptionsMain + { _compileInputFile = inputFile + } + compileAnomaOpts opts' + +compileAnomaOpts :: (Members AppEffects r) => CompileCommonOptions 'InputMain -> Sem r Nockma.AnomaResult +compileAnomaOpts opts' = do coreRes <- fromCompileCommonOptionsMain opts' >>= compileToCore entryPoint <- - applyOptions opts + applyOptions opts' <$> getEntryPoint (opts' ^. compileInputFile) - nockmaFile :: Path Abs File <- getOutputFile FileExtNockma inputFile moutputFile r <- runReader entryPoint . runError @JuvixError . coreToAnoma $ coreRes ^. coreResultModule - res <- getRight r - outputAnomaResult (opts' ^. compileDebug) nockmaFile res + getRight r outputAnomaResult :: (Members '[EmbedIO, App, Files] r) => Bool -> Path Abs File -> Nockma.AnomaResult -> Sem r () outputAnomaResult debugOutput nockmaFile Nockma.AnomaResult {..} = do diff --git a/app/Commands/Compile/CommonOptions.hs b/app/Commands/Compile/CommonOptions.hs index 07883e4eaf..99730cd899 100644 --- a/app/Commands/Compile/CommonOptions.hs +++ b/app/Commands/Compile/CommonOptions.hs @@ -27,6 +27,16 @@ deriving stock instance (Typeable k, Data (InputFileType k)) => Data (CompileCom makeLenses ''CompileCommonOptions +defaultCompileCommonOptionsMain :: CompileCommonOptions 'InputMain +defaultCompileCommonOptionsMain = + CompileCommonOptions + { _compileInputFile = Nothing, + _compileOutputFile = Nothing, + _compileDebug = False, + _compileInliningDepth = defaultInliningDepth, + _compileOptimizationLevel = Just defaultOptimizationLevel + } + instance EntryPointOptions (CompileCommonOptions b) where applyOptions opts e = e diff --git a/app/Commands/Dev.hs b/app/Commands/Dev.hs index c9910635c0..c4726a5097 100644 --- a/app/Commands/Dev.hs +++ b/app/Commands/Dev.hs @@ -5,6 +5,7 @@ module Commands.Dev where import Commands.Base +import Commands.Dev.Anoma qualified as Anoma import Commands.Dev.Asm qualified as Asm import Commands.Dev.Casm qualified as Casm import Commands.Dev.Core qualified as Core @@ -45,3 +46,4 @@ runCommand = \case JuvixDevRepl opts -> Repl.runCommand opts MigrateJuvixYaml opts -> runFilesIO $ MigrateJuvixYaml.runCommand opts Nockma opts -> Nockma.runCommand opts + Anoma opts -> Anoma.runCommand opts diff --git a/app/Commands/Dev/Anoma.hs b/app/Commands/Dev/Anoma.hs new file mode 100644 index 0000000000..b723f0cef0 --- /dev/null +++ b/app/Commands/Dev/Anoma.hs @@ -0,0 +1,13 @@ +module Commands.Dev.Anoma + ( module Commands.Dev.Anoma, + module Commands.Dev.Anoma.Options, + ) +where + +import Commands.Base +import Commands.Dev.Anoma.Node qualified as Node +import Commands.Dev.Anoma.Options + +runCommand :: (Members AppEffects r) => AnomaCommand -> Sem r () +runCommand = \case + Node opts -> Node.runCommand opts diff --git a/app/Commands/Dev/Anoma/Node.hs b/app/Commands/Dev/Anoma/Node.hs new file mode 100644 index 0000000000..f885c82967 --- /dev/null +++ b/app/Commands/Dev/Anoma/Node.hs @@ -0,0 +1,14 @@ +module Commands.Dev.Anoma.Node where + +import Anoma.Effect +import Commands.Base +import Commands.Dev.Anoma.Node.Options + +runCommand :: forall r. (Members AppEffects r) => NodeOptions -> Sem r () +runCommand opts = runAppError @SimpleError + . runConcurrent + . runProcess + $ do + anomaDir :: AnomaPath <- AnomaPath <$> fromAppPathDir (opts ^. nodeAnomaPath) + runAnoma anomaDir $ do + void noHalt diff --git a/app/Commands/Dev/Anoma/Node/Options.hs b/app/Commands/Dev/Anoma/Node/Options.hs new file mode 100644 index 0000000000..1886e30066 --- /dev/null +++ b/app/Commands/Dev/Anoma/Node/Options.hs @@ -0,0 +1,15 @@ +module Commands.Dev.Anoma.Node.Options where + +import CommonOptions + +newtype NodeOptions = NodeOptions + { _nodeAnomaPath :: AppPath Dir + } + deriving stock (Data) + +makeLenses ''NodeOptions + +parseNodeOptions :: Parser NodeOptions +parseNodeOptions = do + _nodeAnomaPath <- anomaDirOpt + pure NodeOptions {..} diff --git a/app/Commands/Dev/Anoma/Options.hs b/app/Commands/Dev/Anoma/Options.hs new file mode 100644 index 0000000000..d58c6e5506 --- /dev/null +++ b/app/Commands/Dev/Anoma/Options.hs @@ -0,0 +1,24 @@ +module Commands.Dev.Anoma.Options where + +import Commands.Dev.Anoma.Node.Options +import CommonOptions + +newtype AnomaCommand + = Node NodeOptions + deriving stock (Data) + +parseAnomaCommand :: Parser AnomaCommand +parseAnomaCommand = + hsubparser + ( mconcat + [commandNode] + ) + where + commandNode :: Mod CommandFields AnomaCommand + commandNode = command "node" runInfo + where + runInfo :: ParserInfo AnomaCommand + runInfo = + info + (Node <$> parseNodeOptions) + (progDesc "Run an Anoma node and client.") diff --git a/app/Commands/Dev/Core/Repl.hs b/app/Commands/Dev/Core/Repl.hs index 650d8d81bf..b04eb381ff 100644 --- a/app/Commands/Dev/Core/Repl.hs +++ b/app/Commands/Dev/Core/Repl.hs @@ -28,7 +28,7 @@ parseText = Core.runParser replPath defaultModuleId runRepl :: forall r. (Members '[EmbedIO, App] r) => CoreReplOptions -> Core.InfoTable -> Sem r () runRepl opts tab = do putStr "> " - liftIO (hFlush stdout) + hFlush stdout done <- liftIO isEOF unless done $ do s <- getLine diff --git a/app/Commands/Dev/Nockma/Options.hs b/app/Commands/Dev/Nockma/Options.hs index 4b4f87431d..9937351e45 100644 --- a/app/Commands/Dev/Nockma/Options.hs +++ b/app/Commands/Dev/Nockma/Options.hs @@ -30,7 +30,7 @@ parseNockmaCommand = runInfo = info (NockmaRun <$> parseNockmaRunOptions) - (progDesc "Run an Anoma program. It should be used with artefacts obtained from compilation with the anoma target.") + (progDesc ("Run an Anoma program. It should be used with artefacts obtained from compilation with the anoma target. If the --" <> anomaDirOptLongStr <> " is given, then it runs the code in an anoma node")) commandFromAsm :: Mod CommandFields NockmaCommand commandFromAsm = command "eval" fromAsmInfo diff --git a/app/Commands/Dev/Nockma/Run.hs b/app/Commands/Dev/Nockma/Run.hs index 7350f3f376..50f90c369b 100644 --- a/app/Commands/Dev/Nockma/Run.hs +++ b/app/Commands/Dev/Nockma/Run.hs @@ -1,5 +1,6 @@ module Commands.Dev.Nockma.Run where +import Anoma.Effect import Commands.Base hiding (Atom) import Commands.Dev.Nockma.Run.Options import Juvix.Compiler.Nockma.Anoma @@ -13,22 +14,28 @@ runCommand opts = do afile <- fromAppPathFile inputFile argsFile <- mapM fromAppPathFile (opts ^. nockmaRunArgs) parsedArgs <- runAppError @JuvixError (mapM Nockma.cueJammedFileOrPretty argsFile) - parsedTerm <- checkCued (Nockma.cueJammedFileOrPretty afile) + parsedTerm <- runAppError @JuvixError (Nockma.cueJammedFileOrPretty afile) case parsedTerm of - t@(TermCell {}) -> do - let formula = anomaCallTuple parsedArgs - (counts, res) <- - runOpCounts - . runReader defaultEvalOptions - . runOutputSem @(Term Natural) (logInfo . mkAnsiText . ppTrace) - $ evalCompiledNock' t formula - putStrLn (ppPrint res) - let statsFile = replaceExtension' ".profile" afile - writeFileEnsureLn statsFile (prettyText counts) TermAtom {} -> exitFailMsg "Expected nockma input to be a cell" + t@(TermCell {}) -> case opts ^. nockmaRunAnomaDir of + Just path -> do + anomaDir <- AnomaPath <$> fromAppPathDir path + runInAnoma anomaDir t (unfoldTuple parsedArgs) + Nothing -> do + let formula = anomaCallTuple parsedArgs + (counts, res) <- + runOpCounts + . runReader defaultEvalOptions + . runOutputSem @(Term Natural) (logInfo . mkAnsiText . ppTrace) + $ evalCompiledNock' t formula + putStrLn (ppPrint res) + let statsFile = replaceExtension' ".profile" afile + writeFileEnsureLn statsFile (prettyText counts) where inputFile :: AppPath File inputFile = opts ^. nockmaRunFile - checkCued :: Sem (Error JuvixError ': r) a -> Sem r a - checkCued = runErrorNoCallStackWith exitJuvixError +runInAnoma :: (Members AppEffects r) => AnomaPath -> Term Natural -> [Term Natural] -> Sem r () +runInAnoma anoma t args = runAppError @SimpleError . runAnoma anoma $ do + res <- runNockma t args + putStrLn (ppPrint res) diff --git a/app/Commands/Dev/Nockma/Run/Options.hs b/app/Commands/Dev/Nockma/Run/Options.hs index 2133bedb87..f3236e11e8 100644 --- a/app/Commands/Dev/Nockma/Run/Options.hs +++ b/app/Commands/Dev/Nockma/Run/Options.hs @@ -4,6 +4,7 @@ import CommonOptions data NockmaRunOptions = NockmaRunOptions { _nockmaRunFile :: AppPath File, + _nockmaRunAnomaDir :: Maybe (AppPath Dir), _nockmaRunProfile :: Bool, _nockmaRunArgs :: Maybe (AppPath File) } @@ -24,6 +25,7 @@ parseNockmaRunOptions = do <> action "file" ) pure AppPath {_pathIsInput = True, ..} + _nockmaRunAnomaDir <- optional anomaDirOpt _nockmaRunProfile <- switch ( long "profile" diff --git a/app/Commands/Dev/Options.hs b/app/Commands/Dev/Options.hs index f68a579789..f0892cffd9 100644 --- a/app/Commands/Dev/Options.hs +++ b/app/Commands/Dev/Options.hs @@ -12,6 +12,7 @@ module Commands.Dev.Options ) where +import Commands.Dev.Anoma.Options import Commands.Dev.Asm.Options hiding (Compile) import Commands.Dev.Casm.Options import Commands.Dev.Core.Options @@ -52,6 +53,7 @@ data DevCommand | JuvixDevRepl ReplOptions | MigrateJuvixYaml MigrateJuvixYamlOptions | Nockma NockmaCommand + | Anoma AnomaCommand deriving stock (Data) parseDevCommand :: Parser DevCommand @@ -75,6 +77,7 @@ parseDevCommand = commandJuvixDevRepl, commandMigrateJuvixYaml, commandLatex, + commandAnoma, commandNockma ] ) @@ -206,3 +209,10 @@ commandNockma = info (Nockma <$> parseNockmaCommand) (progDesc "Subcommands related to the nockma backend") + +commandAnoma :: Mod CommandFields DevCommand +commandAnoma = + command "anoma" $ + info + (Anoma <$> parseAnomaCommand) + (progDesc "Subcommands related to the anoma") diff --git a/app/CommonOptions.hs b/app/CommonOptions.hs index 2682bfd0e8..7a5a225d2e 100644 --- a/app/CommonOptions.hs +++ b/app/CommonOptions.hs @@ -28,7 +28,7 @@ import Juvix.Prelude.Pretty hiding (group, list) import Options.Applicative hiding (helpDoc) import Options.Applicative qualified as Opt import Prettyprinter.Render.Terminal hiding (renderIO, renderStrict) -import System.Process +import System.Process as System import Text.Read (readMaybe) import Prelude qualified @@ -76,6 +76,25 @@ parseInputFile = parseInputFiles . NonEmpty.singleton numThreadsOpt :: ReadM NumThreads numThreadsOpt = eitherReader readNumThreads +anomaDirOptLongStr :: forall str. (IsString str) => str +anomaDirOptLongStr = "anoma-dir" + +anomaDirOpt :: Parser (AppPath Dir) +anomaDirOpt = do + path <- + option + somePreDirOpt + ( long anomaDirOptLongStr + <> metavar "ANOMA_DIR" + <> help "Path to anoma repository" + <> action "directory" + ) + return + AppPath + { _pathIsInput = False, + _pathPath = path + } + parseNumThreads :: Parser NumThreads parseNumThreads = do option @@ -209,7 +228,7 @@ enumCompleter _ = listCompleter [Juvix.show e | e <- allElements @a] extCompleter :: FileExt -> Completer extCompleter ext = mkCompleter $ \word -> do let cmd = unwords ["compgen", "-o", "plusdirs", "-f", "-X", "!*" <> Prelude.show ext, "--", requote word] - result <- GHC.try @GHC.SomeException $ readProcess "bash" ["-c", cmd] "" + result <- GHC.try @GHC.SomeException $ System.readProcess "bash" ["-c", cmd] "" return . lines . fromRight [] $ result requote :: String -> String diff --git a/include/anoma/start.exs b/include/anoma/start.exs new file mode 100644 index 0000000000..f2beab944c --- /dev/null +++ b/include/anoma/start.exs @@ -0,0 +1 @@ + IO.puts(Anoma.Node.Examples.ENode.start_node().grpc_port) diff --git a/package.yaml b/package.yaml index faeee7bcb3..cd61a2ac62 100644 --- a/package.yaml +++ b/package.yaml @@ -52,6 +52,7 @@ dependencies: - ansi-terminal == 1.1.* - base == 4.19.* - base16-bytestring == 1.0.* + - base64-bytestring == 1.2.* - bitvec == 1.1.* - blaze-html == 0.9.* - bytestring == 0.12.* diff --git a/src/Anoma/Effect.hs b/src/Anoma/Effect.hs new file mode 100644 index 0000000000..4720d4da49 --- /dev/null +++ b/src/Anoma/Effect.hs @@ -0,0 +1,8 @@ +module Anoma.Effect + ( module Anoma.Effect.Base, + module Anoma.Effect.RunNockma, + ) +where + +import Anoma.Effect.Base +import Anoma.Effect.RunNockma diff --git a/src/Anoma/Effect/Base.hs b/src/Anoma/Effect/Base.hs new file mode 100644 index 0000000000..f35781c1f6 --- /dev/null +++ b/src/Anoma/Effect/Base.hs @@ -0,0 +1,151 @@ +-- | This module assumes that the following external dependencies are installed: +-- 1. mix +-- +-- 2. grpcurl +module Anoma.Effect.Base + ( Anoma, + noHalt, + anomaRpc, + AnomaPath (..), + anomaPath, + runAnoma, + module Anoma.Rpc.Base, + module Juvix.Compiler.Nockma.Translation.FromTree, + ) +where + +import Anoma.Effect.Paths +import Anoma.Rpc.Base +import Data.ByteString qualified as B +import Juvix.Compiler.Nockma.Translation.FromTree (AnomaResult) +import Juvix.Data.CodeAnn +import Juvix.Extra.Paths (anomaStartExs) +import Juvix.Prelude +import Juvix.Prelude.Aeson (Value, eitherDecodeStrict, encode) + +data Anoma :: Effect where + -- | Keep the node and client running + NoHalt :: Anoma m ExitCode + -- | grpc call + AnomaRpc :: GrpcMethodUrl -> Value -> Anoma m Value + +makeSem ''Anoma + +newtype AnomaPath = AnomaPath {_anomaPath :: Path Abs Dir} + +newtype GrpcPort = GrpcPort {_grpcPort :: Int} + +makeLenses ''AnomaPath +makeLenses ''GrpcPort + +listenPort :: Int +listenPort = 50051 + +relativeToAnomaDir :: (Members '[Reader AnomaPath] r) => Path Rel x -> Sem r (Path Abs x) +relativeToAnomaDir p = do + anoma <- asks (^. anomaPath) + return (anoma p) + +withSpawnAnomaClient :: + (Members '[Process, Logger, EmbedIO, Reader AnomaPath, Reader GrpcPort, Error SimpleError] r) => + (ProcessHandle -> Sem r a) -> + Sem r a +withSpawnAnomaClient body = do + cprocess <- mkProcess + withCreateProcess cprocess $ \_stdin mstdout _stderr procHandle -> do + let out = fromJust mstdout + txt <- hGetLine out + case takeWhile (/= '.') (unpack txt) of + "Connected to node" -> do + logInfo "Anoma client successfully started" + logInfo (mkAnsiText ("Listening on port " <> annotate AnnImportant (pretty listenPort))) + body procHandle + _ -> throw (SimpleError (mkAnsiText @Text "Something went wrong when starting the anoma client")) + where + mkProcess :: (Members '[Reader AnomaPath, Reader GrpcPort] r') => Sem r' CreateProcess + mkProcess = do + grpcport <- asks (^. grpcPort) + anomaClient <- relativeToAnomaDir clientRelFile + return + ( proc + (toFilePath anomaClient) + [ "--listen-port", + show listenPort, + "--node-host", + "localhost", + "--node-port", + show grpcport + ] + ) + { std_out = CreatePipe + } + +withSpawnAnomaNode :: + forall r a. + (Members '[EmbedIO, Logger, Error SimpleError, Process, Reader AnomaPath] r) => + (Int -> Handle -> ProcessHandle -> Sem r a) -> + Sem r a +withSpawnAnomaNode body = withSystemTempFile "start.exs" $ \fp tmpHandle -> do + liftIO (B.hPutStr tmpHandle anomaStartExs) + hClose tmpHandle + cproc <- cprocess (toFilePath fp) + withCreateProcess cproc $ \_stdin mstdout _stderr procHandle -> do + let nodeOut = fromJust mstdout + ln <- hGetLine nodeOut + let parseError = throw (SimpleError (mkAnsiText ("Failed to parse the grpc port when starting the anoma client.\nExpected a number but got " <> ln))) + nodeport :: Int <- either (const parseError) return . readEither . unpack $ ln + logInfo "Anoma node successfully started" + body nodeport (fromJust mstdout) procHandle + where + cprocess :: (Members '[Reader AnomaPath] r') => FilePath -> Sem r' CreateProcess + cprocess exs = do + anomapath <- asks (^. anomaPath) + return + (proc "mix" ["run", "--no-halt", exs]) + { std_out = CreatePipe, + cwd = Just (toFilePath anomapath) + } + +anomaRpc' :: (Members '[Reader AnomaPath, Process, EmbedIO, Error SimpleError] r) => GrpcMethodUrl -> Value -> Sem r Value +anomaRpc' method payload = do + cproc <- grpcCliProcess method + withCreateProcess cproc $ \mstdin mstdout _stderr _procHandle -> do + let stdinH = fromJust mstdin + stdoutH = fromJust mstdout + inputbs = B.toStrict (encode payload) + liftIO (B.hPutStr stdinH inputbs) + hClose stdinH + res <- eitherDecodeStrict <$> liftIO (B.hGetContents stdoutH) + case res of + Right r -> return r + Left err -> throw (SimpleError (mkAnsiText err)) + +grpcCliProcess :: (Members '[Reader AnomaPath] r) => GrpcMethodUrl -> Sem r CreateProcess +grpcCliProcess method = do + importPath <- relativeToAnomaDir relProtoDir + return + ( proc + "grpcurl" + [ "-import-path", + toFilePath importPath, + "-proto", + toFilePath relProtoFile, + "-d", + "@", + "-plaintext", + "localhost:" <> show listenPort, + show method + ] + ) + { std_in = CreatePipe, + std_out = CreatePipe + } + +runAnoma :: forall r a. (Members '[Logger, EmbedIO, Error SimpleError] r) => AnomaPath -> Sem (Anoma ': r) a -> Sem r a +runAnoma anomapath body = runReader anomapath . runConcurrent . runProcess $ + withSpawnAnomaNode $ \grpcport _nodeOut nodeH -> + runReader (GrpcPort grpcport) $ + withSpawnAnomaClient $ \_clientH -> do + (`interpret` inject body) $ \case + NoHalt -> waitForProcess nodeH + AnomaRpc method i -> anomaRpc' method i diff --git a/src/Anoma/Effect/Paths.hs b/src/Anoma/Effect/Paths.hs new file mode 100644 index 0000000000..663a7a104c --- /dev/null +++ b/src/Anoma/Effect/Paths.hs @@ -0,0 +1,12 @@ +module Anoma.Effect.Paths where + +import Juvix.Prelude + +clientRelFile :: Path Rel File +clientRelFile = $(mkRelFile "apps/anoma_client/anoma_client") + +relProtoDir :: Path Rel Dir +relProtoDir = $(mkRelDir "apps/anoma_protobuf/priv/protobuf") + +relProtoFile :: Path Rel File +relProtoFile = $(mkRelFile "anoma.proto") diff --git a/src/Anoma/Effect/RunNockma.hs b/src/Anoma/Effect/RunNockma.hs new file mode 100644 index 0000000000..1007b7a36e --- /dev/null +++ b/src/Anoma/Effect/RunNockma.hs @@ -0,0 +1,63 @@ +module Anoma.Effect.RunNockma + ( module Anoma.Effect.RunNockma, + module Anoma.Rpc.RunNock, + ) +where + +import Anoma.Effect.Base +import Anoma.Rpc.RunNock +import Data.ByteString.Base64 qualified as Base64 +import Juvix.Compiler.Nockma.Encoding.Cue (DecodingError, cueFromByteString'') +import Juvix.Compiler.Nockma.Encoding.Jam (jamToByteString) +import Juvix.Compiler.Nockma.Language (NockNaturalNaturalError) +import Juvix.Compiler.Nockma.Language qualified as Nockma +import Juvix.Data.CodeAnn (simpleErrorCodeAnn) +import Juvix.Prelude +import Juvix.Prelude.Aeson (Value) +import Juvix.Prelude.Aeson qualified as Aeson +import Juvix.Prelude.Pretty + +data RunNockmaInput = RunNockmaInput + { _runNockmaProgram :: AnomaResult, + _runNockmaInput :: [Nockma.Term Natural] + } + +makeLenses ''RunNockmaInput + +decodeJam64 :: (Members '[Error SimpleError] r) => Text -> Sem r (Nockma.Term Natural) +decodeJam64 encoded = + case Base64.decode (encodeUtf8 encoded) of + Left err -> throw (SimpleError (mkAnsiText err)) + Right bs' -> + case cueFromByteString'' bs' of + Left (err :: NockNaturalNaturalError) -> throw (simpleErrorCodeAnn err) + Right (Left (err :: DecodingError)) -> throw (simpleErrorCodeAnn err) + Right (Right r) -> return r + +encodeJam64 :: Nockma.Term Natural -> Text +encodeJam64 = decodeUtf8 . Base64.encode . jamToByteString + +fromJSON :: (Members '[Error SimpleError] r) => (Aeson.FromJSON a) => Value -> Sem r a +fromJSON v = case Aeson.fromJSON v of + Aeson.Success r -> return r + Aeson.Error err -> throw (SimpleError (mkAnsiText err)) + +runNockma :: + (Members '[Anoma, Error SimpleError] r) => + Nockma.Term Natural -> + [Nockma.Term Natural] -> + Sem r (Nockma.Term Natural) +runNockma prog inputs = do + let prog' = encodeJam64 prog + args = map (NockInputJammed . encodeJam64) inputs + msg = + RunNock + { _runNockJammedProgram = prog', + _runNockPrivateInputs = args, + _runNockPublicInputs = [] + } + let json = Aeson.toJSON msg + res :: Response <- anomaRpc runNockGrpcUrl json >>= fromJSON + case res of + ResponseProof x -> decodeJam64 x + ResponseError err -> throw (SimpleError (mkAnsiText err)) diff --git a/src/Anoma/Rpc/Base.hs b/src/Anoma/Rpc/Base.hs new file mode 100644 index 0000000000..dc116e07e8 --- /dev/null +++ b/src/Anoma/Rpc/Base.hs @@ -0,0 +1,6 @@ +module Anoma.Rpc.Base + ( module Anoma.Rpc.GrpcMethodUrl, + ) +where + +import Anoma.Rpc.GrpcMethodUrl diff --git a/src/Anoma/Rpc/GrpcMethodUrl.hs b/src/Anoma/Rpc/GrpcMethodUrl.hs new file mode 100644 index 0000000000..ec6acaf19d --- /dev/null +++ b/src/Anoma/Rpc/GrpcMethodUrl.hs @@ -0,0 +1,23 @@ +module Anoma.Rpc.GrpcMethodUrl + ( GrpcMethodUrl, + mkGrpcMethodUrl, + grpcMethodUrlToText, + ) +where + +import Data.Text qualified as Text +import Juvix.Prelude +import Prelude (show) + +newtype GrpcMethodUrl = GrpcMethodUrl + { _grpcMethodUrl :: NonEmpty Text + } + +mkGrpcMethodUrl :: NonEmpty Text -> GrpcMethodUrl +mkGrpcMethodUrl = GrpcMethodUrl + +grpcMethodUrlToText :: GrpcMethodUrl -> Text +grpcMethodUrlToText (GrpcMethodUrl u) = Text.intercalate "." (toList u) + +instance Show GrpcMethodUrl where + show = unpack . grpcMethodUrlToText diff --git a/src/Anoma/Rpc/RunNock.hs b/src/Anoma/Rpc/RunNock.hs new file mode 100644 index 0000000000..c25a8085f3 --- /dev/null +++ b/src/Anoma/Rpc/RunNock.hs @@ -0,0 +1,61 @@ +module Anoma.Rpc.RunNock where + +import Anoma.Rpc.Base +import Juvix.Prelude +import Juvix.Prelude.Aeson + +runNockGrpcUrl :: GrpcMethodUrl +runNockGrpcUrl = + mkGrpcMethodUrl $ + "Anoma" :| ["Protobuf", "Intents", "Prove"] + +data NockInput + = NockInputText Text + | NockInputJammed Text + +$( deriveJSON + defaultOptions + { constructorTagModifier = \case + "NockInputText" -> "text" + "NockInputJammed" -> "jammed" + _ -> impossibleError "All constructors must be covered", + sumEncoding = ObjectWithSingleField + } + ''NockInput + ) + +data RunNock = RunNock + { _runNockJammedProgram :: Text, + _runNockPrivateInputs :: [NockInput], + _runNockPublicInputs :: [NockInput] + } + +$( deriveJSON + defaultOptions + { unwrapUnaryRecords = True, + fieldLabelModifier = \case + "_runNockJammedProgram" -> "jammed_program" + "_runNockPrivateInputs" -> "private_inputs" + "_runNockPublicInputs" -> "public_inputs" + _ -> impossibleError "All fields must be covered" + } + ''RunNock + ) + +data Response + = ResponseProof Text + | ResponseError Text + +$( deriveJSON + defaultOptions + { unwrapUnaryRecords = True, + sumEncoding = ObjectWithSingleField, + constructorTagModifier = \case + "ResponseProof" -> "proof" + "ResponseError" -> "error" + _ -> impossibleError "All constructors must be covered" + } + ''Response + ) + +makeLenses ''Response diff --git a/src/Juvix/Compiler/Nockma/Encoding/Cue.hs b/src/Juvix/Compiler/Nockma/Encoding/Cue.hs index 1d92d82ce4..8faad322d2 100644 --- a/src/Juvix/Compiler/Nockma/Encoding/Cue.hs +++ b/src/Juvix/Compiler/Nockma/Encoding/Cue.hs @@ -69,7 +69,7 @@ registerElementStart sem = do -- | Convert a BitReadError to a DecodingError handleBitError :: (Member (Error DecodingError) r) => DecodingError -> Sem (Error BitReadError ': r) x -> Sem r x -handleBitError e = mapError @_ @_ @BitReadError (const e) +handleBitError e = mapError @BitReadError (const e) -- | Consume the encoded length from the input bits consumeLength' :: forall r. (Members '[BitReader, Error DecodingError] r) => Sem r Int @@ -174,6 +174,19 @@ cueFromBits :: Sem r (Term a) cueFromBits v = evalBitReader v (evalState (initCueState @a) (runReader initCueEnv cueFromBitsSem)) +cueFromByteStringNatural :: + forall r. + ( Members + '[ Error DecodingError, + Error NockNaturalNaturalError, + Error (ErrNockNatural' Natural) + ] + r + ) => + ByteString -> + Sem r (Term Natural) +cueFromByteStringNatural = cueFromByteString' + cueFromByteString' :: forall a r. ( NockNatural a, @@ -324,7 +337,7 @@ When handling an error with `runError` before `a` is resolved, the compiler cannot distinguish between `Error (ErrNockNatural a)` and `Error DecodingError`. For some `a` it's possible that `ErrNockNatural a` is equal to `DecodingError`. -} -newtype ErrNockNatural' a = ErrNockNatural' (ErrNockNatural a) +newtype ErrNockNatural' a = ErrNockNatural' {_unErrNocknatural' :: ErrNockNatural a} fromNatural' :: forall a r. (NockNatural a, Member (Error (ErrNockNatural' a)) r) => Natural -> Sem r a fromNatural' = mapError (ErrNockNatural' @a) . fromNatural diff --git a/src/Juvix/Compiler/Nockma/Encoding/Jam.hs b/src/Juvix/Compiler/Nockma/Encoding/Jam.hs index 0a7facaf6e..74ec69c11e 100644 --- a/src/Juvix/Compiler/Nockma/Encoding/Jam.hs +++ b/src/Juvix/Compiler/Nockma/Encoding/Jam.hs @@ -100,7 +100,11 @@ jamToByteString :: forall a. (Integral a, Hashable a) => Term a -> ByteString jamToByteString = vectorBitsToByteString . jamToBits -- | jam encode a Nock term to an atom -jam :: forall a r. (Integral a, Hashable a, NockNatural a, Member (Error (ErrNockNatural a)) r) => Term a -> Sem r (Atom a) +jam :: + forall a r. + (Integral a, Hashable a, NockNatural a, Member (Error (ErrNockNatural a)) r) => + Term a -> + Sem r (Atom a) jam t = do let i = fromInteger . vectorBitsToInteger . jamToBits $ t ai <- fromNatural i diff --git a/src/Juvix/Compiler/Nockma/Language.hs b/src/Juvix/Compiler/Nockma/Language.hs index 207ea33cca..024e35efc2 100644 --- a/src/Juvix/Compiler/Nockma/Language.hs +++ b/src/Juvix/Compiler/Nockma/Language.hs @@ -560,3 +560,15 @@ instance (NockmaEq a) => NockmaEq (Term a) where instance (NockmaEq a) => NockmaEq (Cell a) where nockmaEq (Cell l r) (Cell l' r') = nockmaEq l l' && nockmaEq r r' + +unfoldTuple :: Maybe (Term Natural) -> [Term Natural] +unfoldTuple = maybe [] (toList . unfoldTuple1) + +unfoldTuple1 :: Term Natural -> NonEmpty (Term Natural) +unfoldTuple1 = nonEmpty' . run . execOutputList . go + where + go :: (Members '[Output (Term Natural)] r) => Term Natural -> Sem r () + go t = + case t of + TermAtom {} -> output t + TermCell (Cell l r) -> output l >> go r diff --git a/src/Juvix/Compiler/Pipeline.hs b/src/Juvix/Compiler/Pipeline.hs index 4f957b11b6..c76f29f97b 100644 --- a/src/Juvix/Compiler/Pipeline.hs +++ b/src/Juvix/Compiler/Pipeline.hs @@ -52,7 +52,7 @@ import Juvix.Compiler.Reg.Translation.FromAsm qualified as Reg import Juvix.Compiler.Store.Language qualified as Store import Juvix.Compiler.Tree qualified as Tree import Juvix.Data.Effect.Git -import Juvix.Data.Effect.Process +import Juvix.Data.Effect.Process.Base (ProcessE) import Juvix.Data.Field import Parallel.ProgressLog @@ -73,7 +73,7 @@ type PipelineLocalEff = Error DependencyError, GitClone, Error GitProcessError, - Process, + ProcessE, Log, Reader EntryPoint, Files, diff --git a/src/Juvix/Compiler/Reg/Interpreter.hs b/src/Juvix/Compiler/Reg/Interpreter.hs index 0961c72f8b..66181269de 100644 --- a/src/Juvix/Compiler/Reg/Interpreter.hs +++ b/src/Juvix/Compiler/Reg/Interpreter.hs @@ -352,8 +352,8 @@ runIO hin hout infoTable = \case hPutStr hout (ppPrint infoTable arg) return ValVoid ValConstr (Constr (BuiltinTag TagReadLn) []) -> do - liftIO $ hFlush hout - s <- liftIO $ hGetLine hin + hFlush hout + s <- hGetLine hin return (ValString s) val -> return val diff --git a/src/Juvix/Compiler/Tree/Evaluator.hs b/src/Juvix/Compiler/Tree/Evaluator.hs index e8dc8797f0..a104021613 100644 --- a/src/Juvix/Compiler/Tree/Evaluator.hs +++ b/src/Juvix/Compiler/Tree/Evaluator.hs @@ -296,8 +296,8 @@ hRunIO hin hout infoTable = \case hPutStr hout (ppPrint infoTable arg) return ValVoid ValConstr (Constr (BuiltinTag TagReadLn) []) -> do - liftIO $ hFlush hout - s <- liftIO $ hGetLine hin + hFlush hout + s <- hGetLine hin return (ValString s) val -> return val diff --git a/src/Juvix/Compiler/Tree/EvaluatorEff.hs b/src/Juvix/Compiler/Tree/EvaluatorEff.hs index 859b38f50b..83f812bab8 100644 --- a/src/Juvix/Compiler/Tree/EvaluatorEff.hs +++ b/src/Juvix/Compiler/Tree/EvaluatorEff.hs @@ -334,8 +334,8 @@ hRunIO hin hout infoTable = \case hPutStr hout (ppPrint infoTable arg) return ValVoid ValConstr (Constr (BuiltinTag TagReadLn) []) -> do - liftIO $ hFlush hout - s <- liftIO $ hGetLine hin + hFlush hout + s <- hGetLine hin return (ValString s) val -> return val diff --git a/src/Juvix/Data/CodeAnn.hs b/src/Juvix/Data/CodeAnn.hs index c2256fe336..eda39034f6 100644 --- a/src/Juvix/Data/CodeAnn.hs +++ b/src/Juvix/Data/CodeAnn.hs @@ -66,6 +66,9 @@ instance HasAnsiBackend (Doc CodeAnn) where toAnsiDoc = fmap stylize toAnsiStream = fmap stylize . layoutPretty defaultLayoutOptions +simpleErrorCodeAnn :: (PrettyCodeAnn msg) => msg -> SimpleError +simpleErrorCodeAnn = SimpleError . mkAnsiText . ppCodeAnn + kwTypeAnn :: KeywordType -> CodeAnn kwTypeAnn = \case KeywordTypeDelimiter -> AnnDelimiter diff --git a/src/Juvix/Data/Effect/Git/Process.hs b/src/Juvix/Data/Effect/Git/Process.hs index 209339385a..1dba21c5df 100644 --- a/src/Juvix/Data/Effect/Git/Process.hs +++ b/src/Juvix/Data/Effect/Git/Process.hs @@ -13,7 +13,7 @@ newtype CloneEnv = CloneEnv makeLenses ''CloneEnv -- | Run a git command in the current working directory of the parent process. -runGitCmd :: (Members '[Process, Error GitProcessError] r) => [Text] -> Sem r Text +runGitCmd :: (Members '[ProcessE, Error GitProcessError] r) => [Text] -> Sem r Text runGitCmd args = do mcmd <- findExecutable' $(mkRelFile "git") case mcmd of @@ -35,53 +35,53 @@ runGitCmd args = do ExitSuccess -> return (res ^. processResultStdout) -- | Run a git command within a directory, throws an error if the directory is not a valid clone -runGitCmdInDir :: (Members '[Process, Error GitProcessError, Reader CloneEnv] r) => [Text] -> Sem r Text +runGitCmdInDir :: (Members '[ProcessE, Error GitProcessError, Reader CloneEnv] r) => [Text] -> Sem r Text runGitCmdInDir args = do checkValidGitClone runGitCmdInDir' args -- | Run a git command within a directory -runGitCmdInDir' :: (Members '[Process, Error GitProcessError, Reader CloneEnv] r) => [Text] -> Sem r Text +runGitCmdInDir' :: (Members '[ProcessE, Error GitProcessError, Reader CloneEnv] r) => [Text] -> Sem r Text runGitCmdInDir' args = do p <- asks (^. cloneEnvDir) runGitCmd (["--git-dir", ".git", "-C", T.pack (toFilePath p)] <> args) -- | Throws an error if the directory is not a valid git clone -checkValidGitClone :: (Members '[Process, Error GitProcessError, Reader CloneEnv] r) => Sem r () +checkValidGitClone :: (Members '[ProcessE, Error GitProcessError, Reader CloneEnv] r) => Sem r () checkValidGitClone = void gitHeadRef -isValidGitClone :: (Members '[Process, Reader CloneEnv] r) => Sem r Bool +isValidGitClone :: (Members '[ProcessE, Reader CloneEnv] r) => Sem r Bool isValidGitClone = isRight <$> runError @GitProcessError checkValidGitClone -- | Return the normal form of the passed git reference -gitNormalizeRef :: forall r. (Members '[Process, Error GitProcessError, Reader CloneEnv] r) => Text -> Sem r Text +gitNormalizeRef :: forall r. (Members '[ProcessE, Error GitProcessError, Reader CloneEnv] r) => Text -> Sem r Text gitNormalizeRef ref = T.strip <$> runGitCmdInDir' ["rev-parse", "--verify", ref <> "^{commit}"] -- | Return the HEAD ref of the clone -gitHeadRef :: (Members '[Process, Error GitProcessError, Reader CloneEnv] r) => Sem r Text +gitHeadRef :: (Members '[ProcessE, Error GitProcessError, Reader CloneEnv] r) => Sem r Text gitHeadRef = gitNormalizeRef "HEAD" -- | Checkout the clone at a particular ref -gitCheckout :: (Members '[TaggedLock, Process, Error GitProcessError, Reader CloneEnv] r) => Text -> Sem r () +gitCheckout :: (Members '[TaggedLock, ProcessE, Error GitProcessError, Reader CloneEnv] r) => Text -> Sem r () gitCheckout ref = withTaggedLockDir' (void (runGitCmdInDir ["checkout", ref])) -- | Fetch in the clone -gitFetch :: (Members '[TaggedLock, Process, Error GitProcessError, Reader CloneEnv, Internet] r) => Sem r () +gitFetch :: (Members '[TaggedLock, ProcessE, Error GitProcessError, Reader CloneEnv, Internet] r) => Sem r () gitFetch = whenHasInternet gitFetchOnline -gitFetchOnline :: (Members '[TaggedLock, Reader CloneEnv, Error GitProcessError, Process, Online] r) => Sem r () +gitFetchOnline :: (Members '[TaggedLock, Reader CloneEnv, Error GitProcessError, ProcessE, Online] r) => Sem r () gitFetchOnline = withTaggedLockDir' (void (runGitCmdInDir ["fetch"])) -gitCloneOnline :: (Members '[Log, Error GitProcessError, Process, Online, Reader CloneEnv] r) => Text -> Sem r () +gitCloneOnline :: (Members '[Log, Error GitProcessError, ProcessE, Online, Reader CloneEnv] r) => Text -> Sem r () gitCloneOnline url = do p <- asks (^. cloneEnvDir) log ("Cloning " <> url <> " to " <> pack (toFilePath p)) void (runGitCmd ["clone", url, T.pack (toFilePath p)]) -cloneGitRepo :: (Members '[Log, Files, Process, Error GitProcessError, Reader CloneEnv, Internet] r) => Text -> Sem r () +cloneGitRepo :: (Members '[Log, Files, ProcessE, Error GitProcessError, Reader CloneEnv, Internet] r) => Text -> Sem r () cloneGitRepo = whenHasInternet . gitCloneOnline -initGitRepo :: (Members '[TaggedLock, Log, Files, Process, Error GitProcessError, Reader CloneEnv, Internet] r) => Text -> Sem r (Path Abs Dir) +initGitRepo :: (Members '[TaggedLock, Log, Files, ProcessE, Error GitProcessError, Reader CloneEnv, Internet] r) => Text -> Sem r (Path Abs Dir) initGitRepo url = do p <- asks (^. cloneEnvDir) withTaggedLockDir' (unlessM (directoryExists' p) (cloneGitRepo url)) @@ -112,7 +112,7 @@ withTaggedLockDir' ma = do runGitProcess :: forall r a. - (Members '[TaggedLock, Log, Files, Process, Error GitProcessError, Internet] r) => + (Members '[TaggedLock, Log, Files, ProcessE, Error GitProcessError, Internet] r) => Sem (GitClone ': r) a -> Sem r a runGitProcess = runProvider_ helper diff --git a/src/Juvix/Data/Effect/Process/Base.hs b/src/Juvix/Data/Effect/Process/Base.hs index f22f37063b..4aaf52a181 100644 --- a/src/Juvix/Data/Effect/Process/Base.hs +++ b/src/Juvix/Data/Effect/Process/Base.hs @@ -13,10 +13,10 @@ data ProcessCall = ProcessCall _processCallArgs :: [Text] } -data Process :: Effect where - FindExecutable' :: Path Rel File -> Process m (Maybe (Path Abs File)) - ReadProcess' :: ProcessCall -> Process m ProcessResult +data ProcessE :: Effect where + FindExecutable' :: Path Rel File -> ProcessE m (Maybe (Path Abs File)) + ReadProcess' :: ProcessCall -> ProcessE m ProcessResult -makeSem ''Process +makeSem ''ProcessE makeLenses ''ProcessResult makeLenses ''ProcessCall diff --git a/src/Juvix/Data/Effect/Process/IO.hs b/src/Juvix/Data/Effect/Process/IO.hs index fe61277f34..03420258a7 100644 --- a/src/Juvix/Data/Effect/Process/IO.hs +++ b/src/Juvix/Data/Effect/Process/IO.hs @@ -10,7 +10,7 @@ import System.Process.Typed qualified as P runProcessIO :: forall r a. (Members '[EmbedIO] r) => - Sem (Process ': r) a -> + Sem (ProcessE ': r) a -> Sem r a runProcessIO = interpret $ \case FindExecutable' n -> findExecutable n diff --git a/src/Juvix/Data/Error/GenericError.hs b/src/Juvix/Data/Error/GenericError.hs index 2b27218dd3..7dac8376e9 100644 --- a/src/Juvix/Data/Error/GenericError.hs +++ b/src/Juvix/Data/Error/GenericError.hs @@ -20,8 +20,13 @@ newtype GenericOptions = GenericOptions } deriving stock (Eq, Show) +newtype SimpleError = SimpleError + { _simpleErrorMessage :: AnsiText + } + makeLenses ''GenericError makeLenses ''GenericOptions +makeLenses ''SimpleError defaultGenericOptions :: GenericOptions defaultGenericOptions = @@ -36,6 +41,14 @@ instance Pretty GenericError where instance HasLoc GenericError where getLoc = (^. genericErrorLoc) +instance HasAnsiBackend SimpleError where + toAnsiDoc (SimpleError msg) = toAnsiDoc msg + toAnsiStream (SimpleError msg) = toAnsiStream msg + +instance HasTextBackend SimpleError where + toTextStream (SimpleError msg) = toTextStream msg + toTextDoc (SimpleError msg) = toTextDoc msg + genericErrorHeader :: GenericError -> Doc a genericErrorHeader g = pretty (g ^. genericErrorLoc) diff --git a/src/Juvix/Data/FiniteField/PrimeField.hs b/src/Juvix/Data/FiniteField/PrimeField.hs index ee8cf6bb91..b22f34e32b 100644 --- a/src/Juvix/Data/FiniteField/PrimeField.hs +++ b/src/Juvix/Data/FiniteField/PrimeField.hs @@ -33,7 +33,7 @@ import GHC.TypeLits.Singletons () import Juvix.Data.FiniteField.Base import Juvix.Prelude.Base.Foundation hiding (toInteger) import Language.Haskell.TH qualified as TH -import Prelude (Read, readsPrec, showsPrec) +import Prelude (readsPrec, showsPrec) -- | Finite field of prime order p, Fp = Z/pZ. -- diff --git a/src/Juvix/Extra/Paths.hs b/src/Juvix/Extra/Paths.hs index d127e1eb86..84dbbb432f 100644 --- a/src/Juvix/Extra/Paths.hs +++ b/src/Juvix/Extra/Paths.hs @@ -21,6 +21,9 @@ cssDir = map (first relFile) $(cssDirQ) juvixSty :: ByteString juvixSty = $(juvixStyQ) +anomaStartExs :: ByteString +anomaStartExs = $(anomaStartExsQ) + jsDir :: [(Path Rel File, ByteString)] jsDir = map (first relFile) $(jsDirQ) diff --git a/src/Juvix/Extra/Paths/Base.hs b/src/Juvix/Extra/Paths/Base.hs index dee0093307..d359069e1f 100644 --- a/src/Juvix/Extra/Paths/Base.hs +++ b/src/Juvix/Extra/Paths/Base.hs @@ -15,6 +15,9 @@ cssDirQ = FE.makeRelativeToProject "assets/css" >>= FE.embedDir juvixStyQ :: Q Exp juvixStyQ = FE.embedFileRelative "include/latex/juvix.sty" +anomaStartExsQ :: Q Exp +anomaStartExsQ = FE.embedFileRelative "include/anoma/start.exs" + jsDirQ :: Q Exp jsDirQ = FE.makeRelativeToProject "assets/js" >>= FE.embedDir diff --git a/src/Juvix/Prelude/Aeson.hs b/src/Juvix/Prelude/Aeson.hs index d33959149a..26f1d8300e 100644 --- a/src/Juvix/Prelude/Aeson.hs +++ b/src/Juvix/Prelude/Aeson.hs @@ -1,12 +1,14 @@ module Juvix.Prelude.Aeson ( module Juvix.Prelude.Aeson, module Data.Aeson, + module Data.Aeson.TH, module Data.Aeson.Text, ) where import Data.Aeson import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.TH import Data.Aeson.Text import Data.ByteString.Lazy qualified as BS import Data.Text.Lazy qualified as Lazy @@ -17,10 +19,10 @@ readJSONFile f = do bs <- BS.readFile f return $ decode bs -encodeToText :: (ToJSON a) => a -> Text -encodeToText = Lazy.toStrict . encodeToLazyText +jsonEncodeToText :: (ToJSON a) => a -> Text +jsonEncodeToText = Lazy.toStrict . encodeToLazyText -appendFields :: [(Key, Value)] -> Value -> Value -appendFields keyValues = \case +jsonAppendFields :: [(Key, Value)] -> Value -> Value +jsonAppendFields keyValues = \case Object obj -> Object (KeyMap.fromList keyValues <> obj) a -> a diff --git a/src/Juvix/Prelude/Base/Foundation.hs b/src/Juvix/Prelude/Base/Foundation.hs index 204e25905a..630dd41845 100644 --- a/src/Juvix/Prelude/Base/Foundation.hs +++ b/src/Juvix/Prelude/Base/Foundation.hs @@ -180,7 +180,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 (getLine, hPutStr, hPutStrLn, putStr, putStrLn, readFile, writeFile) +import Data.Text.IO.Utf8 hiding (getLine, hGetLine, hPutStr, hPutStrLn, putStr, putStrLn, readFile, writeFile) import Data.Text.IO.Utf8 qualified as Utf8 import Data.Text.Lazy.Builder qualified as LazyText import Data.Traversable @@ -213,8 +213,11 @@ import System.IO hiding ( appendFile, getContents, getLine, + hClose, + hFlush, hGetContents, hGetLine, + hIsEOF, hPutStr, hPutStrLn, interact, @@ -229,7 +232,7 @@ import System.IO hiding ) import System.IO qualified as IO import System.IO.Error -import Text.Read (readEither) +import Text.Read (Read, readEither) import Text.Read qualified as Text import Text.Show (Show) import Text.Show qualified as Show @@ -248,6 +251,9 @@ type SimpleFold s a = forall r. (Monoid r) => Getting r s a type SimpleGetter s a = forall r. Getting r s a +readJust :: (Read a) => String -> a +readJust = Text.read + traverseM :: (Monad m, Traversable m, Applicative f) => (a1 -> f (m a2)) -> @@ -559,6 +565,18 @@ indexFrom i = zipWith Indexed [i ..] makeLenses ''Indexed +hClose :: (MonadIO m) => Handle -> m () +hClose = liftIO . IO.hClose + +hGetLine :: (MonadIO m) => Handle -> m Text +hGetLine = liftIO . Utf8.hGetLine + +hIsEOF :: (MonadIO m) => Handle -> m Bool +hIsEOF = liftIO . IO.hIsEOF + +hFlush :: (MonadIO m) => Handle -> m () +hFlush = liftIO . IO.hFlush + toTuple :: Indexed a -> (Int, a) toTuple i = (i ^. indexedIx, i ^. indexedThing) diff --git a/src/Juvix/Prelude/Effects/Base.hs b/src/Juvix/Prelude/Effects/Base.hs index 7afde7b547..5fc441e399 100644 --- a/src/Juvix/Prelude/Effects/Base.hs +++ b/src/Juvix/Prelude/Effects/Base.hs @@ -10,6 +10,7 @@ module Juvix.Prelude.Effects.Base module Effectful.Dispatch.Static, module Effectful.Provider, module Effectful.Concurrent.Async, + module Effectful.Process, ) where @@ -23,6 +24,7 @@ import Effectful.Dispatch.Dynamic qualified as E import Effectful.Dispatch.Static import Effectful.Error.Static hiding (runError, runErrorWith) import Effectful.Internal.Env (getEnv, putEnv) +import Effectful.Process hiding (env) import Effectful.Provider import Effectful.Reader.Static import Effectful.State.Static.Local hiding (runState, state) @@ -109,7 +111,7 @@ modifyShared = Shared.modify modify' :: (Member (State s) r) => (s -> s) -> Sem r () modify' = State.modify -mapError :: (Member (Error b) r) => (a -> b) -> Sem (Error a ': r) x -> Sem r x +mapError :: forall a b r x. (Member (Error b) r) => (a -> b) -> Sem (Error a ': r) x -> Sem r x mapError f = runErrorWith (throwError . f) runM :: (MonadIO m) => Sem '[EmbedIO] a -> m a diff --git a/src/Juvix/Prelude/Trace.hs b/src/Juvix/Prelude/Trace.hs index c926ba1aa0..5643a45ed4 100644 --- a/src/Juvix/Prelude/Trace.hs +++ b/src/Juvix/Prelude/Trace.hs @@ -46,6 +46,6 @@ traceToFile fpath t a = return a {-# WARNING traceToFile "Using traceToFile" #-} -traceToFileM :: (Applicative m) => Path Abs File -> Text -> a -> m () -traceToFileM fpath t a = pure (traceToFile fpath t a) $> () +traceToFileM :: (Applicative m) => Path Abs File -> Text -> m () +traceToFileM fpath t = pure (traceToFile fpath t ()) $> () {-# WARNING traceToFileM "Using traceFileM" #-} diff --git a/test/Base.hs b/test/Base.hs index 01758b7249..68eaded81d 100644 --- a/test/Base.hs +++ b/test/Base.hs @@ -21,7 +21,7 @@ import Juvix.Compiler.Pipeline.Loader.PathResolver import Juvix.Compiler.Pipeline.Run import Juvix.Data.Effect.TaggedLock import Juvix.Extra.Paths hiding (rootBuildDir) -import Juvix.Prelude hiding (assert) +import Juvix.Prelude hiding (assert, readProcess) import Juvix.Prelude.Env import Juvix.Prelude.Pretty (prettyString) import System.Process qualified as P diff --git a/tests/Anoma/Compilation/positive/test003.juvix b/tests/Anoma/Compilation/positive/test003.juvix index 8e0005ad59..f9d007a091 100644 --- a/tests/Anoma/Compilation/positive/test003.juvix +++ b/tests/Anoma/Compilation/positive/test003.juvix @@ -1,14 +1,6 @@ -- Integer arithmetic module test003; -{- - -Multiline comment - -{- nested comments work -} - --} - import Stdlib.Prelude open; import Stdlib.Debug.Trace open; diff --git a/tests/Casm/Compilation/positive/test003.juvix b/tests/Casm/Compilation/positive/test003.juvix index 535c119129..59edd8773d 100644 --- a/tests/Casm/Compilation/positive/test003.juvix +++ b/tests/Casm/Compilation/positive/test003.juvix @@ -1,14 +1,6 @@ -- Integer arithmetic module test003; -{- - -Multiline comment - -{- nested comments work -} - --} - import Stdlib.Prelude open; main : Nat := mod 3 2 + div 18 4 + mod 18 4 + div 16 4 + mod 16 4; diff --git a/tests/Compilation/positive/test003.juvix b/tests/Compilation/positive/test003.juvix index 015fc6aa64..2b7247e005 100644 --- a/tests/Compilation/positive/test003.juvix +++ b/tests/Compilation/positive/test003.juvix @@ -1,14 +1,6 @@ -- Integer arithmetic module test003; -{- - -Multiline comment - -{- nested comments work -} - --} - import Stdlib.Prelude open; main : IO := diff --git a/tests/Rust/Compilation/positive/test003.juvix b/tests/Rust/Compilation/positive/test003.juvix index 535c119129..59edd8773d 100644 --- a/tests/Rust/Compilation/positive/test003.juvix +++ b/tests/Rust/Compilation/positive/test003.juvix @@ -1,14 +1,6 @@ -- Integer arithmetic module test003; -{- - -Multiline comment - -{- nested comments work -} - --} - import Stdlib.Prelude open; main : Nat := mod 3 2 + div 18 4 + mod 18 4 + div 16 4 + mod 16 4;