diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,19 @@ ## [Unreleased] +## [3.0.1.1] - 2026-09-15 + +### Fixed + +- Read a quantified constraint that is one item of a comma-separated context. + The context-item parser had no rule for `forall a. C a => D (f a)` or for + `p => q`, so a context such as + `class (Eq1 t, forall a. Eq a => Eq (t a)) => Eq1Wrapper t` did not divide + into items. The parentheses then fell back to the general type parser, which + read the full list as one tuple type, and `classDeclContext` held a single + `TTuple` instead of two constraints. A quantified constraint that is the only + item of a context was not affected. + ## [3.0.1.0] - 2026-09-09 ### Performance 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: 3.0.1.0 +version: 3.0.1.1 build-type: Simple license: Unlicense license-file: LICENSE diff --git a/docs/aihc-parser-supported-extensions.md b/docs/aihc-parser-supported-extensions.md --- a/docs/aihc-parser-supported-extensions.md +++ b/docs/aihc-parser-supported-extensions.md @@ -17,7 +17,7 @@ | CApiFFI | 🟢 | 4/4 | | CPP | 🟢 | 8/8 | | ConstraintKinds | 🟢 | 8/8 | -| DataKinds | 🟢 | 65/65 | +| DataKinds | 🟢 | 68/68 | | DefaultSignatures | 🟢 | 4/4 | | DerivingStrategies | 🟢 | 8/8 | | DerivingVia | 🟢 | 7/7 | @@ -51,7 +51,7 @@ | LinearTypes | 🟢 | 15/15 | | MagicHash | 🟢 | 24/24 | | MultiParamTypeClasses | 🟢 | 24/24 | -| MultiWayIf | 🟢 | 21/21 | +| MultiWayIf | 🟢 | 22/22 | | MultilineStrings | 🟢 | 6/6 | | NamedFieldPuns | 🟢 | 6/6 | | NamedWildCards | 🟢 | 5/5 | @@ -63,7 +63,7 @@ | OverloadedRecordDot | 🟢 | 8/8 | | PackageImports | 🟢 | 6/6 | | ParallelListComp | 🟢 | 3/3 | -| PartialTypeSignatures | 🟢 | 21/21 | +| PartialTypeSignatures | 🟢 | 22/22 | | PatternGuards | 🟢 | 9/9 | | PatternSynonyms | 🟢 | 34/34 | | PolyKinds | 🟢 | 14/14 | @@ -80,18 +80,18 @@ | StandaloneDeriving | 🟢 | 18/18 | | StandaloneKindSignatures | 🟢 | 12/12 | | StarIsType | 🟢 | 4/4 | -| TemplateHaskell | 🟢 | 68/68 | +| TemplateHaskell | 🟢 | 69/69 | | TemplateHaskellQuotes | 🟢 | 14/14 | | TransformListComp | 🟢 | 18/18 | | TupleSections | 🟢 | 4/4 | | TypeAbstractions | 🟢 | 5/5 | -| TypeApplications | 🟢 | 13/13 | +| TypeApplications | 🟢 | 14/14 | | TypeData | 🟢 | 1/1 | | TypeFamilies | 🟢 | 61/61 | | TypeFamilyDependencies | 🟢 | 4/4 | | TypeOperators | 🟢 | 71/71 | | UnboxedSums | 🟢 | 13/13 | -| UnboxedTuples | 🟢 | 22/22 | +| UnboxedTuples | 🟢 | 25/25 | | UnicodeSyntax | 🟢 | 21/21 | | ViewPatterns | 🟢 | 26/26 | 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 @@ -720,12 +720,59 @@ MP.try parenthesizedContextItemsParser <|> fmap pure (contextItemParserWith typeParser typeAtomParser) where parenthesizedContextItemsParser = do - items <- parens (contextItemParserWith typeParser typeAtomParser `MP.sepEndBy` expectedTok TkSpecialComma) + items <- parens (listContextItemParser `MP.sepEndBy` expectedTok TkSpecialComma) guardNotFollowedByConstraintInfixOp case items of [] -> fail "empty constraint list in parens" [item] -> pure [typeAnnSpan NoSourceSpan (TParen item)] _ -> pure items + listContextItemParser = + MP.try quantifiedContextItemParser <|> contextItemParserWith typeParser typeAtomParser + -- \| Extension form (QuantifiedConstraints): + -- + -- > context item -> ['forall' binders '.'] [context '=>'] constraint + -- + -- 'contextItemParserWith' cannot read these two forms. Without this + -- alternative the comma-separated list fails, and the enclosing + -- parentheses fall back to 'typeAtomParser', which reads the full list as + -- one tuple type. The generic type parser reads both forms. + quantifiedContextItemParser = do + guard =<< startsQuantifiedConstraint + typeParser + -- \| Look ahead for a 'forall' or a '=>' that belongs to this list item. + -- The scan stops at the comma that ends the item and at the closing + -- parenthesis of the list. + startsQuantifiedConstraint :: TokParser Bool + startsQuantifiedConstraint = MP.lookAhead (go (0 :: Int)) + where + go depth = do + tok <- anySingle + case lexTokenKind tok of + TkEOF -> pure False + TkKeywordForall | depth == 0 -> pure True + TkReservedDoubleArrow | depth == 0 -> pure True + TkSpecialComma | depth == 0 -> pure False + TkSpecialLParen -> go (depth + 1) + TkSpecialRParen + | depth > 0 -> go (depth - 1) + | otherwise -> pure False + TkSpecialUnboxedLParen -> go (depth + 1) + TkSpecialUnboxedRParen + | depth > 0 -> go (depth - 1) + | otherwise -> pure False + TkSpecialLBracket -> go (depth + 1) + TkSpecialRBracket + | depth > 0 -> go (depth - 1) + | otherwise -> pure False + TkSpecialLBrace + | lexTokenOrigin tok == InsertedLayout -> pure False + TkSpecialRBrace + | lexTokenOrigin tok == InsertedLayout -> pure False + TkSpecialSemicolon -> pure False + TkReservedEquals -> pure False + TkReservedPipe -> pure False + TkKeywordWhere -> pure False + _ -> go depth guardNotFollowedByConstraintInfixOp = do isFollowed <- fmap (either (const False) (const True)) diff --git a/test/Test/Fixtures/golden/module/class-context-list-implication-constraint.yaml b/test/Test/Fixtures/golden/module/class-context-list-implication-constraint.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/class-context-list-implication-constraint.yaml @@ -0,0 +1,7 @@ +extensions: [QuantifiedConstraints] +input: | + {-# LANGUAGE QuantifiedConstraints #-} + class (Marker f, p => q) => Implies f p q +ast: |- + Module {[QuantifiedConstraints], [DeclClass (ClassDecl {[TApp (TCon "Marker") (TVar "f"), TContext [TVar "p"] (TVar "q")], Prefix "Implies" [TyVarBinder {"f"}, TyVarBinder {"p"}, TyVarBinder {"q"}]})]} +status: pass diff --git a/test/Test/Fixtures/golden/module/class-context-list-quantified-constraint.yaml b/test/Test/Fixtures/golden/module/class-context-list-quantified-constraint.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/class-context-list-quantified-constraint.yaml @@ -0,0 +1,7 @@ +extensions: [QuantifiedConstraints] +input: | + {-# LANGUAGE QuantifiedConstraints #-} + class (Eq1 t, forall a. Eq a => Eq (t a)) => Eq1Wrapper t +ast: |- + Module {[QuantifiedConstraints], [DeclClass (ClassDecl {[TApp (TCon "Eq1") (TVar "t"), TForall [TyVarBinder {"a"}] (TContext [TApp (TCon "Eq") (TVar "a")] (TApp (TCon "Eq") (TParen (TApp (TVar "t") (TVar "a")))))], Prefix "Eq1Wrapper" [TyVarBinder {"t"}]})]} +status: pass diff --git a/test/Test/Fixtures/golden/module/instance-context-list-quantified-constraint.yaml b/test/Test/Fixtures/golden/module/instance-context-list-quantified-constraint.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/instance-context-list-quantified-constraint.yaml @@ -0,0 +1,7 @@ +extensions: [QuantifiedConstraints] +input: | + {-# LANGUAGE QuantifiedConstraints #-} + instance (Show a, forall b. Show b => Show (f b)) => Show (Wrap f a) +ast: |- + Module {[QuantifiedConstraints], [DeclInstance (InstanceDecl {[TApp (TCon "Show") (TVar "a"), TForall [TyVarBinder {"b"}] (TContext [TApp (TCon "Show") (TVar "b")] (TApp (TCon "Show") (TParen (TApp (TVar "f") (TVar "b")))))], TApp (TCon "Show") (TParen (TApp (TApp (TCon "Wrap") (TVar "f")) (TVar "a")))})]} +status: pass diff --git a/test/Test/Fixtures/oracle/QuantifiedConstraints/context-list-items.hs b/test/Test/Fixtures/oracle/QuantifiedConstraints/context-list-items.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/QuantifiedConstraints/context-list-items.hs @@ -0,0 +1,15 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE QuantifiedConstraints #-} + +module QuantifiedConstraintContextListItems where + +class Marker f + +class (Marker f, forall a. Eq a => Eq (f a)) => Eq1Wrapper f + +class (Marker f, p => q) => Implies f p q + +data Wrap f a = Wrap (f a) + +instance (Show a, forall b. Show b => Show (f b)) => Show (Wrap f a) where + show (Wrap x) = show x