From 182b119943d34e82f67525c4b2390557f060c5f9 Mon Sep 17 00:00:00 2001 From: Sebastian Graf Date: Thu, 10 Oct 2019 14:44:18 +0200 Subject: Separate `LPat` from `Pat` on the type-level Since the Trees That Grow effort started, we had `type LPat = Pat`. This is so that `SrcLoc`s would only be annotated in GHC's AST, which is the reason why all GHC passes use the extension constructor `XPat` to attach source locations. See #15495 for the design discussion behind that. But now suddenly there are `XPat`s everywhere! There are several functions which dont't cope with `XPat`s by either crashing (`hsPatType`) or simply returning incorrect results (`collectEvVarsPat`). This issue was raised in #17330. I also came up with a rather clean and type-safe solution to the problem: We define ```haskell type family XRec p (f :: * -> *) = r | r -> p f type instance XRec (GhcPass p) f = Located (f (GhcPass p)) type instance XRec TH f = f p type LPat p = XRec p Pat ``` This is a rather modular embedding of the old "ping-pong" style, while we only pay for the `Located` wrapper within GHC. No ping-ponging in a potential Template Haskell AST, for example. Yet, we miss no case where we should've handled a `SrcLoc`: `hsPatType` and `collectEvVarsPat` are not callable at an `LPat`. Also, this gets rid of one indirection in `Located` variants: Previously, we'd have to go through `XPat` and `Located` to get from `LPat` to the wrapped `Pat`. Now it's just `Located` again. Thus we fix #17330. --- testsuite/tests/parser/should_compile/KindSigs.stderr | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) (limited to 'testsuite/tests/parser/should_compile') diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr index 4612d87cad..2873bfcfaa 100644 --- a/testsuite/tests/parser/should_compile/KindSigs.stderr +++ b/testsuite/tests/parser/should_compile/KindSigs.stderr @@ -339,14 +339,12 @@ {OccName: qux})) (Prefix) (NoSrcStrict)) - [(XPat - ({ KindSigs.hs:23:5 } - (WildPat - (NoExtField)))) - ,(XPat - ({ KindSigs.hs:23:7 } - (WildPat - (NoExtField))))] + [({ KindSigs.hs:23:5 } + (WildPat + (NoExtField))) + ,({ KindSigs.hs:23:7 } + (WildPat + (NoExtField)))] (GRHSs (NoExtField) [({ KindSigs.hs:23:9-12 } -- cgit v1.2.1