summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2018-04-04 21:43:25 +0200
committerAlan Zimmerman <alan.zimm@gmail.com>2018-04-07 11:10:29 +0200
commit151b14d4b152daa70f11b3d09ec2307f4c375f01 (patch)
tree005f98f39fad88267b7e21b46131059f49cec683
parent0d06dad00a0b3de9ad5257b9a98c2e66f01eb3ec (diff)
downloadhaskell-151b14d4b152daa70f11b3d09ec2307f4c375f01.tar.gz
WIP on TTG for HsBindswip/ttg-next
Diffstat
-rw-r--r--compiler/deSugar/Coverage.hs10
-rw-r--r--compiler/deSugar/DsBinds.hs7
-rw-r--r--compiler/deSugar/DsExpr.hs9
-rw-r--r--compiler/deSugar/DsMeta.hs24
-rw-r--r--compiler/hsSyn/Convert.hs21
-rw-r--r--compiler/hsSyn/HsBinds.hs171
-rw-r--r--compiler/hsSyn/HsExtension.hs112
-rw-r--r--compiler/hsSyn/HsUtils.hs16
-rw-r--r--compiler/parser/Parser.y38
-rw-r--r--compiler/parser/RdrHsSyn.hs4
-rw-r--r--compiler/rename/RnBinds.hs104
-rw-r--r--compiler/rename/RnExpr.hs6
-rw-r--r--compiler/rename/RnNames.hs2
-rw-r--r--compiler/rename/RnSource.hs6
-rw-r--r--compiler/typecheck/TcBinds.hs33
-rw-r--r--compiler/typecheck/TcClassDcl.hs15
-rw-r--r--compiler/typecheck/TcEnv.hs4
-rw-r--r--compiler/typecheck/TcGenDeriv.hs10
-rw-r--r--compiler/typecheck/TcHsSyn.hs31
-rw-r--r--compiler/typecheck/TcInstDcls.hs16
-rw-r--r--compiler/typecheck/TcPatSyn.hs3
-rw-r--r--compiler/typecheck/TcSigs.hs25
-rw-r--r--compiler/typecheck/TcTyClsDecls.hs4
-rw-r--r--compiler/typecheck/TcTyDecls.hs2
24 files changed, 443 insertions, 230 deletions
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index 431acddbc9..6f7a457fa5 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -803,16 +803,18 @@ addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do
addTickHsValBinds _ = panic "addTickHsValBinds"
addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
-addTickHsIPBinds (IPBinds ipbinds dictbinds) =
+addTickHsIPBinds (IPBinds dictbinds ipbinds ) =
liftM2 IPBinds
- (mapM (liftL (addTickIPBind)) ipbinds)
(return dictbinds)
+ (mapM (liftL (addTickIPBind)) ipbinds)
+addTickHsIPBinds (XHsIPBinds x) = return (XHsIPBinds x)
addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)
-addTickIPBind (IPBind nm e) =
- liftM2 IPBind
+addTickIPBind (IPBind x nm e) =
+ liftM2 (IPBind x)
(return nm)
(addTickLHsExpr e)
+addTickIPBind (XCIPBind x) = return (XCIPBind x)
-- There is no location here, so we might need to use a context location??
addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 5028d04de7..ad666a2ce2 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -163,7 +163,7 @@ dsHsBind dflags b@(FunBind { fun_id = L _ fun, fun_matches = matches
return (force_var, [core_binds]) }
dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
- , pat_rhs_ty = ty
+ , pat_ext = NPatBindTc _ ty
, pat_ticks = (rhs_tick, var_ticks) })
= do { body_expr <- dsGuarded grhss ty
; checkGuardMatches PatBindGuards grhss
@@ -252,6 +252,7 @@ dsAbsBinds dflags tyvars dicts exports
; return (makeCorePair dflags global
(isDefaultMethod prags)
0 (core_wrap (Var local))) }
+ mk_bind (XABExport _) = panic "dsAbsBinds"
; main_binds <- mapM mk_bind exports
; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) }
@@ -296,6 +297,7 @@ dsAbsBinds dflags tyvars dicts exports
-- the user written (local) function. The global
-- Id is just the selector. Hmm.
; return ((global', rhs) : fromOL spec_binds) }
+ mk_bind (XABExport _) = panic "dsAbsBinds"
; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
@@ -343,7 +345,8 @@ dsAbsBinds dflags tyvars dicts exports
mk_export local =
do global <- newSysLocalDs
(exprType (mkLams tyvars (mkLams dicts (Var local))))
- return (ABE { abe_poly = global
+ return (ABE { abe_ext = noExt
+ , abe_poly = global
, abe_mono = local
, abe_wrap = WpHole
, abe_prags = SpecPrags [] })
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 30f61e5790..8fa65539b3 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -86,16 +86,18 @@ dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn"
-------------------------
dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
-dsIPBinds (IPBinds ip_binds ev_binds) body
+dsIPBinds (IPBinds ev_binds ip_binds) body
= do { ds_binds <- dsTcEvBinds ev_binds
; let inner = mkCoreLets ds_binds body
-- The dict bindings may not be in
-- dependency order; hence Rec
; foldrM ds_ip_bind inner ip_binds }
where
- ds_ip_bind (L _ (IPBind ~(Right n) e)) body
+ ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body
= do e' <- dsLExpr e
return (Let (NonRec n e') body)
+ ds_ip_bind (L _ (XCIPBind _)) _ = panic "dsIPBinds"
+dsIPBinds (XHsIPBinds _) _ = panic "dsIPBinds"
-------------------------
-- caller sets location
@@ -202,7 +204,8 @@ dsUnliftedBind (FunBind { fun_id = L l fun
; let rhs' = mkOptTickBox tick rhs
; return (bindNonRec fun rhs' body) }
-dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
+dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss
+ , pat_ext = NPatBindTc _ ty }) body
= -- let C x# y# = rhs in body
-- ==> case rhs of C x# y# -> body
do { rhs <- dsGuarded grhss ty
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index afdc1b835d..4d86e1cc83 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -193,11 +193,11 @@ hsSigTvBinders binds
get_scoped_tvs :: LSig GhcRn -> [Name]
get_scoped_tvs (L _ signature)
- | TypeSig _ sig <- signature
+ | TypeSig _ _ sig <- signature
= get_scoped_tvs_from_sig (hswc_body sig)
- | ClassOpSig _ _ sig <- signature
+ | ClassOpSig _ _ _ sig <- signature
= get_scoped_tvs_from_sig sig
- | PatSynSig _ sig <- signature
+ | PatSynSig _ _ sig <- signature
= get_scoped_tvs_from_sig sig
| otherwise
= []
@@ -602,7 +602,7 @@ repSafety PlayInterruptible = rep2 interruptibleName []
repSafety PlaySafe = rep2 safeName []
repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
-repFixD (L loc (FixitySig names (Fixity _ prec dir)))
+repFixD (L loc (FixitySig _ names (Fixity _ prec dir)))
= do { MkC prec' <- coreIntLit prec
; let rep_fn = case dir of
InfixL -> infixLDName
@@ -771,20 +771,21 @@ rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)]
rep_sigs = concatMapM rep_sig
rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
-rep_sig (L loc (TypeSig nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms
-rep_sig (L loc (PatSynSig nms ty)) = mapM (rep_patsyn_ty_sig loc ty) nms
-rep_sig (L loc (ClassOpSig is_deflt nms ty))
+rep_sig (L loc (TypeSig _ nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms
+rep_sig (L loc (PatSynSig _ nms ty)) = mapM (rep_patsyn_ty_sig loc ty) nms
+rep_sig (L loc (ClassOpSig _ is_deflt nms ty))
| is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms
| otherwise = mapM (rep_ty_sig sigDName loc ty) nms
rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level
-rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
-rep_sig (L loc (SpecSig nm tys ispec))
+rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc
+rep_sig (L loc (SpecSig _ nm tys ispec))
= concatMapM (\t -> rep_specialise nm t ispec loc) tys
-rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty loc
+rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc
rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty
-rep_sig (L loc (CompleteMatchSig _st cls mty)) = rep_complete_sig cls mty loc
+rep_sig (L loc (CompleteMatchSig _ _st cls mty)) = rep_complete_sig cls mty loc
+rep_sig (L _ (XSig _)) = panic "rep_sig"
rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name
-> DsM (SrcSpan, Core TH.DecQ)
@@ -1561,6 +1562,7 @@ rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn
wrapGenArgSyms (RecCon _) _ dec = return dec
wrapGenArgSyms _ ss dec = wrapGenSyms ss dec
+rep_bind (L _ (PatSynBind _ (XPatSynBind _))) = panic "rep_bind: XPatSynBind"
rep_bind (L _ (XHsBindsLR {})) = panic "rep_bind: XHsBindsLR"
repPatSynD :: Core TH.Name
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index c3eed53fc0..57bb562386 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -153,7 +153,7 @@ cvtDec (TH.ValD pat body ds)
; ds' <- cvtLocalDecs (text "a where clause") ds
; returnJustL $ Hs.ValD $
PatBind { pat_lhs = pat', pat_rhs = GRHSs body' (noLoc ds')
- , pat_rhs_ty = placeHolderType, pat_ext = noExt
+ , pat_ext = noExt
, pat_ticks = ([],[]) } }
cvtDec (TH.FunD nm cls)
@@ -169,7 +169,7 @@ cvtDec (TH.FunD nm cls)
cvtDec (TH.SigD nm typ)
= do { nm' <- vNameL nm
; ty' <- cvtType typ
- ; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) }
+ ; returnJustL $ Hs.SigD (TypeSig noExt [nm'] (mkLHsSigWcType ty')) }
cvtDec (TH.InfixD fx nm)
-- Fixity signatures are allowed for variables, constructors, and types
@@ -177,7 +177,8 @@ cvtDec (TH.InfixD fx nm)
-- the RdrName says it's a variable or a constructor. So, just assume
-- it's a variable or constructor and proceed.
= do { nm' <- vcNameL nm
- ; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) }
+ ; returnJustL (Hs.SigD (FixSig noExt
+ (FixitySig noExt [nm'] (cvtFixity fx)))) }
cvtDec (PragmaD prag)
= cvtPragmaD prag
@@ -358,7 +359,7 @@ cvtDec (TH.StandaloneDerivD ds cxt ty)
cvtDec (TH.DefaultSigD nm typ)
= do { nm' <- vNameL nm
; ty' <- cvtType typ
- ; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') }
+ ; returnJustL $ Hs.SigD $ ClassOpSig noExt True [nm'] (mkLHsSigType ty')}
cvtDec (TH.PatSynD nm args dir pat)
= do { nm' <- cNameL nm
@@ -366,7 +367,7 @@ cvtDec (TH.PatSynD nm args dir pat)
; dir' <- cvtDir nm' dir
; pat' <- cvtPat pat
; returnJustL $ Hs.ValD $ PatSynBind noExt $
- PSB nm' placeHolderType args' pat' dir' }
+ PSB noExt nm' placeHolderType args' pat' dir' }
where
cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args
cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2
@@ -384,7 +385,7 @@ cvtDec (TH.PatSynD nm args dir pat)
cvtDec (TH.PatSynSigD nm ty)
= do { nm' <- cNameL nm
; ty' <- cvtPatSynSigTy ty
- ; returnJustL $ Hs.SigD $ PatSynSig [nm'] (mkLHsSigType ty') }
+ ; returnJustL $ Hs.SigD $ PatSynSig noExt [nm'] (mkLHsSigType ty') }
----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
@@ -651,7 +652,7 @@ cvtPragmaD (InlineP nm inline rm phases)
, inl_rule = cvtRuleMatch rm
, inl_act = cvtPhases phases dflt
, inl_sat = Nothing }
- ; returnJustL $ Hs.SigD $ InlineSig nm' ip }
+ ; returnJustL $ Hs.SigD $ InlineSig noExt nm' ip }
cvtPragmaD (SpecialiseP nm ty inline phases)
= do { nm' <- vNameL nm
@@ -669,12 +670,12 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
, inl_rule = Hs.FunLike
, inl_act = cvtPhases phases dflt
, inl_sat = Nothing }
- ; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip }
+ ; returnJustL $ Hs.SigD $ SpecSig noExt nm' [mkLHsSigType ty'] ip }
cvtPragmaD (SpecialiseInstP ty)
= do { ty' <- cvtType ty
; returnJustL $ Hs.SigD $
- SpecInstSig (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
+ SpecInstSig noExt (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
cvtPragmaD (RuleP nm bndrs lhs rhs phases)
= do { let nm' = mkFastString nm
@@ -711,7 +712,7 @@ cvtPragmaD (CompleteP cls mty)
= do { cls' <- noLoc <$> mapM cNameL cls
; mty' <- traverse tconNameL mty
; returnJustL $ Hs.SigD
- $ CompleteMatchSig NoSourceText cls' mty' }
+ $ CompleteMatchSig noExt NoSourceText cls' mty' }
dfltActivation :: TH.Inline -> Activation
dfltActivation TH.NoInline = NeverActive
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index 164c0a4a1e..d375f6b9ae 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -274,8 +274,7 @@ data HsBindLR idL idR
pat_ext :: XPatBind idL idR, -- ^ See Note [Bind free vars]
pat_lhs :: LPat idL,
pat_rhs :: GRHSs idR (LHsExpr idR),
- -- AZ:TODO: put this into TTG extension too
- pat_rhs_ty :: PostTc idR Type, -- ^ Type of the GRHSs
+ -- pat_rhs_ty :: PostTc idR Type, -- ^ Type of the GRHSs
-- bind_fvs :: PostRn idL NameSet, -- ^ See Note [Bind free vars]
pat_ticks :: ([Tickish Id], [[Tickish Id]])
-- ^ Ticks to put on the rhs, if any, and ticks to put on
@@ -331,13 +330,18 @@ data HsBindLR idL idR
-- deriving instance (DataIdLR idL idR) => Data (HsBindLR idL idR)
+data NPatBindTc = NPatBindTc {
+ pat_fvs :: NameSet, -- ^ Free variables
+ pat_rhs_ty :: Type -- ^ Type of the GRHSs
+ } deriving Data
+
type instance XFunBind (GhcPass pL) GhcPs = PlaceHolder
type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables
type instance XFunBind (GhcPass pL) GhcTc = NameSet -- Free variables
type instance XPatBind GhcPs (GhcPass pR) = PlaceHolder
type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables
-type instance XPatBind GhcTc (GhcPass pR) = NameSet -- Free variables
+type instance XPatBind GhcTc (GhcPass pR) = NPatBindTc
type instance XVarBind (GhcPass pL) (GhcPass pR) = PlaceHolder
type instance XAbsBinds (GhcPass pL) (GhcPass pR) = PlaceHolder
@@ -359,15 +363,20 @@ type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = PlaceHolder
-- | Abtraction Bindings Export
data ABExport p
- -- AZ:TODO: TTG ABExport
- = ABE { abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id
+ = ABE { abe_ext :: XABE p
+ , abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id
, abe_mono :: IdP p
, abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper]
-- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
, abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas
- }
+ }
+ | XABExport (XXABExport p)
-- deriving instance (DataId p) => Data (ABExport p)
+type instance XABE (GhcPass p) = PlaceHolder
+type instance XXABExport (GhcPass p) = PlaceHolder
+
+
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
-- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow'
-- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen' @'{'@,
@@ -377,16 +386,20 @@ data ABExport p
-- | Pattern Synonym binding
data PatSynBind idL idR
- -- AZ:TODO: TTG PatSynBind
- = PSB { psb_id :: Located (IdP idL), -- ^ Name of the pattern synonym
+ = PSB { psb_ext :: XPSB idL idR,
+ psb_id :: Located (IdP idL), -- ^ Name of the pattern synonym
psb_fvs :: PostRn idR NameSet, -- ^ See Note [Bind free vars]
psb_args :: HsPatSynDetails (Located (IdP idR)),
-- ^ Formal parameter names
psb_def :: LPat idR, -- ^ Right-hand side
psb_dir :: HsPatSynDir idR -- ^ Directionality
- }
+ }
+ | XPatSynBind (XXPatSynBind idL idR)
-- deriving instance (DataIdLR idL idR) => Data (PatSynBind idL idR)
+type instance XPSB (GhcPass idL) (GhcPass idR) = PlaceHolder
+type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = PlaceHolder
+
{-
Note [AbsBinds]
~~~~~~~~~~~~~~~
@@ -686,11 +699,18 @@ pprDeclList ds = pprDeeperList vcat ds
emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds = EmptyLocalBinds noExt
-isEmptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool
-isEmptyLocalBinds (HsValBinds _ ds) = isEmptyValBinds ds
-isEmptyLocalBinds (HsIPBinds _ ds) = isEmptyIPBinds ds
-isEmptyLocalBinds (EmptyLocalBinds _) = True
-isEmptyLocalBinds (XHsLocalBindsLR _) = True
+-- AZ:These functions do not seem to be used at all?
+isEmptyLocalBindsTc :: HsLocalBindsLR (GhcPass a) GhcTc -> Bool
+isEmptyLocalBindsTc (HsValBinds _ ds) = isEmptyValBinds ds
+isEmptyLocalBindsTc (HsIPBinds _ ds) = isEmptyIPBindsTc ds
+isEmptyLocalBindsTc (EmptyLocalBinds _) = True
+isEmptyLocalBindsTc (XHsLocalBindsLR _) = True
+
+isEmptyLocalBindsPR :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool
+isEmptyLocalBindsPR (HsValBinds _ ds) = isEmptyValBinds ds
+isEmptyLocalBindsPR (HsIPBinds _ ds) = isEmptyIPBindsPR ds
+isEmptyLocalBindsPR (EmptyLocalBinds _) = True
+isEmptyLocalBindsPR (XHsLocalBindsLR _) = True
eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
eqEmptyLocalBinds (EmptyLocalBinds _) = True
@@ -767,8 +787,10 @@ instance (OutputableBndrId p) => Outputable (ABExport p) where
= vcat [ ppr gbl <+> text "<=" <+> ppr lcl
, nest 2 (pprTcSpecPrags prags)
, nest 2 (text "wrap:" <+> ppr wrap)]
+ ppr (XABExport x) = ppr x
-instance (idR ~ GhcPass pr,OutputableBndrId idL, OutputableBndrId idR)
+instance (idR ~ GhcPass pr,OutputableBndrId idL, OutputableBndrId idR,
+ Outputable (XXPatSynBind idL idR))
=> Outputable (PatSynBind idL idR) where
ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,
psb_dir = dir })
@@ -788,6 +810,7 @@ instance (idR ~ GhcPass pr,OutputableBndrId idL, OutputableBndrId idR)
ImplicitBidirectional -> ppr_simple equals
ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$
(nest 2 $ pprFunBind mg)
+ ppr (XPatSynBind x) = ppr x
pprTicks :: SDoc -> SDoc -> SDoc
-- Print stuff about ticks only when -dppr-debug is on, to avoid
@@ -809,15 +832,29 @@ pprTicks pp_no_debug pp_when_debug
-- | Haskell Implicit Parameter Bindings
data HsIPBinds id
- -- AZ:TODO TTG HsIPBinds
= IPBinds
+ (XIPBinds id)
[LIPBind id]
- TcEvBinds -- Only in typechecker output; binds
- -- uses of the implicit parameters
+ -- TcEvBinds -- Only in typechecker output; binds
+ -- -- uses of the implicit parameters
+ | XHsIPBinds (XXHsIPBinds id)
-- deriving instance (DataIdLR id id) => Data (HsIPBinds id)
-isEmptyIPBinds :: HsIPBinds id -> Bool
-isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
+type instance XIPBinds GhcPs = PlaceHolder
+type instance XIPBinds GhcRn = PlaceHolder
+type instance XIPBinds GhcTc = TcEvBinds -- binds uses of the
+ -- implicit parameters
+
+
+type instance XXHsIPBinds (GhcPass p) = PlaceHolder
+
+isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool
+isEmptyIPBindsPR (IPBinds _ is) = null is
+isEmptyIPBindsPR (XHsIPBinds _) = True
+
+isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool
+isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds
+isEmptyIPBindsTc (XHsIPBinds _) = True
-- | Located Implicit Parameter Binding
type LIPBind id = Located (IPBind id)
@@ -837,20 +874,28 @@ type LIPBind id = Located (IPBind id)
-- For details on above see note [Api annotations] in ApiAnnotation
data IPBind id
- -- AZ:TTG IPBind.
- = IPBind (Either (Located HsIPName) (IdP id)) (LHsExpr id)
+ = IPBind
+ (XIPBind id)
+ (Either (Located HsIPName) (IdP id))
+ (LHsExpr id)
+ | XCIPBind (XXIPBind id)
-- deriving instance (DataIdLR id id) => Data (IPBind id)
+type instance XIPBind (GhcPass p) = PlaceHolder
+type instance XXIPBind (GhcPass p) = PlaceHolder
+
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsIPBinds p) where
- ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
+ ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs)
$$ whenPprDebug (ppr ds)
+ ppr (XHsIPBinds x) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (IPBind p) where
- ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
+ ppr (IPBind _ lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
where name = case lr of
Left (L _ ip) -> pprBndr LetBind ip
Right id -> pprBndr LetBind id
+ ppr (XCIPBind x) = ppr x
{-
************************************************************************
@@ -870,7 +915,6 @@ type LSig pass = Located (Sig pass)
-- | Signatures and pragmas
data Sig pass
- -- AZ:TODO: TTG Sig
= -- | An ordinary type signature
--
-- > f :: Num a => a -> a
@@ -888,6 +932,7 @@ data Sig pass
-- For details on above see note [Api annotations] in ApiAnnotation
TypeSig
+ (XTypeSig pass)
[Located (IdP pass)] -- LHS of the signature; e.g. f,g,h :: blah
(LHsSigWcType pass) -- RHS of the signature; can have wildcards
@@ -900,7 +945,7 @@ data Sig pass
-- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
-- For details on above see note [Api annotations] in ApiAnnotation
- | PatSynSig [Located (IdP pass)] (LHsSigType pass)
+ | PatSynSig (XPatSynSig pass) [Located (IdP pass)] (LHsSigType pass)
-- P :: forall a b. Req => Prov => ty
-- | A signature for a class method
@@ -913,14 +958,14 @@ data Sig pass
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',
-- 'ApiAnnotation.AnnDcolon'
- | ClassOpSig Bool [Located (IdP pass)] (LHsSigType pass)
+ | ClassOpSig (XClassOpSig pass) Bool [Located (IdP pass)] (LHsSigType pass)
-- | A type signature in generated code, notably the code
-- generated for record selectors. We simply record
-- the desired Id itself, replete with its name, type
-- and IdDetails. Otherwise it's just like a type
-- signature: there should be an accompanying binding
- | IdSig Id
+ | IdSig (XIdSig pass) Id
-- | An ordinary fixity declaration
--
@@ -931,7 +976,7 @@ data Sig pass
-- 'ApiAnnotation.AnnVal'
-- For details on above see note [Api annotations] in ApiAnnotation
- | FixSig (FixitySig pass)
+ | FixSig (XFixSig pass) (FixitySig pass)
-- | An inline pragma
--
@@ -944,7 +989,8 @@ data Sig pass
-- 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
- | InlineSig (Located (IdP pass)) -- Function name
+ | InlineSig (XInlineSig pass)
+ (Located (IdP pass)) -- Function name
InlinePragma -- Never defaultInlinePragma
-- | A specialisation pragma
@@ -959,7 +1005,8 @@ data Sig pass
-- 'ApiAnnotation.AnnDcolon'
-- For details on above see note [Api annotations] in ApiAnnotation
- | SpecSig (Located (IdP pass)) -- Specialise a function or datatype ...
+ | SpecSig (XSpecSig pass)
+ (Located (IdP pass)) -- Specialise a function or datatype ...
[LHsSigType pass] -- ... to these types
InlinePragma -- The pragma on SPECIALISE_INLINE form.
-- If it's just defaultInlinePragma, then we said
@@ -976,7 +1023,7 @@ data Sig pass
-- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
- | SpecInstSig SourceText (LHsSigType pass)
+ | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass)
-- Note [Pragma source text] in BasicTypes
-- | A minimal complete definition pragma
@@ -988,7 +1035,8 @@ data Sig pass
-- 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
- | MinimalSig SourceText (LBooleanFormula (Located (IdP pass)))
+ | MinimalSig (XMinimalSig pass)
+ SourceText (LBooleanFormula (Located (IdP pass)))
-- Note [Pragma source text] in BasicTypes
-- | A "set cost centre" pragma for declarations
@@ -999,7 +1047,8 @@ data Sig pass
--
-- > {-# SCC funName "cost_centre_name" #-}
- | SCCFunSig SourceText -- Note [Pragma source text] in BasicTypes
+ | SCCFunSig (XSCCFunSig pass)
+ SourceText -- Note [Pragma source text] in BasicTypes
(Located (IdP pass)) -- Function name
(Maybe (Located StringLiteral))
-- | A complete match pragma
@@ -1009,19 +1058,38 @@ data Sig pass
-- Used to inform the pattern match checker about additional
-- complete matchings which, for example, arise from pattern
-- synonym definitions.
- | CompleteMatchSig SourceText
+ | CompleteMatchSig (XCompleteMatchSig pass)
+ SourceText
(Located [Located (IdP pass)])
(Maybe (Located (IdP pass)))
+ | XSig (XXSig pass)
-- deriving instance (DataIdLR pass pass) => Data (Sig pass)
+type instance XTypeSig (GhcPass p) = PlaceHolder
+type instance XPatSynSig (GhcPass p) = PlaceHolder
+type instance XClassOpSig (GhcPass p) = PlaceHolder
+type instance XIdSig (GhcPass p) = PlaceHolder
+type instance XFixSig (GhcPass p) = PlaceHolder
+type instance XInlineSig (GhcPass p) = PlaceHolder
+type instance XSpecSig (GhcPass p) = PlaceHolder
+type instance XSpecInstSig (GhcPass p) = PlaceHolder
+type instance XMinimalSig (GhcPass p) = PlaceHolder
+type instance XSCCFunSig (GhcPass p) = PlaceHolder
+type instance XCompleteMatchSig (GhcPass p) = PlaceHolder
+type instance XXSig (GhcPass p) = PlaceHolder
+
-- | Located Fixity Signature
type LFixitySig pass = Located (FixitySig pass)
-- | Fixity Signature
-data FixitySig pass = FixitySig [Located (IdP pass)] Fixity
+data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity
+ | XFixitySig (XXFixitySig pass)
-- deriving instance (DataId pass) => Data (FixitySig pass)
+type instance XFixitySig (GhcPass p) = PlaceHolder
+type instance XXFixitySig (GhcPass p) = PlaceHolder
+
-- | Type checker Specialisation Pragmas
--
-- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer
@@ -1102,17 +1170,18 @@ isCompleteMatchSig _ = False
hsSigDoc :: Sig name -> SDoc
hsSigDoc (TypeSig {}) = text "type signature"
hsSigDoc (PatSynSig {}) = text "pattern synonym signature"
-hsSigDoc (ClassOpSig is_deflt _ _)
+hsSigDoc (ClassOpSig _ is_deflt _ _)
| is_deflt = text "default type signature"
| otherwise = text "class method signature"
hsSigDoc (IdSig {}) = text "id signature"
hsSigDoc (SpecSig {}) = text "SPECIALISE pragma"
-hsSigDoc (InlineSig _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma"
+hsSigDoc (InlineSig _ _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma"
hsSigDoc (SpecInstSig {}) = text "SPECIALISE instance pragma"
hsSigDoc (FixSig {}) = text "fixity declaration"
hsSigDoc (MinimalSig {}) = text "MINIMAL pragma"
hsSigDoc (SCCFunSig {}) = text "SCC pragma"
hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma"
+hsSigDoc (XSig {}) = text "XSIG TTG extension"
{-
Check if signatures overlap; this is used when checking for duplicate
@@ -1124,41 +1193,43 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Sig p) where
ppr sig = ppr_sig sig
ppr_sig :: (OutputableBndrId (GhcPass p)) => Sig (GhcPass p) -> SDoc
-ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty)
-ppr_sig (ClassOpSig is_deflt vars ty)
+ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty)
+ppr_sig (ClassOpSig _ is_deflt vars ty)
| is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)
| otherwise = pprVarSig (map unLoc vars) (ppr ty)
-ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id))
-ppr_sig (FixSig fix_sig) = ppr fix_sig
-ppr_sig (SpecSig var ty inl@(InlinePragma { inl_inline = spec }))
+ppr_sig (IdSig _ id) = pprVarSig [id] (ppr (varType id))
+ppr_sig (FixSig _ fix_sig) = ppr fix_sig
+ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec }))
= pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var)
(interpp'SP ty) inl)
where
pragmaSrc = case spec of
NoUserInline -> "{-# SPECIALISE"
_ -> "{-# SPECIALISE_INLINE"
-ppr_sig (InlineSig var inl)
+ppr_sig (InlineSig _ var inl)
= pragSrcBrackets (inl_src inl) "{-# INLINE" (pprInline inl
<+> pprPrefixOcc (unLoc var))
-ppr_sig (SpecInstSig src ty)
+ppr_sig (SpecInstSig _ src ty)
= pragSrcBrackets src "{-# SPECIALISE" (text "instance" <+> ppr ty)
-ppr_sig (MinimalSig src bf)
+ppr_sig (MinimalSig _ src bf)
= pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf)
-ppr_sig (PatSynSig names sig_ty)
+ppr_sig (PatSynSig _ names sig_ty)
= text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)
-ppr_sig (SCCFunSig src fn mlabel)
+ppr_sig (SCCFunSig _ src fn mlabel)
= pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel )
-ppr_sig (CompleteMatchSig src cs mty)
+ppr_sig (CompleteMatchSig _ src cs mty)
= pragSrcBrackets src "{-# COMPLETE"
((hsep (punctuate comma (map ppr (unLoc cs))))
<+> opt_sig)
where
opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty
+ppr_sig (XSig x) = ppr x
instance OutputableBndrId pass => Outputable (FixitySig pass) where
- ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
+ ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops]
where
pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)
+ ppr (XFixitySig x) = ppr x
pragBrackets :: SDoc -> SDoc
pragBrackets doc = text "{-#" <+> doc <+> text "#-}"
diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs
index b5ffdfbe28..cc9edbf7ee 100644
--- a/compiler/hsSyn/HsExtension.hs
+++ b/compiler/hsSyn/HsExtension.hs
@@ -142,6 +142,80 @@ type ForallXHsBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =
, c (XXHsBindsLR x x')
)
+-- ABExport type families
+type family XABE x
+type family XXABExport x
+
+type ForallXABExport (c :: * -> Constraint) (x :: *) =
+ ( c (XABE x)
+ , c (XXABExport x)
+ )
+
+-- PatSynBind type families
+type family XPSB x x'
+type family XXPatSynBind x x'
+
+type ForallXPatSynBind (c :: * -> Constraint) (x :: *) (x' :: *) =
+ ( c (XPSB x x')
+ , c (XXPatSynBind x x')
+ )
+
+-- HsIPBinds type families
+type family XIPBinds x
+type family XXHsIPBinds x
+
+type ForallXHsIPBinds (c :: * -> Constraint) (x :: *) =
+ ( c (XIPBinds x)
+ , c (XXHsIPBinds x)
+ )
+
+-- IPBind type families
+type family XIPBind x
+type family XXIPBind x
+
+type ForallXIPBind (c :: * -> Constraint) (x :: *) =
+ ( c (XIPBind x)
+ , c (XXIPBind x)
+ )
+
+-- Sig type families
+type family XTypeSig x
+type family XPatSynSig x
+type family XClassOpSig x
+type family XIdSig x
+type family XFixSig x
+type family XInlineSig x
+type family XSpecSig x
+type family XSpecInstSig x
+type family XMinimalSig x
+type family XSCCFunSig x
+type family XCompleteMatchSig x
+type family XXSig x
+
+type ForallXSig (c :: * -> Constraint) (x :: *) =
+ ( c (XTypeSig x)
+ , c (XPatSynSig x)
+ , c (XClassOpSig x)
+ , c (XIdSig x)
+ , c (XFixSig x)
+ , c (XInlineSig x)
+ , c (XSpecSig x)
+ , c (XSpecInstSig x)
+ , c (XMinimalSig x)
+ , c (XSCCFunSig x)
+ , c (XCompleteMatchSig x)
+ , c (XXSig x)
+ )
+
+-- FixitySig type families
+type family XFixitySig x
+type family XXFixitySig x
+
+type ForallXFixitySig (c :: * -> Constraint) (x :: *) =
+ ( c (XFixitySig x)
+ , c (XXFixitySig x)
+ )
+
-- =====================================================================
-- Type families for the HsDecls extension points
@@ -604,6 +678,15 @@ type OutputableX p =
, Outputable (XXType p)
+ , Outputable (XXABExport p)
+
+ , Outputable (XIPBinds p)
+ , Outputable (XXHsIPBinds p)
+ , Outputable (XXIPBind p)
+ , Outputable (XXIPBind GhcRn)
+ , Outputable (XXSig p)
+ , Outputable (XXFixitySig p)
+
, Outputable (XExprWithTySig p)
, Outputable (XExprWithTySig GhcRn)
@@ -640,12 +723,17 @@ type DataId p =
, ForallXFieldOcc Data p
, ForallXAmbiguousFieldOcc Data p
- , ForallXExpr Data p
- , ForallXTupArg Data p
- , ForallXSplice Data p
- , ForallXBracket Data p
- , ForallXCmdTop Data p
- , ForallXCmd Data p
+ , ForallXExpr Data p
+ , ForallXTupArg Data p
+ , ForallXSplice Data p
+ , ForallXBracket Data p
+ , ForallXCmdTop Data p
+ , ForallXCmd Data p
+ , ForallXABExport Data p
+ , ForallXHsIPBinds Data p
+ , ForallXIPBind Data p
+ , ForallXSig Data p
+ , ForallXFixitySig Data p
, Data (NameOrRdrName (IdP p))
@@ -682,9 +770,15 @@ type DataIdLR pL pR =
, ForallXHsBindsLR Data pL pL
, ForallXHsBindsLR Data pR pR
- , ForallXParStmtBlock Data pL pR
- , ForallXParStmtBlock Data pL pL
- , ForallXParStmtBlock Data pR pR
+ , ForallXPatSynBind Data pL pR
+ , ForallXPatSynBind Data pL pL
+ , ForallXPatSynBind Data pR pR
+ -- , ForallXPatSynBind Data GhcPs GhcRn
+ -- , ForallXPatSynBind Data GhcRn GhcRn
+
+ , ForallXParStmtBlock Data pL pR
+ , ForallXParStmtBlock Data pL pL
+ , ForallXParStmtBlock Data pR pR
, ForallXParStmtBlock Data GhcRn GhcRn
)
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index cbd1c2cc48..56ec8d5f97 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -616,8 +616,8 @@ mkHsSigEnv get_info sigs
-- of which use this function
where
(gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs
- is_gen_dm_sig (L _ (ClassOpSig True _ _)) = True
- is_gen_dm_sig _ = False
+ is_gen_dm_sig (L _ (ClassOpSig _ True _ _)) = True
+ is_gen_dm_sig _ = False
mk_pairs :: [LSig GhcRn] -> [(Name, a)]
mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs
@@ -630,8 +630,9 @@ mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs]
mkClassOpSigs sigs
= map fiddle sigs
where
- fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty))
- fiddle sig = sig
+ fiddle (L loc (TypeSig _ nms ty))
+ = L loc (ClassOpSig noExt False nms (dropWildCards ty))
+ fiddle sig = sig
typeToLHsType :: Type -> LHsType GhcPs
-- ^ Converting a Type to an HsType RdrName
@@ -815,7 +816,8 @@ mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
-> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs
mkPatSynBind name details lpat dir = PatSynBind noExt psb
where
- psb = PSB{ psb_id = name
+ psb = PSB{ psb_ext = noExt
+ , psb_id = name
, psb_args = details
, psb_def = lpat
, psb_dir = dir
@@ -990,6 +992,7 @@ collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++
collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = L _ ps })) acc
| omitPatSyn = acc
| otherwise = ps : acc
+collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc
collect_bind _ (XHsBindsLR _) acc = acc
collectMethodBinders :: LHsBindsLR GhcPs idR -> [Located RdrName]
@@ -1135,7 +1138,8 @@ hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = L _ cls_name
, tcdSigs = sigs, tcdATs = ats }))
= (L loc cls_name :
[ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++
- [ L mem_loc mem_name | L mem_loc (ClassOpSig False ns _) <- sigs, L _ mem_name <- ns ]
+ [ L mem_loc mem_name | L mem_loc (ClassOpSig _ False ns _) <- sigs
+ , L _ mem_name <- ns ]
, [])
hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn }))
= (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 45835940b9..e3a05724b2 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1449,7 +1449,7 @@ where_decls :: { Located ([AddAnn]
pattern_synonym_sig :: { LSig GhcPs }
: 'pattern' con_list '::' sigtypedoc
- {% ams (sLL $1 $> $ PatSynSig (unLoc $2) (mkLHsSigType $4))
+ {% ams (sLL $1 $> $ PatSynSig noExt (unLoc $2) (mkLHsSigType $4))
[mj AnnPattern $1, mu AnnDcolon $3] }
-----------------------------------------------------------------------------
@@ -1466,7 +1466,7 @@ decl_cls : at_decl_cls { $1 }
{% do { v <- checkValSigLhs $2
; let err = text "in default signature" <> colon <+>
quotes (ppr $2)
- ; ams (sLL $1 $> $ SigD $ ClassOpSig True [v] $ mkLHsSigType $4)
+ ; ams (sLL $1 $> $ SigD $ ClassOpSig noExt True [v] $ mkLHsSigType $4)
[mj AnnDefault $1,mu AnnDcolon $3] } }
decls_cls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
@@ -1575,12 +1575,10 @@ binds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) }
,sL1 $1 $ HsValBinds noExt val_binds)) } }
| '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3]
- ,sL1 $2 $ HsIPBinds noExt (IPBinds (reverse $ unLoc $2)
- emptyTcEvBinds)) }
+ ,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) }
| vocurly dbinds close { L (getLoc $2) ([]
- ,sL1 $2 $ HsIPBinds noExt (IPBinds (reverse $ unLoc $2)
- emptyTcEvBinds)) }
+ ,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) }
wherebinds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) }
@@ -2283,7 +2281,7 @@ decl_no_th :: { LHsDecl GhcPs }
case r of {
(FunBind _ n _ _ _) ->
ams (L l ()) [mj AnnFunId n] >> return () ;
- (PatBind _ (L lh _lhs) _rhs _ _) ->
+ (PatBind _ (L lh _lhs) _rhs _) ->
ams (L lh ()) [] >> return () } ;
_ <- ams (L l ()) (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ;
@@ -2297,7 +2295,7 @@ decl_no_th :: { LHsDecl GhcPs }
case r of {
(FunBind _ n _ _ _) ->
ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ;
- (PatBind _ (L lh _lhs) _rhs _ _) ->
+ (PatBind _ (L lh _lhs) _rhs _) ->
ams (L lh ()) (fst $2) >> return () } ;
_ <- ams (L l ()) (ann ++ (fst $ unLoc $3));
return $! (sL l $ ValD r) } }
@@ -2336,10 +2334,10 @@ sigdecl :: { LHsDecl GhcPs }
{% do v <- checkValSigLhs $1
; _ <- ams (sLL $1 $> ()) [mu AnnDcolon $2]
; return (sLL $1 $> $ SigD $
- TypeSig [v] (mkLHsSigWcType $3)) }
+ TypeSig noExt [v] (mkLHsSigWcType $3)) }
| var ',' sig_vars '::' sigtypedoc
- {% do { let sig = TypeSig ($1 : reverse (unLoc $3))
+ {% do { let sig = TypeSig noExt ($1 : reverse (unLoc $3))
(mkLHsSigWcType $5)
; addAnnotation (gl $1) AnnComma (gl $2)
; ams ( sLL $1 $> $ SigD sig )
@@ -2347,7 +2345,7 @@ sigdecl :: { LHsDecl GhcPs }
| infix prec ops
{% ams (sLL $1 $> $ SigD
- (FixSig (FixitySig (fromOL $ unLoc $3)
+ (FixSig noExt (FixitySig noExt (fromOL $ unLoc $3)
(Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1)))))
[mj AnnInfix $1,mj AnnVal $2] }
@@ -2357,47 +2355,47 @@ sigdecl :: { LHsDecl GhcPs }
{% let (dcolon, tc) = $3
in ams
(sLL $1 $>
- (SigD (CompleteMatchSig (getCOMPLETE_PRAGs $1) $2 tc)))
+ (SigD (CompleteMatchSig noExt (getCOMPLETE_PRAGs $1) $2 tc)))
([ mo $1 ] ++ dcolon ++ [mc $4]) }
-- This rule is for both INLINE and INLINABLE pragmas
| '{-# INLINE' activation qvar '#-}'
- {% ams ((sLL $1 $> $ SigD (InlineSig $3
+ {% ams ((sLL $1 $> $ SigD (InlineSig noExt $3
(mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1)
(snd $2)))))
((mo $1:fst $2) ++ [mc $4]) }
| '{-# SCC' qvar '#-}'
- {% ams (sLL $1 $> (SigD (SCCFunSig (getSCC_PRAGs $1) $2 Nothing)))
+ {% ams (sLL $1 $> (SigD (SCCFunSig noExt (getSCC_PRAGs $1) $2 Nothing)))
[mo $1, mc $3] }
| '{-# SCC' qvar STRING '#-}'
{% do { scc <- getSCC $3
; let str_lit = StringLiteral (getSTRINGs $3) scc
- ; ams (sLL $1 $> (SigD (SCCFunSig (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit)))))
+ ; ams (sLL $1 $> (SigD (SCCFunSig noExt (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit)))))
[mo $1, mc $4] } }
| '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
{% ams (
let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)
(NoUserInline, FunLike) (snd $2)
- in sLL $1 $> $ SigD (SpecSig $3 (fromOL $5) inl_prag))
+ in sLL $1 $> $ SigD (SpecSig noExt $3 (fromOL $5) inl_prag))
(mo $1:mu AnnDcolon $4:mc $6:(fst $2)) }
| '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
- {% ams (sLL $1 $> $ SigD (SpecSig $3 (fromOL $5)
+ {% ams (sLL $1 $> $ SigD (SpecSig noExt $3 (fromOL $5)
(mkInlinePragma (getSPEC_INLINE_PRAGs $1)
(getSPEC_INLINE $1) (snd $2))))
(mo $1:mu AnnDcolon $4:mc $6:(fst $2)) }
| '{-# SPECIALISE' 'instance' inst_type '#-}'
{% ams (sLL $1 $>
- $ SigD (SpecInstSig (getSPEC_PRAGs $1) $3))
+ $ SigD (SpecInstSig noExt (getSPEC_PRAGs $1) $3))
[mo $1,mj AnnInstance $2,mc $4] }
-- A minimal complete definition
| '{-# MINIMAL' name_boolformula_opt '#-}'
- {% ams (sLL $1 $> $ SigD (MinimalSig (getMINIMAL_PRAGs $1) $2))
+ {% ams (sLL $1 $> $ SigD (MinimalSig noExt (getMINIMAL_PRAGs $1) $2))
[mo $1,mc $3] }
activation :: { ([AddAnn],Maybe Activation) }
@@ -3027,7 +3025,7 @@ dbinds :: { Located [LIPBind GhcPs] }
-- | {- empty -} { [] }
dbind :: { LIPBind GhcPs }
-dbind : ipvar '=' exp {% ams (sLL $1 $> (IPBind (Left $1) $3))
+dbind : ipvar '=' exp {% ams (sLL $1 $> (IPBind noExt (Left $1) $3))
[mj AnnEqual $2] }
ipvar :: { Located HsIPName }
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index f5278fc9fd..13d582cf4c 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -563,7 +563,7 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
where
fromDecl (L loc decl@(ValD (PatBind _
pat@(L _ (ConPatIn ln@(L _ name) details))
- rhs _ _))) =
+ rhs _))) =
do { unless (name == patsyn_name) $
wrongNameBindingErr loc decl
; match <- case details of
@@ -1105,7 +1105,7 @@ checkPatBind :: SDoc
-> P ([AddAnn],HsBind GhcPs)
checkPatBind msg lhs (L _ (_,grhss))
= do { lhs <- checkPattern msg lhs
- ; return ([],PatBind noExt lhs grhss placeHolderType
+ ; return ([],PatBind noExt lhs grhss
([],[])) }
checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index 4b4aad7c00..4ce3a58539 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -32,7 +32,6 @@ import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
import HsSyn
import TcRnMonad
-import TcEvidence ( emptyTcEvBinds )
import RnTypes
import RnPat
import RnNames
@@ -218,14 +217,16 @@ rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do
rnLocalBindsAndThen (XHsLocalBindsLR _) _ = panic "rnLocalBindsAndThen"
rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars)
-rnIPBinds (IPBinds ip_binds _no_dict_binds) = do
+rnIPBinds (IPBinds _ ip_binds ) = do
(ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds
- return (IPBinds ip_binds' emptyTcEvBinds, plusFVs fvs_s)
+ return (IPBinds noExt ip_binds', plusFVs fvs_s)
+rnIPBinds (XHsIPBinds _) = panic "rnIPBinds"
rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars)
-rnIPBind (IPBind ~(Left n) expr) = do
+rnIPBind (IPBind _ ~(Left n) expr) = do
(expr',fvExpr) <- rnLExpr expr
- return (IPBind (Left n) expr', fvExpr)
+ return (IPBind noExt (Left n) expr', fvExpr)
+rnIPBind (XCIPBind _) = panic "rnIPBind"
{-
************************************************************************
@@ -340,8 +341,8 @@ rnLocalValBindsAndThen
-> RnM (result, FreeVars)
rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside
= do { -- (A) Create the local fixity environment
- new_fixities <- makeMiniFixityEnv [L loc sig
- | L loc (FixSig sig) <- sigs]
+ new_fixities <- makeMiniFixityEnv [ L loc sig
+ | L loc (FixSig _ sig) <- sigs]
-- (B) Rename the LHSes
; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds
@@ -421,13 +422,13 @@ rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname })
| isTopRecNameMaker name_maker
= do { addLocM checkConName rdrname
; name <- lookupLocatedTopBndrRn rdrname -- Should be in scope already
- ; return (PatSynBind x psb{ psb_id = name }) }
+ ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) }
| otherwise -- Pattern synonym, not at top level
= do { addErr localPatternSynonymErr -- Complain, but make up a fake
-- name so that we can carry on
; name <- applyNameMaker name_maker rdrname
- ; return (PatSynBind x psb{ psb_id = name }) }
+ ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) }
where
localPatternSynonymErr :: SDoc
localPatternSynonymErr
@@ -464,7 +465,7 @@ rnBind _ bind@(PatBind { pat_lhs = pat
-- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
bndrs = collectPatBinders pat
bind' = bind { pat_rhs = grhss'
- , pat_rhs_ty = placeHolderType, pat_ext = fvs' }
+ , pat_ext = fvs' }
ok_nobind_pat
= -- See Note [Pattern bindings that bind no variables]
@@ -593,11 +594,11 @@ mkSigTvFn sigs = \n -> lookupNameEnv env n `orElse` []
get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name])
-- Returns (binders, scoped tvs for those binders)
- get_scoped_tvs (L _ (ClassOpSig _ names sig_ty))
+ get_scoped_tvs (L _ (ClassOpSig _ _ names sig_ty))
= Just (names, hsScopedTvs sig_ty)
- get_scoped_tvs (L _ (TypeSig names sig_ty))
+ get_scoped_tvs (L _ (TypeSig _ names sig_ty))
= Just (names, hsWcScopedTvs sig_ty)
- get_scoped_tvs (L _ (PatSynSig names sig_ty))
+ get_scoped_tvs (L _ (PatSynSig _ names sig_ty))
= Just (names, hsScopedTvs sig_ty)
get_scoped_tvs _ = Nothing
@@ -612,9 +613,10 @@ makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv
makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls
where
- add_one_sig env (L loc (FixitySig names fixity)) =
+ add_one_sig env (L loc (FixitySig _ names fixity)) =
foldlM add_one env [ (loc,name_loc,name,fixity)
| L name_loc name <- names ]
+ add_one_sig _ (L _ (XFixitySig _)) = panic "makeMiniFixityEnv"
add_one env (loc, name_loc, name,fixity) = do
{ -- this fixity decl is a duplicate iff
@@ -703,7 +705,8 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
-- As well as dependency analysis, we need these for the
-- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
- bind' = bind{ psb_args = details'
+ bind' = bind{ psb_ext = noExt
+ , psb_args = details'
, psb_def = pat'
, psb_dir = dir'
, psb_fvs = fvs' }
@@ -725,6 +728,8 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
= hang (text "Illegal pattern synonym declaration")
2 (text "Use -XPatternSynonyms to enable this extension")
+rnPatSynBind _ (XPatSynBind _) = panic "rnPatSynBind"
+
{-
Note [Renaming pattern synonym variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -941,41 +946,41 @@ renameSigs ctxt sigs
-- Doesn't seem worth much trouble to sort this.
renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars)
-renameSig _ (IdSig x)
- = return (IdSig x, emptyFVs) -- Actually this never occurs
+renameSig _ (IdSig _ x)
+ = return (IdSig noExt x, emptyFVs) -- Actually this never occurs
-renameSig ctxt sig@(TypeSig vs ty)
+renameSig ctxt sig@(TypeSig _ vs ty)
= do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
; let doc = TypeSigCtx (ppr_sig_bndrs vs)
; (new_ty, fvs) <- rnHsSigWcType doc ty
- ; return (TypeSig new_vs new_ty, fvs) }
+ ; return (TypeSig noExt new_vs new_ty, fvs) }
-renameSig ctxt sig@(ClassOpSig is_deflt vs ty)
+renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
= do { defaultSigs_on <- xoptM LangExt.DefaultSignatures
; when (is_deflt && not defaultSigs_on) $
addErr (defaultSigErr sig)
; new_v <- mapM (lookupSigOccRn ctxt sig) vs
; (new_ty, fvs) <- rnHsSigType ty_ctxt ty
- ; return (ClassOpSig is_deflt new_v new_ty, fvs) }
+ ; return (ClassOpSig noExt is_deflt new_v new_ty, fvs) }
where
(v1:_) = vs
ty_ctxt = GenericCtx (text "a class method signature for"
<+> quotes (ppr v1))
-renameSig _ (SpecInstSig src ty)
+renameSig _ (SpecInstSig _ src ty)
= do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx ty
- ; return (SpecInstSig src new_ty,fvs) }
+ ; return (SpecInstSig noExt src new_ty,fvs) }
-- {-# SPECIALISE #-} pragmas can refer to imported Ids
-- so, in the top-level case (when mb_names is Nothing)
-- we use lookupOccRn. If there's both an imported and a local 'f'
-- then the SPECIALISE pragma is ambiguous, unlike all other signatures
-renameSig ctxt sig@(SpecSig v tys inl)
+renameSig ctxt sig@(SpecSig _ v tys inl)
= do { new_v <- case ctxt of
TopSigCtxt {} -> lookupLocatedOccRn v
_ -> lookupSigOccRn ctxt sig v
; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys
- ; return (SpecSig new_v new_ty inl, fvs) }
+ ; return (SpecSig noExt new_v new_ty inl, fvs) }
where
ty_ctxt = GenericCtx (text "a SPECIALISE signature for"
<+> quotes (ppr v))
@@ -983,33 +988,33 @@ renameSig ctxt sig@(SpecSig v tys inl)
= do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt ty
; return ( new_ty:tys, fvs_ty `plusFV` fvs) }
-renameSig ctxt sig@(InlineSig v s)
+renameSig ctxt sig@(InlineSig _ v s)
= do { new_v <- lookupSigOccRn ctxt sig v
- ; return (InlineSig new_v s, emptyFVs) }
+ ; return (InlineSig noExt new_v s, emptyFVs) }
-renameSig ctxt (FixSig fsig)
+renameSig ctxt (FixSig _ fsig)
= do { new_fsig <- rnSrcFixityDecl ctxt fsig
- ; return (FixSig new_fsig, emptyFVs) }
+ ; return (FixSig noExt new_fsig, emptyFVs) }
-renameSig ctxt sig@(MinimalSig s (L l bf))
+renameSig ctxt sig@(MinimalSig _ s (L l bf))
= do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
- return (MinimalSig s (L l new_bf), emptyFVs)
+ return (MinimalSig noExt s (L l new_bf), emptyFVs)
-renameSig ctxt sig@(PatSynSig vs ty)
+renameSig ctxt sig@(PatSynSig _ vs ty)
= do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
; (ty', fvs) <- rnHsSigType ty_ctxt ty
- ; return (PatSynSig new_vs ty', fvs) }
+ ; return (PatSynSig noExt new_vs ty', fvs) }
where
ty_ctxt = GenericCtx (text "a pattern synonym signature for"
<+> ppr_sig_bndrs vs)
-renameSig ctxt sig@(SCCFunSig st v s)
+renameSig ctxt sig@(SCCFunSig _ st v s)
= do { new_v <- lookupSigOccRn ctxt sig v
- ; return (SCCFunSig st new_v s, emptyFVs) }
+ ; return (SCCFunSig noExt st new_v s, emptyFVs) }
-- COMPLETE Sigs can refer to imported IDs which is why we use
-- lookupLocatedOccRn rather than lookupSigOccRn
-renameSig _ctxt sig@(CompleteMatchSig s (L l bf) mty)
+renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty)
= do new_bf <- traverse lookupLocatedOccRn bf
new_mty <- traverse lookupLocatedOccRn mty
@@ -1018,7 +1023,7 @@ renameSig _ctxt sig@(CompleteMatchSig s (L l bf) mty)
-- Why 'any'? See Note [Orphan COMPLETE pragmas]
addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError
- return (CompleteMatchSig s (L l new_bf) new_mty, emptyFVs)
+ return (CompleteMatchSig noExt s (L l new_bf) new_mty, emptyFVs)
where
orphanError :: SDoc
orphanError =
@@ -1026,6 +1031,8 @@ renameSig _ctxt sig@(CompleteMatchSig s (L l bf) mty)
text "A COMPLETE pragma must mention at least one data constructor" $$
text "or pattern synonym defined in the same module."
+renameSig _ (XSig _) = panic "renameSig"
+
{-
Note [Orphan COMPLETE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1092,6 +1099,8 @@ okHsSig ctxt (L _ sig)
(CompleteMatchSig {}, TopSigCtxt {} ) -> True
(CompleteMatchSig {}, _) -> False
+ (XSig _, _) -> panic "okHsSig"
+
-------------------
findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)]
-- Check for duplicates on RdrName version,
@@ -1105,20 +1114,20 @@ findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)]
findDupSigs sigs
= findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs)
where
- expand_sig sig@(FixSig (FixitySig ns _)) = zip ns (repeat sig)
- expand_sig sig@(InlineSig n _) = [(n,sig)]
- expand_sig sig@(TypeSig ns _) = [(n,sig) | n <- ns]
- expand_sig sig@(ClassOpSig _ ns _) = [(n,sig) | n <- ns]
- expand_sig sig@(PatSynSig ns _ ) = [(n,sig) | n <- ns]
- expand_sig sig@(SCCFunSig _ n _) = [(n,sig)]
+ expand_sig sig@(FixSig _ (FixitySig _ ns _)) = zip ns (repeat sig)
+ expand_sig sig@(InlineSig _ n _) = [(n,sig)]
+ expand_sig sig@(TypeSig _ ns _) = [(n,sig) | n <- ns]
+ expand_sig sig@(ClassOpSig _ _ ns _) = [(n,sig) | n <- ns]
+ expand_sig sig@(PatSynSig _ ns _ ) = [(n,sig) | n <- ns]
+ expand_sig sig@(SCCFunSig _ _ n _) = [(n,sig)]
expand_sig _ = []
matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2
mtch (FixSig {}) (FixSig {}) = True
mtch (InlineSig {}) (InlineSig {}) = True
mtch (TypeSig {}) (TypeSig {}) = True
- mtch (ClassOpSig d1 _ _) (ClassOpSig d2 _ _) = d1 == d2
- mtch (PatSynSig _ _) (PatSynSig _ _) = True
+ mtch (ClassOpSig _ d1 _ _) (ClassOpSig _ d2 _ _) = d1 == d2
+ mtch (PatSynSig _ _ _) (PatSynSig _ _ _) = True
mtch (SCCFunSig{}) (SCCFunSig{}) = True
mtch _ _ = False
@@ -1240,9 +1249,10 @@ rnSrcFixityDecl sig_ctxt = rn_decl
-- for con-like things; hence returning a list
-- If neither are in scope, report an error; otherwise
-- return a fixity sig for each (slightly odd)
- rn_decl (FixitySig fnames fixity)
+ rn_decl (FixitySig _ fnames fixity)
= do names <- concatMapM lookup_one fnames
- return (FixitySig names fixity)
+ return (FixitySig noExt names fixity)
+ rn_decl (XFixitySig _) = panic "rnSrcFixityDecl"
lookup_one :: Located RdrName -> RnM [Located Name]
lookup_one (L name_loc rdr_name)
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index dec5cb1b35..4fe4102891 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -1100,9 +1100,9 @@ collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
collectRecStmtsFixities l =
foldr (\ s -> \acc -> case s of
(L _ (LetStmt (L _ (HsValBinds _ (ValBinds _ _ sigs))))) ->
- foldr (\ sig -> \ acc -> case sig of
- (L loc (FixSig s)) -> (L loc s) : acc
- _ -> acc) acc sigs
+ foldr (\ sig -> \ acc -> case sig of
+ (L loc (FixSig _ s)) -> (L loc s) : acc
+ _ -> acc) acc sigs
_ -> acc) [] l
-- left-hand sides
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 0f6f3a1327..5458469c44 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -667,7 +667,7 @@ getLocalNonValBinders fixity_env
-- In a hs-boot file, the value binders come from the
-- *signatures*, and there should be no foreign binders
hs_boot_sig_bndrs = [ L decl_loc (unLoc n)
- | L decl_loc (TypeSig ns _) <- val_sigs, n <- ns]
+ | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns]
-- the SrcSpan attached to the input should be the span of the
-- declaration, not just the name
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 6881575c0b..07dcff2a04 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -1571,7 +1571,7 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
-- Check the signatures
-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
- ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig False ops _) <- sigs
+ ; let sig_rdr_names_w_locs = [op |L _ (ClassOpSig _ False ops _) <- sigs
, op <- ops]
; checkDupRdrNames sig_rdr_names_w_locs
-- Typechecker is responsible for checking that we only
@@ -2105,13 +2105,13 @@ add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
-- Class declarations: pull out the fixity signatures to the top
add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
| isClassDecl d
- = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
+ = let fsigs = [ L l f | L l (FixSig _ f) <- tcdSigs d ] in
addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
| otherwise
= addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
-- Signatures: fixity sigs go a different place than all others
-add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
+add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig _ f)) ds
= addl (gp {hs_fixds = L l f : ts}) ds
add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
= addl (gp {hs_valds = add_sig (L l d) ts}) ds
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 893b18b51c..4d2e51f728 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -235,7 +235,7 @@ tcCompleteSigs :: [LSig GhcRn] -> TcM [CompleteMatch]
tcCompleteSigs sigs =
let
doOne :: Sig GhcRn -> TcM (Maybe CompleteMatch)
- doOne c@(CompleteMatchSig _ lns mtc)
+ doOne c@(CompleteMatchSig _ _ lns mtc)
= fmap Just $ do
addErrCtxt (text "In" <+> ppr c) $
case mtc of
@@ -308,7 +308,7 @@ tcCompleteSigs sigs =
tcRecSelBinds :: HsValBinds GhcRn -> TcM TcGblEnv
tcRecSelBinds (XValBindsLR (NValBinds binds sigs))
- = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
+ = tcExtendGlobalValEnv [sel_id | L _ (IdSig _ sel_id) <- sigs] $
do { (rec_sel_binds, tcg_env) <- discardWarnings $
tcValBinds TopLevel binds sigs getGblEnv
; let tcg_env' = tcg_env `addTypecheckedBinds` map snd rec_sel_binds
@@ -322,7 +322,7 @@ tcHsBootSigs binds sigs
= do { checkTc (null binds) badBootDeclErr
; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
where
- tc_boot_sig (TypeSig lnames hs_ty) = mapM f lnames
+ tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames
where
f (L _ name)
= do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty
@@ -346,7 +346,7 @@ tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside
; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) }
tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds"
-tcLocalBinds (HsIPBinds x (IPBinds ip_binds _)) thing_inside
+tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
= do { ipClass <- tcLookupClass ipClassName
; (given_ips, ip_binds') <-
mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
@@ -357,28 +357,30 @@ tcLocalBinds (HsIPBinds x (IPBinds ip_binds _)) thing_inside
; (ev_binds, result) <- checkConstraints (IPSkol ips)
[] given_ips thing_inside
- ; return (HsIPBinds x (IPBinds ip_binds' ev_binds), result) }
+ ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) }
where
- ips = [ip | L _ (IPBind (Left (L _ ip)) _) <- ip_binds]
+ ips = [ip | L _ (IPBind _ (Left (L _ ip)) _) <- ip_binds]
-- I wonder if we should do these one at at time
-- Consider ?x = 4
-- ?y = ?x + 1
- tc_ip_bind ipClass (IPBind (Left (L _ ip)) expr)
+ tc_ip_bind ipClass (IPBind _ (Left (L _ ip)) expr)
= do { ty <- newOpenFlexiTyVarTy
; let p = mkStrLitTy $ hsIPNameFS ip
; ip_id <- newDict ipClass [ p, ty ]
; expr' <- tcMonoExpr expr (mkCheckExpType ty)
; let d = toDict ipClass p ty `fmap` expr'
- ; return (ip_id, (IPBind (Right ip_id) d)) }
- tc_ip_bind _ (IPBind (Right {}) _) = panic "tc_ip_bind"
+ ; return (ip_id, (IPBind noExt (Right ip_id) d)) }
+ tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind"
+ tc_ip_bind _ (XCIPBind _) = panic "tc_ip_bind"
-- Coerces a `t` into a dictionry for `IP "x" t`.
-- co : t -> IP "x" t
toDict ipClass x ty = mkHsWrap $ mkWpCastR $
wrapIP $ mkClassPred ipClass [x,ty]
-tcLocalBinds (XHsLocalBindsLR _) _ = panic "tcLocalBinds"
+tcLocalBinds (HsIPBinds _ (XHsIPBinds _ )) _ = panic "tcLocalBinds"
+tcLocalBinds (XHsLocalBindsLR _) _ = panic "tcLocalBinds"
{- Note [Implicit parameter untouchables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -726,7 +728,8 @@ tcPolyCheck prag_fn
, fun_ext = placeHolderNamesTc
, fun_tick = tick }
- export = ABE { abe_wrap = idHsWrapper
+ export = ABE { abe_ext = noExt
+ , abe_wrap = idHsWrapper
, abe_poly = poly_id
, abe_mono = mono_id
, abe_prags = SpecPrags spec_prags }
@@ -748,7 +751,7 @@ tcPolyCheck _prag_fn sig bind
funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]
-> TcM [Tickish TcId]
funBindTicks loc fun_id mod sigs
- | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ cc_name) <- sigs ]
+ | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ]
-- this can only be a singleton list, as duplicate pragmas are rejected
-- by the renamer
, let cc_str
@@ -875,7 +878,8 @@ mkExport prag_fn insoluble qtvs theta
; when warn_missing_sigs $
localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig
- ; return (ABE { abe_wrap = wrap
+ ; return (ABE { abe_ext = noExt
+ , abe_wrap = wrap
-- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)
, abe_poly = poly_id
, abe_mono = mono_id
@@ -1512,8 +1516,7 @@ tcRhs (TcPatBind infos pat' grhss pat_ty)
; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
tcGRHSsPat grhss pat_ty
; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
- , pat_rhs_ty = pat_ty
- , pat_ext = placeHolderNamesTc
+ , pat_ext = NPatBindTc placeHolderNamesTc pat_ty
, pat_ticks = ([],[]) } )}
tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs
index 70f3f9e8f0..496bd1597b 100644
--- a/compiler/typecheck/TcClassDcl.hs
+++ b/compiler/typecheck/TcClassDcl.hs
@@ -139,8 +139,8 @@ tcClassSigs clas sigs def_methods
; traceTc "tcClassSigs 2" (ppr clas)
; return op_info }
where
- vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig False nm ty) <- sigs]
- gen_sigs = [L loc (nm,ty) | L loc (ClassOpSig True nm ty) <- sigs]
+ vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs]
+ gen_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ True nm ty) <- sigs]
dm_bind_names :: [Name] -- These ones have a value binding in the class decl
dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
@@ -280,7 +280,8 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
tcPolyCheck no_prag_fn local_dm_sig
(L bind_loc lm_bind)
- ; let export = ABE { abe_poly = global_dm_id
+ ; let export = ABE { abe_ext = noExt
+ , abe_poly = global_dm_id
, abe_mono = local_dm_id
, abe_wrap = idHsWrapper
, abe_prags = IsDefaultMethod }
@@ -352,8 +353,8 @@ mkHsSigFun sigs = lookupNameEnv env
env = mkHsSigEnv get_classop_sig sigs
get_classop_sig :: LSig GhcRn -> Maybe ([Located Name], LHsSigType GhcRn)
- get_classop_sig (L _ (ClassOpSig _ ns hs_ty)) = Just (ns, hs_ty)
- get_classop_sig _ = Nothing
+ get_classop_sig (L _ (ClassOpSig _ _ ns hs_ty)) = Just (ns, hs_ty)
+ get_classop_sig _ = Nothing
---------------------------
findMethodBind :: Name -- Selector
@@ -378,8 +379,8 @@ findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef
findMinimalDef = firstJusts . map toMinimalDef
where
toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef
- toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc bf)
- toMinimalDef _ = Nothing
+ toMinimalDef (L _ (MinimalSig _ _ (L _ bf))) = Just (fmap unLoc bf)
+ toMinimalDef _ = Nothing
{-
Note [Polymorphic methods]
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index 9f48fe0523..790708b4c9 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -655,8 +655,8 @@ getTypeSigNames sigs
get_type_sig :: LSig GhcRn -> NameSet -> NameSet
get_type_sig sig ns =
case sig of
- L _ (TypeSig names _) -> extendNameSetList ns (map unLoc names)
- L _ (PatSynSig names _) -> extendNameSetList ns (map unLoc names)
+ L _ (TypeSig _ names _) -> extendNameSetList ns (map unLoc names)
+ L _ (PatSynSig _ names _) -> extendNameSetList ns (map unLoc names)
_ -> ns
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 383b580aa5..88b697b72a 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -1328,7 +1328,7 @@ gen_data dflags data_type_name constr_names loc rep_tc
genDataTyCon :: DerivStuff
genDataTyCon -- $dT
= DerivHsBind (mkHsVarBind loc data_type_name rhs,
- L loc (TypeSig [L loc data_type_name] sig_ty))
+ L loc (TypeSig noExt [L loc data_type_name] sig_ty))
sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)
rhs = nlHsVar mkDataType_RDR
@@ -1338,7 +1338,7 @@ gen_data dflags data_type_name constr_names loc rep_tc
genDataDataCon :: DataCon -> RdrName -> DerivStuff
genDataDataCon dc constr_name -- $cT1 etc
= DerivHsBind (mkHsVarBind loc constr_name rhs,
- L loc (TypeSig [L loc constr_name] sig_ty))
+ L loc (TypeSig noExt [L loc constr_name] sig_ty))
where
sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR)
rhs = nlHsApps mkConstr_RDR constr_args
@@ -1759,7 +1759,7 @@ genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec
-> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpec dflags loc (DerivCon2Tag tycon)
= (mkFunBindSE 0 loc rdr_name eqns,
- L loc (TypeSig [L loc rdr_name] sig_ty))
+ L loc (TypeSig noExt [L loc rdr_name] sig_ty))
where
rdr_name = con2tag_RDR dflags tycon
@@ -1785,7 +1785,7 @@ genAuxBindSpec dflags loc (DerivTag2Con tycon)
= (mkFunBindSE 0 loc rdr_name
[([nlConVarPat intDataCon_RDR [a_RDR]],
nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
- L loc (TypeSig [L loc rdr_name] sig_ty))
+ L loc (TypeSig noExt [L loc rdr_name] sig_ty))
where
sig_ty = mkLHsSigWcType $ L loc $
XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
@@ -1795,7 +1795,7 @@ genAuxBindSpec dflags loc (DerivTag2Con tycon)
genAuxBindSpec dflags loc (DerivMaxTag tycon)
= (mkHsVarBind loc rdr_name rhs,
- L loc (TypeSig [L loc rdr_name] sig_ty))
+ L loc (TypeSig noExt [L loc rdr_name] sig_ty))
where
rdr_name = maxtag_RDR dflags tycon
sig_ty = mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy)))
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 1ce29ea551..789725f060 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -418,18 +418,22 @@ zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs)))
; (env2, bs') <- go env1 bs
; return (env2, (r,b'):bs') }
-zonkLocalBinds env (HsIPBinds x (IPBinds binds dict_binds)) = do
+zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do
new_binds <- mapM (wrapLocM zonk_ip_bind) binds
let
- env1 = extendIdZonkEnvRec env [ n | L _ (IPBind (Right n) _) <- new_binds]
+ env1 = extendIdZonkEnvRec env [ n
+ | L _ (IPBind _ (Right n) _) <- new_binds]
(env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
- return (env2, HsIPBinds x (IPBinds new_binds new_dict_binds))
+ return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds))
where
- zonk_ip_bind (IPBind n e)
+ zonk_ip_bind (IPBind x n e)
= do n' <- mapIPNameTc (zonkIdBndr env) n
e' <- zonkLExpr env e
- return (IPBind n' e')
+ return (IPBind x n' e')
+ zonk_ip_bind (XCIPBind _) = panic "zonkLocalBinds : XCIPBind"
+zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds _))
+ = panic "zonkLocalBinds" -- Not in typechecker output
zonkLocalBinds _ (XHsLocalBindsLR _)
= panic "zonkLocalBinds" -- Not in typechecker output
@@ -449,11 +453,13 @@ zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc)
zonk_lbind env = wrapLocM (zonk_bind env)
zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc)
-zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
+zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss
+ , pat_ext = NPatBindTc fvs ty})
= do { (_env, new_pat) <- zonkPat env pat -- Env already extended
; new_grhss <- zonkGRHSs env zonkLExpr grhss
; new_ty <- zonkTcTypeToType env ty
- ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
+ ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss
+ , pat_ext = NPatBindTc fvs new_ty }) }
zonk_bind env (VarBind { var_ext = x
, var_id = var, var_rhs = expr, var_inline = inl })
@@ -510,17 +516,20 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
| otherwise
= zonk_lbind env lbind -- The normal case
- zonk_export env (ABE{ abe_wrap = wrap
+ zonk_export env (ABE{ abe_ext = x
+ , abe_wrap = wrap
, abe_poly = poly_id
, abe_mono = mono_id
, abe_prags = prags })
= do new_poly_id <- zonkIdBndr env poly_id
(_, new_wrap) <- zonkCoFn env wrap
new_prags <- zonkSpecPrags env prags
- return (ABE{ abe_wrap = new_wrap
+ return (ABE{ abe_ext = x
+ , abe_wrap = new_wrap
, abe_poly = new_poly_id
, abe_mono = zonkIdOcc env mono_id
, abe_prags = new_prags })
+ zonk_export _ (XABExport _) = panic "zonk_bind: XABExport"
zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id
, psb_args = details
@@ -535,7 +544,9 @@ zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id
, psb_args = details'
, psb_def = lpat'
, psb_dir = dir' } }
-zonk_bind _ (XHsBindsLR _) = panic "zonk_bind"
+
+zonk_bind _ (PatSynBind _ (XPatSynBind _)) = panic "zonk_bind"
+zonk_bind _ (XHsBindsLR _) = panic "zonk_bind"
zonkPatSynDetails :: ZonkEnv
-> HsPatSynDetails (Located TcId)
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 8e201045c1..1a55d4c51c 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -890,7 +890,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
-- Newtype dfuns just inline unconditionally,
-- so don't attempt to specialise them
- export = ABE { abe_wrap = idHsWrapper
+ export = ABE { abe_ext = noExt
+ , abe_wrap = idHsWrapper
, abe_poly = dfun_id_w_prags
, abe_mono = self_dict
, abe_prags = dfun_spec_prags }
@@ -1040,7 +1041,8 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta
; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id (EvExpr sc_ev_tm)
; let sc_top_ty = mkInvForAllTys tyvars (mkLamTypes dfun_evs sc_pred)
sc_top_id = mkLocalId sc_top_name sc_top_ty
- export = ABE { abe_wrap = idHsWrapper
+ export = ABE { abe_ext = noExt
+ , abe_wrap = idHsWrapper
, abe_poly = sc_top_id
, abe_mono = sc_ev_id
, abe_prags = noSpecPrags }
@@ -1382,7 +1384,8 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys
; spec_prags <- tcSpecPrags global_meth_id prags
; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags
- export = ABE { abe_poly = global_meth_id
+ export = ABE { abe_ext = noExt
+ , abe_poly = global_meth_id
, abe_mono = local_meth_id
, abe_wrap = idHsWrapper
, abe_prags = specs }
@@ -1431,7 +1434,8 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind
- ; let export = ABE { abe_poly = local_meth_id
+ ; let export = ABE { abe_ext = noExt
+ , abe_poly = local_meth_id
, abe_mono = inner_id
, abe_wrap = hs_wrap
, abe_prags = noSpecPrags }
@@ -1583,7 +1587,7 @@ mkDefMethBind clas inst_tys sel_id dm_name
; dm_id <- tcLookupId dm_name
; let inline_prag = idInlinePragma dm_id
inline_prags | isAnyInlinePragma inline_prag
- = [noLoc (InlineSig fn inline_prag)]
+ = [noLoc (InlineSig noExt fn inline_prag)]
| otherwise
= []
-- Copy the inline pragma (if any) from the default method
@@ -1806,7 +1810,7 @@ tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
------------------------------
tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag
-tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty)
+tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty)
= addErrCtxt (spec_ctxt prag) $
do { (tyvars, theta, clas, tys) <- tcHsClsInstType SpecInstCtxt hs_ty
; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index 7f8187cf78..76eb1bd9b4 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -119,6 +119,7 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
, mkTyVarTys ex_tvs, prov_theta, map evId filtered_prov_dicts)
(map nlHsVar args, map idType args)
pat_ty rec_fields }
+tcInferPatSynDecl (XPatSynBind _) = panic "tcInferPatSynDecl"
badUnivTvErr :: [TyVar] -> TyVar -> TcM ()
-- See Note [Type variables whose kind is captured]
@@ -332,6 +333,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
-- Why do we need tcSubType here?
-- See Note [Pattern synonyms and higher rank types]
; return (mkLHsWrap wrap $ nlHsVar arg_id) }
+tcCheckPatSynDecl (XPatSynBind _) _ = panic "tcCheckPatSynDecl"
{- [Pattern synonyms and higher rank types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -821,6 +823,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
= mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] }
add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
pprMatches other_mg
+tcPatSynBuilderBind (XPatSynBind _) = panic "tcPatSynBuilderBind"
tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType)
-- monadic only for failure
diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs
index 62fa83287c..706c10c819 100644
--- a/compiler/typecheck/TcSigs.hs
+++ b/compiler/typecheck/TcSigs.hs
@@ -180,20 +180,20 @@ tcTySigs hs_sigs
; return (poly_ids, lookupNameEnv env) }
tcTySig :: LSig GhcRn -> TcM [TcSigInfo]
-tcTySig (L _ (IdSig id))
+tcTySig (L _ (IdSig _ id))
= do { let ctxt = FunSigCtxt (idName id) False
-- False: do not report redundant constraints
-- The user has no control over the signature!
sig = completeSigFromId ctxt id
; return [TcIdSig sig] }
-tcTySig (L loc (TypeSig names sig_ty))
+tcTySig (L loc (TypeSig _ names sig_ty))
= setSrcSpan loc $
do { sigs <- sequence [ tcUserTypeSig loc sig_ty (Just name)
| L _ name <- names ]
; return (map TcIdSig sigs) }
-tcTySig (L loc (PatSynSig names sig_ty))
+tcTySig (L loc (PatSynSig _ names sig_ty))
= setSrcSpan loc $
do { tpsigs <- sequence [ tcPatSynSig name sig_ty
| L _ name <- names ]
@@ -477,10 +477,13 @@ mkPragEnv sigs binds
prs = mapMaybe get_sig sigs
get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn)
- get_sig (L l (SpecSig lnm@(L _ nm) ty inl)) = Just (nm, L l $ SpecSig lnm ty (add_arity nm inl))
- get_sig (L l (InlineSig lnm@(L _ nm) inl)) = Just (nm, L l $ InlineSig lnm (add_arity nm inl))
- get_sig (L l (SCCFunSig st lnm@(L _ nm) str)) = Just (nm, L l $ SCCFunSig st lnm str)
- get_sig _ = Nothing
+ get_sig (L l (SpecSig x lnm@(L _ nm) ty inl))
+ = Just (nm, L l $ SpecSig x lnm ty (add_arity nm inl))
+ get_sig (L l (InlineSig x lnm@(L _ nm) inl))
+ = Just (nm, L l $ InlineSig x lnm (add_arity nm inl))
+ get_sig (L l (SCCFunSig x st lnm@(L _ nm) str))
+ = Just (nm, L l $ SCCFunSig x st lnm str)
+ get_sig _ = Nothing
add_arity n inl_prag -- Adjust inl_sat field to match visible arity of function
| Inline <- inl_inline inl_prag
@@ -513,7 +516,7 @@ addInlinePrags poly_id prags_for_me
| otherwise
= return poly_id
where
- inl_prags = [L loc prag | L loc (InlineSig _ prag) <- prags_for_me]
+ inl_prags = [L loc prag | L loc (InlineSig _ _ prag) <- prags_for_me]
warn_multiple_inlines _ [] = return ()
@@ -665,7 +668,7 @@ tcSpecPrags poly_id prag_sigs
--------------
tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag]
-tcSpecPrag poly_id prag@(SpecSig fun_name hs_tys inl)
+tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl)
-- See Note [Handling SPECIALISE pragmas]
--
-- The Name fun_name in the SpecSig may not be the same as that of the poly_id
@@ -721,8 +724,8 @@ tcImpPrags prags
else do
{ pss <- mapAndRecoverM (wrapLocM tcImpSpec)
[L loc (name,prag)
- | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
- , not (nameIsLocalOrFrom this_mod name) ]
+ | (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags
+ , not (nameIsLocalOrFrom this_mod name) ]
; return $ concatMap (\(L l ps) -> map (L l) ps) pss } }
where
-- Ignore SPECIALISE pragmas for imported things
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 0cfe494fc7..ba1626ca3d 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -656,8 +656,8 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name
do { _ <- tcHsContext ctxt
; mapM_ (wrapLocM kc_sig) sigs }
where
- kc_sig (ClassOpSig _ nms op_ty) = kcHsSigType nms op_ty
- kc_sig _ = return ()
+ kc_sig (ClassOpSig _ _ nms op_ty) = kcHsSigType nms op_ty
+ kc_sig _ = return ()
kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name
, fdInfo = fd_info }))
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
index 3a06af6b3a..5f2a629883 100644
--- a/compiler/typecheck/TcTyDecls.hs
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -843,7 +843,7 @@ mkRecSelBind (tycon, fl)
mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel
-> (LSig GhcRn, (RecFlag, LHsBinds GhcRn))
mkOneRecordSelector all_cons idDetails fl
- = (L loc (IdSig sel_id), (NonRecursive, unitBag (L loc sel_bind)))
+ = (L loc (IdSig noExt sel_id), (NonRecursive, unitBag (L loc sel_bind)))
where
loc = getSrcSpan sel_name
lbl = flLabel fl
View Lorry Controller Status