From 2ae700a4fe5648bc9690a4a4f03ef3ef11bb5e8f Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Tue, 22 Oct 2024 09:14:31 +0200 Subject: [PATCH] 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 | 8 +---- 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, 69 insertions(+), 33 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..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 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