From cf8bef4efbc74cef3ab67c3e34a765653666a896 Mon Sep 17 00:00:00 2001 From: Paul Cadman Date: Thu, 26 Sep 2024 18:07:54 +0100 Subject: [PATCH 1/8] Serialize Nockma output using nock jam The Anoma API accepts jammed nock terms as input. The benefit to this is that jammed terms are greatly compressed compared to the original term. --- app/Commands/Compile/Anoma.hs | 7 ++++--- src/Juvix/Compiler/Nockma/Encoding/Jam.hs | 4 ++++ 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/app/Commands/Compile/Anoma.hs b/app/Commands/Compile/Anoma.hs index 5b0086158e..516fedf72f 100644 --- a/app/Commands/Compile/Anoma.hs +++ b/app/Commands/Compile/Anoma.hs @@ -3,6 +3,7 @@ module Commands.Compile.Anoma where import Commands.Base import Commands.Compile.Anoma.Options import Commands.Extra.NewCompile +import Juvix.Compiler.Nockma.Encoding.Jam qualified as Encoding import Juvix.Compiler.Nockma.Pretty qualified as Nockma import Juvix.Compiler.Nockma.Translation.FromTree qualified as Nockma @@ -25,9 +26,9 @@ runCommand opts = do res <- getRight r outputAnomaResult (opts' ^. compileDebug) nockmaFile res -outputAnomaResult :: (Members '[EmbedIO, App] r) => Bool -> Path Abs File -> Nockma.AnomaResult -> Sem r () +outputAnomaResult :: (Members '[EmbedIO, App, Files] r) => Bool -> Path Abs File -> Nockma.AnomaResult -> Sem r () outputAnomaResult debugOutput nockmaFile Nockma.AnomaResult {..} = do - let code = Nockma.ppSerialize _anomaClosure + let code = Encoding.jamToByteString _anomaClosure prettyNockmaFile = replaceExtensions' [".debug", ".nockma"] nockmaFile - writeFileEnsureLn nockmaFile code + writeFileBS nockmaFile code when debugOutput (writeFileEnsureLn prettyNockmaFile (Nockma.ppPrint _anomaClosure)) diff --git a/src/Juvix/Compiler/Nockma/Encoding/Jam.hs b/src/Juvix/Compiler/Nockma/Encoding/Jam.hs index 393b174e79..0a7facaf6e 100644 --- a/src/Juvix/Compiler/Nockma/Encoding/Jam.hs +++ b/src/Juvix/Compiler/Nockma/Encoding/Jam.hs @@ -95,6 +95,10 @@ jamToBits = . evalState (initJamState @a) . jamSem +-- | jam encode a Nock term to the bytes encoding of an atom +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 t = do From 9635e4fb7c35d05053cc9ed506999718e618fd26 Mon Sep 17 00:00:00 2001 From: Paul Cadman Date: Fri, 27 Sep 2024 14:05:23 +0100 Subject: [PATCH 2/8] cue the input file in the nockma dev commands --- app/Commands/Dev/Nockma/Run.hs | 2 +- src/Juvix/Compiler/Nockma/Encoding/Cue.hs | 37 ++++++++++++++++++- src/Juvix/Compiler/Nockma/Evaluator/Error.hs | 7 ---- .../Nockma/Translation/FromSource/Base.hs | 10 +++++ .../Nockma/Translation/FromSource/Error.hs | 15 ++++++++ 5 files changed, 62 insertions(+), 9 deletions(-) create mode 100644 src/Juvix/Compiler/Nockma/Translation/FromSource/Error.hs diff --git a/app/Commands/Dev/Nockma/Run.hs b/app/Commands/Dev/Nockma/Run.hs index de1797a526..e66aa7ba34 100644 --- a/app/Commands/Dev/Nockma/Run.hs +++ b/app/Commands/Dev/Nockma/Run.hs @@ -14,7 +14,7 @@ runCommand opts = do afile <- fromAppPathFile inputFile argsFile <- mapM fromAppPathFile (opts ^. nockmaRunArgs) parsedArgs <- mapM (Nockma.parseTermFile >=> checkParsed) argsFile - parsedTerm <- Nockma.parseTermFile afile >>= checkParsed + parsedTerm <- Nockma.parseJammedFile afile case parsedTerm of t@(TermCell {}) -> do let formula = anomaCallTuple parsedArgs diff --git a/src/Juvix/Compiler/Nockma/Encoding/Cue.hs b/src/Juvix/Compiler/Nockma/Encoding/Cue.hs index ee20276373..ff6fd60c9d 100644 --- a/src/Juvix/Compiler/Nockma/Encoding/Cue.hs +++ b/src/Juvix/Compiler/Nockma/Encoding/Cue.hs @@ -154,7 +154,7 @@ atomToBits a' = do n <- nockNatural' a' return (integerToVectorBits @Integer (fromIntegral n)) --- | Transfor a vector of bits to a decoded term +-- | Transform a vector of bits to a decoded term cueFromBits :: forall a r. ( NockNatural a, @@ -168,6 +168,19 @@ cueFromBits :: Sem r (Term a) cueFromBits v = evalBitReader v (evalState (initCueState @a) (runReader initCueEnv cueFromBitsSem)) +cueFromByteString' :: + forall a r. + ( NockNatural a, + Members + '[ Error DecodingError, + Error (ErrNockNatural' a) + ] + r + ) => + ByteString -> + Sem r (Term a) +cueFromByteString' = cueFromBits . cloneFromByteString + cueFromBitsSem :: forall a r. ( NockNatural a, @@ -275,6 +288,28 @@ cueEither = . runErrorNoCallStack @DecodingError . cue' +cueFromByteString :: + -- NB: The signature returns the DecodingError in an Either to avoid + -- overlapping instances with `ErrNockNatural a` when errors are handled. See + -- the comment above `ErrNockNatural' a` for more explanation. + forall a r. + ( NockNatural a, + Member (Error (ErrNockNatural a)) r + ) => + ByteString -> + Sem r (Either DecodingError (Term a)) +cueFromByteString = + runErrorNoCallStackWith @(ErrNockNatural' a) (\(ErrNockNatural' e) -> throw e) + . runErrorNoCallStack @DecodingError + . cueFromByteString' + +cueFromByteString'' :: + forall a. + (NockNatural a) => + ByteString -> + Either (ErrNockNatural a) (Either DecodingError (Term a)) +cueFromByteString'' = run . runErrorNoCallStack . cueFromByteString + {- `ErrNockNatural a` must be wrapped in a newtype to avoid overlapping instances with `DecodingError` when errors are handled before the type variable `a` is resolved. diff --git a/src/Juvix/Compiler/Nockma/Evaluator/Error.hs b/src/Juvix/Compiler/Nockma/Evaluator/Error.hs index c35c1a15c9..1f76d64566 100644 --- a/src/Juvix/Compiler/Nockma/Evaluator/Error.hs +++ b/src/Juvix/Compiler/Nockma/Evaluator/Error.hs @@ -26,13 +26,6 @@ data NockEvalError a | ErrDecodingFailed (DecodingFailed a) | ErrVerificationFailed (VerificationFailed a) -newtype GenericNockEvalError = GenericNockEvalError - { _genericNockEvalErrorMessage :: AnsiText - } - -class ToGenericNockEvalError a where - toGenericNockEvalError :: a -> GenericNockEvalError - data ExpectedCell a = ExpectedCell { _expectedCellCtx :: EvalCtx, _expectedCellAtom :: Atom a diff --git a/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs b/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs index 59f8e61ff4..17c7cd4c6f 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs @@ -14,6 +14,8 @@ import Juvix.Prelude qualified as Prelude import Juvix.Prelude.Parsing hiding (runParser) import Text.Megaparsec qualified as P import Text.Megaparsec.Char.Lexer qualified as L +import Juvix.Compiler.Nockma.Encoding.Cue qualified as Cue +import Data.ByteString qualified as BS type Parser = Parsec Void Text @@ -23,6 +25,14 @@ parseText = runParser noFile parseReplText :: Text -> Either MegaparsecError (ReplTerm Natural) parseReplText = runParserFor replTerm noFile +parseJammedFile :: (MonadIO m) => Prelude.Path Abs File -> m (Term Natural) +parseJammedFile fp = do + bs <- liftIO (BS.readFile (toFilePath fp)) + case Cue.cueFromByteString'' @Natural bs of + Left _ -> error "nock natural error" + Right (Left _) -> error "cue decoding error" + Right (Right t) -> return t + parseTermFile :: (MonadIO m) => Prelude.Path Abs File -> m (Either MegaparsecError (Term Natural)) parseTermFile fp = do txt <- readFile fp diff --git a/src/Juvix/Compiler/Nockma/Translation/FromSource/Error.hs b/src/Juvix/Compiler/Nockma/Translation/FromSource/Error.hs new file mode 100644 index 0000000000..fa19a1e71f --- /dev/null +++ b/src/Juvix/Compiler/Nockma/Translation/FromSource/Error.hs @@ -0,0 +1,15 @@ +module Juvix.Compiler.Nockma.Translation.FromSource.Error where + +import Juvix.Prelude.Base +import Juvix.Compiler.Nockma.Encoding.Cue qualified as Cue +import Juvix.Compiler.Nockma.Language (NockNaturalNaturalError) +import Juvix.Prelude.Pretty + +data CueDecodingError + = ErrDecodingError Cue.DecodingError + | ErrNockNaturalError NockNaturalNaturalError + deriving stock (Show) + +instance Pretty CueDecodingError where + pretty = \case + ErrDecodingError e -> undefined From 3718b302e74643e39c74770982bc336f9fe8dc46 Mon Sep 17 00:00:00 2001 From: Paul Cadman Date: Fri, 4 Oct 2024 13:36:43 +0100 Subject: [PATCH 3/8] Fix formatting --- src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs | 4 ++-- src/Juvix/Compiler/Nockma/Translation/FromSource/Error.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs b/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs index 17c7cd4c6f..aff5e9c479 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs @@ -1,9 +1,11 @@ module Juvix.Compiler.Nockma.Translation.FromSource.Base where +import Data.ByteString qualified as BS import Data.HashMap.Internal.Strict qualified as HashMap import Data.List.NonEmpty qualified as NonEmpty import Data.Text qualified as Text import Juvix.Compiler.Nockma.Encoding.ByteString (textToNatural) +import Juvix.Compiler.Nockma.Encoding.Cue qualified as Cue import Juvix.Compiler.Nockma.Language import Juvix.Extra.Paths import Juvix.Extra.Strings qualified as Str @@ -14,8 +16,6 @@ import Juvix.Prelude qualified as Prelude import Juvix.Prelude.Parsing hiding (runParser) import Text.Megaparsec qualified as P import Text.Megaparsec.Char.Lexer qualified as L -import Juvix.Compiler.Nockma.Encoding.Cue qualified as Cue -import Data.ByteString qualified as BS type Parser = Parsec Void Text diff --git a/src/Juvix/Compiler/Nockma/Translation/FromSource/Error.hs b/src/Juvix/Compiler/Nockma/Translation/FromSource/Error.hs index fa19a1e71f..8046eb6329 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromSource/Error.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromSource/Error.hs @@ -1,8 +1,8 @@ module Juvix.Compiler.Nockma.Translation.FromSource.Error where -import Juvix.Prelude.Base import Juvix.Compiler.Nockma.Encoding.Cue qualified as Cue import Juvix.Compiler.Nockma.Language (NockNaturalNaturalError) +import Juvix.Prelude.Base import Juvix.Prelude.Pretty data CueDecodingError From 3c6d965f14dc34c6257a5036407bc37a04b79020 Mon Sep 17 00:00:00 2001 From: Paul Cadman Date: Fri, 4 Oct 2024 13:39:55 +0100 Subject: [PATCH 4/8] Remove unused file --- .../Nockma/Translation/FromSource/Error.hs | 15 --------------- 1 file changed, 15 deletions(-) delete mode 100644 src/Juvix/Compiler/Nockma/Translation/FromSource/Error.hs diff --git a/src/Juvix/Compiler/Nockma/Translation/FromSource/Error.hs b/src/Juvix/Compiler/Nockma/Translation/FromSource/Error.hs deleted file mode 100644 index 8046eb6329..0000000000 --- a/src/Juvix/Compiler/Nockma/Translation/FromSource/Error.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Juvix.Compiler.Nockma.Translation.FromSource.Error where - -import Juvix.Compiler.Nockma.Encoding.Cue qualified as Cue -import Juvix.Compiler.Nockma.Language (NockNaturalNaturalError) -import Juvix.Prelude.Base -import Juvix.Prelude.Pretty - -data CueDecodingError - = ErrDecodingError Cue.DecodingError - | ErrNockNaturalError NockNaturalNaturalError - deriving stock (Show) - -instance Pretty CueDecodingError where - pretty = \case - ErrDecodingError e -> undefined From 14f11a103747c70160b269df1e9df60c210f702a Mon Sep 17 00:00:00 2001 From: Paul Cadman Date: Fri, 4 Oct 2024 17:18:19 +0100 Subject: [PATCH 5/8] Use cue to read compiled nockma files in nockma run and repl --- app/Commands/Dev/Nockma/Repl.hs | 10 +++++----- app/Commands/Dev/Nockma/Run.hs | 5 ++++- .../Compiler/Nockma/Translation/FromSource/Base.hs | 7 +++---- 3 files changed, 12 insertions(+), 10 deletions(-) diff --git a/app/Commands/Dev/Nockma/Repl.hs b/app/Commands/Dev/Nockma/Repl.hs index 3e34b04ea3..aa016ed12e 100644 --- a/app/Commands/Dev/Nockma/Repl.hs +++ b/app/Commands/Dev/Nockma/Repl.hs @@ -181,7 +181,7 @@ replAction = banner } -runCommand :: forall r. (Members '[EmbedIO, App] r) => NockmaReplOptions -> Sem r () +runCommand :: forall r. (Members '[Files, EmbedIO, App] r) => NockmaReplOptions -> Sem r () runCommand opts = do mt :: Maybe (Term Natural) <- mapM iniStack (opts ^. nockmaReplOptionsStackFile) liftIO . (`State.evalStateT` (iniState mt)) $ replAction @@ -189,10 +189,7 @@ runCommand opts = do iniStack :: AppPath File -> Sem r (Term Natural) iniStack af = do afile <- fromAppPathFile af - parsedTerm <- Nockma.parseTermFile afile - case parsedTerm of - Left err -> exitJuvixError (JuvixError err) - Right t -> return t + checkCued (Nockma.cueJammedFile afile) iniState :: Maybe (Term Natural) -> ReplState iniState mt = @@ -202,3 +199,6 @@ runCommand opts = do _replStateLoadedFile = Nothing, _replStateLastResult = nockNilTagged "repl-result" } + + checkCued :: Sem (Error JuvixError ': r) a -> Sem r a + checkCued = runErrorNoCallStackWith exitJuvixError diff --git a/app/Commands/Dev/Nockma/Run.hs b/app/Commands/Dev/Nockma/Run.hs index e66aa7ba34..45762f3539 100644 --- a/app/Commands/Dev/Nockma/Run.hs +++ b/app/Commands/Dev/Nockma/Run.hs @@ -14,7 +14,7 @@ runCommand opts = do afile <- fromAppPathFile inputFile argsFile <- mapM fromAppPathFile (opts ^. nockmaRunArgs) parsedArgs <- mapM (Nockma.parseTermFile >=> checkParsed) argsFile - parsedTerm <- Nockma.parseJammedFile afile + parsedTerm <- checkCued (Nockma.cueJammedFile afile) case parsedTerm of t@(TermCell {}) -> do let formula = anomaCallTuple parsedArgs @@ -35,3 +35,6 @@ runCommand opts = do checkParsed = \case Left err -> exitJuvixError (JuvixError err) Right tm -> return tm + + checkCued :: Sem (Error JuvixError ': r) a -> Sem r a + checkCued = runErrorNoCallStackWith exitJuvixError diff --git a/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs b/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs index aff5e9c479..fa899629c2 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs @@ -1,6 +1,5 @@ module Juvix.Compiler.Nockma.Translation.FromSource.Base where -import Data.ByteString qualified as BS import Data.HashMap.Internal.Strict qualified as HashMap import Data.List.NonEmpty qualified as NonEmpty import Data.Text qualified as Text @@ -25,9 +24,9 @@ parseText = runParser noFile parseReplText :: Text -> Either MegaparsecError (ReplTerm Natural) parseReplText = runParserFor replTerm noFile -parseJammedFile :: (MonadIO m) => Prelude.Path Abs File -> m (Term Natural) -parseJammedFile fp = do - bs <- liftIO (BS.readFile (toFilePath fp)) +cueJammedFile :: (Members '[Files, Error JuvixError] r) => Prelude.Path Abs File -> Sem r (Term Natural) +cueJammedFile fp = do + bs <- readFileBS' fp case Cue.cueFromByteString'' @Natural bs of Left _ -> error "nock natural error" Right (Left _) -> error "cue decoding error" From 34bffaf8fc3d5fe4bbb31544dc8a631dfcfe78f4 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Mon, 21 Oct 2024 18:39:32 +0200 Subject: [PATCH 6/8] better errors --- src/Juvix/Compiler/Nockma/Encoding/Cue.hs | 24 +++++++++------ src/Juvix/Compiler/Nockma/Language.hs | 2 +- src/Juvix/Compiler/Nockma/Pretty/Base.hs | 10 +++++++ .../Nockma/Translation/FromSource/Base.hs | 29 +++++++++++++++++-- 4 files changed, 52 insertions(+), 13 deletions(-) diff --git a/src/Juvix/Compiler/Nockma/Encoding/Cue.hs b/src/Juvix/Compiler/Nockma/Encoding/Cue.hs index ff6fd60c9d..15424bd352 100644 --- a/src/Juvix/Compiler/Nockma/Encoding/Cue.hs +++ b/src/Juvix/Compiler/Nockma/Encoding/Cue.hs @@ -10,7 +10,7 @@ import Juvix.Prelude.Base import VectorBuilder.Builder as Builder import VectorBuilder.Vector -data CueState a = CueState +newtype CueState a = CueState { _cueStateCache :: HashMap Int (Term a) } @@ -20,7 +20,7 @@ initCueState = { _cueStateCache = mempty } -data CueEnv = CueEnv +newtype CueEnv = CueEnv {_cueEnvStartPos :: Int} initCueEnv :: CueEnv @@ -38,14 +38,20 @@ data DecodingError | DecodingErrorInvalidBackref deriving stock (Show) +instance Pretty DecodingError where + pretty = unAnnotate . ppCodeAnn + +instance PrettyCodeAnn DecodingError where + ppCodeAnn = \case + DecodingErrorInvalidTag -> "Invalid tag" + DecodingErrorCacheMiss -> "Cache miss" + DecodingErrorInvalidLength -> "Invalid length" + DecodingErrorExpectedAtom -> "Expected atom" + DecodingErrorInvalidAtom -> "Invalid atom" + DecodingErrorInvalidBackref -> "Invalid backref" + instance PrettyCode DecodingError where - ppCode = \case - DecodingErrorInvalidTag -> return "Invalid tag" - DecodingErrorCacheMiss -> return "Cache miss" - DecodingErrorInvalidLength -> return "Invalid length" - DecodingErrorExpectedAtom -> return "Expected atom" - DecodingErrorInvalidAtom -> return "Invalid atom" - DecodingErrorInvalidBackref -> return "Invalid backref" + ppCode = return . pretty -- | Register the start of processing a new entity registerElementStart :: diff --git a/src/Juvix/Compiler/Nockma/Language.hs b/src/Juvix/Compiler/Nockma/Language.hs index be76c5b089..8e86d32f22 100644 --- a/src/Juvix/Compiler/Nockma/Language.hs +++ b/src/Juvix/Compiler/Nockma/Language.hs @@ -11,8 +11,8 @@ import GHC.Base (Type) import Juvix.Compiler.Core.Language.Base (Symbol) import Juvix.Compiler.Nockma.AnomaLib.Base import Juvix.Compiler.Nockma.Language.Path +import Juvix.Data.CodeAnn import Juvix.Prelude hiding (Atom, Path) -import Juvix.Prelude.Pretty data ReplStatement a = ReplStatementExpression (ReplExpression a) diff --git a/src/Juvix/Compiler/Nockma/Pretty/Base.hs b/src/Juvix/Compiler/Nockma/Pretty/Base.hs index 0b8eb23336..62bc7ee1a8 100644 --- a/src/Juvix/Compiler/Nockma/Pretty/Base.hs +++ b/src/Juvix/Compiler/Nockma/Pretty/Base.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + module Juvix.Compiler.Nockma.Pretty.Base ( module Juvix.Compiler.Nockma.Pretty.Base, module Juvix.Data.CodeAnn, @@ -12,6 +14,9 @@ import Juvix.Data.CodeAnn import Juvix.Extra.Strings qualified as Str import Juvix.Prelude hiding (Atom, Path) +docDefault :: (PrettyCode c) => c -> Doc Ann +docDefault = doc defaultOptions + doc :: (PrettyCode c) => Options -> c -> Doc Ann doc opts = run @@ -24,6 +29,11 @@ class PrettyCode c where runPrettyCode :: (PrettyCode c) => Options -> c -> Doc Ann runPrettyCode opts = run . runReader opts . ppCode +instance PrettyCodeAnn NockNaturalNaturalError where + ppCodeAnn = \case + NaturalInvalidPath a -> "Invalid path" <+> docDefault a + NaturalInvalidOp a -> "Invalid operator code" <+> docDefault a + instance forall a. (PrettyCode a, NockNatural a) => PrettyCode (Atom a) where ppCode atm = do t <- runFail $ do diff --git a/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs b/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs index fa899629c2..3f5a7708d1 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs @@ -6,6 +6,7 @@ import Data.Text qualified as Text import Juvix.Compiler.Nockma.Encoding.ByteString (textToNatural) import Juvix.Compiler.Nockma.Encoding.Cue qualified as Cue import Juvix.Compiler.Nockma.Language +import Juvix.Data.CodeAnn import Juvix.Extra.Paths import Juvix.Extra.Strings qualified as Str import Juvix.Parser.Error @@ -24,13 +25,35 @@ parseText = runParser noFile parseReplText :: Text -> Either MegaparsecError (ReplTerm Natural) parseReplText = runParserFor replTerm noFile -cueJammedFile :: (Members '[Files, Error JuvixError] r) => Prelude.Path Abs File -> Sem r (Term Natural) +cueJammedFile :: forall r. (Members '[Files, Error JuvixError] r) => Prelude.Path Abs File -> Sem r (Term Natural) cueJammedFile fp = do bs <- readFileBS' fp case Cue.cueFromByteString'' @Natural bs of - Left _ -> error "nock natural error" - Right (Left _) -> error "cue decoding error" + Left e -> natErr e + Right (Left e) -> decodingErr e Right (Right t) -> return t + where + err :: AnsiText -> Sem r x + err msg = + throw $ + JuvixError + GenericError + { _genericErrorLoc = i, + _genericErrorIntervals = [i], + _genericErrorMessage = msg + } + + decodingErr :: Cue.DecodingError -> Sem r x + decodingErr e = err (mkAnsiText (ppCodeAnn e)) + + natErr :: NockNaturalNaturalError -> Sem r x + natErr e = err (mkAnsiText (ppCodeAnn e)) + + i :: Interval + i = mkInterval loc loc + where + loc :: Loc + loc = mkInitialLoc fp parseTermFile :: (MonadIO m) => Prelude.Path Abs File -> m (Either MegaparsecError (Term Natural)) parseTermFile fp = do From 67e456776113ea00cb615f350fd2916a698a6e1c Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Tue, 22 Oct 2024 09:14:31 +0200 Subject: [PATCH 7/8] parsing --- app/Commands/Compile/Anoma.hs | 2 +- app/Commands/Dev/Nockma/Eval.hs | 7 ++-- app/Commands/Dev/Nockma/Format.hs | 8 ++--- app/Commands/Dev/Nockma/Repl.hs | 5 +-- app/Commands/Dev/Nockma/Run.hs | 10 ++---- src/Juvix/Compiler/Nockma/Encoding/Cue.hs | 2 +- src/Juvix/Compiler/Nockma/Language.hs | 3 ++ .../Nockma/Translation/FromSource/Base.hs | 34 +++++++++++++++---- src/Juvix/Data/FileExt.hs | 20 +++++++++++ src/Juvix/Prelude/Effects/Accum.hs | 1 + src/Juvix/Prelude/Path.hs | 12 +++---- 11 files changed, 70 insertions(+), 34 deletions(-) diff --git a/app/Commands/Compile/Anoma.hs b/app/Commands/Compile/Anoma.hs index 516fedf72f..b6b62da809 100644 --- a/app/Commands/Compile/Anoma.hs +++ b/app/Commands/Compile/Anoma.hs @@ -29,6 +29,6 @@ runCommand opts = do outputAnomaResult :: (Members '[EmbedIO, App, Files] r) => Bool -> Path Abs File -> Nockma.AnomaResult -> Sem r () outputAnomaResult debugOutput nockmaFile Nockma.AnomaResult {..} = do let code = Encoding.jamToByteString _anomaClosure - prettyNockmaFile = replaceExtensions' [".debug", ".nockma"] nockmaFile + prettyNockmaFile = replaceExtensions' nockmaDebugFileExts nockmaFile writeFileBS nockmaFile code when debugOutput (writeFileEnsureLn prettyNockmaFile (Nockma.ppPrint _anomaClosure)) diff --git a/app/Commands/Dev/Nockma/Eval.hs b/app/Commands/Dev/Nockma/Eval.hs index 961d604cfe..ae741cd5fc 100644 --- a/app/Commands/Dev/Nockma/Eval.hs +++ b/app/Commands/Dev/Nockma/Eval.hs @@ -10,10 +10,9 @@ import Juvix.Compiler.Nockma.Translation.FromSource qualified as Nockma runCommand :: forall r. (Members AppEffects r) => NockmaEvalOptions -> Sem r () runCommand opts = do afile <- fromAppPathFile file - parsedTerm <- Nockma.parseTermFile afile + parsedTerm <- runAppError @JuvixError (Nockma.cueJammedFileOrPretty afile) case parsedTerm of - Left err -> exitJuvixError (JuvixError err) - Right (TermCell c) -> do + TermCell c -> do (counts, res) <- runOpCounts . runReader defaultEvalOptions @@ -22,7 +21,7 @@ runCommand opts = do putStrLn (ppPrint res) let statsFile = replaceExtension' ".profile" afile writeFileEnsureLn statsFile (prettyText counts) - Right TermAtom {} -> exitFailMsg "Expected nockma input to be a cell" + TermAtom {} -> exitFailMsg "Expected nockma input to be a cell" where file :: AppPath File file = opts ^. nockmaEvalFile diff --git a/app/Commands/Dev/Nockma/Format.hs b/app/Commands/Dev/Nockma/Format.hs index 48c702673b..d1a2c6c0a9 100644 --- a/app/Commands/Dev/Nockma/Format.hs +++ b/app/Commands/Dev/Nockma/Format.hs @@ -5,13 +5,11 @@ import Commands.Dev.Nockma.Format.Options import Juvix.Compiler.Nockma.Pretty import Juvix.Compiler.Nockma.Translation.FromSource qualified as Nockma -runCommand :: forall r. (Members '[EmbedIO, App] r) => NockmaFormatOptions -> Sem r () +runCommand :: forall r. (Members AppEffects r) => NockmaFormatOptions -> Sem r () runCommand opts = do afile <- fromAppPathFile file - parsedTerm <- Nockma.parseTermFile afile - case parsedTerm of - Left err -> exitJuvixError (JuvixError err) - Right t -> putStrLn (ppPrint t) + parsedTerm <- runAppError @JuvixError (Nockma.parseTermFile afile) + putStrLn (ppPrint parsedTerm) where file :: AppPath File file = opts ^. nockmaFormatFile diff --git a/app/Commands/Dev/Nockma/Repl.hs b/app/Commands/Dev/Nockma/Repl.hs index aa016ed12e..8bac5c6cce 100644 --- a/app/Commands/Dev/Nockma/Repl.hs +++ b/app/Commands/Dev/Nockma/Repl.hs @@ -10,7 +10,7 @@ import Juvix.Compiler.Nockma.Evaluator.Options import Juvix.Compiler.Nockma.Language import Juvix.Compiler.Nockma.Pretty import Juvix.Compiler.Nockma.Pretty qualified as Nockma -import Juvix.Compiler.Nockma.Translation.FromSource (parseProgramFile, parseReplStatement, parseReplText, parseText) +import Juvix.Compiler.Nockma.Translation.FromSource (cueJammedFileOrPrettyProgram, parseReplStatement, parseReplText, parseText) import Juvix.Compiler.Nockma.Translation.FromSource qualified as Nockma import Juvix.Parser.Error import Juvix.Prelude qualified as Prelude @@ -111,7 +111,8 @@ getProgram :: Repl (Maybe (Program Natural)) getProgram = State.gets (^. replStateProgram) readProgram :: Prelude.Path Abs File -> Repl (Program Natural) -readProgram s = fromMegaParsecError <$> parseProgramFile s +readProgram s = runM . runFilesIO $ do + runErrorIO' @JuvixError (cueJammedFileOrPrettyProgram s) direction' :: String -> Repl () direction' s = Repline.dontCrash $ do diff --git a/app/Commands/Dev/Nockma/Run.hs b/app/Commands/Dev/Nockma/Run.hs index 45762f3539..7350f3f376 100644 --- a/app/Commands/Dev/Nockma/Run.hs +++ b/app/Commands/Dev/Nockma/Run.hs @@ -7,14 +7,13 @@ import Juvix.Compiler.Nockma.EvalCompiled import Juvix.Compiler.Nockma.Evaluator import Juvix.Compiler.Nockma.Pretty import Juvix.Compiler.Nockma.Translation.FromSource qualified as Nockma -import Juvix.Parser.Error runCommand :: forall r. (Members AppEffects r) => NockmaRunOptions -> Sem r () runCommand opts = do afile <- fromAppPathFile inputFile argsFile <- mapM fromAppPathFile (opts ^. nockmaRunArgs) - parsedArgs <- mapM (Nockma.parseTermFile >=> checkParsed) argsFile - parsedTerm <- checkCued (Nockma.cueJammedFile afile) + parsedArgs <- runAppError @JuvixError (mapM Nockma.cueJammedFileOrPretty argsFile) + parsedTerm <- checkCued (Nockma.cueJammedFileOrPretty afile) case parsedTerm of t@(TermCell {}) -> do let formula = anomaCallTuple parsedArgs @@ -31,10 +30,5 @@ runCommand opts = do inputFile :: AppPath File inputFile = opts ^. nockmaRunFile - checkParsed :: Either MegaparsecError (Term Natural) -> Sem r (Term Natural) - checkParsed = \case - Left err -> exitJuvixError (JuvixError err) - Right tm -> return tm - checkCued :: Sem (Error JuvixError ': r) a -> Sem r a checkCued = runErrorNoCallStackWith exitJuvixError diff --git a/src/Juvix/Compiler/Nockma/Encoding/Cue.hs b/src/Juvix/Compiler/Nockma/Encoding/Cue.hs index 15424bd352..1d92d82ce4 100644 --- a/src/Juvix/Compiler/Nockma/Encoding/Cue.hs +++ b/src/Juvix/Compiler/Nockma/Encoding/Cue.hs @@ -51,7 +51,7 @@ instance PrettyCodeAnn DecodingError where DecodingErrorInvalidBackref -> "Invalid backref" instance PrettyCode DecodingError where - ppCode = return . pretty + ppCode = return . ppCodeAnn -- | Register the start of processing a new entity registerElementStart :: diff --git a/src/Juvix/Compiler/Nockma/Language.hs b/src/Juvix/Compiler/Nockma/Language.hs index 8e86d32f22..207ea33cca 100644 --- a/src/Juvix/Compiler/Nockma/Language.hs +++ b/src/Juvix/Compiler/Nockma/Language.hs @@ -245,6 +245,9 @@ makeLenses ''WithStack makeLenses ''AtomInfo makeLenses ''CellInfo +singletonProgram :: Term a -> Program a +singletonProgram t = Program [StatementStandalone t] + isCell :: Term a -> Bool isCell = \case TermCell {} -> True diff --git a/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs b/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs index 3f5a7708d1..c2dc3d9f12 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs @@ -25,6 +25,28 @@ parseText = runParser noFile parseReplText :: Text -> Either MegaparsecError (ReplTerm Natural) parseReplText = runParserFor replTerm noFile +-- | If the file ends in .debug.nockma it parses an annotated unjammed term. Otherwise +-- it is equivalent to cueJammedFile +cueJammedFileOrPretty :: + forall r. + (Members '[Files, Error JuvixError] r) => + Prelude.Path Abs File -> + Sem r (Term Natural) +cueJammedFileOrPretty f + | f `hasExtensions` nockmaDebugFileExts = parseTermFile f + | otherwise = cueJammedFile f + +-- | If the file ends in .debug.nockma it parses an annotated unjammed program. Otherwise +-- it parses program with a single jammed term +cueJammedFileOrPrettyProgram :: + forall r. + (Members '[Files, Error JuvixError] r) => + Prelude.Path Abs File -> + Sem r (Program Natural) +cueJammedFileOrPrettyProgram f + | f `hasExtensions` nockmaDebugFileExts = parseProgramFile f + | otherwise = singletonProgram <$> cueJammedFile f + cueJammedFile :: forall r. (Members '[Files, Error JuvixError] r) => Prelude.Path Abs File -> Sem r (Term Natural) cueJammedFile fp = do bs <- readFileBS' fp @@ -55,15 +77,15 @@ cueJammedFile fp = do loc :: Loc loc = mkInitialLoc fp -parseTermFile :: (MonadIO m) => Prelude.Path Abs File -> m (Either MegaparsecError (Term Natural)) +parseTermFile :: (Members '[Files, Error JuvixError] r) => Prelude.Path Abs File -> Sem r (Term Natural) parseTermFile fp = do - txt <- readFile fp - return (runParser fp txt) + txt <- readFile' fp + either (throw . JuvixError) return (runParser fp txt) -parseProgramFile :: (MonadIO m) => Prelude.Path Abs File -> m (Either MegaparsecError (Program Natural)) +parseProgramFile :: (Members '[Files, Error JuvixError] r) => Prelude.Path Abs File -> Sem r (Program Natural) parseProgramFile fp = do - txt <- readFile fp - return (runParserProgram fp txt) + txt <- readFile' fp + either (throw . JuvixError) return (runParserProgram fp txt) parseReplStatement :: Text -> Either MegaparsecError (ReplStatement Natural) parseReplStatement = runParserFor replStatement noFile diff --git a/src/Juvix/Data/FileExt.hs b/src/Juvix/Data/FileExt.hs index 1f34568a27..f5a4e8c8db 100644 --- a/src/Juvix/Data/FileExt.hs +++ b/src/Juvix/Data/FileExt.hs @@ -32,9 +32,29 @@ data FileExt $(genSingletons [''FileExt]) +splitExtensions :: Path b File -> (Path b File, [String]) +splitExtensions = + swap + . run + . runAccumListReverse + . go + where + go :: (Members '[Accum String] r) => Path b File -> Sem r (Path b File) + go f = case splitExtension f of + Nothing -> return f + Just (f', ext) -> do + accum ext + go f' + +hasExtensions :: (Foldable l) => Path b File -> l String -> Bool +hasExtensions f exts = toList exts == snd (splitExtensions f) + juvixFileExt :: (IsString a) => a juvixFileExt = ".juvix" +nockmaDebugFileExts :: (IsString a) => NonEmpty a +nockmaDebugFileExts = ".debug" :| [".nockma"] + juvixMarkdownFileExt :: (IsString a) => a juvixMarkdownFileExt = ".juvix.md" diff --git a/src/Juvix/Prelude/Effects/Accum.hs b/src/Juvix/Prelude/Effects/Accum.hs index ff23c64611..8a8e66a926 100644 --- a/src/Juvix/Prelude/Effects/Accum.hs +++ b/src/Juvix/Prelude/Effects/Accum.hs @@ -22,6 +22,7 @@ newtype instance StaticRep (Accum o) = Accum accum :: (Member (Accum o) r) => o -> Sem r () accum o = overStaticRep (\(Accum l) -> Accum (o : l)) +-- | Accumulates in LIFO order runAccumListReverse :: Sem (Accum o ': r) a -> Sem r ([o], a) runAccumListReverse m = do (a, Accum s) <- runStaticRep (Accum mempty) m diff --git a/src/Juvix/Prelude/Path.hs b/src/Juvix/Prelude/Path.hs index 5912bb991d..8075a197f4 100644 --- a/src/Juvix/Prelude/Path.hs +++ b/src/Juvix/Prelude/Path.hs @@ -88,18 +88,16 @@ removeExtension = fmap fst . splitExtension removeExtension' :: Path b File -> Path b File removeExtension' = fst . fromJust . splitExtension -addExtensions :: (MonadThrow m) => [String] -> Path b File -> m (Path b File) -addExtensions ext p = case ext of - [] -> return p - e : es -> addExtension e p >>= addExtensions es +addExtensions :: forall m l b. (MonadThrow m, Foldable l) => l String -> Path b File -> m (Path b File) +addExtensions exts p = foldM (flip addExtension) p exts -replaceExtensions :: (MonadThrow m) => [String] -> Path b File -> m (Path b File) +replaceExtensions :: (MonadThrow m, Foldable l) => l String -> Path b File -> m (Path b File) replaceExtensions ext = addExtensions ext . removeExtensions -replaceExtensions' :: [String] -> Path b File -> Path b File +replaceExtensions' :: (Foldable l) => l String -> Path b File -> Path b File replaceExtensions' ext = fromJust . replaceExtensions ext -addExtensions' :: [String] -> Path b File -> Path b File +addExtensions' :: (Foldable l) => l String -> Path b File -> Path b File addExtensions' ext = fromJust . addExtensions ext -- | TODO this is ugly. Please, fix it. FileExtJuvixMarkdown needs special From 4a66cf2dc4dc5a6f0825d621b62e2bf61768b644 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Tue, 22 Oct 2024 17:53:08 +0200 Subject: [PATCH 8/8] add smoke tests --- .../positive/test001-args.debug.nockma | 1 + tests/smoke/Commands/compile.smoke.yaml | 32 +++++++++++++++++++ 2 files changed, 33 insertions(+) create mode 100644 tests/Anoma/Compilation/positive/test001-args.debug.nockma diff --git a/tests/Anoma/Compilation/positive/test001-args.debug.nockma b/tests/Anoma/Compilation/positive/test001-args.debug.nockma new file mode 100644 index 0000000000..5040491f27 --- /dev/null +++ b/tests/Anoma/Compilation/positive/test001-args.debug.nockma @@ -0,0 +1 @@ +[1 100] diff --git a/tests/smoke/Commands/compile.smoke.yaml b/tests/smoke/Commands/compile.smoke.yaml index 88aa15868d..46e0375aa4 100644 --- a/tests/smoke/Commands/compile.smoke.yaml +++ b/tests/smoke/Commands/compile.smoke.yaml @@ -144,6 +144,38 @@ tests: stdout: "" exit-status: 0 + - name: target-anoma-run-debug + command: + shell: + - bash + script: | + temp=$(mktemp -d) + trap 'rm -rf -- "$temp"' EXIT + testdir=$PWD/tests/Anoma/Compilation/positive + cd $temp + juvix --log-level error compile anoma $testdir/test001.juvix --debug + [ -f test001.debug.nockma ] + juvix dev nockma run test001.debug.nockma --args $testdir/test001-args.debug.nockma + stdout: | + 106 + exit-status: 0 + + - name: target-anoma-run + command: + shell: + - bash + script: | + temp=$(mktemp -d) + trap 'rm -rf -- "$temp"' EXIT + testdir=$PWD/tests/Anoma/Compilation/positive + cd $temp + juvix --log-level error compile anoma $testdir/test001.juvix + [ -f test001.nockma ] + juvix dev nockma run test001.nockma --args $testdir/test001-args.debug.nockma + stdout: | + 106 + exit-status: 0 + - name: target-anoma command: shell: