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 20e9d1ed36..ad88d24a17 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.Language.Path import Juvix.Compiler.Nockma.StdlibFunction.Base +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 b164fa81b3..b8aa3c4171 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 1db2c22982..fa13e816c6 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