Commit 182b1199 authored by Sebastian Graf's avatar Sebastian Graf Committed by Marge Bot

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.
parent 9980fb58
Pipeline #12083 failed with stages
in 3 minutes and 22 seconds
......@@ -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
......
......@@ -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)
......
......@@ -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))
......@@ -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@
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 _ ->
......
......@@ -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 })
......
......@@ -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"
......
......@@ -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 }
......
Subproject commit fad111e9d3de1a2e86837d3e6f72fe0cf2f6c0ac
Subproject commit b34ca2554a3440f092f585bb7fc1e9d4b2ca8616
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment