From 1582c6dd4df3b9a2563f1e906f64faa70d2ad6e7 Mon Sep 17 00:00:00 2001 From: Neil Mitchell Date: Fri, 26 Jan 2018 20:49:18 +0000 Subject: [PATCH 01/12] Tidy up the fixies, fixes #395 --- src/Language/Haskell/Exts/Fixity.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Language/Haskell/Exts/Fixity.hs b/src/Language/Haskell/Exts/Fixity.hs index f623a461..26abb7b1 100644 --- a/src/Language/Haskell/Exts/Fixity.hs +++ b/src/Language/Haskell/Exts/Fixity.hs @@ -141,7 +141,7 @@ preludeFixities = concat [infixr_ 9 ["."] ,infixl_ 9 ["!!"] ,infixr_ 8 ["^","^^","**"] - ,infixl_ 7 ["*","/","`quot`","`rem`","`div`","`mod`",":%","%"] + ,infixl_ 7 ["*","/","`quot`","`rem`","`div`","`mod`"] ,infixl_ 6 ["+","-"] ,infixr_ 5 [":","++"] ,infix_ 4 ["==","/=","<","<=",">=",">","`elem`","`notElem`"] @@ -162,13 +162,14 @@ baseFixities :: [Fixity] baseFixities = preludeFixities ++ concat [infixl_ 9 ["!","//","!:"] ,infixl_ 8 ["`shift`","`rotate`","`shiftL`","`shiftR`","`rotateL`","`rotateR`"] - ,infixl_ 7 [".&."] + ,infixl_ 7 [".&.","%"] + ,infixr_ 6 ["<>"] ,infixl_ 6 ["`xor`"] ,infix_ 6 [":+"] ,infixl_ 5 [".|."] - ,infixr_ 5 ["+:+","<++","<+>"] -- fixity conflict for +++ between ReadP and Arrow + ,infixr_ 5 ["+:+","<++","<+>","<|"] -- fixity conflict for +++ between ReadP and Arrow ,infix_ 5 ["\\\\"] - ,infixl_ 4 ["<**>"] + ,infixl_ 4 ["<**>","$>","<$!>"] ,infix_ 4 ["`elemP`","`notElemP`"] ,infixl_ 3 ["<|>"] ,infixr_ 3 ["&&&","***"] From 48bfca822c5c8a0eafeccdb292273fb259c04c80 Mon Sep 17 00:00:00 2001 From: Neil Mitchell Date: Fri, 26 Jan 2018 20:49:30 +0000 Subject: [PATCH 02/12] Ignore .stack-work --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 77599870..bd8bf20f 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ /dist/ +/.stack-work/ *.out From eee74278d680706904b36863cddde5d1b8c2815d Mon Sep 17 00:00:00 2001 From: Neil Mitchell Date: Wed, 7 Feb 2018 13:47:00 +0000 Subject: [PATCH 03/12] Copy fixities from @yairchu --- src/Language/Haskell/Exts/Fixity.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Language/Haskell/Exts/Fixity.hs b/src/Language/Haskell/Exts/Fixity.hs index 26abb7b1..56be8bf8 100644 --- a/src/Language/Haskell/Exts/Fixity.hs +++ b/src/Language/Haskell/Exts/Fixity.hs @@ -161,6 +161,7 @@ preludeFixities = concat baseFixities :: [Fixity] baseFixities = preludeFixities ++ concat [infixl_ 9 ["!","//","!:"] + ,infixr_ 9 ["`Compose`"] ,infixl_ 8 ["`shift`","`rotate`","`shiftL`","`shiftR`","`rotateL`","`rotateR`"] ,infixl_ 7 [".&.","%"] ,infixr_ 6 ["<>"] @@ -169,8 +170,8 @@ baseFixities = preludeFixities ++ concat ,infixl_ 5 [".|."] ,infixr_ 5 ["+:+","<++","<+>","<|"] -- fixity conflict for +++ between ReadP and Arrow ,infix_ 5 ["\\\\"] - ,infixl_ 4 ["<**>","$>","<$!>"] - ,infix_ 4 ["`elemP`","`notElemP`"] + ,infixl_ 4 ["<**>","$>","<$","<$!>"] + ,infix_ 4 ["`elemP`","`notElemP`",":~:",":~~:"] ,infixl_ 3 ["<|>"] ,infixr_ 3 ["&&&","***"] ,infixr_ 2 ["+++","|||"] From af339a9d703de4d47f2f36aea8a8c4bd697db2d3 Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Mon, 12 Mar 2018 15:39:41 +0000 Subject: [PATCH 04/12] Parse contexts of GADT records --- src/Language/Haskell/Exts/ExactPrint.hs | 3 +- src/Language/Haskell/Exts/InternalParser.ly | 8 +- src/Language/Haskell/Exts/Pretty.hs | 4 +- src/Language/Haskell/Exts/Syntax.hs | 8 +- .../ConstraintKinds2.hs.parser.golden | 2 + tests/examples/DsStrictData.hs.parser.golden | 4 + tests/examples/GADTRecord.hs.parser.golden | 2 + tests/examples/GADTRecord2.hs | 4 + .../GADTRecord2.hs.exactprinter.golden | 1 + tests/examples/GADTRecord2.hs.parser.golden | 137 ++++++++++++++++++ .../GADTRecord2.hs.prettyparser.golden | 1 + .../GADTRecord2.hs.prettyprinter.golden | 4 + tests/examples/GadtDeriving.hs.parser.golden | 2 + .../GadtRecordFields.hs.parser.golden | 4 + .../examples/GadtStrictness.hs.parser.golden | 2 + .../examples/InfixTypeMinus.hs.parser.golden | 8 + .../PatternSynonyms3.hs.parser.golden | 2 + tests/examples/PolyKindSigs.hs.parser.golden | 2 + tests/examples/Unpack.hs.parser.golden | 2 + 19 files changed, 192 insertions(+), 8 deletions(-) create mode 100644 tests/examples/GADTRecord2.hs create mode 100644 tests/examples/GADTRecord2.hs.exactprinter.golden create mode 100644 tests/examples/GADTRecord2.hs.parser.golden create mode 100644 tests/examples/GADTRecord2.hs.prettyparser.golden create mode 100644 tests/examples/GADTRecord2.hs.prettyprinter.golden diff --git a/src/Language/Haskell/Exts/ExactPrint.hs b/src/Language/Haskell/Exts/ExactPrint.hs index c65a3256..f3e76498 100644 --- a/src/Language/Haskell/Exts/ExactPrint.hs +++ b/src/Language/Haskell/Exts/ExactPrint.hs @@ -1361,7 +1361,7 @@ instance ExactP ConDecl where RecDecl l n fds -> exactP n >> curlyList (srcInfoPoints l) fds instance ExactP GadtDecl where - exactP (GadtDecl l n ns' t) = + exactP (GadtDecl l n _mtvs mctxt ns' t) = case ns' of Nothing -> case srcInfoPoints l of @@ -1375,6 +1375,7 @@ instance ExactP GadtDecl where (a:b:c:d:rest) -> do exactPC n printStringAt (pos a) "::" + maybeEP exactPC mctxt printStringAt (pos b) "{" printInterleaved' (zip rest (repeat ",")) ts printStringAt (pos c) "}" diff --git a/src/Language/Haskell/Exts/InternalParser.ly b/src/Language/Haskell/Exts/InternalParser.ly index 8a8ea96b..b1d4b537 100644 --- a/src/Language/Haskell/Exts/InternalParser.ly +++ b/src/Language/Haskell/Exts/InternalParser.ly @@ -1127,10 +1127,14 @@ GADTs - require the GADTs extension enabled, but we handle that at the calling s > gadtconstr :: { [GadtDecl L] } > : qcon '::' truectype {% do { c <- checkUnQual $1; -> return [GadtDecl ($1 <> $3 <** [$2]) c Nothing $3] } } +> return [GadtDecl ($1 <> $3 <** [$2]) c Nothing Nothing Nothing $3] } } +> | qcon '::' context '{' fielddecls '}' '->' truectype +> {% do { c <- checkUnQual $1; +> ctxt <- checkContext (Just $3) ; +> return [GadtDecl ($1 <> $8 <** [$2,$4,$6,$7] ++ snd $5) c Nothing ctxt (Just (reverse $ fst $5)) $8] } } > | qcon '::' '{' fielddecls '}' '->' truectype > {% do { c <- checkUnQual $1; -> return [GadtDecl ($1 <> $7 <** [$2,$3,$5,$6] ++ snd $4) c (Just (reverse $ fst $4)) $7] } } +> return [GadtDecl ($1 <> $7 <** [$2,$3,$5,$6] ++ snd $4) c Nothing Nothing (Just (reverse $ fst $4)) $7] } } To allow the empty case we need the EmptyDataDecls extension. > constrs0 :: { ([QualConDecl L],[S],Maybe L) } diff --git a/src/Language/Haskell/Exts/Pretty.hs b/src/Language/Haskell/Exts/Pretty.hs index adced3f4..ce937e9f 100644 --- a/src/Language/Haskell/Exts/Pretty.hs +++ b/src/Language/Haskell/Exts/Pretty.hs @@ -769,12 +769,12 @@ instance Pretty (QualConDecl l) where myFsep [ppForall tvs, maybePP pretty ctxt, pretty con] instance Pretty (GadtDecl l) where - pretty (GadtDecl _pos name names ty) = + pretty (GadtDecl _pos name tvs ctxt names ty) = case names of Nothing -> myFsep [pretty name, text "::", pretty ty] Just ts' -> - myFsep [pretty name, text "::" , + myFsep [pretty name, text "::" , ppForall tvs, maybePP pretty ctxt, braceList . map pretty $ ts', text "->", pretty ty] instance Pretty (ConDecl l) where diff --git a/src/Language/Haskell/Exts/Syntax.hs b/src/Language/Haskell/Exts/Syntax.hs index 2404fc2a..966d3539 100644 --- a/src/Language/Haskell/Exts/Syntax.hs +++ b/src/Language/Haskell/Exts/Syntax.hs @@ -558,7 +558,9 @@ data FieldDecl l = FieldDecl l [Name l] (Type l) -- then @'Maybe' ['FieldDecl' l]@ is 'Nothing', and the whole constructor's -- type (such as @Int -> Bool -> Ty@) is stored in the last 'Type' field. data GadtDecl l - = GadtDecl l (Name l) (Maybe [FieldDecl l]) (Type l) + = GadtDecl l (Name l) + {-forall-} (Maybe [TyVarBind l]) {- . -} (Maybe (Context l)) + {- => -} (Maybe [FieldDecl l]) (Type l) deriving (Eq,Ord,Show,Typeable,Data,Foldable,Traversable,Functor,Generic) -- | Declarations inside a class declaration. @@ -1434,8 +1436,8 @@ instance Annotated FieldDecl where amap f (FieldDecl l ns t) = FieldDecl (f l) ns t instance Annotated GadtDecl where - ann (GadtDecl l _ _ _) = l - amap f (GadtDecl l n t1 t2) = GadtDecl (f l) n t1 t2 + ann (GadtDecl l _ _ _ _ _) = l + amap f (GadtDecl l n t1 t2 t3 t4) = GadtDecl (f l) n t1 t2 t3 t4 instance Annotated ClassDecl where ann (ClsDecl l _) = l diff --git a/tests/examples/ConstraintKinds2.hs.parser.golden b/tests/examples/ConstraintKinds2.hs.parser.golden index 9d3bd187..d056b60d 100644 --- a/tests/examples/ConstraintKinds2.hs.parser.golden +++ b/tests/examples/ConstraintKinds2.hs.parser.golden @@ -133,6 +133,8 @@ ParseOk } "Dict") Nothing + Nothing + Nothing (TyForall SrcSpanInfo { srcInfoSpan = diff --git a/tests/examples/DsStrictData.hs.parser.golden b/tests/examples/DsStrictData.hs.parser.golden index 644fec78..c27fbe03 100644 --- a/tests/examples/DsStrictData.hs.parser.golden +++ b/tests/examples/DsStrictData.hs.parser.golden @@ -370,6 +370,8 @@ ParseOk } "S3") Nothing + Nothing + Nothing (TyFun SrcSpanInfo { srcInfoSpan = SrcSpan "tests/examples/DsStrictData.hs" 12 9 12 23 @@ -666,6 +668,8 @@ ParseOk } "L2") Nothing + Nothing + Nothing (TyFun SrcSpanInfo { srcInfoSpan = SrcSpan "tests/examples/DsStrictData.hs" 18 9 18 22 diff --git a/tests/examples/GADTRecord.hs.parser.golden b/tests/examples/GADTRecord.hs.parser.golden index e67c195c..9e44e5d1 100644 --- a/tests/examples/GADTRecord.hs.parser.golden +++ b/tests/examples/GADTRecord.hs.parser.golden @@ -72,6 +72,8 @@ ParseOk , srcInfoPoints = [] } "T") + Nothing + Nothing (Just [ FieldDecl SrcSpanInfo diff --git a/tests/examples/GADTRecord2.hs b/tests/examples/GADTRecord2.hs new file mode 100644 index 00000000..c6ebb2dd --- /dev/null +++ b/tests/examples/GADTRecord2.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE GADTs #-} + +data T where + T :: () => { field :: Int } -> T diff --git a/tests/examples/GADTRecord2.hs.exactprinter.golden b/tests/examples/GADTRecord2.hs.exactprinter.golden new file mode 100644 index 00000000..1796dc27 --- /dev/null +++ b/tests/examples/GADTRecord2.hs.exactprinter.golden @@ -0,0 +1 @@ +Match diff --git a/tests/examples/GADTRecord2.hs.parser.golden b/tests/examples/GADTRecord2.hs.parser.golden new file mode 100644 index 00000000..9bb0b92c --- /dev/null +++ b/tests/examples/GADTRecord2.hs.parser.golden @@ -0,0 +1,137 @@ +ParseOk + ( Module + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/GADTRecord2.hs" 1 1 5 1 + , srcInfoPoints = + [ SrcSpan "tests/examples/GADTRecord2.hs" 1 1 1 1 + , SrcSpan "tests/examples/GADTRecord2.hs" 3 1 3 1 + , SrcSpan "tests/examples/GADTRecord2.hs" 3 1 3 1 + , SrcSpan "tests/examples/GADTRecord2.hs" 3 1 3 1 + , SrcSpan "tests/examples/GADTRecord2.hs" 5 1 5 1 + , SrcSpan "tests/examples/GADTRecord2.hs" 5 1 5 1 + ] + } + Nothing + [ LanguagePragma + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/GADTRecord2.hs" 1 1 1 23 + , srcInfoPoints = + [ SrcSpan "tests/examples/GADTRecord2.hs" 1 1 1 13 + , SrcSpan "tests/examples/GADTRecord2.hs" 1 20 1 23 + ] + } + [ Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/GADTRecord2.hs" 1 14 1 19 + , srcInfoPoints = [] + } + "GADTs" + ] + ] + [] + [ GDataDecl + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/GADTRecord2.hs" 3 1 5 0 + , srcInfoPoints = + [ SrcSpan "tests/examples/GADTRecord2.hs" 3 8 3 13 + , SrcSpan "tests/examples/GADTRecord2.hs" 4 3 4 3 + , SrcSpan "tests/examples/GADTRecord2.hs" 5 1 5 0 + ] + } + (DataType + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/GADTRecord2.hs" 3 1 3 5 + , srcInfoPoints = [] + }) + Nothing + (DHead + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/GADTRecord2.hs" 3 6 3 7 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/GADTRecord2.hs" 3 6 3 7 + , srcInfoPoints = [] + } + "T")) + Nothing + [ GadtDecl + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/GADTRecord2.hs" 4 3 4 35 + , srcInfoPoints = + [ SrcSpan "tests/examples/GADTRecord2.hs" 4 5 4 7 + , SrcSpan "tests/examples/GADTRecord2.hs" 4 14 4 15 + , SrcSpan "tests/examples/GADTRecord2.hs" 4 29 4 30 + , SrcSpan "tests/examples/GADTRecord2.hs" 4 31 4 33 + ] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/GADTRecord2.hs" 4 3 4 4 + , srcInfoPoints = [] + } + "T") + Nothing + (Just + (CxEmpty + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/GADTRecord2.hs" 4 8 4 13 + , srcInfoPoints = + [ SrcSpan "tests/examples/GADTRecord2.hs" 4 8 4 9 + , SrcSpan "tests/examples/GADTRecord2.hs" 4 9 4 10 + , SrcSpan "tests/examples/GADTRecord2.hs" 4 11 4 13 + ] + })) + (Just + [ FieldDecl + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/GADTRecord2.hs" 4 16 4 28 + , srcInfoPoints = + [ SrcSpan "tests/examples/GADTRecord2.hs" 4 22 4 24 ] + } + [ Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/GADTRecord2.hs" 4 16 4 21 + , srcInfoPoints = [] + } + "field" + ] + (TyCon + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/GADTRecord2.hs" 4 25 4 28 + , srcInfoPoints = [] + } + (UnQual + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/GADTRecord2.hs" 4 25 4 28 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/GADTRecord2.hs" 4 25 4 28 + , srcInfoPoints = [] + } + "Int"))) + ]) + (TyCon + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/GADTRecord2.hs" 4 34 4 35 + , srcInfoPoints = [] + } + (UnQual + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/GADTRecord2.hs" 4 34 4 35 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/GADTRecord2.hs" 4 34 4 35 + , srcInfoPoints = [] + } + "T"))) + ] + [] + ] + , [] + ) diff --git a/tests/examples/GADTRecord2.hs.prettyparser.golden b/tests/examples/GADTRecord2.hs.prettyparser.golden new file mode 100644 index 00000000..1796dc27 --- /dev/null +++ b/tests/examples/GADTRecord2.hs.prettyparser.golden @@ -0,0 +1 @@ +Match diff --git a/tests/examples/GADTRecord2.hs.prettyprinter.golden b/tests/examples/GADTRecord2.hs.prettyprinter.golden new file mode 100644 index 00000000..ffac16c1 --- /dev/null +++ b/tests/examples/GADTRecord2.hs.prettyprinter.golden @@ -0,0 +1,4 @@ +{-# LANGUAGE GADTs #-} + +data T where + T :: () => {field :: Int} -> T diff --git a/tests/examples/GadtDeriving.hs.parser.golden b/tests/examples/GadtDeriving.hs.parser.golden index db937fe8..7e9451e6 100644 --- a/tests/examples/GadtDeriving.hs.parser.golden +++ b/tests/examples/GadtDeriving.hs.parser.golden @@ -70,6 +70,8 @@ ParseOk } "Foo") Nothing + Nothing + Nothing (TyFun SrcSpanInfo { srcInfoSpan = SrcSpan "tests/examples/GadtDeriving.hs" 4 12 4 22 diff --git a/tests/examples/GadtRecordFields.hs.parser.golden b/tests/examples/GadtRecordFields.hs.parser.golden index 03fb0ca6..1570c83b 100644 --- a/tests/examples/GadtRecordFields.hs.parser.golden +++ b/tests/examples/GadtRecordFields.hs.parser.golden @@ -83,6 +83,8 @@ ParseOk , srcInfoPoints = [] } "TCon") + Nothing + Nothing (Just [ FieldDecl SrcSpanInfo @@ -187,6 +189,8 @@ ParseOk } "TCon2") Nothing + Nothing + Nothing (TyCon SrcSpanInfo { srcInfoSpan = diff --git a/tests/examples/GadtStrictness.hs.parser.golden b/tests/examples/GadtStrictness.hs.parser.golden index a1e10b84..cc1185d9 100644 --- a/tests/examples/GadtStrictness.hs.parser.golden +++ b/tests/examples/GadtStrictness.hs.parser.golden @@ -70,6 +70,8 @@ ParseOk } "X") Nothing + Nothing + Nothing (TyFun SrcSpanInfo { srcInfoSpan = SrcSpan "tests/examples/GadtStrictness.hs" 4 8 4 17 diff --git a/tests/examples/InfixTypeMinus.hs.parser.golden b/tests/examples/InfixTypeMinus.hs.parser.golden index 21a4783d..542b2a83 100644 --- a/tests/examples/InfixTypeMinus.hs.parser.golden +++ b/tests/examples/InfixTypeMinus.hs.parser.golden @@ -156,6 +156,8 @@ ParseOk } "VCons") Nothing + Nothing + Nothing (TyForall SrcSpanInfo { srcInfoSpan = @@ -460,6 +462,8 @@ ParseOk } "VCons") Nothing + Nothing + Nothing (TyForall SrcSpanInfo { srcInfoSpan = @@ -764,6 +768,8 @@ ParseOk } "VCons") Nothing + Nothing + Nothing (TyForall SrcSpanInfo { srcInfoSpan = @@ -1068,6 +1074,8 @@ ParseOk } "VCons") Nothing + Nothing + Nothing (TyForall SrcSpanInfo { srcInfoSpan = diff --git a/tests/examples/PatternSynonyms3.hs.parser.golden b/tests/examples/PatternSynonyms3.hs.parser.golden index 9259423e..b584215d 100644 --- a/tests/examples/PatternSynonyms3.hs.parser.golden +++ b/tests/examples/PatternSynonyms3.hs.parser.golden @@ -3238,6 +3238,8 @@ ParseOk } "MkT") Nothing + Nothing + Nothing (TyFun SrcSpanInfo { srcInfoSpan = diff --git a/tests/examples/PolyKindSigs.hs.parser.golden b/tests/examples/PolyKindSigs.hs.parser.golden index bbe2ac53..8901b363 100644 --- a/tests/examples/PolyKindSigs.hs.parser.golden +++ b/tests/examples/PolyKindSigs.hs.parser.golden @@ -118,6 +118,8 @@ ParseOk } "Foo") Nothing + Nothing + Nothing (TyApp SrcSpanInfo { srcInfoSpan = SrcSpan "tests/examples/PolyKindSigs.hs" 8 10 8 15 diff --git a/tests/examples/Unpack.hs.parser.golden b/tests/examples/Unpack.hs.parser.golden index 58944dad..87a27257 100644 --- a/tests/examples/Unpack.hs.parser.golden +++ b/tests/examples/Unpack.hs.parser.golden @@ -101,6 +101,8 @@ ParseOk } "CmmEntry") Nothing + Nothing + Nothing (TyFun SrcSpanInfo { srcInfoSpan = SrcSpan "tests/examples/Unpack.hs" 4 21 4 55 From 302bbe52d3503ebb89f29f4aad7bcaf995b5d126 Mon Sep 17 00:00:00 2001 From: David Fox Date: Tue, 8 May 2018 10:51:51 -0700 Subject: [PATCH 05/12] Documentation fix for ImportSpecList --- src/Language/Haskell/Exts/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/Haskell/Exts/Syntax.hs b/src/Language/Haskell/Exts/Syntax.hs index 966d3539..a624838b 100644 --- a/src/Language/Haskell/Exts/Syntax.hs +++ b/src/Language/Haskell/Exts/Syntax.hs @@ -241,7 +241,7 @@ data ImportDecl l = ImportDecl -- | An explicit import specification list. data ImportSpecList l = ImportSpecList l Bool [ImportSpec l] - -- A list of import specifications. + -- ^ A list of import specifications. -- The 'Bool' is 'True' if the names are excluded -- by @hiding@. deriving (Eq,Ord,Show,Typeable,Data,Foldable,Traversable,Functor,Generic) From 0f03d9a22051d44cd19e74c15c027db288c186af Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Fri, 10 Aug 2018 19:48:21 +0000 Subject: [PATCH 06/12] TypeInType implies PolyKinds Fixes #412 --- src/Language/Haskell/Exts/Extension.hs | 4 + tests/examples/t412.hs | 8 + tests/examples/t412.hs.exactprinter.golden | 1 + tests/examples/t412.hs.parser.golden | 171 ++++++++++++++++++++ tests/examples/t412.hs.prettyparser.golden | 1 + tests/examples/t412.hs.prettyprinter.golden | 5 + 6 files changed, 190 insertions(+) create mode 100644 tests/examples/t412.hs create mode 100644 tests/examples/t412.hs.exactprinter.golden create mode 100644 tests/examples/t412.hs.parser.golden create mode 100644 tests/examples/t412.hs.prettyparser.golden create mode 100644 tests/examples/t412.hs.prettyprinter.golden diff --git a/src/Language/Haskell/Exts/Extension.hs b/src/Language/Haskell/Exts/Extension.hs index 515bdb28..0bf28255 100644 --- a/src/Language/Haskell/Exts/Extension.hs +++ b/src/Language/Haskell/Exts/Extension.hs @@ -546,6 +546,8 @@ data KnownExtension = | UnboxedSums + | TypeInType + deriving (Show, Read, Eq, Ord, Enum, Bounded, Data, Typeable) -- | Certain extensions imply other extensions, and this function @@ -581,6 +583,8 @@ impliesExts = go ImpredicativeTypes -> [ExplicitForAll] PolyKinds -> [KindSignatures] TypeFamilyDependencies -> [TypeFamilies] + TypeInType -> [PolyKinds, DataKinds, KindSignatures] + TypeOperators -> [ExplicitNamespaces] -- Deprecations RecordPuns -> [NamedFieldPuns] PatternSignatures -> [ScopedTypeVariables] diff --git a/tests/examples/t412.hs b/tests/examples/t412.hs new file mode 100644 index 00000000..5a0705c2 --- /dev/null +++ b/tests/examples/t412.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeInType #-} + +module Typeintype + ( App ) where + +import Data.Kind + +data App (f :: k -> *) diff --git a/tests/examples/t412.hs.exactprinter.golden b/tests/examples/t412.hs.exactprinter.golden new file mode 100644 index 00000000..1796dc27 --- /dev/null +++ b/tests/examples/t412.hs.exactprinter.golden @@ -0,0 +1 @@ +Match diff --git a/tests/examples/t412.hs.parser.golden b/tests/examples/t412.hs.parser.golden new file mode 100644 index 00000000..94c95439 --- /dev/null +++ b/tests/examples/t412.hs.parser.golden @@ -0,0 +1,171 @@ +ParseOk + ( Module + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 1 1 9 1 + , srcInfoPoints = + [ SrcSpan "tests/examples/t412.hs" 1 1 1 1 + , SrcSpan "tests/examples/t412.hs" 3 1 3 1 + , SrcSpan "tests/examples/t412.hs" 3 1 3 1 + , SrcSpan "tests/examples/t412.hs" 6 1 6 1 + , SrcSpan "tests/examples/t412.hs" 8 1 8 1 + , SrcSpan "tests/examples/t412.hs" 9 1 9 1 + , SrcSpan "tests/examples/t412.hs" 9 1 9 1 + ] + } + (Just + (ModuleHead + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 3 1 4 21 + , srcInfoPoints = + [ SrcSpan "tests/examples/t412.hs" 3 1 3 7 + , SrcSpan "tests/examples/t412.hs" 4 16 4 21 + ] + } + (ModuleName + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 3 8 3 18 + , srcInfoPoints = [] + } + "Typeintype") + Nothing + (Just + (ExportSpecList + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 4 8 4 15 + , srcInfoPoints = + [ SrcSpan "tests/examples/t412.hs" 4 8 4 9 + , SrcSpan "tests/examples/t412.hs" 4 14 4 15 + ] + } + [ EAbs + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 4 10 4 13 + , srcInfoPoints = [] + } + (NoNamespace + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 4 10 4 13 + , srcInfoPoints = [] + }) + (UnQual + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 4 10 4 13 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 4 10 4 13 + , srcInfoPoints = [] + } + "App")) + ])))) + [ LanguagePragma + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 1 1 1 28 + , srcInfoPoints = + [ SrcSpan "tests/examples/t412.hs" 1 1 1 13 + , SrcSpan "tests/examples/t412.hs" 1 25 1 28 + ] + } + [ Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 1 14 1 24 + , srcInfoPoints = [] + } + "TypeInType" + ] + ] + [ ImportDecl + { importAnn = + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 6 1 6 17 + , srcInfoPoints = [ SrcSpan "tests/examples/t412.hs" 6 1 6 7 ] + } + , importModule = + ModuleName + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 6 8 6 17 + , srcInfoPoints = [] + } + "Data.Kind" + , importQualified = False + , importSrc = False + , importSafe = False + , importPkg = Nothing + , importAs = Nothing + , importSpecs = Nothing + } + ] + [ DataDecl + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 8 1 8 5 + , srcInfoPoints = [] + } + (DataType + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 8 1 8 5 + , srcInfoPoints = [] + }) + Nothing + (DHApp + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 8 6 8 23 + , srcInfoPoints = [] + } + (DHead + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 8 6 8 9 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 8 6 8 9 + , srcInfoPoints = [] + } + "App")) + (KindedVar + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 8 10 8 23 + , srcInfoPoints = + [ SrcSpan "tests/examples/t412.hs" 8 10 8 11 + , SrcSpan "tests/examples/t412.hs" 8 13 8 15 + , SrcSpan "tests/examples/t412.hs" 8 22 8 23 + ] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 8 11 8 12 + , srcInfoPoints = [] + } + "f") + (KindFn + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 8 16 8 22 + , srcInfoPoints = [ SrcSpan "tests/examples/t412.hs" 8 18 8 20 ] + } + (KindVar + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 8 16 8 17 + , srcInfoPoints = [] + } + (UnQual + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 8 16 8 17 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 8 16 8 17 + , srcInfoPoints = [] + } + "k"))) + (KindStar + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t412.hs" 8 21 8 22 + , srcInfoPoints = [] + })))) + [] + [] + ] + , [] + ) diff --git a/tests/examples/t412.hs.prettyparser.golden b/tests/examples/t412.hs.prettyparser.golden new file mode 100644 index 00000000..1796dc27 --- /dev/null +++ b/tests/examples/t412.hs.prettyparser.golden @@ -0,0 +1 @@ +Match diff --git a/tests/examples/t412.hs.prettyprinter.golden b/tests/examples/t412.hs.prettyprinter.golden new file mode 100644 index 00000000..6874df7e --- /dev/null +++ b/tests/examples/t412.hs.prettyprinter.golden @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeInType #-} +module Typeintype (App) where +import Data.Kind + +data App (f :: k -> *) From 756e7f396ad4a06ca091166fd003de6ddba17365 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Fri, 10 Aug 2018 19:51:03 +0000 Subject: [PATCH 07/12] Add Strict and StrictData extensions Fixes #407 --- src/Language/Haskell/Exts/Extension.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Language/Haskell/Exts/Extension.hs b/src/Language/Haskell/Exts/Extension.hs index 0bf28255..bcd0b29e 100644 --- a/src/Language/Haskell/Exts/Extension.hs +++ b/src/Language/Haskell/Exts/Extension.hs @@ -548,6 +548,10 @@ data KnownExtension = | TypeInType + | Strict + + | StrictData + deriving (Show, Read, Eq, Ord, Enum, Bounded, Data, Typeable) -- | Certain extensions imply other extensions, and this function From d97e3bb782f638c5283f2e5697d7a18a39af3f08 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Fri, 10 Aug 2018 20:45:26 +0000 Subject: [PATCH 08/12] Parse forall in provided constraints Fixes #403 --- src/Language/Haskell/Exts/ExactPrint.hs | 2 +- src/Language/Haskell/Exts/InternalParser.ly | 22 +- src/Language/Haskell/Exts/Pretty.hs | 4 +- src/Language/Haskell/Exts/Syntax.hs | 8 +- .../PatternSynonymSignatures.hs.parser.golden | 6 + .../PatternSynonyms3.hs.parser.golden | 8 + tests/examples/T11727.hs.parser.golden | 1 + tests/examples/completesig01.hs.parser.golden | 1 + tests/examples/t403.hs | 9 + tests/examples/t403.hs.exactprinter.golden | 10 + tests/examples/t403.hs.parser.golden | 515 ++++++++++++++++++ tests/examples/t403.hs.prettyparser.golden | 1 + tests/examples/t403.hs.prettyprinter.golden | 11 + 13 files changed, 584 insertions(+), 14 deletions(-) create mode 100644 tests/examples/t403.hs create mode 100644 tests/examples/t403.hs.exactprinter.golden create mode 100644 tests/examples/t403.hs.parser.golden create mode 100644 tests/examples/t403.hs.prettyparser.golden create mode 100644 tests/examples/t403.hs.prettyprinter.golden diff --git a/src/Language/Haskell/Exts/ExactPrint.hs b/src/Language/Haskell/Exts/ExactPrint.hs index f3e76498..2d73df3b 100644 --- a/src/Language/Haskell/Exts/ExactPrint.hs +++ b/src/Language/Haskell/Exts/ExactPrint.hs @@ -733,7 +733,7 @@ instance ExactP Decl where let pts = srcInfoPoints l printInterleaved' (zip pts (replicate (length pts - 1) "," ++ ["::"])) ns exactPC t - PatSynSig l ns dh c1 c2 t -> do + PatSynSig l ns dh c1 _ c2 t -> do let (pat:pts) = srcInfoPoints l printStringAt (pos pat) "pattern" printInterleaved' (zip pts (replicate (length ns - 1) "," ++ ["::"])) ns diff --git a/src/Language/Haskell/Exts/InternalParser.ly b/src/Language/Haskell/Exts/InternalParser.ly index b1d4b537..844cba48 100644 --- a/src/Language/Haskell/Exts/InternalParser.ly +++ b/src/Language/Haskell/Exts/InternalParser.ly @@ -2091,25 +2091,31 @@ Pattern Synonyms > pattern_synonym_sig :: { Decl L } > : 'pattern' con_list '::' pstype > {% do { checkEnabled PatternSynonyms ; -> let {(qtvs, ps, prov, req, ty) = $4} ; -> let {sig = PatSynSig (nIS $1 <++> ann ty <** [$1] ++ fst $2 ++ [$3] ++ ps) (snd $2) qtvs prov req ty} ; +> let {(qtvs, ps, prov, req_vars, req, ty) = $4} ; +> let {sig = PatSynSig (nIS $1 <++> ann ty <** [$1] ++ fst $2 ++ [$3] ++ ps) (snd $2) qtvs prov req_vars req ty} ; > return sig } } -> pstype :: { (Maybe [TyVarBind L], [S], Maybe (Context L), Maybe (Context L), Type L )} +> pstype :: { (Maybe [TyVarBind L], [S], Maybe (Context L), Maybe [TyVarBind L] +> , Maybe (Context L), Type L )} > : 'forall' ktyvars '.' pstype -> { let (qtvs, ps, prov, req, ty) = $4 -> in (Just (reverse (fst $2) ++ fromMaybe [] qtvs), ($1 : $3 : ps), prov, req, ty) } +> { let (qtvs, ps, prov, req_vars, req, ty) = $4 +> in (Just (reverse (fst $2) ++ fromMaybe [] qtvs), ($1 : $3 : ps), prov, req_vars, req, ty) } > | context context type > {% do { c1 <- checkContext (Just $1) ; > c2 <- checkContext (Just $2) ; > t <- checkType $3 ; -> return $ (Nothing, [], c1, c2, t) }} +> return $ (Nothing, [], c1, Nothing, c2, t) }} +> | context 'forall' ktyvars '.' context type +> {% do { c1 <- checkContext (Just $1) ; +> c2 <- checkContext (Just $5) ; +> t <- checkType $6 ; +> return $ (Nothing, [], c1, Just (reverse (fst $3)), c2, t) }} > | context type > {% do { c1 <- checkContext (Just $1); > t <- checkType $2; -> return (Nothing, [], c1, Nothing, t) } } +> return (Nothing, [], c1, Nothing, Nothing, t) } } > | type -> {% checkType $1 >>= \t -> return (Nothing, [], Nothing, Nothing, t) } +> {% checkType $1 >>= \t -> return (Nothing, [], Nothing, Nothing, Nothing, t) } ----------------------------------------------------------------------------- Deriving strategies diff --git a/src/Language/Haskell/Exts/Pretty.hs b/src/Language/Haskell/Exts/Pretty.hs index ce937e9f..acead199 100644 --- a/src/Language/Haskell/Exts/Pretty.hs +++ b/src/Language/Haskell/Exts/Pretty.hs @@ -486,8 +486,8 @@ instance Pretty (Decl l) where -- Req can be ommitted if it is empty -- We must print prov if req is nonempty - pretty (PatSynSig _ ns mtvs prov req t) = - let contexts = map (maybePP pretty) [prov, req] + pretty (PatSynSig _ ns mtvs prov mtvs2 req t) = + let contexts = [maybePP pretty prov, ppForall mtvs2, maybePP pretty req] in mySep ( [text "pattern" ] ++ punctuate comma (map pretty ns) diff --git a/src/Language/Haskell/Exts/Syntax.hs b/src/Language/Haskell/Exts/Syntax.hs index a624838b..d998492c 100644 --- a/src/Language/Haskell/Exts/Syntax.hs +++ b/src/Language/Haskell/Exts/Syntax.hs @@ -301,7 +301,9 @@ data Decl l -- ^ A Template Haskell splicing declaration | TypeSig l [Name l] (Type l) -- ^ A type signature declaration - | PatSynSig l [Name l] (Maybe [TyVarBind l]) (Maybe (Context l)) (Maybe (Context l)) (Type l) + | PatSynSig l [Name l] (Maybe [TyVarBind l]) (Maybe (Context l)) + (Maybe [TyVarBind l]) (Maybe (Context l)) + (Type l) -- ^ A pattern synonym signature declation | FunBind l [Match l] -- ^ A set of function binding clauses @@ -1286,7 +1288,7 @@ instance Annotated Decl where DefaultDecl l _ -> l SpliceDecl l _ -> l TypeSig l _ _ -> l - PatSynSig l _ _ _ _ _ -> l + PatSynSig l _ _ _ _ _ _ -> l FunBind l _ -> l PatBind l _ _ _ -> l ForImp l _ _ _ _ _ -> l @@ -1323,7 +1325,7 @@ instance Annotated Decl where DefaultDecl l ts -> DefaultDecl (f l) ts SpliceDecl l sp -> SpliceDecl (f l) sp TypeSig l ns t -> TypeSig (f l) ns t - PatSynSig l n dh c1 c2 t -> PatSynSig (f l) n dh c1 c2 t + PatSynSig l n dh c1 dh2 c2 t -> PatSynSig (f l) n dh c1 dh2 c2 t FunBind l ms -> FunBind (f l) ms PatBind l p rhs bs -> PatBind (f l) p rhs bs ForImp l cc msf s n t -> ForImp (f l) cc msf s n t diff --git a/tests/examples/PatternSynonymSignatures.hs.parser.golden b/tests/examples/PatternSynonymSignatures.hs.parser.golden index 109981ff..b9de65f1 100644 --- a/tests/examples/PatternSynonymSignatures.hs.parser.golden +++ b/tests/examples/PatternSynonymSignatures.hs.parser.golden @@ -57,6 +57,7 @@ ParseOk Nothing Nothing Nothing + Nothing (TyCon SrcSpanInfo { srcInfoSpan = @@ -105,6 +106,7 @@ ParseOk , SrcSpan "tests/examples/PatternSynonymSignatures.hs" 6 19 6 21 ] })) + Nothing (Just (CxEmpty SrcSpanInfo @@ -195,6 +197,7 @@ ParseOk } "a") ]))) + Nothing (Just (CxSingle SrcSpanInfo @@ -319,6 +322,7 @@ ParseOk "b") ]))) Nothing + Nothing (TyCon SrcSpanInfo { srcInfoSpan = @@ -400,6 +404,7 @@ ParseOk } "b") ]))) + Nothing (Just (CxEmpty SrcSpanInfo @@ -459,6 +464,7 @@ ParseOk , SrcSpan "tests/examples/PatternSynonymSignatures.hs" 14 19 14 21 ] })) + Nothing (Just (CxSingle SrcSpanInfo diff --git a/tests/examples/PatternSynonyms3.hs.parser.golden b/tests/examples/PatternSynonyms3.hs.parser.golden index b584215d..6947113e 100644 --- a/tests/examples/PatternSynonyms3.hs.parser.golden +++ b/tests/examples/PatternSynonyms3.hs.parser.golden @@ -464,6 +464,7 @@ ParseOk Nothing Nothing Nothing + Nothing (TyFun SrcSpanInfo { srcInfoSpan = @@ -601,6 +602,7 @@ ParseOk , SrcSpan "tests/examples/PatternSynonyms3.hs" 16 22 16 24 ] })) + Nothing (Just (CxSingle SrcSpanInfo @@ -991,6 +993,7 @@ ParseOk Nothing Nothing Nothing + Nothing (TyFun SrcSpanInfo { srcInfoSpan = @@ -1483,6 +1486,7 @@ ParseOk Nothing Nothing Nothing + Nothing (TyFun SrcSpanInfo { srcInfoSpan = @@ -1776,6 +1780,7 @@ ParseOk , SrcSpan "tests/examples/PatternSynonyms3.hs" 34 37 34 39 ] })) + Nothing (Just (CxEmpty SrcSpanInfo @@ -1910,6 +1915,7 @@ ParseOk ] ])))) Nothing + Nothing (TyFun SrcSpanInfo { srcInfoSpan = @@ -2215,6 +2221,7 @@ ParseOk Nothing Nothing Nothing + Nothing (TyApp SrcSpanInfo { srcInfoSpan = @@ -2368,6 +2375,7 @@ ParseOk Nothing Nothing Nothing + Nothing (TyFun SrcSpanInfo { srcInfoSpan = diff --git a/tests/examples/T11727.hs.parser.golden b/tests/examples/T11727.hs.parser.golden index 97395339..17355f1b 100644 --- a/tests/examples/T11727.hs.parser.golden +++ b/tests/examples/T11727.hs.parser.golden @@ -72,6 +72,7 @@ ParseOk Nothing Nothing Nothing + Nothing (TyCon SrcSpanInfo { srcInfoSpan = SrcSpan "tests/examples/T11727.hs" 5 16 5 19 diff --git a/tests/examples/completesig01.hs.parser.golden b/tests/examples/completesig01.hs.parser.golden index 58f6c82e..07d6f552 100644 --- a/tests/examples/completesig01.hs.parser.golden +++ b/tests/examples/completesig01.hs.parser.golden @@ -101,6 +101,7 @@ ParseOk Nothing Nothing Nothing + Nothing (TyCon SrcSpanInfo { srcInfoSpan = SrcSpan "tests/examples/completesig01.hs" 6 16 6 18 diff --git a/tests/examples/t403.hs b/tests/examples/t403.hs new file mode 100644 index 00000000..2e793d49 --- /dev/null +++ b/tests/examples/t403.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +module T403 where + +pattern (:&&:) :: () => forall k. ((k :+ 1) ~ n) => a -> HoHeList k a -> HoHeList n a +pattern (:&&:) x rest <- (matchNext -> Right (x, Refl, rest)) diff --git a/tests/examples/t403.hs.exactprinter.golden b/tests/examples/t403.hs.exactprinter.golden new file mode 100644 index 00000000..6e33927e --- /dev/null +++ b/tests/examples/t403.hs.exactprinter.golden @@ -0,0 +1,10 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +module T403 where + +pattern (:&&:) :: () => ((k :+ 1) ~ n) => a -> HoHeList k a -> HoHeList n a +pattern ((:&&:))xrest <- (matchNext -> Right (x, Refl, rest)) + diff --git a/tests/examples/t403.hs.parser.golden b/tests/examples/t403.hs.parser.golden new file mode 100644 index 00000000..de12bdc7 --- /dev/null +++ b/tests/examples/t403.hs.parser.golden @@ -0,0 +1,515 @@ +ParseOk + ( Module + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 1 1 10 1 + , srcInfoPoints = + [ SrcSpan "tests/examples/t403.hs" 1 1 1 1 + , SrcSpan "tests/examples/t403.hs" 2 1 2 1 + , SrcSpan "tests/examples/t403.hs" 3 1 3 1 + , SrcSpan "tests/examples/t403.hs" 4 1 4 1 + , SrcSpan "tests/examples/t403.hs" 5 1 5 1 + , SrcSpan "tests/examples/t403.hs" 6 1 6 1 + , SrcSpan "tests/examples/t403.hs" 6 1 6 1 + , SrcSpan "tests/examples/t403.hs" 8 1 8 1 + , SrcSpan "tests/examples/t403.hs" 9 1 9 1 + , SrcSpan "tests/examples/t403.hs" 10 1 10 1 + , SrcSpan "tests/examples/t403.hs" 10 1 10 1 + ] + } + (Just + (ModuleHead + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 6 1 6 18 + , srcInfoPoints = + [ SrcSpan "tests/examples/t403.hs" 6 1 6 7 + , SrcSpan "tests/examples/t403.hs" 6 13 6 18 + ] + } + (ModuleName + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 6 8 6 12 + , srcInfoPoints = [] + } + "T403") + Nothing + Nothing)) + [ LanguagePragma + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 1 1 1 33 + , srcInfoPoints = + [ SrcSpan "tests/examples/t403.hs" 1 1 1 13 + , SrcSpan "tests/examples/t403.hs" 1 30 1 33 + ] + } + [ Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 1 14 1 29 + , srcInfoPoints = [] + } + "PatternSynonyms" + ] + , LanguagePragma + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 2 1 2 28 + , srcInfoPoints = + [ SrcSpan "tests/examples/t403.hs" 2 1 2 13 + , SrcSpan "tests/examples/t403.hs" 2 25 2 28 + ] + } + [ Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 2 14 2 24 + , srcInfoPoints = [] + } + "RankNTypes" + ] + , LanguagePragma + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 3 1 3 30 + , srcInfoPoints = + [ SrcSpan "tests/examples/t403.hs" 3 1 3 13 + , SrcSpan "tests/examples/t403.hs" 3 27 3 30 + ] + } + [ Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 3 14 3 26 + , srcInfoPoints = [] + } + "ViewPatterns" + ] + , LanguagePragma + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 4 1 4 31 + , srcInfoPoints = + [ SrcSpan "tests/examples/t403.hs" 4 1 4 13 + , SrcSpan "tests/examples/t403.hs" 4 28 4 31 + ] + } + [ Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 4 14 4 27 + , srcInfoPoints = [] + } + "TypeOperators" + ] + , LanguagePragma + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 5 1 5 27 + , srcInfoPoints = + [ SrcSpan "tests/examples/t403.hs" 5 1 5 13 + , SrcSpan "tests/examples/t403.hs" 5 24 5 27 + ] + } + [ Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 5 14 5 23 + , srcInfoPoints = [] + } + "DataKinds" + ] + ] + [] + [ PatSynSig + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 1 8 86 + , srcInfoPoints = + [ SrcSpan "tests/examples/t403.hs" 8 1 8 8 + , SrcSpan "tests/examples/t403.hs" 8 16 8 18 + ] + } + [ Symbol + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 9 8 15 + , srcInfoPoints = + [ SrcSpan "tests/examples/t403.hs" 8 9 8 10 + , SrcSpan "tests/examples/t403.hs" 8 10 8 14 + , SrcSpan "tests/examples/t403.hs" 8 14 8 15 + ] + } + ":&&:" + ] + Nothing + (Just + (CxEmpty + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 19 8 24 + , srcInfoPoints = + [ SrcSpan "tests/examples/t403.hs" 8 19 8 20 + , SrcSpan "tests/examples/t403.hs" 8 20 8 21 + , SrcSpan "tests/examples/t403.hs" 8 22 8 24 + ] + })) + (Just + [ UnkindedVar + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 32 8 33 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 32 8 33 + , srcInfoPoints = [] + } + "k") + ]) + (Just + (CxSingle + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 35 8 52 + , srcInfoPoints = + [ SrcSpan "tests/examples/t403.hs" 8 35 8 36 + , SrcSpan "tests/examples/t403.hs" 8 48 8 49 + , SrcSpan "tests/examples/t403.hs" 8 50 8 52 + ] + } + (ParenA + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 35 8 52 + , srcInfoPoints = + [ SrcSpan "tests/examples/t403.hs" 8 35 8 36 + , SrcSpan "tests/examples/t403.hs" 8 48 8 49 + , SrcSpan "tests/examples/t403.hs" 8 50 8 52 + ] + } + (EqualP + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 36 8 48 + , srcInfoPoints = [ SrcSpan "tests/examples/t403.hs" 8 45 8 46 ] + } + (TyParen + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 36 8 44 + , srcInfoPoints = + [ SrcSpan "tests/examples/t403.hs" 8 36 8 37 + , SrcSpan "tests/examples/t403.hs" 8 43 8 44 + ] + } + (TyInfix + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 37 8 43 + , srcInfoPoints = [] + } + (TyVar + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 37 8 38 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 37 8 38 + , srcInfoPoints = [] + } + "k")) + (UnpromotedName + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 39 8 41 + , srcInfoPoints = [] + } + (UnQual + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 39 8 41 + , srcInfoPoints = [] + } + (Symbol + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 39 8 41 + , srcInfoPoints = [] + } + ":+"))) + (TyPromoted + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 42 8 43 + , srcInfoPoints = [] + } + (PromotedInteger + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 42 8 43 + , srcInfoPoints = [] + } + 1 + "1")))) + (TyVar + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 47 8 48 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 47 8 48 + , srcInfoPoints = [] + } + "n")))))) + (TyFun + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 53 8 86 + , srcInfoPoints = [ SrcSpan "tests/examples/t403.hs" 8 55 8 57 ] + } + (TyVar + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 53 8 54 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 53 8 54 + , srcInfoPoints = [] + } + "a")) + (TyFun + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 58 8 86 + , srcInfoPoints = [ SrcSpan "tests/examples/t403.hs" 8 71 8 73 ] + } + (TyApp + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 58 8 70 + , srcInfoPoints = [] + } + (TyApp + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 58 8 68 + , srcInfoPoints = [] + } + (TyCon + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 58 8 66 + , srcInfoPoints = [] + } + (UnQual + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 58 8 66 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 58 8 66 + , srcInfoPoints = [] + } + "HoHeList"))) + (TyVar + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 67 8 68 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 67 8 68 + , srcInfoPoints = [] + } + "k"))) + (TyVar + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 69 8 70 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 69 8 70 + , srcInfoPoints = [] + } + "a"))) + (TyApp + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 74 8 86 + , srcInfoPoints = [] + } + (TyApp + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 74 8 84 + , srcInfoPoints = [] + } + (TyCon + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 74 8 82 + , srcInfoPoints = [] + } + (UnQual + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 74 8 82 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 74 8 82 + , srcInfoPoints = [] + } + "HoHeList"))) + (TyVar + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 83 8 84 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 83 8 84 + , srcInfoPoints = [] + } + "n"))) + (TyVar + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 85 8 86 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 8 85 8 86 + , srcInfoPoints = [] + } + "a"))))) + , PatSyn + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 1 9 62 + , srcInfoPoints = + [ SrcSpan "tests/examples/t403.hs" 9 1 9 8 + , SrcSpan "tests/examples/t403.hs" 9 23 9 25 + ] + } + (PApp + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 9 9 22 + , srcInfoPoints = [] + } + (UnQual + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 9 9 15 + , srcInfoPoints = + [ SrcSpan "tests/examples/t403.hs" 9 9 9 10 + , SrcSpan "tests/examples/t403.hs" 9 10 9 14 + , SrcSpan "tests/examples/t403.hs" 9 14 9 15 + ] + } + (Symbol + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 9 9 15 + , srcInfoPoints = + [ SrcSpan "tests/examples/t403.hs" 9 9 9 10 + , SrcSpan "tests/examples/t403.hs" 9 10 9 14 + , SrcSpan "tests/examples/t403.hs" 9 14 9 15 + ] + } + ":&&:")) + [ PVar + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 16 9 17 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 16 9 17 + , srcInfoPoints = [] + } + "x") + , PVar + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 18 9 22 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 18 9 22 + , srcInfoPoints = [] + } + "rest") + ]) + (PParen + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 26 9 62 + , srcInfoPoints = + [ SrcSpan "tests/examples/t403.hs" 9 26 9 27 + , SrcSpan "tests/examples/t403.hs" 9 61 9 62 + ] + } + (PViewPat + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 27 9 61 + , srcInfoPoints = [ SrcSpan "tests/examples/t403.hs" 9 37 9 39 ] + } + (Var + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 27 9 36 + , srcInfoPoints = [] + } + (UnQual + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 27 9 36 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 27 9 36 + , srcInfoPoints = [] + } + "matchNext"))) + (PApp + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 40 9 61 + , srcInfoPoints = [] + } + (UnQual + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 40 9 45 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 40 9 45 + , srcInfoPoints = [] + } + "Right")) + [ PTuple + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 46 9 61 + , srcInfoPoints = + [ SrcSpan "tests/examples/t403.hs" 9 46 9 47 + , SrcSpan "tests/examples/t403.hs" 9 48 9 49 + , SrcSpan "tests/examples/t403.hs" 9 54 9 55 + , SrcSpan "tests/examples/t403.hs" 9 60 9 61 + ] + } + Boxed + [ PVar + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 47 9 48 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 47 9 48 + , srcInfoPoints = [] + } + "x") + , PApp + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 50 9 54 + , srcInfoPoints = [] + } + (UnQual + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 50 9 54 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 50 9 54 + , srcInfoPoints = [] + } + "Refl")) + [] + , PVar + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 56 9 60 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/t403.hs" 9 56 9 60 + , srcInfoPoints = [] + } + "rest") + ] + ]))) + Unidirectional + ] + , [] + ) diff --git a/tests/examples/t403.hs.prettyparser.golden b/tests/examples/t403.hs.prettyparser.golden new file mode 100644 index 00000000..1796dc27 --- /dev/null +++ b/tests/examples/t403.hs.prettyparser.golden @@ -0,0 +1 @@ +Match diff --git a/tests/examples/t403.hs.prettyprinter.golden b/tests/examples/t403.hs.prettyprinter.golden new file mode 100644 index 00000000..42295cab --- /dev/null +++ b/tests/examples/t403.hs.prettyprinter.golden @@ -0,0 +1,11 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +module T403 where + +pattern (:&&:) :: () => forall k . ((k :+ 1) ~ n) => + a -> HoHeList k a -> HoHeList n a + +pattern (:&&:) x rest <- (matchNext -> Right (x, Refl, rest)) From 18370d1e850eb412f1bc185ba6efe35c3dc12882 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Fri, 10 Aug 2018 21:02:08 +0000 Subject: [PATCH 09/12] Add Eq and Ord for ParseResult Fixes #401 --- src/Language/Haskell/Exts/ParseMonad.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/Haskell/Exts/ParseMonad.hs b/src/Language/Haskell/Exts/ParseMonad.hs index 704a3ff6..6de2e4b4 100644 --- a/src/Language/Haskell/Exts/ParseMonad.hs +++ b/src/Language/Haskell/Exts/ParseMonad.hs @@ -75,7 +75,7 @@ data ParseResult a | ParseFailed SrcLoc String -- ^ The parse failed at the specified -- source location, with an error message. - deriving Show + deriving (Show, Ord, Eq) -- | Retrieve the result of a successful parse, throwing an -- error if the parse is actually not successful. From 27bddf16e04f1ada093498cd80be4165f368d56e Mon Sep 17 00:00:00 2001 From: Vaibhav Sagar Date: Thu, 16 Aug 2018 02:45:02 +0800 Subject: [PATCH 10/12] Add MonadFail instances to ParseMonad.hs --- haskell-src-exts.cabal | 6 ++++-- src/Language/Haskell/Exts/ParseMonad.hs | 11 ++++++++++- 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/haskell-src-exts.cabal b/haskell-src-exts.cabal index b2820519..5556900e 100644 --- a/haskell-src-exts.cabal +++ b/haskell-src-exts.cabal @@ -49,10 +49,12 @@ Library base >= 4.5 && < 5, -- this is needed to access GHC.Generics on GHC 7.4 ghc-prim - -- this is needed to access Data.Semigroup on GHCs before 8.0 + -- this is needed to access Data.Semigroup and Control.Monad.Fail on GHCs + -- before 8.0 if !impl(ghc >= 8.0) Build-Depends: - semigroups >= 0.18.3 + semigroups >= 0.18.3, + fail == 4.9.* Exposed-modules: Language.Haskell.Exts, Language.Haskell.Exts.Lexer, diff --git a/src/Language/Haskell/Exts/ParseMonad.hs b/src/Language/Haskell/Exts/ParseMonad.hs index 6de2e4b4..09a55c09 100644 --- a/src/Language/Haskell/Exts/ParseMonad.hs +++ b/src/Language/Haskell/Exts/ParseMonad.hs @@ -45,6 +45,7 @@ import Language.Haskell.Exts.Extension -- (Extension, impliesExts, haskell2010) import Data.List (intercalate) import Control.Applicative import Control.Monad (when, liftM, ap) +import qualified Control.Monad.Fail as Fail import Data.Monoid hiding ((<>)) import Data.Semigroup (Semigroup(..)) -- To avoid import warnings for Control.Applicative, Data.Monoid, and Data.Semigroup @@ -95,9 +96,11 @@ instance Applicative ParseResult where instance Monad ParseResult where return = ParseOk - fail = ParseFailed noLoc + fail = Fail.fail ParseOk x >>= f = f x ParseFailed loc msg >>= _ = ParseFailed loc msg +instance Fail.MonadFail ParseResult where + fail = ParseFailed noLoc instance Semigroup m => Semigroup (ParseResult m) where ParseOk x <> ParseOk y = ParseOk $ x <> y @@ -243,6 +246,9 @@ instance Monad P where case m i x y l ch s mode of Failed loc msg -> Failed loc msg Ok s' a -> runP (k a) i x y l ch s' mode + fail = Fail.fail + +instance Fail.MonadFail P where fail s = P $ \_r _col _line loc _ _stk _m -> Failed loc s atSrcLoc :: P a -> SrcLoc -> P a @@ -348,6 +354,9 @@ instance Monad (Lex r) where return a = Lex $ \k -> k a Lex v >>= f = Lex $ \k -> v (\a -> runL (f a) k) Lex v >> Lex w = Lex $ \k -> v (\_ -> w k) + fail = Fail.fail + +instance Fail.MonadFail (Lex r) where fail s = Lex $ \_ -> fail s -- Operations on this monad From 6a8b5adb6de332bd5103374710f4a78c9f40d44e Mon Sep 17 00:00:00 2001 From: Mizunashi Mana Date: Sat, 6 Oct 2018 14:19:46 +0900 Subject: [PATCH 11/12] Refactor codes --- src/Language/Haskell/Exts/InternalLexer.hs | 28 ++++++-- src/Language/Haskell/Exts/InternalParser.ly | 20 ++++-- src/Language/Haskell/Exts/ParseMonad.hs | 66 ++++++++++++------- .../BracketInstanceHead.hs.parser.golden | 2 +- .../examples/ConstraintKinds.hs.parser.golden | 2 +- tests/examples/DataKinds2.hs.parser.golden | 2 +- tests/examples/EmptyInstance.hs.parser.golden | 2 +- tests/examples/EmptyWhere.hs.parser.golden | 4 +- .../ForallInInstance.hs.parser.golden | 2 +- tests/examples/TrailingWhere.hs.parser.golden | 4 +- .../examples/TrailingWhere2.hs.parser.golden | 4 +- .../examples/TrailingWhere3.hs.parser.golden | 4 +- 12 files changed, 95 insertions(+), 45 deletions(-) diff --git a/src/Language/Haskell/Exts/InternalLexer.hs b/src/Language/Haskell/Exts/InternalLexer.hs index fbfc3aa3..ff49dbf1 100644 --- a/src/Language/Haskell/Exts/InternalLexer.hs +++ b/src/Language/Haskell/Exts/InternalLexer.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -31,8 +32,11 @@ import Data.Char import Data.Ratio import Data.List (intercalate, isPrefixOf) import Control.Monad (when) +-- #define DEBUG 1 +#ifdef DEBUG +import Debug.Trace (trace) +#endif --- import Debug.Trace (trace) data Token = VarId String @@ -385,13 +389,22 @@ matchChar c msg = do lexer :: (Loc Token -> P a) -> P a lexer = runL topLexer +#ifdef DEBUG + . \f token -> trace (show token) $ f token +#endif topLexer :: Lex a (Loc Token) topLexer = do b <- pullCtxtFlag - if b then -- trace (show cf ++ ": " ++ show VRightCurly) $ - -- the lex context state flags that we must do an empty {} - UGLY - setBOL >> getSrcLocL >>= \l -> return (Loc (mkSrcSpan l l) VRightCurly) + if b then do +#ifdef DEBUG + trace ("By context flag: " ++ show VRightCurly) $ return () +#endif + -- the lex context state flags that we must do an empty {} - UGLY + sl <- getSrcLocL + setBOL + el <- getSrcLocL + return $ Loc (mkSrcSpan sl el) VRightCurly else do bol <- checkBOL (bol', ws) <- lexWhiteSpace bol @@ -512,7 +525,10 @@ lexNestedComment bol str = do lexBOL :: Lex a Token lexBOL = do pos <- getOffside - -- trace ("Off: " ++ (show pos)) $ do +#ifdef DEBUG + currentLoc <- getSrcLocL + trace ("Off: " ++ show (pos, currentLoc)) $ return () +#endif case pos of LT -> do -- trace "layout: inserting '}'\n" $ @@ -524,7 +540,7 @@ lexBOL = do popContextL "lexBOL" return VRightCurly EQ -> - -- trace "layout: inserting ';'\n" $ + -- trace "layout: inserting ';'" $ return SemiColon GT -> lexToken diff --git a/src/Language/Haskell/Exts/InternalParser.ly b/src/Language/Haskell/Exts/InternalParser.ly index 844cba48..12212065 100644 --- a/src/Language/Haskell/Exts/InternalParser.ly +++ b/src/Language/Haskell/Exts/InternalParser.ly @@ -1807,7 +1807,7 @@ TODO: The points can't be added here, must be propagated! > stmtlist :: { ([Stmt L],L,[S]) } > : '{' stmts '}' { (fst $2, $1 <^^> $3, $1:snd $2 ++ [$3]) } -> | open stmts close { let l' = ann . last $ fst $2 +> | stmtopen stmts close { let l' = ann . last $ fst $2 > in (fst $2, nIS $1 <++> l', $1:snd $2 ++ [$3]) } > stmts :: { ([Stmt L],[S]) } @@ -2037,11 +2037,20 @@ Implicit parameter ----------------------------------------------------------------------------- Layout -> open :: { S } : {% pushCurrentContext >> getSrcLoc >>= \s -> return $ mkSrcSpan s s {- >>= \x -> trace (show x) (return x) -} } +> open :: { S } : {% pushCurrentContext BindLayout >> getZeroSpanByLoc +> {- >>= \x -> trace (show x) (return x) -} +> } +> stmtopen :: { S } : {% pushCurrentContext StmtLayout >> getZeroSpanByLoc +> {- >>= \x -> trace (show x) (return x) -} +> } > close :: { S } -> : vccurly { $1 {- >>= \x -> trace (show x ++ show x ++ show x) (return x) -} } -- context popped in lexer. -> | error {% popContext >> getSrcLoc >>= \s -> return $ mkSrcSpan s s {- >>= \x -> trace (show x ++ show x) (return x) -} } +> : vccurly {% return $1 +> {- >>= \x -> trace (show x ++ show x ++ show x) (return x) -} +> } +> | error {% popContext >> getZeroSpanByLoc +> {- >>= \x -> trace (show x ++ show x) (return x) -} +> } ----------------------------------------------------------------------------- Pattern Synonyms @@ -2206,4 +2215,7 @@ Exported as partial parsers: > fail $ "Expected single declaration, found import declaration" > checkSingleDecl ds +> getZeroSpanByLoc :: P SrcSpan +> getZeroSpanByLoc = getSrcLoc >>= \s -> return $ mkSrcSpan s s + > } diff --git a/src/Language/Haskell/Exts/ParseMonad.hs b/src/Language/Haskell/Exts/ParseMonad.hs index 09a55c09..a97c9dba 100644 --- a/src/Language/Haskell/Exts/ParseMonad.hs +++ b/src/Language/Haskell/Exts/ParseMonad.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -18,7 +19,7 @@ module Language.Haskell.Exts.ParseMonad( -- * Generic Parsing Parseable(..), -- * Parsing - P, ParseResult(..), atSrcLoc, LexContext(..), + P, ParseResult(..), atSrcLoc, LexContext(..), LayoutKind(..), ParseMode(..), defaultParseMode, fromParseResult, runParserWithMode, runParserWithModeComments, runParser, getSrcLoc, pushCurrentContext, popContext, @@ -51,6 +52,10 @@ import Data.Semigroup (Semigroup(..)) -- To avoid import warnings for Control.Applicative, Data.Monoid, and Data.Semigroup import Prelude +#ifdef DEBUG +import Debug.Trace +#endif + -- | Class providing function for parsing at many different types. -- -- Note that for convenience of implementation, the default methods have @@ -115,7 +120,12 @@ instance ( Monoid m , Semigroup m) => Monoid (ParseResult m) where data ParseStatus a = Ok ParseState a | Failed SrcLoc String deriving Show -data LexContext = NoLayout | Layout Int +data LayoutKind + = BindLayout + | StmtLayout + deriving (Eq, Ord, Show) + +data LexContext = NoLayout | Layout LayoutKind Int deriving (Eq,Ord,Show) data ExtContext = CodeCtxt | HarpCtxt | TagCtxt | ChildCtxt @@ -123,14 +133,14 @@ data ExtContext = CodeCtxt | HarpCtxt | TagCtxt | ChildCtxt deriving (Eq,Ord,Show) type CtxtFlag = (Bool,Bool) --- (True,_) = We're in a do context. --- (_, True)= Next token must be a virtual closing brace. +-- (True, _) = We're in a do context. +-- (_, True) = Next token must be a virtual closing brace. type ParseState = ([LexContext],[[KnownExtension]],[ExtContext],CtxtFlag,[Comment]) indentOfParseState :: ParseState -> Int -indentOfParseState (Layout n:_,_,_,_,_) = n -indentOfParseState _ = 0 +indentOfParseState (Layout _ n:_,_,_,_,_) = n +indentOfParseState _ = 0 -- | Static parameters governing a parse. -- Note that the various parse functions in "Language.Haskell.Exts.Parser" @@ -278,30 +288,35 @@ getModuleName = P $ \_i _x _y _l _ch s m -> -- (So if the source loc is not to the right of the current indent, an -- empty list {} will be inserted.) -pushCurrentContext :: P () -pushCurrentContext = do +pushCurrentContext :: LayoutKind -> P () +pushCurrentContext layoutKind = do lc <- getSrcLoc indent <- currentIndent dob <- pullDoStatus let loc = srcColumn lc when (dob && loc < indent || not dob && loc <= indent) pushCtxtFlag - pushContext (Layout loc) + pushContext (Layout layoutKind loc) currentIndent :: P Int currentIndent = P $ \_r _x _y _ _ stk _mode -> Ok stk (indentOfParseState stk) pushContext :: LexContext -> P () pushContext ctxt = ---trace ("pushing lexical scope: " ++ show ctxt ++"\n") $ +#ifdef DEBUG + trace ("pushing lexical scope: " ++ show ctxt) $ +#endif P $ \_i _x _y _l _ (s, exts, e, p, c) _m -> Ok (ctxt:s, exts, e, p, c) () popContext :: P () popContext = P $ \_i _x _y loc _ stk _m -> - case stk of - (_:s, exts, e, p, c) -> --trace ("popping lexical scope, context now "++show s ++ "\n") $ - Ok (s, exts, e, p, c) () - ([],_,_,_,_) -> Failed loc "Unexpected }" -- error "Internal error: empty context in popContext" + case stk of + (_:s, exts, e, p, c) -> +#ifdef DEBUG + trace ("popping lexical scope, context now " ++ show s) $ +#endif + Ok (s, exts, e, p, c) () + ([],_,_,_,_) -> Failed loc "Unexpected }" {- -- HaRP/Hsx @@ -323,9 +338,13 @@ getExtensions = P $ \_i _x _y _l _ s m -> pushCtxtFlag :: P () pushCtxtFlag = - P $ \_i _x _y _l _ (s, exts, e, (d,c), cs) _m -> case c of - False -> Ok (s, exts, e, (d,True), cs) () - _ -> error "Internal error: context flag already pushed" + P $ \_i _x _y _l _ (s, exts, e, (d,c), cs) _m -> +#ifdef DEBUG + trace "pushing context switch" $ +#endif + case c of + False -> Ok (s, exts, e, (d,True), cs) () + _ -> error "Internal error: context flag already pushed" pullDoStatus :: P Bool pullDoStatus = P $ \_i _x _y _l _ (s, exts, e, (d,c), cs) _m -> Ok (s,exts,e,(False,c),cs) d @@ -364,6 +383,9 @@ instance Fail.MonadFail (Lex r) where getInput :: Lex r String getInput = Lex $ \cont -> P $ \r -> runP (cont r) r +parserL :: P a -> Lex r a +parserL p = Lex (p >>=) + -- | Discard some input characters (these must not include tabs or newlines). discard :: Int -> Lex r () @@ -480,16 +502,16 @@ setSrcLineL y = Lex $ \cont -> P $ \i x _ -> runP (cont ()) i x y pushContextL :: LexContext -> Lex a () -pushContextL ctxt = Lex $ \cont -> P $ \r x y loc ch (stk, exts, e, pst, cs) -> - runP (cont ()) r x y loc ch (ctxt:stk, exts, e, pst, cs) +pushContextL = parserL . pushContext popContextL :: String -> Lex a () -popContextL _ = Lex $ \cont -> P $ \r x y loc ch stk m -> case stk of - (_:ctxt, exts, e, pst, cs) -> runP (cont ()) r x y loc ch (ctxt, exts, e, pst, cs) m - ([], _, _, _, _) -> Failed loc "Unexpected }" +popContextL _ = parserL popContext pullCtxtFlag :: Lex a Bool pullCtxtFlag = Lex $ \cont -> P $ \r x y loc ch (ct, exts, e, (d,c), cs) -> +#ifdef DEBUG + trace "pulling context switch" $ +#endif runP (cont c) r x y loc ch (ct, exts, e, (d,False), cs) diff --git a/tests/examples/BracketInstanceHead.hs.parser.golden b/tests/examples/BracketInstanceHead.hs.parser.golden index b8ad64bc..e2739fe4 100644 --- a/tests/examples/BracketInstanceHead.hs.parser.golden +++ b/tests/examples/BracketInstanceHead.hs.parser.golden @@ -23,7 +23,7 @@ ParseOk , SrcSpan "tests/examples/BracketInstanceHead.hs" 1 37 1 42 , SrcSpan "tests/examples/BracketInstanceHead.hs" 2 1 2 1 , SrcSpan "tests/examples/BracketInstanceHead.hs" 2 1 2 1 - , SrcSpan "tests/examples/BracketInstanceHead.hs" 2 0 2 0 + , SrcSpan "tests/examples/BracketInstanceHead.hs" 2 1 2 0 ] } Nothing diff --git a/tests/examples/ConstraintKinds.hs.parser.golden b/tests/examples/ConstraintKinds.hs.parser.golden index bfdc4363..00da8b16 100644 --- a/tests/examples/ConstraintKinds.hs.parser.golden +++ b/tests/examples/ConstraintKinds.hs.parser.golden @@ -80,7 +80,7 @@ ParseOk , SrcSpan "tests/examples/ConstraintKinds.hs" 4 13 4 18 , SrcSpan "tests/examples/ConstraintKinds.hs" 6 1 6 1 , SrcSpan "tests/examples/ConstraintKinds.hs" 6 1 6 1 - , SrcSpan "tests/examples/ConstraintKinds.hs" 6 0 6 0 + , SrcSpan "tests/examples/ConstraintKinds.hs" 6 1 6 0 ] } Nothing diff --git a/tests/examples/DataKinds2.hs.parser.golden b/tests/examples/DataKinds2.hs.parser.golden index 09af9cbb..5cce966e 100644 --- a/tests/examples/DataKinds2.hs.parser.golden +++ b/tests/examples/DataKinds2.hs.parser.golden @@ -204,7 +204,7 @@ ParseOk , SrcSpan "tests/examples/DataKinds2.hs" 9 27 9 32 , SrcSpan "tests/examples/DataKinds2.hs" 10 1 10 1 , SrcSpan "tests/examples/DataKinds2.hs" 10 1 10 1 - , SrcSpan "tests/examples/DataKinds2.hs" 10 0 10 0 + , SrcSpan "tests/examples/DataKinds2.hs" 10 1 10 0 ] } Nothing diff --git a/tests/examples/EmptyInstance.hs.parser.golden b/tests/examples/EmptyInstance.hs.parser.golden index 8c6e8802..e0d1bd4e 100644 --- a/tests/examples/EmptyInstance.hs.parser.golden +++ b/tests/examples/EmptyInstance.hs.parser.golden @@ -23,7 +23,7 @@ ParseOk , SrcSpan "tests/examples/EmptyInstance.hs" 1 27 1 32 , SrcSpan "tests/examples/EmptyInstance.hs" 3 1 3 1 , SrcSpan "tests/examples/EmptyInstance.hs" 3 1 3 1 - , SrcSpan "tests/examples/EmptyInstance.hs" 3 0 3 0 + , SrcSpan "tests/examples/EmptyInstance.hs" 3 1 3 0 ] } Nothing diff --git a/tests/examples/EmptyWhere.hs.parser.golden b/tests/examples/EmptyWhere.hs.parser.golden index 674defd1..cdf2b494 100644 --- a/tests/examples/EmptyWhere.hs.parser.golden +++ b/tests/examples/EmptyWhere.hs.parser.golden @@ -51,11 +51,11 @@ ParseOk (Just (BDecls SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/EmptyWhere.hs" 2 0 2 1 + { srcInfoSpan = SrcSpan "tests/examples/EmptyWhere.hs" 2 1 2 1 , srcInfoPoints = [ SrcSpan "tests/examples/EmptyWhere.hs" 2 1 2 1 , SrcSpan "tests/examples/EmptyWhere.hs" 2 1 2 1 - , SrcSpan "tests/examples/EmptyWhere.hs" 2 0 2 0 + , SrcSpan "tests/examples/EmptyWhere.hs" 2 1 2 0 ] } [])) diff --git a/tests/examples/ForallInInstance.hs.parser.golden b/tests/examples/ForallInInstance.hs.parser.golden index ceb37d71..03ccbfd4 100644 --- a/tests/examples/ForallInInstance.hs.parser.golden +++ b/tests/examples/ForallInInstance.hs.parser.golden @@ -59,7 +59,7 @@ ParseOk , SrcSpan "tests/examples/ForallInInstance.hs" 4 45 4 50 , SrcSpan "tests/examples/ForallInInstance.hs" 5 1 5 1 , SrcSpan "tests/examples/ForallInInstance.hs" 5 1 5 1 - , SrcSpan "tests/examples/ForallInInstance.hs" 5 0 5 0 + , SrcSpan "tests/examples/ForallInInstance.hs" 5 1 5 0 ] } Nothing diff --git a/tests/examples/TrailingWhere.hs.parser.golden b/tests/examples/TrailingWhere.hs.parser.golden index 0ea7442a..e1fff591 100644 --- a/tests/examples/TrailingWhere.hs.parser.golden +++ b/tests/examples/TrailingWhere.hs.parser.golden @@ -99,11 +99,11 @@ ParseOk (Just (BDecls SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/TrailingWhere.hs" 5 0 5 5 + { srcInfoSpan = SrcSpan "tests/examples/TrailingWhere.hs" 5 5 5 5 , srcInfoPoints = [ SrcSpan "tests/examples/TrailingWhere.hs" 5 5 5 5 , SrcSpan "tests/examples/TrailingWhere.hs" 5 5 5 5 - , SrcSpan "tests/examples/TrailingWhere.hs" 5 0 5 0 + , SrcSpan "tests/examples/TrailingWhere.hs" 5 5 5 0 ] } [])) diff --git a/tests/examples/TrailingWhere2.hs.parser.golden b/tests/examples/TrailingWhere2.hs.parser.golden index 26213fda..c0625408 100644 --- a/tests/examples/TrailingWhere2.hs.parser.golden +++ b/tests/examples/TrailingWhere2.hs.parser.golden @@ -177,11 +177,11 @@ ParseOk (Just (BDecls SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/TrailingWhere2.hs" 6 0 6 3 + { srcInfoSpan = SrcSpan "tests/examples/TrailingWhere2.hs" 6 3 6 3 , srcInfoPoints = [ SrcSpan "tests/examples/TrailingWhere2.hs" 6 3 6 3 , SrcSpan "tests/examples/TrailingWhere2.hs" 6 3 6 3 - , SrcSpan "tests/examples/TrailingWhere2.hs" 6 0 6 0 + , SrcSpan "tests/examples/TrailingWhere2.hs" 6 3 6 0 ] } [])) diff --git a/tests/examples/TrailingWhere3.hs.parser.golden b/tests/examples/TrailingWhere3.hs.parser.golden index b33de2fd..cc4f941e 100644 --- a/tests/examples/TrailingWhere3.hs.parser.golden +++ b/tests/examples/TrailingWhere3.hs.parser.golden @@ -104,11 +104,11 @@ ParseOk (Just (BDecls SrcSpanInfo - { srcInfoSpan = SrcSpan "tests/examples/TrailingWhere3.hs" 3 0 3 5 + { srcInfoSpan = SrcSpan "tests/examples/TrailingWhere3.hs" 3 5 3 5 , srcInfoPoints = [ SrcSpan "tests/examples/TrailingWhere3.hs" 3 5 3 5 , SrcSpan "tests/examples/TrailingWhere3.hs" 3 5 3 5 - , SrcSpan "tests/examples/TrailingWhere3.hs" 3 0 3 0 + , SrcSpan "tests/examples/TrailingWhere3.hs" 3 5 3 0 ] } [])) From 6df6c0de7f76af095045f935216cac696e569cc0 Mon Sep 17 00:00:00 2001 From: Mizunashi Mana Date: Sat, 6 Oct 2018 14:21:16 +0900 Subject: [PATCH 12/12] Fix layout process for empty let statements --- src/Language/Haskell/Exts/InternalLexer.hs | 6 +- src/Language/Haskell/Exts/ParseMonad.hs | 9 +- tests/examples/EmptyBinds.hs | 8 + .../EmptyBinds.hs.exactprinter.golden | 1 + tests/examples/EmptyBinds.hs.parser.golden | 193 ++++++++++++++++++ .../EmptyBinds.hs.prettyparser.golden | 1 + .../EmptyBinds.hs.prettyprinter.golden | 7 + 7 files changed, 223 insertions(+), 2 deletions(-) create mode 100644 tests/examples/EmptyBinds.hs create mode 100644 tests/examples/EmptyBinds.hs.exactprinter.golden create mode 100644 tests/examples/EmptyBinds.hs.parser.golden create mode 100644 tests/examples/EmptyBinds.hs.prettyparser.golden create mode 100644 tests/examples/EmptyBinds.hs.prettyprinter.golden diff --git a/src/Language/Haskell/Exts/InternalLexer.hs b/src/Language/Haskell/Exts/InternalLexer.hs index ff49dbf1..185b97cd 100644 --- a/src/Language/Haskell/Exts/InternalLexer.hs +++ b/src/Language/Haskell/Exts/InternalLexer.hs @@ -32,7 +32,7 @@ import Data.Char import Data.Ratio import Data.List (intercalate, isPrefixOf) import Control.Monad (when) --- #define DEBUG 1 + #ifdef DEBUG import Debug.Trace (trace) #endif @@ -400,6 +400,10 @@ topLexer = do #ifdef DEBUG trace ("By context flag: " ++ show VRightCurly) $ return () #endif + pCtxtFlg <- checkParentContextL + when pCtxtFlg $ + popContextL "lexBOL" + -- the lex context state flags that we must do an empty {} - UGLY sl <- getSrcLocL setBOL diff --git a/src/Language/Haskell/Exts/ParseMonad.hs b/src/Language/Haskell/Exts/ParseMonad.hs index a97c9dba..e76e4204 100644 --- a/src/Language/Haskell/Exts/ParseMonad.hs +++ b/src/Language/Haskell/Exts/ParseMonad.hs @@ -34,7 +34,7 @@ module Language.Haskell.Exts.ParseMonad( -- * Harp/Hsx ExtContext(..), pushExtContextL, popExtContextL, getExtContext, - pullCtxtFlag, flagDo, + pullCtxtFlag, flagDo, checkParentContextL, getModuleName ) where @@ -519,6 +519,13 @@ flagDo :: Lex a () flagDo = Lex $ \cont -> P $ \r x y loc ch (ct, exts, e, (_,c), cs) -> runP (cont ()) r x y loc ch (ct, exts, e, (True,c), cs) +checkParentContextL :: Lex a Bool +checkParentContextL = do + l <- getSrcLocL + parserL $ P $ \_i _x _y _l _ s@(stk, _, _, _, _) _m -> case stk of + (_:Layout StmtLayout i:_) | srcColumn l == i -> Ok s True + _ -> Ok s False + -- Harp/Hsx diff --git a/tests/examples/EmptyBinds.hs b/tests/examples/EmptyBinds.hs new file mode 100644 index 00000000..28d67c48 --- /dev/null +++ b/tests/examples/EmptyBinds.hs @@ -0,0 +1,8 @@ +m1 = do let + [] + +m2 = do + let + [] + +x = True diff --git a/tests/examples/EmptyBinds.hs.exactprinter.golden b/tests/examples/EmptyBinds.hs.exactprinter.golden new file mode 100644 index 00000000..1796dc27 --- /dev/null +++ b/tests/examples/EmptyBinds.hs.exactprinter.golden @@ -0,0 +1 @@ +Match diff --git a/tests/examples/EmptyBinds.hs.parser.golden b/tests/examples/EmptyBinds.hs.parser.golden new file mode 100644 index 00000000..7c19bbf6 --- /dev/null +++ b/tests/examples/EmptyBinds.hs.parser.golden @@ -0,0 +1,193 @@ +ParseOk + ( Module + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 1 1 9 1 + , srcInfoPoints = + [ SrcSpan "tests/examples/EmptyBinds.hs" 1 1 1 1 + , SrcSpan "tests/examples/EmptyBinds.hs" 1 1 1 1 + , SrcSpan "tests/examples/EmptyBinds.hs" 1 1 1 1 + , SrcSpan "tests/examples/EmptyBinds.hs" 4 1 4 1 + , SrcSpan "tests/examples/EmptyBinds.hs" 8 1 8 1 + , SrcSpan "tests/examples/EmptyBinds.hs" 9 1 9 1 + , SrcSpan "tests/examples/EmptyBinds.hs" 9 1 9 1 + ] + } + Nothing + [] + [] + [ PatBind + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 1 1 2 11 + , srcInfoPoints = [] + } + (PVar + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 1 1 1 3 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 1 1 1 3 + , srcInfoPoints = [] + } + "m1")) + (UnGuardedRhs + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 1 4 2 11 + , srcInfoPoints = + [ SrcSpan "tests/examples/EmptyBinds.hs" 1 4 1 5 ] + } + (Do + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 1 6 2 11 + , srcInfoPoints = + [ SrcSpan "tests/examples/EmptyBinds.hs" 1 6 1 8 + , SrcSpan "tests/examples/EmptyBinds.hs" 1 9 1 9 + , SrcSpan "tests/examples/EmptyBinds.hs" 2 9 2 9 + , SrcSpan "tests/examples/EmptyBinds.hs" 4 1 4 0 + ] + } + [ LetStmt + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 1 9 2 9 + , srcInfoPoints = + [ SrcSpan "tests/examples/EmptyBinds.hs" 1 9 1 12 ] + } + (BDecls + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 2 9 2 9 + , srcInfoPoints = + [ SrcSpan "tests/examples/EmptyBinds.hs" 2 9 2 9 + , SrcSpan "tests/examples/EmptyBinds.hs" 2 9 2 9 + , SrcSpan "tests/examples/EmptyBinds.hs" 2 9 2 0 + ] + } + []) + , Qualifier + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 2 9 2 11 + , srcInfoPoints = + [ SrcSpan "tests/examples/EmptyBinds.hs" 2 9 2 10 + , SrcSpan "tests/examples/EmptyBinds.hs" 2 10 2 11 + ] + } + (List + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 2 9 2 11 + , srcInfoPoints = + [ SrcSpan "tests/examples/EmptyBinds.hs" 2 9 2 10 + , SrcSpan "tests/examples/EmptyBinds.hs" 2 10 2 11 + ] + } + []) + ])) + Nothing + , PatBind + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 4 1 6 4 + , srcInfoPoints = [] + } + (PVar + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 4 1 4 3 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 4 1 4 3 + , srcInfoPoints = [] + } + "m2")) + (UnGuardedRhs + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 4 4 6 4 + , srcInfoPoints = + [ SrcSpan "tests/examples/EmptyBinds.hs" 4 4 4 5 ] + } + (Do + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 4 6 6 4 + , srcInfoPoints = + [ SrcSpan "tests/examples/EmptyBinds.hs" 4 6 4 8 + , SrcSpan "tests/examples/EmptyBinds.hs" 5 2 5 2 + , SrcSpan "tests/examples/EmptyBinds.hs" 6 2 6 2 + , SrcSpan "tests/examples/EmptyBinds.hs" 8 1 8 0 + ] + } + [ LetStmt + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 5 2 6 2 + , srcInfoPoints = + [ SrcSpan "tests/examples/EmptyBinds.hs" 5 2 5 5 ] + } + (BDecls + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 6 2 6 2 + , srcInfoPoints = + [ SrcSpan "tests/examples/EmptyBinds.hs" 6 2 6 2 + , SrcSpan "tests/examples/EmptyBinds.hs" 6 2 6 2 + , SrcSpan "tests/examples/EmptyBinds.hs" 6 2 6 0 + ] + } + []) + , Qualifier + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 6 2 6 4 + , srcInfoPoints = + [ SrcSpan "tests/examples/EmptyBinds.hs" 6 2 6 3 + , SrcSpan "tests/examples/EmptyBinds.hs" 6 3 6 4 + ] + } + (List + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 6 2 6 4 + , srcInfoPoints = + [ SrcSpan "tests/examples/EmptyBinds.hs" 6 2 6 3 + , SrcSpan "tests/examples/EmptyBinds.hs" 6 3 6 4 + ] + } + []) + ])) + Nothing + , PatBind + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 8 1 8 9 + , srcInfoPoints = [] + } + (PVar + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 8 1 8 2 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 8 1 8 2 + , srcInfoPoints = [] + } + "x")) + (UnGuardedRhs + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 8 3 8 9 + , srcInfoPoints = + [ SrcSpan "tests/examples/EmptyBinds.hs" 8 3 8 4 ] + } + (Con + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 8 5 8 9 + , srcInfoPoints = [] + } + (UnQual + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 8 5 8 9 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = SrcSpan "tests/examples/EmptyBinds.hs" 8 5 8 9 + , srcInfoPoints = [] + } + "True")))) + Nothing + ] + , [] + ) diff --git a/tests/examples/EmptyBinds.hs.prettyparser.golden b/tests/examples/EmptyBinds.hs.prettyparser.golden new file mode 100644 index 00000000..1796dc27 --- /dev/null +++ b/tests/examples/EmptyBinds.hs.prettyparser.golden @@ -0,0 +1 @@ +Match diff --git a/tests/examples/EmptyBinds.hs.prettyprinter.golden b/tests/examples/EmptyBinds.hs.prettyprinter.golden new file mode 100644 index 00000000..74bf20d6 --- /dev/null +++ b/tests/examples/EmptyBinds.hs.prettyprinter.golden @@ -0,0 +1,7 @@ +m1 + = do let + [] +m2 + = do let + [] +x = True