diff options
author | Sebastian Graf <sebastian.graf@kit.edu> | 2019-10-10 14:44:18 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2019-11-02 20:16:33 -0400 |
commit | 182b119943d34e82f67525c4b2390557f060c5f9 (patch) | |
tree | be48b9cbadd299bece85d4d3aca33a24e6e64e71 | |
parent | 9980fb58f613ee3363c7e4cb86453e542c6c69aa (diff) | |
download | haskell-182b119943d34e82f67525c4b2390557f060c5f9.tar.gz |
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.
-rw-r--r-- | compiler/GHC/Hs/Extension.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/Hs/Pat.hs | 32 | ||||
-rw-r--r-- | compiler/GHC/Hs/Pat.hs-boot | 6 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/PmCheck.hs | 40 | ||||
-rw-r--r-- | compiler/deSugar/DsArrows.hs | 4 | ||||
-rw-r--r-- | compiler/deSugar/DsListComp.hs | 4 | ||||
-rw-r--r-- | compiler/deSugar/DsUtils.hs | 4 | ||||
-rw-r--r-- | compiler/hieFile/HieAst.hs | 9 | ||||
-rw-r--r-- | compiler/typecheck/TcArrows.hs | 4 | ||||
-rw-r--r-- | compiler/typecheck/TcHsSyn.hs | 14 | ||||
-rw-r--r-- | testsuite/tests/parser/should_compile/KindSigs.stderr | 14 | ||||
m--------- | utils/haddock | 0 |
12 files changed, 61 insertions, 77 deletions
diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs index b73855eb7a..6b1042700a 100644 --- a/compiler/GHC/Hs/Extension.hs +++ b/compiler/GHC/Hs/Extension.hs @@ -7,6 +7,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE PatternSynonyms #-} @@ -143,6 +144,12 @@ type GhcRn = GhcPass 'Renamed -- Old 'Name' type param type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, type GhcTcId = GhcTc -- Old 'TcId' type param +-- | GHC's L prefixed variants wrap their vanilla variant in this type family, +-- to add 'SrcLoc' info via 'Located'. Other passes than 'GhcPass' not +-- interested in location information can define this instance as @f p@. +type family XRec p (f :: * -> *) = r | r -> p f +type instance XRec (GhcPass p) f = Located (f (GhcPass p)) + -- | Maps the "normal" id type for a given pass type family IdP p type instance IdP GhcPs = RdrName diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index 25b0a1e184..0fa6dca7b8 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -72,7 +72,7 @@ import Data.Data hiding (TyCon,Fixity) type InPat p = LPat p -- No 'Out' constructors type OutPat p = LPat p -- No 'In' constructors -type LPat p = Pat p +type LPat p = XRec p Pat -- | Pattern -- @@ -326,34 +326,8 @@ type instance XSigPat GhcRn = NoExtField type instance XSigPat GhcTc = Type type instance XCoPat (GhcPass _) = NoExtField -type instance XXPat (GhcPass p) = Located (Pat (GhcPass p)) - - -{- -************************************************************************ -* * -* HasSrcSpan Instance -* * -************************************************************************ --} - -type instance SrcSpanLess (LPat (GhcPass p)) = Pat (GhcPass p) -instance HasSrcSpan (LPat (GhcPass p)) where - -- NB: The following chooses the behaviour of the outer location - -- wrapper replacing the inner ones. - composeSrcSpan (L sp p) = if sp == noSrcSpan - then p - else XPat (L sp (stripSrcSpanPat p)) - - -- NB: The following only returns the top-level location, if any. - decomposeSrcSpan (XPat (L sp p)) = L sp (stripSrcSpanPat p) - decomposeSrcSpan p = L noSrcSpan p - -stripSrcSpanPat :: LPat (GhcPass p) -> Pat (GhcPass p) -stripSrcSpanPat (XPat (L _ p)) = stripSrcSpanPat p -stripSrcSpanPat p = p - +type instance XXPat (GhcPass _) = NoExtCon -- --------------------------------------------------------------------- @@ -574,7 +548,7 @@ pprPat (ConPatOut { pat_con = con , ppr binds]) <+> pprConArgs details else pprUserCon (unLoc con) details -pprPat (XPat x) = ppr x +pprPat (XPat n) = noExtCon n pprUserCon :: (OutputableBndr con, OutputableBndrId p) diff --git a/compiler/GHC/Hs/Pat.hs-boot b/compiler/GHC/Hs/Pat.hs-boot index fc5671c27a..b37bf187fd 100644 --- a/compiler/GHC/Hs/Pat.hs-boot +++ b/compiler/GHC/Hs/Pat.hs-boot @@ -10,10 +10,10 @@ module GHC.Hs.Pat where import Outputable -import GHC.Hs.Extension ( OutputableBndrId, GhcPass ) +import GHC.Hs.Extension ( OutputableBndrId, GhcPass, XRec ) type role Pat nominal data Pat (i :: *) -type LPat i = Pat i +type LPat i = XRec i Pat -instance (OutputableBndrId p) => Outputable (Pat (GhcPass p)) +instance OutputableBndrId p => Outputable (Pat (GhcPass p)) diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs index 5e8a80fdcc..637a8fd7e9 100644 --- a/compiler/GHC/HsToCore/PmCheck.hs +++ b/compiler/GHC/HsToCore/PmCheck.hs @@ -470,20 +470,18 @@ translatePat :: FamInstEnvs -> Id -> Pat GhcTc -> DsM GrdVec translatePat fam_insts x pat = case pat of WildPat _ty -> pure [] VarPat _ y -> pure (mkPmLetVar (unLoc y) x) - -- XPat wraps a Located (Pat GhcTc) in GhcTc. The Located part is important - XPat p -> translatePat fam_insts x (unLoc p) - ParPat _ p -> translatePat fam_insts x p + ParPat _ p -> translateLPat fam_insts x p LazyPat _ _ -> pure [] -- like a wildcard BangPat _ p -> -- Add the bang in front of the list, because it will happen before any -- nested stuff. - (PmBang x :) <$> translatePat fam_insts x p + (PmBang x :) <$> translateLPat fam_insts x p -- (x@pat) ==> Translate pat with x as match var and handle impedance -- mismatch with incoming match var - AsPat _ (dL->L _ y) p -> (mkPmLetVar y x ++) <$> translatePat fam_insts y p + AsPat _ (dL->L _ y) p -> (mkPmLetVar y x ++) <$> translateLPat fam_insts y p - SigPat _ p _ty -> translatePat fam_insts x p + SigPat _ p _ty -> translateLPat fam_insts x p -- See Note [Translate CoPats] -- Generally the translation is @@ -507,7 +505,7 @@ translatePat fam_insts x pat = case pat of -- (fun -> pat) ===> let y = fun x, pat <- y where y is a match var of pat ViewPat _arg_ty lexpr pat -> do - (y, grds) <- translatePatV fam_insts pat + (y, grds) <- translateLPatV fam_insts pat fun <- dsLExpr lexpr pure $ PmLet y (App fun (Var x)) : grds @@ -576,12 +574,12 @@ translatePat fam_insts x pat = case pat of mkPmLitGrds x lit TuplePat _tys pats boxity -> do - (vars, grdss) <- mapAndUnzipM (translatePatV fam_insts) pats + (vars, grdss) <- mapAndUnzipM (translateLPatV fam_insts) pats let tuple_con = tupleDataCon boxity (length vars) pure $ vanillaConGrd x tuple_con vars : concat grdss SumPat _ty p alt arity -> do - (y, grds) <- translatePatV fam_insts p + (y, grds) <- translateLPatV fam_insts p let sum_con = sumDataCon alt arity -- See Note [Unboxed tuple RuntimeRep vars] in TyCon pure $ vanillaConGrd x sum_con [y] : grds @@ -590,6 +588,7 @@ translatePat fam_insts x pat = case pat of -- Not supposed to happen ConPatIn {} -> panic "Check.translatePat: ConPatIn" SplicePat {} -> panic "Check.translatePat: SplicePat" + XPat n -> noExtCon n -- | 'translatePat', but also select and return a new match var. translatePatV :: FamInstEnvs -> Pat GhcTc -> DsM (Id, GrdVec) @@ -598,12 +597,19 @@ translatePatV fam_insts pat = do grds <- translatePat fam_insts x pat pure (x, grds) +translateLPat :: FamInstEnvs -> Id -> LPat GhcTc -> DsM GrdVec +translateLPat fam_insts x = translatePat fam_insts x . unLoc + +-- | 'translateLPat', but also select and return a new match var. +translateLPatV :: FamInstEnvs -> LPat GhcTc -> DsM (Id, GrdVec) +translateLPatV fam_insts = translatePatV fam_insts . unLoc + -- | @translateListPat _ x [p1, ..., pn]@ is basically -- @translateConPatOut _ x $(mkListConPatOuts [p1, ..., pn]>@ without ever -- constructing the 'ConPatOut's. -translateListPat :: FamInstEnvs -> Id -> [Pat GhcTc] -> DsM GrdVec +translateListPat :: FamInstEnvs -> Id -> [LPat GhcTc] -> DsM GrdVec translateListPat fam_insts x pats = do - vars_and_grdss <- traverse (translatePatV fam_insts) pats + vars_and_grdss <- traverse (translateLPatV fam_insts) pats mkListGrds x vars_and_grdss -- | Translate a constructor pattern @@ -637,7 +643,7 @@ translateConPatOut fam_insts x con univ_tys ex_tvs dicts = \case -- Translate the mentioned field patterns. We're doing this first to get -- the Ids for pm_con_args. let trans_pat (n, pat) = do - (var, pvec) <- translatePatV fam_insts pat + (var, pvec) <- translateLPatV fam_insts pat pure ((n, var), pvec) (tagged_vars, arg_grdss) <- mapAndUnzipM trans_pat tagged_pats @@ -667,7 +673,7 @@ translateMatch :: FamInstEnvs -> [Id] -> LMatch GhcTc (LHsExpr GhcTc) -> DsM (GrdVec, [GrdVec]) translateMatch fam_insts vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss })) = do - pats' <- concat <$> zipWithM (translatePat fam_insts) vars pats + pats' <- concat <$> zipWithM (translateLPat fam_insts) vars pats guards' <- mapM (translateGuards fam_insts) guards -- tracePm "translateMatch" (vcat [ppr pats, ppr pats', ppr guards, ppr guards']) return (pats', guards') @@ -706,15 +712,15 @@ translateLet _binds = return [] -- | Translate a pattern guard -- @pat <- e ==> let x = e; <guards for pat <- x>@ -translateBind :: FamInstEnvs -> Pat GhcTc -> LHsExpr GhcTc -> DsM GrdVec +translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM GrdVec translateBind fam_insts p e = dsLExpr e >>= \case Var y | Nothing <- isDataConId_maybe y -- RHS is a variable, so that will allow us to omit the let - -> translatePat fam_insts y p + -> translateLPat fam_insts y p rhs -> do - x <- selectMatchVar p - (PmLet x rhs :) <$> translatePat fam_insts x p + (x, grds) <- translateLPatV fam_insts p + pure (PmLet x rhs : grds) -- | Translate a boolean guard -- @e ==> let x = e; True <- x@ diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 052a852127..ade017208d 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -327,7 +327,7 @@ dsProcExpr pat (dL->L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do fail_expr <- mkFailExpr ProcExpr env_stk_ty var <- selectSimpleMatchVarL pat match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr - let pat_ty = hsPatType pat + let pat_ty = hsLPatType pat let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty (Lam var match_code) core_cmd @@ -868,7 +868,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do -- but that's likely to be defined in terms of first. dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do - let pat_ty = hsPatType pat + let pat_ty = hsLPatType pat (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd let pat_vars = mkVarSet (collectPatBinders pat) let diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs index 943b00d71d..e826045eb5 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -279,7 +279,7 @@ deBindComp pat core_list1 quals core_list2 = do let u3_ty@u1_ty = exprType core_list1 -- two names, same thing -- u1_ty is a [alpha] type, and u2_ty = alpha - let u2_ty = hsPatType pat + let u2_ty = hsLPatType pat let res_ty = exprType core_list2 h_ty = u1_ty `mkVisFunTy` res_ty @@ -373,7 +373,7 @@ dfBindComp :: Id -> Id -- 'c' and 'n' -> DsM CoreExpr dfBindComp c_id n_id (pat, core_list1) quals = do -- find the required type - let x_ty = hsPatType pat + let x_ty = hsLPatType pat let b_ty = idType n_id -- create some new local id's diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index d03fe05d60..8559e9ae85 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -672,7 +672,7 @@ mkSelectorBinds ticks pat val_expr = return (v, [(v, val_expr)]) | is_flat_prod_lpat pat' -- Special case (B) - = do { let pat_ty = hsPatType pat' + = do { let pat_ty = hsLPatType pat' ; val_var <- newSysLocalDsNoLP pat_ty ; let mk_bind tick bndr_var @@ -758,7 +758,7 @@ mkLHsPatTup lpats = cL (getLoc (head lpats)) $ mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc -- A vanilla tuple pattern simply gets its type from its sub-patterns -mkVanillaTuplePat pats box = TuplePat (map hsPatType pats) pats box +mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box -- The Big equivalents for the source tuple expressions mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs index ca91056e06..50b4422e64 100644 --- a/compiler/hieFile/HieAst.hs +++ b/compiler/hieFile/HieAst.hs @@ -478,9 +478,6 @@ instance HasLoc (HsDataDefn GhcRn) where -- Most probably the rest will be unhelpful anyway loc _ = noSrcSpan -instance HasLoc (Pat (GhcPass a)) where - loc (dL -> L l _) = l - {- Note [Real DataCon Name] The typechecker subtitutes the conLikeWrapId for the name, but we don't want this showing up in the hieFile, so we replace the name in the Id with the @@ -581,10 +578,10 @@ instance HasType (LHsBind GhcTc) where FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name) _ -> makeNode bind spn -instance HasType (LPat GhcRn) where +instance HasType (Located (Pat GhcRn)) where getTypeNode (dL -> L spn pat) = makeNode pat spn -instance HasType (LPat GhcTc) where +instance HasType (Located (Pat GhcTc)) where getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat) instance HasType (LHsExpr GhcRn) where @@ -768,7 +765,7 @@ instance ( a ~ GhcPass p , ToHie (TScoped (ProtectedSig a)) , HasType (LPat a) , Data (HsSplice a) - ) => ToHie (PScoped (LPat (GhcPass p))) where + ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) = concatM $ getTypeNode lpat : case opat of WildPat _ -> diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index e6c07cf6ba..38ea5ade59 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -16,7 +16,7 @@ import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, t import GHC.Hs import TcMatches -import TcHsSyn( hsPatType ) +import TcHsSyn( hsLPatType ) import TcType import TcMType import TcBinds @@ -258,7 +258,7 @@ tc_cmd env ; let match' = L mtch_loc (Match { m_ext = noExtField , m_ctxt = LambdaExpr, m_pats = pats' , m_grhss = grhss' }) - arg_tys = map hsPatType pats' + arg_tys = map hsLPatType pats' cmd' = HsCmdLam x (MG { mg_alts = L l [match'] , mg_ext = MatchGroupTc arg_tys res_ty , mg_origin = origin }) diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 744af979b1..601433b99d 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -16,7 +16,7 @@ checker. module TcHsSyn ( -- * Extracting types from HsSyn - hsLitType, hsPatType, + hsLitType, hsPatType, hsLPatType, -- * Other HsSyn functions mkHsDictLet, mkHsApp, @@ -97,12 +97,15 @@ import Control.Arrow ( second ) -} +hsLPatType :: LPat GhcTc -> Type +hsLPatType (dL->L _ p) = hsPatType p + hsPatType :: Pat GhcTc -> Type -hsPatType (ParPat _ pat) = hsPatType pat +hsPatType (ParPat _ pat) = hsLPatType pat hsPatType (WildPat ty) = ty hsPatType (VarPat _ lvar) = idType (unLoc lvar) -hsPatType (BangPat _ pat) = hsPatType pat -hsPatType (LazyPat _ pat) = hsPatType pat +hsPatType (BangPat _ pat) = hsLPatType pat +hsPatType (LazyPat _ pat) = hsLPatType pat hsPatType (LitPat _ lit) = hsLitType lit hsPatType (AsPat _ var _) = idType (unLoc var) hsPatType (ViewPat ty _ _) = ty @@ -118,8 +121,7 @@ hsPatType (SigPat ty _ _) = ty hsPatType (NPat ty _ _ _) = ty hsPatType (NPlusKPat ty _ _ _ _ _) = ty hsPatType (CoPat _ _ _ ty) = ty --- XPat wraps a Located (Pat GhcTc) in GhcTc -hsPatType (XPat lpat) = hsPatType (unLoc lpat) +hsPatType (XPat n) = noExtCon n hsPatType ConPatIn{} = panic "hsPatType: ConPatIn" hsPatType SplicePat{} = panic "hsPatType: SplicePat" 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 } diff --git a/utils/haddock b/utils/haddock -Subproject fad111e9d3de1a2e86837d3e6f72fe0cf2f6c0a +Subproject b34ca2554a3440f092f585bb7fc1e9d4b2ca861 |