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..e4a8e10b06 100644 --- a/app/Commands/Dev/Nockma/Run.hs +++ b/app/Commands/Dev/Nockma/Run.hs @@ -7,13 +7,12 @@ 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 + parsedArgs <- runAppError @JuvixError (mapM Nockma.cueJammedFileOrPretty argsFile) parsedTerm <- checkCued (Nockma.cueJammedFile afile) case parsedTerm of t@(TermCell {}) -> do @@ -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 ff6fd60c9d..1d92d82ce4 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 . 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 20e9d1ed36..71ef12c2dc 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) @@ -221,6 +221,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/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..fc0e168260 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,23 +25,67 @@ 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) +-- | 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 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 - -parseTermFile :: (MonadIO m) => Prelude.Path Abs File -> m (Either MegaparsecError (Term Natural)) + 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 :: (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