diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,13 @@ ## [Unreleased] +## [1.0.0.6] - 2026-09-02 + +### Changed + +- Deferred module declaration parsing until declarations, parse errors, or the + module span are demanded. + ## [1.0.0.5] - 2026-07-27 ### Fixed diff --git a/aihc-parser.cabal b/aihc-parser.cabal --- a/aihc-parser.cabal +++ b/aihc-parser.cabal @@ -1,6 +1,6 @@ cabal-version: 3.8 name: aihc-parser -version: 1.0.0.5 +version: 1.0.0.6 build-type: Simple license: Unlicense license-file: LICENSE diff --git a/src/Aihc/Parser.hs b/src/Aihc/Parser.hs --- a/src/Aihc/Parser.hs +++ b/src/Aihc/Parser.hs @@ -166,7 +166,6 @@ let ts = mkTokStreamModule (parserSourceName cfg) (applyImpliedExtensions (parserExtensions cfg)) input parser = do modu <- moduleParser - _ <- eofTok errs <- drainParseErrors pure (errs, modu) in case runParser parser (parserSourceName cfg) ts of diff --git a/src/Aihc/Parser/Internal/Common.hs b/src/Aihc/Parser/Internal/Common.hs --- a/src/Aihc/Parser/Internal/Common.hs +++ b/src/Aihc/Parser/Internal/Common.hs @@ -37,6 +37,7 @@ optionalSuffix, parens, braces, + closeAndExpectRBrace, thQuoteParser, skipSemicolons, bracedSemiSep, @@ -61,6 +62,7 @@ layoutSepEndBy, layoutSepBy1, drainParseErrors, + lazy, startsWithContextType, startsWithTypeSig, startsWithAsPattern, @@ -967,6 +969,30 @@ let errs = MP.stateParseErrors st MP.updateParserState (\s -> s {MP.stateParseErrors = []}) pure errs + +-- | Run a terminal parser from a copy of the current state when its result is +-- demanded. The outer parser does not advance. Recovered errors are retained +-- in the returned state; a complete failure returns 'mempty'. +lazy :: (Monoid a) => TokParser a -> TokParser (a, MP.State TokStream ParserErrorComponent) +lazy parser = do + initialState <- MP.getParserState + let ~(value, finalState) = + case MP.runParser' captureResult initialState of + (_, Right parsed) -> parsed + (failedState, Left bundle) -> + ( mempty, + failedState + { MP.stateParseErrors = + reverse (NE.toList (MPE.bundleErrors bundle)) + } + ) + pure (value, finalState) + where + captureResult = do + value <- parser + finalState <- MP.getParserState + MP.updateParserState (\state -> state {MP.stateParseErrors = []}) + pure (value, finalState) -- | Non-consuming lookahead dispatch for optional context types. -- Uses scanning to probe for @=>@ at top bracket depth. diff --git a/src/Aihc/Parser/Internal/Decl.hs b/src/Aihc/Parser/Internal/Decl.hs --- a/src/Aihc/Parser/Internal/Decl.hs +++ b/src/Aihc/Parser/Internal/Decl.hs @@ -1504,14 +1504,14 @@ bangTypeParserWith typeP = withSpan $ do pragmas <- MP.option [] (fmap (: []) unpackPragmaParser) strict <- MP.option False (expectedTok TkPrefixBang >> pure True) - lazy <- MP.option False (expectedTok TkPrefixTilde >> pure True) + isLazy <- MP.option False (expectedTok TkPrefixTilde >> pure True) ty <- typeP pure $ \span' -> BangType { bangAnns = [mkAnnotation span'], bangPragmas = pragmas, bangStrict = strict, - bangLazy = lazy, + bangLazy = isLazy, bangType = ty } diff --git a/src/Aihc/Parser/Internal/FromTokens.hs b/src/Aihc/Parser/Internal/FromTokens.hs --- a/src/Aihc/Parser/Internal/FromTokens.hs +++ b/src/Aihc/Parser/Internal/FromTokens.hs @@ -35,12 +35,15 @@ import Aihc.Parser.Types import Text.Megaparsec (runParser) -parseFromTokens :: TokParser a -> FilePath -> [LexToken] -> ParseResult a -parseFromTokens parser sourceName toks = - case runParser (parser <* eofTok) sourceName (mkTokStreamFromTokens toks) of +runParserFromTokens :: TokParser a -> FilePath -> [LexToken] -> ParseResult a +runParserFromTokens parser sourceName toks = + case runParser parser sourceName (mkTokStreamFromTokens toks) of Left bundle -> ParseErr (parseErrorBundleToSpannedText bundle) Right parsed -> ParseOk parsed +parseFromTokens :: TokParser a -> FilePath -> [LexToken] -> ParseResult a +parseFromTokens parser = runParserFromTokens (parser <* eofTok) + parseExprFromTokens :: FilePath -> [LexToken] -> ParseResult Expr parseExprFromTokens = parseFromTokens exprParser @@ -54,7 +57,7 @@ parseTypeFromTokens = parseFromTokens typeParser parseModuleFromTokens :: FilePath -> [LexToken] -> ParseResult Module -parseModuleFromTokens = parseFromTokens moduleParser +parseModuleFromTokens = runParserFromTokens moduleParser parseDeclFromTokens :: FilePath -> [LexToken] -> ParseResult Decl parseDeclFromTokens = parseFromTokens declParser diff --git a/src/Aihc/Parser/Internal/Module.hs b/src/Aihc/Parser/Internal/Module.hs --- a/src/Aihc/Parser/Internal/Module.hs +++ b/src/Aihc/Parser/Internal/Module.hs @@ -10,11 +10,20 @@ ) where -import Aihc.Parser.Internal.Common (TokParser, braces, expectedTok, skipSemicolons, withSpan) +import Aihc.Parser.Internal.Common + ( TokParser, + closeAndExpectRBrace, + eofTok, + expectedTok, + inputStartSpan, + lazy, + skipSemicolons, + ) import Aihc.Parser.Internal.Decl (declParser) import Aihc.Parser.Internal.Import (importDeclParser, languagePragmaParser, moduleHeaderParser) -import Aihc.Parser.Lex (LexTokenKind (..), lexTokenKind) -import Aihc.Parser.Syntax (Decl, ImportDecl, Module (..), mkAnnotation) +import Aihc.Parser.Lex (LexToken (lexTokenSpan), LexTokenKind (..), lexTokenKind) +import Aihc.Parser.Syntax (Decl, ImportDecl, Module (..), mergeSourceSpans, mkAnnotation, noSourceSpan) +import Aihc.Parser.Types (TokStream (tokStreamPrevToken)) import Control.Monad (void) import Text.Megaparsec qualified as MP @@ -23,27 +32,33 @@ | RecoverParsed !a | RecoverFailed +-- | Parse the header and imports now, leaving declarations, their errors, and +-- the whole-module span suspended until the corresponding result is demanded. moduleParser :: TokParser Module -moduleParser = withSpan $ do +moduleParser = do + startInput <- MP.getInput languagePragmas <- MP.many (languagePragmaParser <* MP.many (expectedTok TkSpecialSemicolon)) mHeader <- MP.optional (moduleHeaderParser <* MP.many (expectedTok TkSpecialSemicolon)) - (imports, decls) <- moduleBodyParser - pure $ \span' -> + expectedTok TkSpecialLBrace + imports <- importDeclsWithRecovery + (decls, finalState) <- + lazy + ( declsWithRecovery + <* skipSemicolons + <* closeAndExpectRBrace + <* MP.lookAhead eofTok + ) + MP.updateParserState (\state -> state {MP.stateParseErrors = MP.stateParseErrors finalState}) + let endSpan = maybe noSourceSpan lexTokenSpan (tokStreamPrevToken (MP.stateInput finalState)) + moduleSpan = mergeSourceSpans (inputStartSpan startInput) endSpan + pure Module - { moduleAnns = [mkAnnotation span'], + { moduleAnns = [mkAnnotation moduleSpan], moduleHead = mHeader, moduleLanguagePragmas = concat languagePragmas, moduleImports = imports, moduleDecls = decls } - -moduleBodyParser :: TokParser ([ImportDecl], [Decl]) -moduleBodyParser = braces $ do - skipSemicolons - imports <- importDeclsWithRecovery - decls <- declsWithRecovery - skipSemicolons - pure (imports, decls) importDeclsWithRecovery :: TokParser [ImportDecl] importDeclsWithRecovery = recoverDeclLike importDeclParser diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -6,12 +6,15 @@ import Aihc.Cpp (resultOutput) import Aihc.Parser +import Aihc.Parser.Internal.Common (TokParser, lazy) import Aihc.Parser.Lex (LexToken (..), LexTokenKind (..), lexTokens, lexTokensWithExtensions) import Aihc.Parser.Parens (addDeclParens, addExprParens, addTypeParens) import Aihc.Parser.Pretty () import Aihc.Parser.Shorthand (Shorthand (shorthand)) import Aihc.Parser.Syntax +import Aihc.Parser.Types (mkTokStreamFromTokens) import Control.DeepSeq (rnf) +import Control.Exception (ErrorCall, evaluate, try) import CppSupport (preprocessForParserWithoutIncludesIfEnabled) import Data.Char (ord) import Data.Data (Data, dataTypeConstrs, dataTypeOf, gmapQl, isAlgType, showConstr, toConstr) @@ -83,6 +86,9 @@ import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck qualified as QC +import Text.Megaparsec (runParser) +import Text.Megaparsec qualified as MP +import Text.Megaparsec.Error qualified as MPE import Text.Read (readMaybe) tenMinutes :: Timeout @@ -158,6 +164,38 @@ ParseErr bundle -> assertFailure ("expected pretty-printed expression to reparse, got:\n" <> formatParseErrors "" Nothing bundle) +lazyExceptionParser :: TokParser () +lazyExceptionParser = error "lazy parser was forced" + +test_lazyDoesNotForceParser :: Assertion +test_lazyDoesNotForceParser = + case runParser parser "" (mkTokStreamFromTokens []) of + Left bundle -> assertFailure (show bundle) + Right () -> pure () + where + parser = do + _ <- lazy lazyExceptionParser + pure () + +test_lazyForcesParserWhenResultIsForced :: Assertion +test_lazyForcesParserWhenResultIsForced = + case runParser (fst <$> lazy lazyExceptionParser) "" (mkTokStreamFromTokens []) of + Left bundle -> assertFailure (show bundle) + Right value -> do + result <- try (evaluate value) :: IO (Either ErrorCall ()) + case result of + Left _ -> pure () + Right () -> assertFailure "expected the lazy parser to be forced" + +test_lazyPreservesErrors :: Assertion +test_lazyPreservesErrors = + case runParser (snd <$> lazy lazyErrorParser) "" (mkTokStreamFromTokens []) of + Left bundle -> assertFailure (show bundle) + Right finalState -> assertEqual "error count" 1 (length (MP.stateParseErrors finalState)) + where + lazyErrorParser :: TokParser () + lazyErrorParser = MP.registerParseError (MPE.TrivialError 0 Nothing Set.empty) + main :: IO () main = buildTests >>= defaultMain @@ -178,7 +216,13 @@ lexer, testGroup "parser" - [ testCase "emits lexer error token for unterminated strings" test_unterminatedStringProducesErrorToken, + [ testGroup + "lazy" + [ testCase "does not run the parser until its result is forced" test_lazyDoesNotForceParser, + testCase "runs the parser when its result is forced" test_lazyForcesParserWhenResultIsForced, + testCase "preserves errors from the lazy parser" test_lazyPreservesErrors + ], + testCase "emits lexer error token for unterminated strings" test_unterminatedStringProducesErrorToken, testCase "emits lexer error token for unterminated block comments" test_unterminatedBlockCommentProducesErrorToken, testCase "applies hash line directives to subsequent tokens" test_hashLineDirectiveUpdatesSpan, testCase "applies gcc-style hash line directives to subsequent tokens" test_gccHashLineDirectiveUpdatesSpan,