TTG for HsBinds and Data instances Plan B
authorAlan Zimmerman <alan.zimm@gmail.com>
Sun, 1 Apr 2018 19:33:53 +0000 (21:33 +0200)
committerAlan Zimmerman <alan.zimm@gmail.com>
Fri, 13 Apr 2018 11:40:30 +0000 (13:40 +0200)
Summary:
- Add the balance of the TTG extensions for hsSyn/HsBinds

- Move all the (now orphan) data instances into hsSyn/HsInstances and
use TTG Data instances Plan B
https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/Instances#PLANB

Updates haddock submodule.

Illustrative numbers

Compiling HsInstances before using Plan B.

Max residency ~ 5G
<<ghc: 629,864,691,176 bytes, 5300 GCs,
       321075437/1087762592 avg/max bytes residency (23 samples),
       2953M in use, 0.000 INIT (0.000 elapsed),
       383.511 MUT (384.986 elapsed), 37.426 GC (37.444 elapsed) :ghc>>

Using Plan B

Max residency 1.1G

<<ghc: 78,832,782,968 bytes, 2884 GCs,
       222140352/386470152 avg/max bytes residency (34 samples),
       1062M in use, 0.001 INIT (0.001 elapsed),
       56.612 MUT (62.917 elapsed), 32.974 GC (32.923 elapsed) :ghc>>

Test Plan: ./validate

Reviewers: shayan-najd, goldfire, bgamari

Subscribers: goldfire, thomie, mpickering, carter

Differential Revision: https://phabricator.haskell.org/D4581

42 files changed:
compiler/deSugar/Coverage.hs
compiler/deSugar/DsBinds.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsMeta.hs
compiler/ghc.cabal.in
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsBinds.hs
compiler/hsSyn/HsDecls.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsExpr.hs-boot
compiler/hsSyn/HsExtension.hs
compiler/hsSyn/HsInstances.hs [new file with mode: 0644]
compiler/hsSyn/HsLit.hs
compiler/hsSyn/HsPat.hs
compiler/hsSyn/HsPat.hs-boot
compiler/hsSyn/HsSyn.hs
compiler/hsSyn/HsTypes.hs
compiler/hsSyn/HsUtils.hs
compiler/main/InteractiveEval.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/rename/RnBinds.hs
compiler/rename/RnExpr.hs
compiler/rename/RnNames.hs
compiler/rename/RnSource.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcClassDcl.hs
compiler/typecheck/TcEnv.hs
compiler/typecheck/TcGenDeriv.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcSigs.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcTyDecls.hs
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
testsuite/tests/perf/haddock/all.T
utils/ghctags/Main.hs
utils/haddock

index 1f84114..ab04ee4 100644 (file)
@@ -351,6 +351,7 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do
 -- Only internal stuff, not from source, uses VarBind, so we ignore it.
 addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
 addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
+addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind
 
 
 bindTick
@@ -779,13 +780,14 @@ addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
 addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders"
 
 addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
-addTickHsLocalBinds (HsValBinds binds) =
-        liftM HsValBinds
+addTickHsLocalBinds (HsValBinds binds) =
+        liftM (HsValBinds x)
                 (addTickHsValBinds binds)
-addTickHsLocalBinds (HsIPBinds binds)  =
-        liftM HsIPBinds
+addTickHsLocalBinds (HsIPBinds binds)  =
+        liftM (HsIPBinds x)
                 (addTickHsIPBinds binds)
-addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds
+addTickHsLocalBinds (EmptyLocalBinds x)  = return (EmptyLocalBinds x)
+addTickHsLocalBinds (XHsLocalBindsLR x)  = return (XHsLocalBindsLR x)
 
 addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
                   -> TM (HsValBindsLR GhcTc (GhcPass b))
@@ -801,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 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)
index 3a736a5..ad666a2 100644 (file)
@@ -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
@@ -192,6 +192,7 @@ dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
        ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig }
 
 dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
+dsHsBind _ (XHsBindsLR{}) = panic "dsHsBind: XHsBindsLR"
 
 
 -----------------------
@@ -251,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) }
@@ -295,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)
 
@@ -342,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 [] })
index 0eb5c0e..6f7f66e 100644 (file)
@@ -71,10 +71,11 @@ import Control.Monad
 -}
 
 dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
-dsLocalBinds (L _   EmptyLocalBinds)    body = return body
-dsLocalBinds (L loc (HsValBinds binds)) body = putSrcSpanDs loc $
-                                               dsValBinds binds body
-dsLocalBinds (L _ (HsIPBinds binds))    body = dsIPBinds  binds body
+dsLocalBinds (L _   (EmptyLocalBinds _))  body = return body
+dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $
+                                                   dsValBinds binds body
+dsLocalBinds (L _ (HsIPBinds _ binds))    body = dsIPBinds  binds body
+dsLocalBinds (L _ (XHsLocalBindsLR _))    _    = panic "dsLocalBinds"
 
 -------------------------
 -- caller sets location
@@ -85,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
@@ -201,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
index fd8da26..976f3c3 100644 (file)
@@ -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
@@ -613,6 +613,7 @@ repFixD (L loc (FixitySig names (Fixity _ prec dir)))
                    ; dec <- rep2 rep_fn [prec', name']
                    ; return (loc,dec) }
        ; mapM do_one names }
+repFixD (L _ (XFixitySig _)) = panic "repFixD"
 
 repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
 repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
@@ -771,20 +772,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)
@@ -1445,13 +1447,13 @@ repSts other = notHandled "Exotic statement" (ppr other)
 -----------------------------------------------------------
 
 repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ])
-repBinds EmptyLocalBinds
+repBinds (EmptyLocalBinds _)
   = do  { core_list <- coreList decQTyConName []
         ; return ([], core_list) }
 
-repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
+repBinds b@(HsIPBinds {}) = notHandled "Implicit parameters" (ppr b)
 
-repBinds (HsValBinds decs)
+repBinds (HsValBinds decs)
  = do   { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs }
                 -- No need to worry about detailed scopes within
                 -- the binding group, because we are talking Names
@@ -1463,6 +1465,7 @@ repBinds (HsValBinds decs)
         ; core_list <- coreList decQTyConName
                                 (de_loc (sort_by_loc prs))
         ; return (ss, core_list) }
+repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b)
 
 rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
 -- Assumes: all the binders of the binding are already in the meta-env
@@ -1521,11 +1524,11 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
         ; return (srcLocSpan (getSrcLoc v), ans) }
 
 rep_bind (L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds"
-rep_bind (L loc (PatSynBind (PSB { psb_id   = syn
-                                 , psb_fvs  = _fvs
-                                 , psb_args = args
-                                 , psb_def  = pat
-                                 , psb_dir  = dir })))
+rep_bind (L loc (PatSynBind (PSB { psb_id   = syn
+                                   , psb_fvs  = _fvs
+                                   , psb_args = args
+                                   , psb_def  = pat
+                                   , psb_dir  = dir })))
   = do { syn'      <- lookupLBinder syn
        ; dir'      <- repPatSynDir dir
        ; ss        <- mkGenArgSyms args
@@ -1560,6 +1563,9 @@ 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
            -> Core TH.PatSynArgsQ
            -> Core TH.PatSynDirQ
@@ -1628,7 +1634,8 @@ repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
 
 repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ)
 repLambda (L _ (Match { m_pats = ps
-                      , m_grhss = GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds) } ))
+                      , m_grhss = GRHSs [L _ (GRHS [] e)]
+                                        (L _ (EmptyLocalBinds _)) } ))
  = do { let bndrs = collectPatsBinders ps ;
       ; ss  <- mkGenSyms bndrs
       ; lam <- addBinds ss (
index a349904..36dc437 100644 (file)
@@ -320,6 +320,7 @@ Library
         HsLit
         PlaceHolder
         HsExtension
+        HsInstances
         HsPat
         HsSyn
         HsTypes
index 285d2e9..c63de9e 100644 (file)
@@ -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, bind_fvs = placeHolderNames
+                  , 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,15 +359,15 @@ 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
        ; args' <- cvtArgs args
        ; dir'  <- cvtDir nm' dir
        ; pat'  <- cvtPat pat
-       ; returnJustL $ Hs.ValD $ PatSynBind $
-           PSB nm' placeHolderType args' pat' dir' }
+       ; returnJustL $ Hs.ValD $ PatSynBind noExt $
+           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
@@ -747,13 +748,13 @@ cvtRuleBndr (TypedRuleVar n ty)
 cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
 cvtLocalDecs doc ds
   | null ds
-  = return EmptyLocalBinds
+  = return (EmptyLocalBinds noExt)
   | otherwise
   = do { ds' <- cvtDecs ds
        ; let (binds, prob_sigs) = partitionWith is_bind ds'
        ; let (sigs, bads) = partitionWith is_sig prob_sigs
        ; unless (null bads) (failWith (mkBadDecMsg doc bads))
-       ; return (HsValBinds (ValBinds noExt (listToBag binds) sigs)) }
+       ; return (HsValBinds noExt (ValBinds noExt (listToBag binds) sigs)) }
 
 cvtClause :: HsMatchContext RdrName
           -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
index 5fa0a62..ea5704c 100644 (file)
@@ -74,7 +74,9 @@ type LHsLocalBinds id = Located (HsLocalBinds id)
 -- Bindings in a 'let' expression
 -- or a 'where' clause
 data HsLocalBindsLR idL idR
-  = HsValBinds (HsValBindsLR idL idR)
+  = HsValBinds
+        (XHsValBinds idL idR)
+        (HsValBindsLR idL idR)
       -- ^ Haskell Value Bindings
 
          -- There should be no pattern synonyms in the HsValBindsLR
@@ -82,15 +84,24 @@ data HsLocalBindsLR idL idR
          -- The parser accepts them, however, leaving the
          -- renamer to report them
 
-  | HsIPBinds  (HsIPBinds idR)
+  | HsIPBinds
+        (XHsIPBinds idL idR)
+        (HsIPBinds idR)
       -- ^ Haskell Implicit Parameter Bindings
 
-  | EmptyLocalBinds
+  | EmptyLocalBinds (XEmptyLocalBinds idL idR)
       -- ^ Empty Local Bindings
 
+  | XHsLocalBindsLR
+        (XXHsLocalBindsLR idL idR)
+
+type instance XHsValBinds      (GhcPass pL) (GhcPass pR) = PlaceHolder
+type instance XHsIPBinds       (GhcPass pL) (GhcPass pR) = PlaceHolder
+type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = PlaceHolder
+type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = PlaceHolder
+
 type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR)
 
-deriving instance (DataIdLR idL idR) => Data (HsLocalBindsLR idL idR)
 
 -- | Haskell Value Bindings
 type HsValBinds id = HsValBindsLR id id
@@ -116,8 +127,6 @@ data HsValBindsLR idL idR
   | XValBindsLR
       (XXValBindsLR idL idR)
 
-deriving instance (DataIdLR idL idR) => Data (HsValBindsLR idL idR)
-
 -- ---------------------------------------------------------------------
 -- Deal with ValBindsOut
 
@@ -126,7 +135,6 @@ data NHsValBindsLR idL
   = NValBinds
       [(RecFlag, LHsBinds idL)]
       [LSig GhcRn]
-deriving instance (DataIdLR idL idL) => Data (NHsValBindsLR idL)
 
 type instance XValBinds    (GhcPass pL) (GhcPass pR) = PlaceHolder
 type instance XXValBindsLR (GhcPass pL) (GhcPass pR)
@@ -212,6 +220,11 @@ data HsBindLR idL idR
     -- For details on above see note [Api annotations] in ApiAnnotation
     FunBind {
 
+        fun_ext :: XFunBind idL idR, -- ^ After the renamer, this contains
+                                --  the locally-bound
+                                -- free variables of this defn.
+                                -- See Note [Bind free vars]
+
         fun_id :: Located (IdP idL), -- Note [fun_id in Match] in HsExpr
 
         fun_matches :: MatchGroup idR (LHsExpr idR),  -- ^ The payload
@@ -230,12 +243,6 @@ data HsBindLR idL idR
                                 -- type         Int -> forall a'. a' -> a'
                                 -- Notice that the coercion captures the free a'.
 
-        bind_fvs :: PostRn idL NameSet, -- ^ After the renamer, this contains
-                                --  the locally-bound
-                                -- free variables of this defn.
-                                -- See Note [Bind free vars]
-
-
         fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any
     }
 
@@ -253,10 +260,9 @@ data HsBindLR idL idR
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | PatBind {
+        pat_ext    :: XPatBind idL idR, -- ^ See Note [Bind free vars]
         pat_lhs    :: LPat idL,
         pat_rhs    :: GRHSs idR (LHsExpr idR),
-        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
                -- the bound variables.
@@ -267,6 +273,7 @@ data HsBindLR idL idR
   -- Dictionary binding and suchlike.
   -- All VarBinds are introduced by the type checker
   | VarBind {
+        var_ext    :: XVarBind idL idR,
         var_id     :: IdP idL,
         var_rhs    :: LHsExpr idR,   -- ^ Located only for consistency
         var_inline :: Bool           -- ^ True <=> inline this binding regardless
@@ -275,6 +282,7 @@ data HsBindLR idL idR
 
   -- | Abstraction Bindings
   | AbsBinds {                      -- Binds abstraction; TRANSLATION
+        abs_ext     :: XAbsBinds idL idR,
         abs_tvs     :: [TyVar],
         abs_ev_vars :: [EvVar],  -- ^ Includes equality constraints
 
@@ -295,7 +303,9 @@ data HsBindLR idL idR
     }
 
   -- | Patterns Synonym Binding
-  | PatSynBind (PatSynBind idL idR)
+  | PatSynBind
+        (XPatSynBind idL idR)
+        (PatSynBind idL idR)
         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
         --          'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual',
         --          'ApiAnnotation.AnnWhere'
@@ -303,7 +313,26 @@ data HsBindLR idL idR
 
         -- For details on above see note [Api annotations] in ApiAnnotation
 
-deriving instance (DataIdLR idL idR) => Data (HsBindLR idL idR)
+  | XHsBindsLR (XXHsBindsLR 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) = NPatBindTc
+
+type instance XVarBind    (GhcPass pL) (GhcPass pR) = PlaceHolder
+type instance XAbsBinds   (GhcPass pL) (GhcPass pR) = PlaceHolder
+type instance XPatSynBind (GhcPass pL) (GhcPass pR) = PlaceHolder
+type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = PlaceHolder
+
 
         -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
         --
@@ -319,13 +348,18 @@ deriving instance (DataIdLR idL idR) => Data (HsBindLR idL idR)
 
 -- | Abtraction Bindings Export
 data ABExport p
-  = 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
-  }
-deriving instance (DataId p) => Data (ABExport p)
+        }
+   | XABExport (XXABExport p)
+
+type instance XABE       (GhcPass p) = PlaceHolder
+type instance XXABExport (GhcPass p) = PlaceHolder
+
 
 -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
 --             'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow'
@@ -336,14 +370,18 @@ deriving instance (DataId p) => Data (ABExport p)
 
 -- | Pattern Synonym binding
 data PatSynBind idL idR
-  = 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
-  }
-deriving instance (DataIdLR idL idR) => Data (PatSynBind idL idR)
+     }
+   | XPatSynBind (XXPatSynBind idL idR)
+
+type instance XPSB         (GhcPass idL) (GhcPass idR) = PlaceHolder
+type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = PlaceHolder
 
 {-
 Note [AbsBinds]
@@ -581,9 +619,10 @@ Specifically,
 instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
           OutputableBndrId idL, OutputableBndrId idR)
         => Outputable (HsLocalBindsLR idL idR) where
-  ppr (HsValBinds bs) = ppr bs
-  ppr (HsIPBinds bs)  = ppr bs
-  ppr EmptyLocalBinds = empty
+  ppr (HsValBinds _ bs)   = ppr bs
+  ppr (HsIPBinds _ bs)    = ppr bs
+  ppr (EmptyLocalBinds _) = empty
+  ppr (XHsLocalBindsLR x) = ppr x
 
 instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
           OutputableBndrId idL, OutputableBndrId idR)
@@ -640,17 +679,25 @@ pprDeclList :: [SDoc] -> SDoc   -- Braces with a space
 pprDeclList ds = pprDeeperList vcat ds
 
 ------------
-emptyLocalBinds :: HsLocalBindsLR a b
-emptyLocalBinds = EmptyLocalBinds
-
-isEmptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool
-isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
-isEmptyLocalBinds (HsIPBinds ds)  = isEmptyIPBinds ds
-isEmptyLocalBinds EmptyLocalBinds = True
+emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b)
+emptyLocalBinds = EmptyLocalBinds noExt
+
+-- 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
-eqEmptyLocalBinds _               = False
+eqEmptyLocalBinds (EmptyLocalBinds _) = True
+eqEmptyLocalBinds _                   = False
 
 isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool
 isEmptyValBinds (ValBinds _ ds sigs)  = isEmptyLHsBinds ds && null sigs
@@ -698,7 +745,7 @@ ppr_monobind (FunBind { fun_id = fun,
     $$  whenPprDebug (pprBndr LetBind (unLoc fun))
     $$  pprFunBind  matches
     $$  whenPprDebug (ppr wrap)
-ppr_monobind (PatSynBind psb) = ppr psb
+ppr_monobind (PatSynBind psb) = ppr psb
 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
                        , abs_exports = exports, abs_binds = val_binds
                        , abs_ev_binds = ev_binds })
@@ -716,14 +763,17 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
       , text "Evidence:" <+> ppr ev_binds ]
     else
       pprLHsBinds val_binds
+ppr_monobind (XHsBindsLR x) = ppr x
 
 instance (OutputableBndrId p) => Outputable (ABExport p) where
   ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
     = 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 })
@@ -743,6 +793,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
@@ -765,13 +816,27 @@ pprTicks pp_no_debug pp_when_debug
 -- | Haskell Implicit Parameter Bindings
 data HsIPBinds id
   = IPBinds
+        (XIPBinds id)
         [LIPBind id]
-        TcEvBinds       -- Only in typechecker output; binds
-                        -- uses of the implicit parameters
-deriving instance (DataIdLR id id) => Data (HsIPBinds id)
+        -- TcEvBinds       -- Only in typechecker output; binds
+        --                 -- uses of the implicit parameters
+  | XHsIPBinds (XXHsIPBinds 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)
@@ -791,19 +856,27 @@ type LIPBind id = Located (IPBind id)
 
 -- For details on above see note [Api annotations] in ApiAnnotation
 data IPBind id
-  = IPBind (Either (Located HsIPName) (IdP id)) (LHsExpr id)
-deriving instance (DataIdLR id id) => Data (IPBind id)
+  = IPBind
+        (XIPBind id)
+        (Either (Located HsIPName) (IdP id))
+        (LHsExpr id)
+  | XCIPBind (XXIPBind 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
 
 {-
 ************************************************************************
@@ -840,6 +913,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
 
@@ -852,7 +926,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
@@ -865,14 +939,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
         --
@@ -883,7 +957,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
         --
@@ -896,7 +970,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
@@ -911,7 +986,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
@@ -928,7 +1004,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
@@ -940,7 +1016,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
@@ -951,7 +1028,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
@@ -961,18 +1039,34 @@ 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)))
-
-deriving instance (DataIdLR pass pass) => Data (Sig pass)
+  | XSig (XXSig 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
-deriving instance (DataId pass) => Data (FixitySig pass)
+data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity
+                    | XFixitySig (XXFixitySig pass)
+
+type instance XFixitySig  (GhcPass p) = PlaceHolder
+type instance XXFixitySig (GhcPass p) = PlaceHolder
 
 -- | Type checker Specialisation Pragmas
 --
@@ -1054,17 +1148,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
@@ -1076,41 +1171,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 "#-}"
@@ -1215,4 +1312,3 @@ data HsPatSynDir id
   = Unidirectional
   | ImplicitBidirectional
   | ExplicitBidirectional (MatchGroup id (LHsExpr id))
-deriving instance (DataIdLR id id) => Data (HsPatSynDir id)
index 54314a9..2cbdad3 100644 (file)
@@ -132,6 +132,7 @@ type LHsDecl id = Located (HsDecl id)
 
 -- | A Haskell Declaration
 data HsDecl id
+  -- AZ:TODO:TTG HsDecl
   = TyClD       (TyClDecl id)      -- ^ Type or Class Declaration
   | InstD       (InstDecl  id)     -- ^ Instance declaration
   | DerivD      (DerivDecl id)     -- ^ Deriving declaration
@@ -147,7 +148,6 @@ data HsDecl id
                                    -- (Includes quasi-quotes)
   | DocD        (DocDecl)          -- ^ Documentation comment declaration
   | RoleAnnotD  (RoleAnnotDecl id) -- ^ Role annotation declaration
-deriving instance (DataIdLR id id) => Data (HsDecl id)
 
 
 -- NB: all top-level fixity decls are contained EITHER
@@ -168,6 +168,7 @@ deriving instance (DataIdLR id id) => Data (HsDecl id)
 -- A 'HsDecl' is categorised into a 'HsGroup' before being
 -- fed to the renamer.
 data HsGroup id
+  -- AZ:TODO:TTG HsGroup
   = HsGroup {
         hs_valds  :: HsValBinds id,
         hs_splcds :: [LSpliceDecl id],
@@ -193,7 +194,6 @@ data HsGroup id
 
         hs_docs   :: [LDocDecl]
   }
-deriving instance (DataIdLR id id) => Data (HsGroup id)
 
 emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass a)
 emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
@@ -309,10 +309,10 @@ type LSpliceDecl pass = Located (SpliceDecl pass)
 
 -- | Splice Declaration
 data SpliceDecl id
+     -- AZ:TODO: TTG SpliceD
   = SpliceDecl                  -- Top level splice
         (Located (HsSplice id))
         SpliceExplicitFlag
-deriving instance (DataIdLR id id) => Data (SpliceDecl id)
 
 instance (p ~ GhcPass pass, OutputableBndrId p)
        => Outputable (SpliceDecl p) where
@@ -462,6 +462,7 @@ type LTyClDecl pass = Located (TyClDecl pass)
 
 -- | A type or class declaration.
 data TyClDecl pass
+  -- AZ:TODO: TTG TyClDecl
   = -- | @type/data family T :: *->*@
     --
     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
@@ -535,8 +536,6 @@ data TyClDecl pass
 
         -- For details on above see note [Api annotations] in ApiAnnotation
 
-deriving instance (DataIdLR id id) => Data (TyClDecl id)
-
 
 -- Simple classifiers for TyClDecl
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -776,10 +775,10 @@ in RnSource for more info.
 
 -- | Type or Class Group
 data TyClGroup pass  -- See Note [TyClGroups and dependency analysis]
+  -- AZ:TODO: TTG TyClGroups
   = TyClGroup { group_tyclds :: [LTyClDecl pass]
               , group_roles  :: [LRoleAnnotDecl pass]
               , group_instds :: [LInstDecl pass] }
-deriving instance (DataIdLR id id) => Data (TyClGroup id)
 
 emptyTyClGroup :: TyClGroup pass
 emptyTyClGroup = TyClGroup [] [] []
@@ -876,6 +875,7 @@ type LFamilyResultSig pass = Located (FamilyResultSig pass)
 
 -- | type Family Result Signature
 data FamilyResultSig pass = -- see Note [FamilyResultSig]
+  -- AZ:TODO: TTG FamilyResultSig
     NoSig
   -- ^ - 'ApiAnnotation.AnnKeywordId' :
 
@@ -895,8 +895,6 @@ data FamilyResultSig pass = -- see Note [FamilyResultSig]
 
   -- For details on above see note [Api annotations] in ApiAnnotation
 
-deriving instance (DataIdLR pass pass) => Data (FamilyResultSig pass)
-
 -- | Located type Family Declaration
 type LFamilyDecl pass = Located (FamilyDecl pass)
 
@@ -918,8 +916,6 @@ data FamilyDecl pass = FamilyDecl
 
   -- For details on above see note [Api annotations] in ApiAnnotation
 
-deriving instance (DataIdLR id id) => Data (FamilyDecl id)
-
 -- | Located Injectivity Annotation
 type LInjectivityAnn pass = Located (InjectivityAnn pass)
 
@@ -937,7 +933,6 @@ data InjectivityAnn pass
   --             'ApiAnnotation.AnnRarrow', 'ApiAnnotation.AnnVbar'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (InjectivityAnn pass)
 
 data FamilyInfo pass
   = DataFamily
@@ -945,7 +940,6 @@ data FamilyInfo pass
      -- | 'Nothing' if we're in an hs-boot file and the user
      -- said "type family Foo x where .."
   | ClosedTypeFamily (Maybe [LTyFamInstEqn pass])
-deriving instance (DataIdLR pass pass) => Data (FamilyInfo pass)
 
 -- | Does this family declaration have a complete, user-supplied kind signature?
 famDeclHasCusk :: Maybe Bool
@@ -1053,7 +1047,6 @@ data HsDataDefn pass   -- The payload of a data type defn
 
              -- For details on above see note [Api annotations] in ApiAnnotation
    }
-deriving instance (DataIdLR id id) => Data (HsDataDefn id)
 
 -- | Haskell Deriving clause
 type HsDeriving pass = Located [LHsDerivingClause pass]
@@ -1089,7 +1082,6 @@ data HsDerivingClause pass
       --
       -- should produce a derived instance for @C [a] (T b)@.
     }
-deriving instance (DataIdLR id id) => Data (HsDerivingClause id)
 
 instance (p ~ GhcPass pass, OutputableBndrId p)
        => Outputable (HsDerivingClause p) where
@@ -1183,7 +1175,6 @@ data ConDecl pass
       , con_doc       :: Maybe LHsDocString
           -- ^ A possible Haddock comment.
       }
-deriving instance (DataIdLR pass pass) => Data (ConDecl pass)
 
 {- Note [GADT abstract syntax]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1416,7 +1407,6 @@ newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }
     --           'ApiAnnotation.AnnInstance',
 
     -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance DataIdLR pass pass => Data (TyFamInstDecl pass)
 
 ----------------- Data family instances -------------
 
@@ -1434,7 +1424,6 @@ newtype DataFamInstDecl pass
     --           'ApiAnnotation.AnnClose'
 
     -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance DataIdLR pass pass => Data (DataFamInstDecl pass)
 
 ----------------- Family instances (common types) -------------
 
@@ -1464,8 +1453,6 @@ data FamEqn pass pats rhs
     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
 
     -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass, Data pats, Data rhs)
-                => Data (FamEqn pass pats rhs)
 
 ----------------- Class instances -------------
 
@@ -1494,8 +1481,6 @@ data ClsInstDecl pass
     --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
 
     -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataIdLR id id) => Data (ClsInstDecl id)
-
 
 ----------------- Instances of all kinds -------------
 
@@ -1510,7 +1495,6 @@ data InstDecl pass  -- Both class and family instances
       { dfid_inst :: DataFamInstDecl pass }
   | TyFamInstD              -- type family instance
       { tfid_inst :: TyFamInstDecl pass }
-deriving instance (DataIdLR id id) => Data (InstDecl id)
 
 instance (p ~ GhcPass pass, OutputableBndrId p)
        => Outputable (TyFamInstDecl p) where
@@ -1680,7 +1664,6 @@ data DerivDecl pass = DerivDecl
 
   -- For details on above see note [Api annotations] in ApiAnnotation
         }
-deriving instance (DataIdLR pass pass) => Data (DerivDecl pass)
 
 instance (p ~ GhcPass pass, OutputableBndrId p)
        => Outputable (DerivDecl p) where
@@ -1715,7 +1698,6 @@ data DefaultDecl pass
         --          'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataIdLR pass pass) => Data (DefaultDecl pass)
 
 instance (p ~ GhcPass pass, OutputableBndrId p)
        => Outputable (DefaultDecl p) where
@@ -1759,7 +1741,6 @@ data ForeignDecl pass
 
         -- For details on above see note [Api annotations] in ApiAnnotation
 
-deriving instance (DataIdLR pass pass) => Data (ForeignDecl pass)
 {-
     In both ForeignImport and ForeignExport:
         sig_ty is the type given in the Haskell code
@@ -1876,7 +1857,6 @@ type LRuleDecls pass = Located (RuleDecls pass)
 -- | Rule Declarations
 data RuleDecls pass = HsRules { rds_src   :: SourceText
                               , rds_rules :: [LRuleDecl pass] }
-deriving instance (DataIdLR pass pass) => Data (RuleDecls pass)
 
 -- | Located Rule Declaration
 type LRuleDecl pass = Located (RuleDecl pass)
@@ -1902,7 +1882,6 @@ data RuleDecl pass
         --           'ApiAnnotation.AnnEqual',
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataIdLR pass pass) => Data (RuleDecl pass)
 
 flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass]
 flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls
@@ -1919,7 +1898,6 @@ data RuleBndr pass
         --     'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataIdLR pass pass) => Data (RuleBndr pass)
 
 collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass]
 collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
@@ -2010,7 +1988,6 @@ data VectDecl pass
       (LHsSigType pass)
   | HsVectInstOut               -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now
       ClsInst
-deriving instance (DataIdLR pass pass) => Data (VectDecl pass)
 
 lvectDeclName :: NamedThing (IdP pass) => LVectDecl pass -> Name
 lvectDeclName (L _ (HsVect _       (L _ name) _))    = getName name
@@ -2108,14 +2085,12 @@ type LWarnDecls pass = Located (WarnDecls pass)
 data WarnDecls pass = Warnings { wd_src :: SourceText
                                , wd_warnings :: [LWarnDecl pass]
                                }
-deriving instance (DataId pass) => Data (WarnDecls pass)
 
 -- | Located Warning pragma Declaration
 type LWarnDecl pass = Located (WarnDecl pass)
 
 -- | Warning pragma Declaration
 data WarnDecl pass = Warning [Located (IdP pass)] WarningTxt
-deriving instance (DataId pass) => Data (WarnDecl pass)
 
 instance OutputableBndr (IdP pass) => Outputable (WarnDecls pass) where
     ppr (Warnings (SourceText src) decls)
@@ -2148,7 +2123,6 @@ data AnnDecl pass = HsAnnotation
       --           'ApiAnnotation.AnnClose'
 
       -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataIdLR pass pass) => Data (AnnDecl pass)
 
 instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (AnnDecl p) where
     ppr (HsAnnotation _ provenance expr)
@@ -2196,7 +2170,6 @@ data RoleAnnotDecl pass
       --           'ApiAnnotation.AnnRole'
 
       -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (RoleAnnotDecl pass)
 
 instance OutputableBndr (IdP pass) => Outputable (RoleAnnotDecl pass) where
   ppr (RoleAnnotDecl ltycon roles)
index 92797fa..7f6d3f8 100644 (file)
@@ -111,7 +111,6 @@ noPostTcTable = []
 data SyntaxExpr p = SyntaxExpr { syn_expr      :: HsExpr p
                                , syn_arg_wraps :: [HsWrapper]
                                , syn_res_wrap  :: HsWrapper }
-deriving instance (DataIdLR p p) => Data (SyntaxExpr p)
 
 -- | This is used for rebindable-syntax pieces that are too polymorphic
 -- for tcSyntaxOp (trS_fmap and the mzip in ParStmt)
@@ -719,14 +718,12 @@ data HsExpr p
 
   | XExpr       (XXExpr p) -- Note [Trees that Grow] extension constructor
 
-deriving instance (DataIdLR p p) => Data (HsExpr p)
 
 -- | Extra data fields for a 'RecordCon', added by the type checker
 data RecordConTc = RecordConTc
       { rcon_con_like :: ConLike      -- The data constructor or pattern synonym
       , rcon_con_expr :: PostTcExpr   -- Instantiated constructor function
-      } deriving Data
-
+      }
 
 -- | Extra data fields for a 'RecordUpd', added by the type checker
 data RecordUpdTc = RecordUpdTc
@@ -862,7 +859,6 @@ data HsTupArg id
   = Present (XPresent id) (LHsExpr id)     -- ^ The argument
   | Missing (XMissing id)    -- ^ The argument is missing, but this is its type
   | XTupArg (XXTupArg id)    -- ^ Note [Trees that Grow] extension point
-deriving instance (DataIdLR id id) => Data (HsTupArg id)
 
 type instance XPresent         (GhcPass _) = PlaceHolder
 
@@ -1405,7 +1401,6 @@ data HsCmd id
                                --      wrap :: arg1 "->" arg2
                                -- Then (HsCmdWrap wrap cmd) :: arg2 --> res
   | XCmd        (XXCmd id)     -- Note [Trees that Grow] extension point
-deriving instance (DataIdLR id id) => Data (HsCmd id)
 
 type instance XCmdArrApp  GhcPs = PlaceHolder
 type instance XCmdArrApp  GhcRn = PlaceHolder
@@ -1444,13 +1439,11 @@ data HsCmdTop p
   = HsCmdTop (XCmdTop p)
              (LHsCmd p)
   | XCmdTop (XXCmdTop p)        -- Note [Trees that Grow] extension point
-deriving instance (DataIdLR p p) => Data (HsCmdTop p)
 
 data CmdTopTc
   = CmdTopTc Type    -- Nested tuple of inputs on the command's stack
              Type    -- return type of the command
              (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable]
-  deriving Data
 
 type instance XCmdTop  GhcPs = PlaceHolder
 type instance XCmdTop  GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable]
@@ -1596,7 +1589,6 @@ data MatchGroup p body
      -- The type is the type of the entire group
      --      t1 -> ... -> tn -> tr
      -- where there are n patterns
-deriving instance (Data body,DataIdLR p p) => Data (MatchGroup p body)
 
 -- | Located Match
 type LMatch id body = Located (Match id body)
@@ -1612,7 +1604,6 @@ data Match p body
         m_pats :: [LPat p], -- The patterns
         m_grhss :: (GRHSs p body)
   }
-deriving instance (Data body,DataIdLR p p) => Data (Match p body)
 
 instance (idR ~ GhcPass pr, OutputableBndrId idR, Outputable body)
             => Outputable (Match idR body) where
@@ -1698,7 +1689,6 @@ data GRHSs p body
       grhssGRHSs :: [LGRHS p body],      -- ^ Guarded RHSs
       grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause
     }
-deriving instance (Data body,DataIdLR p p) => Data (GRHSs p body)
 
 -- | Located Guarded Right-Hand Side
 type LGRHS id body = Located (GRHS id body)
@@ -1707,7 +1697,6 @@ type LGRHS id body = Located (GRHS id body)
 -- | Guarded Right Hand Side.
 data GRHS id body = GRHS [GuardLStmt id] -- Guards
                          body            -- Right hand side
-deriving instance (Data body,DataIdLR id id) => Data (GRHS id body)
 
 -- We know the list must have at least one @Match@ in it.
 
@@ -1960,8 +1949,6 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
                                    -- With rebindable syntax the type might not
                                    -- be quite as simple as (m (tya, tyb, tyc)).
       }
-deriving instance (Data body, DataIdLR idL idR)
-  => Data (StmtLR idL idR body)
 
 data TransForm   -- The 'f' below is the 'using' function, 'e' is the by function
   = ThenForm     -- then f               or    then f by e             (depending on trS_by)
@@ -1976,7 +1963,6 @@ data ParStmtBlock idL idR
         [IdP idR]          -- The variables to be returned
         (SyntaxExpr idR)   -- The return operator
   | XParStmtBlock (XXParStmtBlock idL idR)
-deriving instance (DataIdLR idL idR) => Data (ParStmtBlock idL idR)
 
 type instance XParStmtBlock  (GhcPass pL) (GhcPass pR) = PlaceHolder
 type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = PlaceHolder
@@ -1996,7 +1982,6 @@ data ApplicativeArg idL
       (LPat idL)           -- (v1,...,vn)
 
 -- AZ: May need to bring back idR?
-deriving instance (DataIdLR idL idL) => Data (ApplicativeArg idL)
 
 {-
 Note [The type of bind in Stmts]
@@ -2344,7 +2329,6 @@ data HsSplice id
         ThModFinalizers     -- TH finalizers produced by the splice.
         (HsSplicedThing id) -- The result of splicing
    | XSplice (XXSplice id)  -- Note [Trees that Grow] extension point
-deriving instance (DataIdLR id id) => Data (HsSplice id)
 
 type instance XTypedSplice   (GhcPass _) = PlaceHolder
 type instance XUntypedSplice (GhcPass _) = PlaceHolder
@@ -2391,7 +2375,6 @@ data HsSplicedThing id
     | HsSplicedTy   (HsType id) -- ^ Haskell Spliced Type
     | HsSplicedPat  (Pat id)    -- ^ Haskell Spliced Pattern
 
-deriving instance (DataIdLR id id) => Data (HsSplicedThing id)
 
 -- See Note [Pending Splices]
 type SplicePointName = Name
@@ -2400,7 +2383,6 @@ type SplicePointName = Name
 data PendingRnSplice
   -- AZ:TODO: The hard-coded GhcRn feels wrong. How to force the PostRn?
   = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn)
-  deriving Data
 
 data UntypedSpliceFlavour
   = UntypedExpSplice
@@ -2413,7 +2395,6 @@ data UntypedSpliceFlavour
 data PendingTcSplice
   -- AZ:TODO: The hard-coded GhcTc feels wrong. How to force the PostTc?
   = PendingTcSplice SplicePointName (LHsExpr GhcTc)
-  deriving Data
 
 {-
 Note [Pending Splices]
@@ -2541,7 +2522,6 @@ data HsBracket p
                                 -- (The Bool flag is used only in pprHsBracket)
   | TExpBr (XTExpBr p) (LHsExpr p)    -- [||  expr  ||]
   | XBracket (XXBracket p)            -- Note [Trees that Grow] extension point
-deriving instance (DataIdLR p p) => Data (HsBracket p)
 
 type instance XExpBr      (GhcPass _) = PlaceHolder
 type instance XPatBr      (GhcPass _) = PlaceHolder
@@ -2605,7 +2585,6 @@ data ArithSeqInfo id
   | FromThenTo      (LHsExpr id)
                     (LHsExpr id)
                     (LHsExpr id)
-deriving instance (DataIdLR id id) => Data (ArithSeqInfo id)
 -- AZ: Sould ArithSeqInfo have a TTG extension?
 
 instance (p ~ GhcPass pass, OutputableBndrId p)
index e8fa7a4..49ae108 100644 (file)
@@ -13,8 +13,7 @@ import SrcLoc     ( Located )
 import Outputable ( SDoc, Outputable )
 import {-# SOURCE #-} HsPat  ( LPat )
 import BasicTypes ( SpliceExplicitFlag(..))
-import HsExtension ( OutputableBndrId, DataIdLR, GhcPass )
-import Data.Data hiding ( Fixity )
+import HsExtension ( OutputableBndrId, GhcPass )
 
 type role HsExpr nominal
 type role HsCmd nominal
@@ -29,13 +28,6 @@ data MatchGroup (a :: *) (body :: *)
 data GRHSs (a :: *) (body :: *)
 data SyntaxExpr (i :: *)
 
-instance (DataIdLR id id) => Data (HsSplice id)
-instance (DataIdLR p p) => Data (HsExpr p)
-instance (DataIdLR id id) => Data (HsCmd id)
-instance (Data body,DataIdLR p p) => Data (MatchGroup p body)
-instance (Data body,DataIdLR p p) => Data (GRHSs p body)
-instance (DataIdLR p p) => Data (SyntaxExpr p)
-
 instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p)
 instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p)
 
index 779ecc5..81ffd05 100644 (file)
@@ -83,8 +83,6 @@ type instance PostTc GhcPs ty = PlaceHolder
 type instance PostTc GhcRn ty = PlaceHolder
 type instance PostTc GhcTc ty = ty
 
--- deriving instance (Data ty) => Data (PostTc (GhcPass 'Parsed) ty)
-
 -- | Types that are not defined until after renaming
 type family PostRn x ty  -- Note [Pass sensitive types] in PlaceHolder
 type instance PostRn GhcPs ty = PlaceHolder
@@ -99,52 +97,23 @@ type instance IdP GhcTc = Id
 
 type LIdP p = Located (IdP p)
 
--- ---------------------------------------------------------------------
--- type families for the Pat extension points
-type family XWildPat   x
-type family XVarPat    x
-type family XLazyPat   x
-type family XAsPat     x
-type family XParPat    x
-type family XBangPat   x
-type family XListPat   x
-type family XTuplePat  x
-type family XSumPat    x
-type family XPArrPat   x
-type family XConPat    x
-type family XViewPat   x
-type family XSplicePat x
-type family XLitPat    x
-type family XNPat      x
-type family XNPlusKPat x
-type family XSigPat    x
-type family XCoPat     x
-type family XXPat      x
+-- =====================================================================
+-- Type families for the HsBinds extension points
 
+-- HsLocalBindsLR type families
+type family XHsValBinds      x x'
+type family XHsIPBinds       x x'
+type family XEmptyLocalBinds x x'
+type family XXHsLocalBindsLR x x'
 
-type ForallXPat (c :: * -> Constraint) (x :: *) =
-       ( c (XWildPat   x)
-       , c (XVarPat    x)
-       , c (XLazyPat   x)
-       , c (XAsPat     x)
-       , c (XParPat    x)
-       , c (XBangPat   x)
-       , c (XListPat   x)
-       , c (XTuplePat  x)
-       , c (XSumPat    x)
-       , c (XPArrPat   x)
-       , c (XViewPat   x)
-       , c (XSplicePat x)
-       , c (XLitPat    x)
-       , c (XNPat      x)
-       , c (XNPlusKPat x)
-       , c (XSigPat    x)
-       , c (XCoPat     x)
-       , c (XXPat      x)
+type ForallXHsLocalBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =
+       ( c (XHsValBinds      x x')
+       , c (XHsIPBinds       x x')
+       , c (XEmptyLocalBinds x x')
+       , c (XXHsLocalBindsLR x x')
        )
--- ---------------------------------------------------------------------
--- ValBindsLR type families
 
+-- ValBindsLR type families
 type family XValBinds    x x'
 type family XXValBindsLR x x'
 
@@ -153,143 +122,106 @@ type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =
        , c (XXValBindsLR x x')
        )
 
--- We define a type family for each extension point. This is based on prepending
--- 'X' to the constructor name, for ease of reference.
-type family XHsChar x
-type family XHsCharPrim x
-type family XHsString x
-type family XHsStringPrim x
-type family XHsInt x
-type family XHsIntPrim x
-type family XHsWordPrim x
-type family XHsInt64Prim x
-type family XHsWord64Prim x
-type family XHsInteger x
-type family XHsRat x
-type family XHsFloatPrim x
-type family XHsDoublePrim x
-type family XXLit x
 
--- | Helper to apply a constraint to all extension points. It has one
--- entry per extension point type family.
-type ForallXHsLit (c :: * -> Constraint) (x :: *) =
-  ( c (XHsChar       x)
-  , c (XHsCharPrim   x)
-  , c (XHsDoublePrim x)
-  , c (XHsFloatPrim  x)
-  , c (XHsInt        x)
-  , c (XHsInt64Prim  x)
-  , c (XHsIntPrim    x)
-  , c (XHsInteger    x)
-  , c (XHsRat        x)
-  , c (XHsString     x)
-  , c (XHsStringPrim x)
-  , c (XHsWord64Prim x)
-  , c (XHsWordPrim   x)
-  , c (XXLit         x)
-  )
+-- HsBindsLR type families
+type family XFunBind    x x'
+type family XPatBind    x x'
+type family XVarBind    x x'
+type family XAbsBinds   x x'
+type family XPatSynBind x x'
+type family XXHsBindsLR x x'
+
+type ForallXHsBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =
+       ( c (XFunBind    x x')
+       , c (XPatBind    x x')
+       , c (XVarBind    x x')
+       , c (XAbsBinds   x x')
+       , c (XPatSynBind x x')
+       , c (XXHsBindsLR x x')
+       )
 
-type family XOverLit  x
-type family XXOverLit x
+-- ABExport type families
+type family XABE x
+type family XXABExport x
 
-type ForallXOverLit (c :: * -> Constraint) (x :: *) =
-       ( c (XOverLit  x)
-       , c (XXOverLit x)
+type ForallXABExport (c :: * -> Constraint) (x :: *) =
+       ( c (XABE       x)
+       , c (XXABExport x)
        )
 
--- ---------------------------------------------------------------------
--- Type families for the Type type families
-
-type family XForAllTy        x
-type family XQualTy          x
-type family XTyVar           x
-type family XAppsTy          x
-type family XAppTy           x
-type family XFunTy           x
-type family XListTy          x
-type family XPArrTy          x
-type family XTupleTy         x
-type family XSumTy           x
-type family XOpTy            x
-type family XParTy           x
-type family XIParamTy        x
-type family XEqTy            x
-type family XKindSig         x
-type family XSpliceTy        x
-type family XDocTy           x
-type family XBangTy          x
-type family XRecTy           x
-type family XExplicitListTy  x
-type family XExplicitTupleTy x
-type family XTyLit           x
-type family XWildCardTy      x
-type family XXType           x
+-- PatSynBind type families
+type family XPSB x x'
+type family XXPatSynBind x x'
 
--- | Helper to apply a constraint to all extension points. It has one
--- entry per extension point type family.
-type ForallXType (c :: * -> Constraint) (x :: *) =
-       ( c (XForAllTy        x)
-       , c (XQualTy          x)
-       , c (XTyVar           x)
-       , c (XAppsTy          x)
-       , c (XAppTy           x)
-       , c (XFunTy           x)
-       , c (XListTy          x)
-       , c (XPArrTy          x)
-       , c (XTupleTy         x)
-       , c (XSumTy           x)
-       , c (XOpTy            x)
-       , c (XParTy           x)
-       , c (XIParamTy        x)
-       , c (XEqTy            x)
-       , c (XKindSig         x)
-       , c (XSpliceTy        x)
-       , c (XDocTy           x)
-       , c (XBangTy          x)
-       , c (XRecTy           x)
-       , c (XExplicitListTy  x)
-       , c (XExplicitTupleTy x)
-       , c (XTyLit           x)
-       , c (XWildCardTy      x)
-       , c (XXType           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 family XUserTyVar   x
-type family XKindedTyVar x
-type family XXTyVarBndr  x
+type ForallXHsIPBinds (c :: * -> Constraint) (x :: *) =
+       ( c (XIPBinds    x)
+       , c (XXHsIPBinds x)
+       )
 
-type ForallXTyVarBndr (c :: * -> Constraint) (x :: *) =
-       ( c (XUserTyVar      x)
-       , c (XKindedTyVar    x)
-       , c (XXTyVarBndr     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)
+       )
 
-type family XAppInfix  x
-type family XAppPrefix x
-type family XXAppType  x
+-- FixitySig type families
+type family XFixitySig          x
+type family XXFixitySig         x
 
-type ForallXAppType (c :: * -> Constraint) (x :: *) =
-       ( c (XAppInfix   x)
-       , c (XAppPrefix  x)
-       , c (XXAppType   x)
+type ForallXFixitySig (c :: * -> Constraint) (x :: *) =
+       ( c (XFixitySig         x)
+       , c (XXFixitySig        x)
        )
 
--- ---------------------------------------------------------------------
+-- =====================================================================
+-- Type families for the HsDecls extension points
 
-type family XFieldOcc  x
-type family XXFieldOcc x
 
-type ForallXFieldOcc (c :: * -> Constraint) (x :: *) =
-       ( c (XFieldOcc  x)
-       , c (XXFieldOcc x)
-       )
+-- TODO
 
--- ---------------------------------------------------------------------
--- Type families for the HsExpr type families
+-- =====================================================================
+-- Type families for the HsExpr extension points
 
 type family XVar            x
 type family XUnboundVar     x
@@ -504,6 +436,199 @@ type ForallXParStmtBlock (c :: * -> Constraint) (x :: *) (x' :: *) =
        , c (XXParStmtBlock x x')
        )
 
+-- =====================================================================
+-- Type families for the HsImpExp extension points
+
+-- TODO
+
+-- =====================================================================
+-- Type families for the HsLit extension points
+
+-- We define a type family for each extension point. This is based on prepending
+-- 'X' to the constructor name, for ease of reference.
+type family XHsChar x
+type family XHsCharPrim x
+type family XHsString x
+type family XHsStringPrim x
+type family XHsInt x
+type family XHsIntPrim x
+type family XHsWordPrim x
+type family XHsInt64Prim x
+type family XHsWord64Prim x
+type family XHsInteger x
+type family XHsRat x
+type family XHsFloatPrim x
+type family XHsDoublePrim x
+type family XXLit x
+
+-- | Helper to apply a constraint to all extension points. It has one
+-- entry per extension point type family.
+type ForallXHsLit (c :: * -> Constraint) (x :: *) =
+  ( c (XHsChar       x)
+  , c (XHsCharPrim   x)
+  , c (XHsDoublePrim x)
+  , c (XHsFloatPrim  x)
+  , c (XHsInt        x)
+  , c (XHsInt64Prim  x)
+  , c (XHsIntPrim    x)
+  , c (XHsInteger    x)
+  , c (XHsRat        x)
+  , c (XHsString     x)
+  , c (XHsStringPrim x)
+  , c (XHsWord64Prim x)
+  , c (XHsWordPrim   x)
+  , c (XXLit         x)
+  )
+
+type family XOverLit  x
+type family XXOverLit x
+
+type ForallXOverLit (c :: * -> Constraint) (x :: *) =
+       ( c (XOverLit  x)
+       , c (XXOverLit x)
+       )
+
+-- =====================================================================
+-- Type families for the HsPat extension points
+
+type family XWildPat   x
+type family XVarPat    x
+type family XLazyPat   x
+type family XAsPat     x
+type family XParPat    x
+type family XBangPat   x
+type family XListPat   x
+type family XTuplePat  x
+type family XSumPat    x
+type family XPArrPat   x
+type family XConPat    x
+type family XViewPat   x
+type family XSplicePat x
+type family XLitPat    x
+type family XNPat      x
+type family XNPlusKPat x
+type family XSigPat    x
+type family XCoPat     x
+type family XXPat      x
+
+
+type ForallXPat (c :: * -> Constraint) (x :: *) =
+       ( c (XWildPat   x)
+       , c (XVarPat    x)
+       , c (XLazyPat   x)
+       , c (XAsPat     x)
+       , c (XParPat    x)
+       , c (XBangPat   x)
+       , c (XListPat   x)
+       , c (XTuplePat  x)
+       , c (XSumPat    x)
+       , c (XPArrPat   x)
+       , c (XViewPat   x)
+       , c (XSplicePat x)
+       , c (XLitPat    x)
+       , c (XNPat      x)
+       , c (XNPlusKPat x)
+       , c (XSigPat    x)
+       , c (XCoPat     x)
+       , c (XXPat      x)
+       )
+
+-- =====================================================================
+-- Type families for the HsTypes type families
+
+type family XForAllTy        x
+type family XQualTy          x
+type family XTyVar           x
+type family XAppsTy          x
+type family XAppTy           x
+type family XFunTy           x
+type family XListTy          x
+type family XPArrTy          x
+type family XTupleTy         x
+type family XSumTy           x
+type family XOpTy            x
+type family XParTy           x
+type family XIParamTy        x
+type family XEqTy            x
+type family XKindSig         x
+type family XSpliceTy        x
+type family XDocTy           x
+type family XBangTy          x
+type family XRecTy           x
+type family XExplicitListTy  x
+type family XExplicitTupleTy x
+type family XTyLit           x
+type family XWildCardTy      x
+type family XXType           x
+
+-- | Helper to apply a constraint to all extension points. It has one
+-- entry per extension point type family.
+type ForallXType (c :: * -> Constraint) (x :: *) =
+       ( c (XForAllTy        x)
+       , c (XQualTy          x)
+       , c (XTyVar           x)
+       , c (XAppsTy          x)
+       , c (XAppTy           x)
+       , c (XFunTy           x)
+       , c (XListTy          x)
+       , c (XPArrTy          x)
+       , c (XTupleTy         x)
+       , c (XSumTy           x)
+       , c (XOpTy            x)
+       , c (XParTy           x)
+       , c (XIParamTy        x)
+       , c (XEqTy            x)
+       , c (XKindSig         x)
+       , c (XSpliceTy        x)
+       , c (XDocTy           x)
+       , c (XBangTy          x)
+       , c (XRecTy           x)
+       , c (XExplicitListTy  x)
+       , c (XExplicitTupleTy x)
+       , c (XTyLit           x)
+       , c (XWildCardTy      x)
+       , c (XXType           x)
+       )
+
+-- ---------------------------------------------------------------------
+
+type family XUserTyVar   x
+type family XKindedTyVar x
+type family XXTyVarBndr  x
+
+type ForallXTyVarBndr (c :: * -> Constraint) (x :: *) =
+       ( c (XUserTyVar      x)
+       , c (XKindedTyVar    x)
+       , c (XXTyVarBndr     x)
+       )
+
+-- ---------------------------------------------------------------------
+
+type family XAppInfix  x
+type family XAppPrefix x
+type family XXAppType  x
+
+type ForallXAppType (c :: * -> Constraint) (x :: *) =
+       ( c (XAppInfix   x)
+       , c (XAppPrefix  x)
+       , c (XXAppType   x)
+       )
+
+-- ---------------------------------------------------------------------
+
+type family XFieldOcc  x
+type family XXFieldOcc x
+
+type ForallXFieldOcc (c :: * -> Constraint) (x :: *) =
+       ( c (XFieldOcc  x)
+       , c (XXFieldOcc x)
+       )
+
+
+-- =====================================================================
+-- End of Type family definitions
+-- =====================================================================
+
 -- ----------------------------------------------------------------------
 -- | Conversion of annotations from one type index to another. This is required
 -- where the AST is converted from one pass to another, and the extension values
@@ -551,6 +676,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)
 
@@ -587,12 +721,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))
 
@@ -616,13 +755,29 @@ type DataId p =
 type DataIdLR pL pR =
   ( DataId pL
   , DataId pR
-  , ForallXValBindsLR Data pL pR
-  , ForallXValBindsLR Data pL pL
-  , ForallXValBindsLR Data pR pR
 
-  , ForallXParStmtBlock Data pL pR
-  , ForallXParStmtBlock Data pL pL
-  , ForallXParStmtBlock Data pR pR
+  , ForallXHsLocalBindsLR Data pL pR
+  , ForallXHsLocalBindsLR Data pL pL
+  , ForallXHsLocalBindsLR Data pR pR
+
+  , ForallXValBindsLR     Data pL pR
+  , ForallXValBindsLR     Data pL pL
+  , ForallXValBindsLR     Data pR pR
+
+  , ForallXHsBindsLR      Data pL pR
+  , ForallXHsBindsLR      Data pL pL
+  , ForallXHsBindsLR      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/HsInstances.hs b/compiler/hsSyn/HsInstances.hs
new file mode 100644 (file)
index 0000000..1059cb1
--- /dev/null
@@ -0,0 +1,405 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module HsInstances where
+
+-- This module defines the Data instances for the hsSyn AST.
+
+-- It happens here to avoid massive constraint types on the AST with concomitant
+-- slow GHC bootstrap times.
+
+-- UndecidableInstances ?
+
+import Data.Data hiding ( Fixity )
+
+import HsExtension
+import HsBinds
+import HsDecls
+import HsExpr
+import HsLit
+import HsTypes
+import HsPat
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsSyn -----------------------------------------
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsBinds ---------------------------------------
+
+-- deriving instance (DataIdLR pL pR) => Data (HsLocalBindsLR pL pR)
+deriving instance Data (HsLocalBindsLR GhcPs GhcPs)
+deriving instance Data (HsLocalBindsLR GhcPs GhcRn)
+deriving instance Data (HsLocalBindsLR GhcRn GhcRn)
+deriving instance Data (HsLocalBindsLR GhcTc GhcTc)
+
+-- deriving instance (DataIdLR pL pR) => Data (HsValBindsLR pL pR)
+deriving instance Data (HsValBindsLR GhcPs GhcPs)
+deriving instance Data (HsValBindsLR GhcPs GhcRn)
+deriving instance Data (HsValBindsLR GhcRn GhcRn)
+deriving instance Data (HsValBindsLR GhcTc GhcTc)
+
+-- deriving instance (DataIdLR pL pL) => Data (NHsValBindsLR pL)
+deriving instance Data (NHsValBindsLR GhcPs)
+deriving instance Data (NHsValBindsLR GhcRn)
+deriving instance Data (NHsValBindsLR GhcTc)
+
+-- deriving instance (DataIdLR pL pR) => Data (HsBindLR pL pR)
+deriving instance Data (HsBindLR GhcPs GhcPs)
+deriving instance Data (HsBindLR GhcPs GhcRn)
+deriving instance Data (HsBindLR GhcRn GhcRn)
+deriving instance Data (HsBindLR GhcTc GhcTc)
+
+-- deriving instance (DataId p)       => Data (ABExport p)
+deriving instance Data (ABExport GhcPs)
+deriving instance Data (ABExport GhcRn)
+deriving instance Data (ABExport GhcTc)
+
+-- deriving instance (DataIdLR pL pR) => Data (PatSynBind pL pR)
+deriving instance Data (PatSynBind GhcPs GhcPs)
+deriving instance Data (PatSynBind GhcPs GhcRn)
+deriving instance Data (PatSynBind GhcRn GhcRn)
+deriving instance Data (PatSynBind GhcTc GhcTc)
+
+-- deriving instance (DataIdLR p p)   => Data (HsIPBinds p)
+deriving instance Data (HsIPBinds GhcPs)
+deriving instance Data (HsIPBinds GhcRn)
+deriving instance Data (HsIPBinds GhcTc)
+
+-- deriving instance (DataIdLR p p)   => Data (IPBind p)
+deriving instance Data (IPBind GhcPs)
+deriving instance Data (IPBind GhcRn)
+deriving instance Data (IPBind GhcTc)
+
+-- deriving instance (DataIdLR p p)   => Data (Sig p)
+deriving instance Data (Sig GhcPs)
+deriving instance Data (Sig GhcRn)
+deriving instance Data (Sig GhcTc)
+
+-- deriving instance (DataId p)       => Data (FixitySig p)
+deriving instance Data (FixitySig GhcPs)
+deriving instance Data (FixitySig GhcRn)
+deriving instance Data (FixitySig GhcTc)
+
+-- deriving instance (DataIdLR p p)   => Data (HsPatSynDir p)
+deriving instance Data (HsPatSynDir GhcPs)
+deriving instance Data (HsPatSynDir GhcRn)
+deriving instance Data (HsPatSynDir GhcTc)
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsDecls ---------------------------------------
+
+-- deriving instance (DataIdLR p p) => Data (HsDecl p)
+deriving instance Data (HsDecl GhcPs)
+deriving instance Data (HsDecl GhcRn)
+deriving instance Data (HsDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsGroup p)
+deriving instance Data (HsGroup GhcPs)
+deriving instance Data (HsGroup GhcRn)
+deriving instance Data (HsGroup GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (SpliceDecl p)
+deriving instance Data (SpliceDecl GhcPs)
+deriving instance Data (SpliceDecl GhcRn)
+deriving instance Data (SpliceDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (TyClDecl p)
+deriving instance Data (TyClDecl GhcPs)
+deriving instance Data (TyClDecl GhcRn)
+deriving instance Data (TyClDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (TyClGroup p)
+deriving instance Data (TyClGroup GhcPs)
+deriving instance Data (TyClGroup GhcRn)
+deriving instance Data (TyClGroup GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (FamilyResultSig p)
+deriving instance Data (FamilyResultSig GhcPs)
+deriving instance Data (FamilyResultSig GhcRn)
+deriving instance Data (FamilyResultSig GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (FamilyDecl p)
+deriving instance Data (FamilyDecl GhcPs)
+deriving instance Data (FamilyDecl GhcRn)
+deriving instance Data (FamilyDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (InjectivityAnn p)
+deriving instance Data (InjectivityAnn GhcPs)
+deriving instance Data (InjectivityAnn GhcRn)
+deriving instance Data (InjectivityAnn GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (FamilyInfo p)
+deriving instance Data (FamilyInfo GhcPs)
+deriving instance Data (FamilyInfo GhcRn)
+deriving instance Data (FamilyInfo GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsDataDefn p)
+deriving instance Data (HsDataDefn GhcPs)
+deriving instance Data (HsDataDefn GhcRn)
+deriving instance Data (HsDataDefn GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsDerivingClause p)
+deriving instance Data (HsDerivingClause GhcPs)
+deriving instance Data (HsDerivingClause GhcRn)
+deriving instance Data (HsDerivingClause GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (ConDecl p)
+deriving instance Data (ConDecl GhcPs)
+deriving instance Data (ConDecl GhcRn)
+deriving instance Data (ConDecl GhcTc)
+
+-- deriving instance DataIdLR p p   => Data (TyFamInstDecl p)
+deriving instance Data (TyFamInstDecl GhcPs)
+deriving instance Data (TyFamInstDecl GhcRn)
+deriving instance Data (TyFamInstDecl GhcTc)
+
+-- deriving instance DataIdLR p p   => Data (DataFamInstDecl p)
+deriving instance Data (DataFamInstDecl GhcPs)
+deriving instance Data (DataFamInstDecl GhcRn)
+deriving instance Data (DataFamInstDecl GhcTc)
+
+-- deriving instance (DataIdLR p p,Data pats,Data rhs)=>Data (FamEqn p pats rhs)
+deriving instance (Data pats,Data rhs) => Data (FamEqn GhcPs pats rhs)
+deriving instance (Data pats,Data rhs) => Data (FamEqn GhcRn pats rhs)
+deriving instance (Data pats,Data rhs) => Data (FamEqn GhcTc pats rhs)
+
+-- deriving instance (DataIdLR p p) => Data (ClsInstDecl p)
+deriving instance Data (ClsInstDecl GhcPs)
+deriving instance Data (ClsInstDecl GhcRn)
+deriving instance Data (ClsInstDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (InstDecl p)
+deriving instance Data (InstDecl GhcPs)
+deriving instance Data (InstDecl GhcRn)
+deriving instance Data (InstDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (DerivDecl p)
+deriving instance Data (DerivDecl GhcPs)
+deriving instance Data (DerivDecl GhcRn)
+deriving instance Data (DerivDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (DefaultDecl p)
+deriving instance Data (DefaultDecl GhcPs)
+deriving instance Data (DefaultDecl GhcRn)
+deriving instance Data (DefaultDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (ForeignDecl p)
+deriving instance Data (ForeignDecl GhcPs)
+deriving instance Data (ForeignDecl GhcRn)
+deriving instance Data (ForeignDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (RuleDecls p)
+deriving instance Data (RuleDecls GhcPs)
+deriving instance Data (RuleDecls GhcRn)
+deriving instance Data (RuleDecls GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (RuleDecl p)
+deriving instance Data (RuleDecl GhcPs)
+deriving instance Data (RuleDecl GhcRn)
+deriving instance Data (RuleDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (RuleBndr p)
+deriving instance Data (RuleBndr GhcPs)
+deriving instance Data (RuleBndr GhcRn)
+deriving instance Data (RuleBndr GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (VectDecl p)
+deriving instance Data (VectDecl GhcPs)
+deriving instance Data (VectDecl GhcRn)
+deriving instance Data (VectDecl GhcTc)
+
+-- deriving instance (DataId p)     => Data (WarnDecls p)
+deriving instance Data (WarnDecls GhcPs)
+deriving instance Data (WarnDecls GhcRn)
+deriving instance Data (WarnDecls GhcTc)
+
+-- deriving instance (DataId p)     => Data (WarnDecl p)
+deriving instance Data (WarnDecl GhcPs)
+deriving instance Data (WarnDecl GhcRn)
+deriving instance Data (WarnDecl GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (AnnDecl p)
+deriving instance Data (AnnDecl GhcPs)
+deriving instance Data (AnnDecl GhcRn)
+deriving instance Data (AnnDecl GhcTc)
+
+-- deriving instance (DataId p)     => Data (RoleAnnotDecl p)
+deriving instance Data (RoleAnnotDecl GhcPs)
+deriving instance Data (RoleAnnotDecl GhcRn)
+deriving instance Data (RoleAnnotDecl GhcTc)
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsExpr ----------------------------------------
+
+-- deriving instance (DataIdLR p p) => Data (SyntaxExpr p)
+deriving instance Data (SyntaxExpr GhcPs)
+deriving instance Data (SyntaxExpr GhcRn)
+deriving instance Data (SyntaxExpr GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsExpr p)
+deriving instance Data (HsExpr GhcPs)
+deriving instance Data (HsExpr GhcRn)
+deriving instance Data (HsExpr GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsTupArg p)
+deriving instance Data (HsTupArg GhcPs)
+deriving instance Data (HsTupArg GhcRn)
+deriving instance Data (HsTupArg GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsCmd p)
+deriving instance Data (HsCmd GhcPs)
+deriving instance Data (HsCmd GhcRn)
+deriving instance Data (HsCmd GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsCmdTop p)
+deriving instance Data (HsCmdTop GhcPs)
+deriving instance Data (HsCmdTop GhcRn)
+deriving instance Data (HsCmdTop GhcTc)
+
+-- deriving instance (DataIdLR p p,Data body) => Data (MatchGroup p body)
+deriving instance (Data body) => Data (MatchGroup GhcPs body)
+deriving instance (Data body) => Data (MatchGroup GhcRn body)
+deriving instance (Data body) => Data (MatchGroup GhcTc body)
+
+-- deriving instance (DataIdLR p p,Data body) => Data (Match      p body)
+deriving instance (Data body) => Data (Match      GhcPs body)
+deriving instance (Data body) => Data (Match      GhcRn body)
+deriving instance (Data body) => Data (Match      GhcTc body)
+
+-- deriving instance (DataIdLR p p,Data body) => Data (GRHSs      p body)
+deriving instance (Data body) => Data (GRHSs     GhcPs body)
+deriving instance (Data body) => Data (GRHSs     GhcRn body)
+deriving instance (Data body) => Data (GRHSs     GhcTc body)
+
+-- deriving instance (DataIdLR p p,Data body) => Data (GRHS       p body)
+deriving instance (Data body) => Data (GRHS     GhcPs body)
+deriving instance (Data body) => Data (GRHS     GhcRn body)
+deriving instance (Data body) => Data (GRHS     GhcTc body)
+
+-- deriving instance (DataIdLR p p,Data body) => Data (StmtLR   p p body)
+deriving instance (Data body) => Data (StmtLR   GhcPs GhcPs body)
+deriving instance (Data body) => Data (StmtLR   GhcPs GhcRn body)
+deriving instance (Data body) => Data (StmtLR   GhcRn GhcRn body)
+deriving instance (Data body) => Data (StmtLR   GhcTc GhcTc body)
+
+-- deriving instance (DataIdLR p p) => Data (ParStmtBlock p p)
+deriving instance Data (ParStmtBlock GhcPs GhcPs)
+deriving instance Data (ParStmtBlock GhcPs GhcRn)
+deriving instance Data (ParStmtBlock GhcRn GhcRn)
+deriving instance Data (ParStmtBlock GhcTc GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (ApplicativeArg p)
+deriving instance Data (ApplicativeArg GhcPs)
+deriving instance Data (ApplicativeArg GhcRn)
+deriving instance Data (ApplicativeArg GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsSplice p)
+deriving instance Data (HsSplice GhcPs)
+deriving instance Data (HsSplice GhcRn)
+deriving instance Data (HsSplice GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsSplicedThing p)
+deriving instance Data (HsSplicedThing GhcPs)
+deriving instance Data (HsSplicedThing GhcRn)
+deriving instance Data (HsSplicedThing GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsBracket p)
+deriving instance Data (HsBracket GhcPs)
+deriving instance Data (HsBracket GhcRn)
+deriving instance Data (HsBracket GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (ArithSeqInfo p)
+deriving instance Data (ArithSeqInfo GhcPs)
+deriving instance Data (ArithSeqInfo GhcRn)
+deriving instance Data (ArithSeqInfo GhcTc)
+
+deriving instance                   Data RecordConTc
+deriving instance                   Data CmdTopTc
+deriving instance                   Data PendingRnSplice
+deriving instance                   Data PendingTcSplice
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsLit ----------------------------------------
+
+-- deriving instance (DataId p) => Data (HsLit p)
+deriving instance Data (HsLit GhcPs)
+deriving instance Data (HsLit GhcRn)
+deriving instance Data (HsLit GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsOverLit p)
+deriving instance Data (HsOverLit GhcPs)
+deriving instance Data (HsOverLit GhcRn)
+deriving instance Data (HsOverLit GhcTc)
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsPat -----------------------------------------
+
+-- deriving instance (DataIdLR p p) => Data (Pat p)
+deriving instance Data (Pat GhcPs)
+deriving instance Data (Pat GhcRn)
+deriving instance Data (Pat GhcTc)
+
+-- deriving instance (DataIdLR p p, Data body) => Data (HsRecFields p body)
+deriving instance (Data body) => Data (HsRecFields GhcPs body)
+deriving instance (Data body) => Data (HsRecFields GhcRn body)
+deriving instance (Data body) => Data (HsRecFields GhcTc body)
+
+-- ---------------------------------------------------------------------
+-- Data derivations from HsTypes ---------------------------------------
+
+-- deriving instance (DataIdLR p p) => Data (LHsQTyVars p)
+deriving instance Data (LHsQTyVars GhcPs)
+deriving instance Data (LHsQTyVars GhcRn)
+deriving instance Data (LHsQTyVars GhcTc)
+
+-- deriving instance (DataIdLR p p, Data thing) =>Data (HsImplicitBndrs p thing)
+deriving instance (Data thing) => Data (HsImplicitBndrs GhcPs thing)
+deriving instance (Data thing) => Data (HsImplicitBndrs GhcRn thing)
+deriving instance (Data thing) => Data (HsImplicitBndrs GhcTc thing)
+
+-- deriving instance (DataIdLR p p, Data thing) =>Data (HsWildCardBndrs p thing)
+deriving instance (Data thing) => Data (HsWildCardBndrs GhcPs thing)
+deriving instance (Data thing) => Data (HsWildCardBndrs GhcRn thing)
+deriving instance (Data thing) => Data (HsWildCardBndrs GhcTc thing)
+
+-- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p)
+deriving instance Data (HsTyVarBndr GhcPs)
+deriving instance Data (HsTyVarBndr GhcRn)
+deriving instance Data (HsTyVarBndr GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsType p)
+deriving instance Data (HsType GhcPs)
+deriving instance Data (HsType GhcRn)
+deriving instance Data (HsType GhcTc)
+
+-- deriving instance (DataId p)     => Data (HsWildCardInfo p)
+deriving instance Data (HsWildCardInfo GhcPs)
+deriving instance Data (HsWildCardInfo GhcRn)
+deriving instance Data (HsWildCardInfo GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (HsAppType p)
+deriving instance Data (HsAppType GhcPs)
+deriving instance Data (HsAppType GhcRn)
+deriving instance Data (HsAppType GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (ConDeclField p)
+deriving instance Data (ConDeclField GhcPs)
+deriving instance Data (ConDeclField GhcRn)
+deriving instance Data (ConDeclField GhcTc)
+
+-- deriving instance (DataId p)     => Data (FieldOcc p)
+deriving instance Data (FieldOcc GhcPs)
+deriving instance Data (FieldOcc GhcRn)
+deriving instance Data (FieldOcc GhcTc)
+
+-- deriving instance DataId p       => Data (AmbiguousFieldOcc p)
+deriving instance Data (AmbiguousFieldOcc GhcPs)
+deriving instance Data (AmbiguousFieldOcc GhcRn)
+deriving instance Data (AmbiguousFieldOcc GhcTc)
+
+
+-- ---------------------------------------------------------------------
index 182d00a..1a38296 100644 (file)
@@ -79,8 +79,6 @@ data HsLit x
 
   | XLit (XXLit x)
 
-deriving instance (DataId x) => Data (HsLit x)
-
 type instance XHsChar       (GhcPass _) = SourceText
 type instance XHsCharPrim   (GhcPass _) = SourceText
 type instance XHsString     (GhcPass _) = SourceText
@@ -121,7 +119,6 @@ data HsOverLit p
 
   | XOverLit
       (XXOverLit p)
-deriving instance (DataIdLR p p) => Data (HsOverLit p)
 
 data OverLitTc
   = OverLitTc {
index 8ffde32..5732c3d 100644 (file)
@@ -279,7 +279,6 @@ data Pat p
   -- | Trees that Grow extension point for new constructors
   | XPat
       (XXPat p)
-deriving instance (DataIdLR p p) => Data (Pat p)
 
 -- ---------------------------------------------------------------------
 
@@ -353,7 +352,6 @@ data HsRecFields p arg         -- A bunch of record fields
   = HsRecFields { rec_flds   :: [LHsRecField p arg],
                   rec_dotdot :: Maybe Int }  -- Note [DotDot fields]
   deriving (Functor, Foldable, Traversable)
-deriving instance (DataId p, Data arg) => Data (HsRecFields p arg)
 
 
 -- Note [DotDot fields]
index d9a4d79..b7efb1c 100644 (file)
@@ -9,13 +9,11 @@
 module HsPat where
 import SrcLoc( Located )
 
-import Data.Data hiding (Fixity)
 import Outputable
-import HsExtension      ( DataIdLR, OutputableBndrId, GhcPass )
+import HsExtension      ( OutputableBndrId, GhcPass )
 
 type role Pat nominal
 data Pat (i :: *)
 type LPat i = Located (Pat i)
 
-instance (DataIdLR p p) => Data (Pat p)
 instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p)
index 1534491..b9abcf2 100644 (file)
@@ -16,6 +16,7 @@ therefore, is almost nothing but re-exporting.
                                       -- in module PlaceHolder
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data
 
 module HsSyn (
         module HsBinds,
@@ -31,7 +32,7 @@ module HsSyn (
         module HsExtension,
         Fixity,
 
-        HsModule(..)
+        HsModule(..),
 ) where
 
 -- friends:
@@ -49,6 +50,7 @@ import HsTypes
 import BasicTypes       ( Fixity, WarningTxt )
 import HsUtils
 import HsDoc
+import HsInstances ()
 
 -- others:
 import Outputable
@@ -111,7 +113,10 @@ data HsModule name
      --    hsmodImports,hsmodDecls if this style is used.
 
      -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataIdLR name name) => Data (HsModule name)
+-- deriving instance (DataIdLR name name) => Data (HsModule name)
+deriving instance Data (HsModule GhcPs)
+deriving instance Data (HsModule GhcRn)
+deriving instance Data (HsModule GhcTc)
 
 instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsModule p) where
 
index 5be6ddb..6d8a660 100644 (file)
@@ -270,7 +270,6 @@ data LHsQTyVars pass   -- See Note [HsType binders]
                -- See Note [Dependent LHsQTyVars] in TcHsType
     }
 
-deriving instance (DataIdLR pass pass) => Data (LHsQTyVars pass)
 
 mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs
 mkHsQTvs tvs = HsQTvs { hsq_implicit = placeHolder, hsq_explicit = tvs
@@ -300,7 +299,6 @@ data HsImplicitBndrs pass thing   -- See Note [HsType binders]
                                            -- is the payload closed? Used in
                                            -- TcHsType.decideKindGeneralisationPlan
     }
-deriving instance (DataId pass, Data thing) => Data (HsImplicitBndrs pass thing)
 
 -- | Haskell Wildcard Binders
 data HsWildCardBndrs pass thing
@@ -316,8 +314,6 @@ data HsWildCardBndrs pass thing
                 -- it's still there in the hsc_body.
     }
 
-deriving instance (DataId pass, Data thing) => Data (HsWildCardBndrs pass thing)
-
 -- | Located Haskell Signature Type
 type LHsSigType   pass = HsImplicitBndrs pass (LHsType pass)    -- Implicit only
 
@@ -420,7 +416,6 @@ data HsTyVarBndr pass
 
   | XTyVarBndr
       (XXTyVarBndr pass)
-deriving instance (DataIdLR pass pass) => Data (HsTyVarBndr pass)
 
 type instance XUserTyVar    (GhcPass _) = PlaceHolder
 type instance XKindedTyVar  (GhcPass _) = PlaceHolder
@@ -627,7 +622,6 @@ data HsType pass
   -- For adding new constructors via Trees that Grow
   | XHsType
       (XXType pass)
-deriving instance (DataIdLR pass pass) => Data (HsType pass)
 
 data NewHsTypeX
   = NHsCoreTy Type -- An escape hatch for tunnelling a *closed*
@@ -692,7 +686,6 @@ newtype HsWildCardInfo pass        -- See Note [The wildcard story for types]
     = AnonWildCard (PostRn pass (Located Name))
       -- A anonymous wild card ('_'). A fresh Name is generated for
       -- each individual anonymous wildcard during renaming
-deriving instance (DataId pass) => Data (HsWildCardInfo pass)
 
 -- | Located Haskell Application Type
 type LHsAppType pass = Located (HsAppType pass)
@@ -706,7 +699,6 @@ data HsAppType pass
                 (LHsType pass)      -- anything else, including things like (+)
   | XAppType
       (XXAppType pass)
-deriving instance (DataIdLR pass pass) => Data (HsAppType pass)
 
 type instance XAppInfix   (GhcPass _) = PlaceHolder
 type instance XAppPrefix  (GhcPass _) = PlaceHolder
@@ -855,7 +847,6 @@ data ConDeclField pass  -- Record fields have Haddoc docs on them
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
 
       -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataIdLR pass pass) => Data (ConDeclField pass)
 
 instance (p ~ GhcPass pass, OutputableBndrId p)
        => Outputable (ConDeclField p) where
@@ -1193,7 +1184,6 @@ data FieldOcc pass = FieldOcc { extFieldOcc :: XFieldOcc pass
       (XXFieldOcc pass)
 deriving instance (p ~ GhcPass pass, Eq (XFieldOcc p)) => Eq  (FieldOcc p)
 deriving instance (p ~ GhcPass pass, Ord (XFieldOcc p)) => Ord (FieldOcc p)
-deriving instance (DataId pass) => Data (FieldOcc pass)
 
 type instance XFieldOcc GhcPs = PlaceHolder
 type instance XFieldOcc GhcRn = Name
@@ -1224,7 +1214,6 @@ data AmbiguousFieldOcc pass
   = Unambiguous (XUnambiguous pass) (Located RdrName)
   | Ambiguous   (XAmbiguous pass)   (Located RdrName)
   | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass)
-deriving instance DataId pass => Data (AmbiguousFieldOcc pass)
 
 type instance XUnambiguous GhcPs = PlaceHolder
 type instance XUnambiguous GhcRn = Name
index 756cdbf..90e1ddb 100644 (file)
@@ -143,9 +143,9 @@ just attach noSrcSpan to everything.
 mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
 mkHsPar e = L (getLoc e) (HsPar noExt e)
 
-mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP id))
-              -> [LPat id] -> Located (body id)
-              -> LMatch id (Located (body id))
+mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
+              -> [LPat (GhcPass p)] -> Located (body (GhcPass p))
+              -> LMatch (GhcPass p) (Located (body (GhcPass p)))
 mkSimpleMatch ctxt pats rhs
   = L loc $
     Match { m_ctxt = ctxt, m_pats = pats
@@ -155,7 +155,8 @@ mkSimpleMatch ctxt pats rhs
                 []      -> getLoc rhs
                 (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
 
-unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id))
+unguardedGRHSs :: Located (body (GhcPass p))
+               -> GRHSs (GhcPass p) (Located (body (GhcPass p)))
 unguardedGRHSs rhs@(L loc _)
   = GRHSs (unguardedRHS loc rhs) (noLoc emptyLocalBinds)
 
@@ -200,7 +201,8 @@ mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
 
 -- |A simple case alternative with a single pattern, no binds, no guards;
 -- pre-typechecking
-mkHsCaseAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id))
+mkHsCaseAlt :: LPat (GhcPass p) -> (Located (body (GhcPass p)))
+            -> LMatch (GhcPass p) (Located (body (GhcPass p)))
 mkHsCaseAlt pat expr
   = mkSimpleMatch CaseAlt [pat] expr
 
@@ -614,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
@@ -628,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
@@ -788,7 +791,7 @@ mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
 mkFunBind fn ms = FunBind { fun_id = fn
                           , fun_matches = mkMatchGroup Generated ms
                           , fun_co_fn = idHsWrapper
-                          , bind_fvs = placeHolderNames
+                          , fun_ext = noExt
                           , fun_tick = [] }
 
 mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]
@@ -797,22 +800,24 @@ mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]
 mkTopFunBind origin fn ms = FunBind { fun_id = fn
                                     , fun_matches = mkMatchGroup origin ms
                                     , fun_co_fn = idHsWrapper
-                                    , bind_fvs = emptyNameSet -- NB: closed
+                                    , fun_ext  = emptyNameSet -- NB: closed
                                                               --     binding
                                     , fun_tick = [] }
 
 mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 
-mkVarBind :: IdP p -> LHsExpr p -> LHsBind p
+mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
 mkVarBind var rhs = L (getLoc rhs) $
-                    VarBind { var_id = var, var_rhs = rhs, var_inline = False }
+                    VarBind { var_ext = noExt,
+                              var_id = var, var_rhs = rhs, var_inline = False }
 
 mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
              -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs
-mkPatSynBind name details lpat dir = PatSynBind psb
+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
@@ -821,7 +826,7 @@ mkPatSynBind name details lpat dir = PatSynBind psb
 -- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
 -- considered infix.
 isInfixFunBind :: HsBindLR id1 id2 -> Bool
-isInfixFunBind (FunBind _ (MG matches _ _ _) _ _ _)
+isInfixFunBind (FunBind _ _ (MG matches _ _ _) _ _)
   = any (isInfixMatch . unLoc) (unLoc matches)
 isInfixFunBind _ = False
 
@@ -940,10 +945,11 @@ isBangedHsBind _
 
 collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR)
                     -> [IdP (GhcPass idL)]
-collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
+collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
                                          -- No pattern synonyms here
-collectLocalBinders (HsIPBinds _)      = []
-collectLocalBinders EmptyLocalBinds    = []
+collectLocalBinders (HsIPBinds {})      = []
+collectLocalBinders (EmptyLocalBinds _) = []
+collectLocalBinders (XHsLocalBindsLR _) = []
 
 collectHsIdBinders, collectHsValBinders
   :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
@@ -983,9 +989,11 @@ collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++
         -- I don't think we want the binders from the abe_binds
 
         -- binding (hence see AbsBinds) is in zonking in TcHsSyn
-collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc
+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]
 -- Used exclusively for the bindings of an instance decl which are all FunBinds
@@ -1130,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
@@ -1153,14 +1162,14 @@ hsPatSynSelectors (XValBindsLR (NValBinds binds _))
 
 addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p]
 addPatSynSelector bind sels
-  | L _ (PatSynBind (PSB { psb_args = RecCon as })) <- bind
+  | L _ (PatSynBind (PSB { psb_args = RecCon as })) <- bind
   = map (unLoc . recordPatSynSelectorId) as ++ sels
   | otherwise = sels
 
 getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
 getPatSynBinds binds
   = [ psb | (_, lbinds) <- binds
-          , L _ (PatSynBind psb) <- bagToList lbinds ]
+          , L _ (PatSynBind psb) <- bagToList lbinds ]
 
 -------------------
 hsLInstDeclBinders :: LInstDecl pass
@@ -1285,9 +1294,10 @@ lStmtsImplicits = hs_lstmts
     hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
     hs_stmt (RecStmt { recS_stmts = ss })     = hs_lstmts ss
 
-    hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds
-    hs_local_binds (HsIPBinds _)         = emptyNameSet
-    hs_local_binds EmptyLocalBinds       = emptyNameSet
+    hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds
+    hs_local_binds (HsIPBinds {})           = emptyNameSet
+    hs_local_binds (EmptyLocalBinds _)      = emptyNameSet
+    hs_local_binds (XHsLocalBindsLR _)      = emptyNameSet
 
 hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> NameSet
 hsValBindsImplicits (XValBindsLR (NValBinds binds _))
index 1012c25..db6f7f8 100644 (file)
@@ -870,7 +870,7 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do
   -- create a new binding.
   let expr_fs = fsLit "_compileParsedExpr"
       expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc
-      let_stmt = L loc . LetStmt . L loc . HsValBinds $
+      let_stmt = L loc . LetStmt . L loc . (HsValBinds noExt) $
         ValBinds noExt
                      (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) []
 
index bbb7517..e3a0572 100644 (file)
@@ -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
@@ -1572,15 +1572,13 @@ binds   ::  { Located ([AddAnn],Located (HsLocalBinds GhcPs)) }
                                                 -- No type declarations
         : decllist          {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1)
                                   ; return (sL1 $1 (fst $ unLoc $1
-                                                    ,sL1 $1 $ HsValBinds val_binds)) } }
+                                                    ,sL1 $1 $ HsValBinds noExt val_binds)) } }
 
         | '{'            dbinds '}'     { sLL $1 $> ([moc $1,mcc $3]
-                                             ,sL1 $2 $ HsIPBinds (IPBinds (reverse $ unLoc $2)
-                                                         emptyTcEvBinds)) }
+                                             ,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) }
 
         |     vocurly    dbinds close   { L (getLoc $2) ([]
-                                            ,sL1 $2 $ HsIPBinds (IPBinds (reverse $ unLoc $2)
-                                                        emptyTcEvBinds)) }
+                                            ,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) }
 
 
 wherebinds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) }
@@ -2281,9 +2279,9 @@ decl_no_th :: { LHsDecl GhcPs }
                                         -- a FunBind or PatBind back from checkValDef. See Note
                                         -- [FunBind vs PatBind]
                                         case r of {
-                                          (FunBind n _ _ _ _) ->
+                                          (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]) ;
@@ -2295,9 +2293,9 @@ decl_no_th :: { LHsDecl GhcPs }
                                         -- a FunBind or PatBind back from checkValDef. See Note
                                         -- [FunBind vs PatBind]
                                         case r of {
-                                          (FunBind n _ _ _ _) ->
+                                          (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 }
index a976d08..f350001 100644 (file)
@@ -100,6 +100,7 @@ import FastString
 import Maybes
 import Util
 import ApiAnnotation
+import HsExtension      ( noExt )
 import Data.List
 import qualified GHC.LanguageExtensions as LangExt
 import MonadUtils
@@ -560,7 +561,9 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
        ; when (null matches) (wrongNumberErr loc)
        ; return $ mkMatchGroup FromSource matches }
   where
-    fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn ln@(L _ name) details)) rhs _ _ _))) =
+    fromDecl (L loc decl@(ValD (PatBind _
+                                   pat@(L _ (ConPatIn ln@(L _ name) details))
+                                   rhs _))) =
         do { unless (name == patsyn_name) $
                wrongNameBindingErr loc decl
            ; match <- case details of
@@ -1090,10 +1093,10 @@ makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
             -> HsBind GhcPs
 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
 makeFunBind fn ms
-  = FunBind { fun_id = fn,
+  = FunBind { fun_ext = noExt,
+              fun_id = fn,
               fun_matches = mkMatchGroup FromSource ms,
               fun_co_fn = idHsWrapper,
-              bind_fvs = placeHolderNames,
               fun_tick = [] }
 
 checkPatBind :: SDoc
@@ -1102,7 +1105,7 @@ checkPatBind :: SDoc
              -> P ([AddAnn],HsBind GhcPs)
 checkPatBind msg lhs (L _ (_,grhss))
   = do  { lhs <- checkPattern msg lhs
-        ; return ([],PatBind lhs grhss placeHolderType placeHolderNames
+        ; return ([],PatBind noExt lhs grhss
                     ([],[])) }
 
 checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
index c54c734..4ce3a58 100644 (file)
@@ -32,7 +32,6 @@ import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
 
 import HsSyn
 import TcRnMonad
-import TcEvidence     ( emptyTcEvBinds )
 import RnTypes
 import RnPat
 import RnNames
@@ -203,27 +202,31 @@ rnLocalBindsAndThen :: HsLocalBinds GhcPs
 -- This version (a) assumes that the binding vars are *not* already in scope
 --               (b) removes the binders from the free vars of the thing inside
 -- The parser doesn't produce ThenBinds
-rnLocalBindsAndThen EmptyLocalBinds thing_inside =
-  thing_inside EmptyLocalBinds emptyNameSet
+rnLocalBindsAndThen (EmptyLocalBinds x) thing_inside =
+  thing_inside (EmptyLocalBinds x) emptyNameSet
 
-rnLocalBindsAndThen (HsValBinds val_binds) thing_inside
+rnLocalBindsAndThen (HsValBinds val_binds) thing_inside
   = rnLocalValBindsAndThen val_binds $ \ val_binds' ->
-      thing_inside (HsValBinds val_binds')
+      thing_inside (HsValBinds val_binds')
 
-rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do
+rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do
     (binds',fv_binds) <- rnIPBinds binds
-    (thing, fvs_thing) <- thing_inside (HsIPBinds binds') fv_binds
+    (thing, fvs_thing) <- thing_inside (HsIPBinds binds') fv_binds
     return (thing, fvs_thing `plusFV` fv_binds)
 
+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"
 
 {-
 ************************************************************************
@@ -338,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
@@ -405,27 +408,27 @@ rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat })
   = do
       -- we don't actually use the FV processing of rnPatsAndThen here
       (pat',pat'_fvs) <- rnBindPat name_maker pat
-      return (bind { pat_lhs = pat', bind_fvs = pat'_fvs })
+      return (bind { pat_lhs = pat', pat_ext = pat'_fvs })
                 -- We temporarily store the pat's FVs in bind_fvs;
                 -- gets updated to the FVs of the whole bind
                 -- when doing the RHS below
 
 rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })
   = do { name <- applyNameMaker name_maker rdr_name
-       ; return (bind { fun_id   = name
-                      , bind_fvs = placeHolderNamesTc }) }
+       ; return (bind { fun_id = name
+                      , fun_ext = noExt }) }
 
-rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname })
+rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname })
   | isTopRecNameMaker name_maker
   = do { addLocM checkConName rdrname
        ; name <- lookupLocatedTopBndrRn rdrname   -- Should be in scope already
-       ; return (PatSynBind 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 psb{ psb_id = name }) }
+       ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) }
   where
     localPatternSynonymErr :: SDoc
     localPatternSynonymErr
@@ -450,7 +453,7 @@ rnBind _ bind@(PatBind { pat_lhs = pat
                        , pat_rhs = grhss
                                    -- pat fvs were stored in bind_fvs
                                    -- after processing the LHS
-                       , bind_fvs = pat_fvs })
+                       , pat_ext = pat_fvs })
   = do  { mod <- getModule
         ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss
 
@@ -462,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, bind_fvs = fvs' }
+                           , pat_ext = fvs' }
 
               ok_nobind_pat
                   = -- See Note [Pattern bindings that bind no variables]
@@ -501,13 +504,13 @@ rnBind sig_fn bind@(FunBind { fun_id = name
 
         ; fvs' `seq` -- See Note [Free-variable space leak]
           return (bind { fun_matches = matches'
-                       , bind_fvs   = fvs' },
+                       , fun_ext     = fvs' },
                   [plain_name], rhs_fvs)
       }
 
-rnBind sig_fn (PatSynBind bind)
+rnBind sig_fn (PatSynBind bind)
   = do  { (bind', name, fvs) <- rnPatSynBind sig_fn bind
-        ; return (PatSynBind bind', name, fvs) }
+        ; return (PatSynBind bind', name, fvs) }
 
 rnBind _ b = pprPanic "rnBind" (ppr b)
 
@@ -591,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
 
@@ -610,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
@@ -701,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' }
@@ -723,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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -876,9 +883,7 @@ rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest
   = setSrcSpan loc $ do
     do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name
                      -- We use the selector name as the binder
-       ; let bind' = bind { fun_id = sel_name
-                          , bind_fvs = placeHolderNamesTc }
-
+       ; let bind' = bind { fun_id = sel_name, fun_ext = noExt }
        ; return (L loc bind' `consBag` rest ) }
 
 -- Report error for all other forms of bindings
@@ -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)
index ec2b09f..4fe4102 100644 (file)
@@ -1099,10 +1099,10 @@ rnRecStmtsAndThen rnBody s cont
 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
+            (L _ (LetStmt (L _ (HsValBinds (ValBinds _ _ sigs))))) ->
+              foldr (\ sig -> \ acc -> case sig of
+                                         (L loc (FixSig _ s)) -> (L loc s) : acc
+                                         _ -> acc) acc sigs
             _ -> acc) [] l
 
 -- left-hand sides
@@ -1127,12 +1127,12 @@ rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b t))
       return [(L loc (BindStmt pat' body a b t),
                fv_pat)]
 
-rn_rec_stmt_lhs _ (L _ (LetStmt (L _ binds@(HsIPBinds _))))
+rn_rec_stmt_lhs _ (L _ (LetStmt (L _ binds@(HsIPBinds {}))))
   = failWith (badIpBinds (text "an mdo expression") binds)
 
-rn_rec_stmt_lhs fix_env (L loc (LetStmt (L l(HsValBinds binds))))
+rn_rec_stmt_lhs fix_env (L loc (LetStmt (L l(HsValBinds binds))))
     = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
-         return [(L loc (LetStmt (L l (HsValBinds binds'))),
+         return [(L loc (LetStmt (L l (HsValBinds binds'))),
                  -- Warning: this is bogus; see function invariant
                  emptyFVs
                  )]
@@ -1150,8 +1150,10 @@ rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {}))     -- Syntactically illegal in mdo
 rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet
   = pprPanic "rn_rec_stmt" (ppr stmt)
 
-rn_rec_stmt_lhs _ (L _ (LetStmt (L _ EmptyLocalBinds)))
+rn_rec_stmt_lhs _ (L _ (LetStmt (L _ (EmptyLocalBinds _))))
   = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
+rn_rec_stmt_lhs _ (L _ (LetStmt (L _ (XHsLocalBindsLR _))))
+  = panic "rn_rec_stmt LetStmt XHsLocalBindsLR"
 
 rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv
                  -> [LStmt GhcPs body]
@@ -1202,15 +1204,15 @@ rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _ _), fv_pat)
        ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
                   L loc (BindStmt pat' body' bind_op fail_op placeHolder))] }
 
-rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds _))), _)
+rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds {}))), _)
   = failWith (badIpBinds (text "an mdo expression") binds)
 
-rn_rec_stmt _ all_bndrs (L loc (LetStmt (L l (HsValBinds binds'))), _)
+rn_rec_stmt _ all_bndrs (L loc (LetStmt (L l (HsValBinds binds'))), _)
   = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
            -- fixities and unused are handled above in rnRecStmtsAndThen
        ; let fvs = allUses du_binds
        ; return [(duDefs du_binds, fvs, emptyNameSet,
-                 L loc (LetStmt (L l (HsValBinds binds'))))] }
+                 L loc (LetStmt (L l (HsValBinds binds'))))] }
 
 -- no RecStmt case because they get flattened above when doing the LHSes
 rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _)
@@ -1222,7 +1224,10 @@ rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _)       -- Syntactically illegal in mdo
 rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _)     -- Syntactically illegal in mdo
   = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
 
-rn_rec_stmt _ _ (L _ (LetStmt (L _ EmptyLocalBinds)), _)
+rn_rec_stmt _ _ (L _ (LetStmt (L _ (XHsLocalBindsLR _))), _)
+  = panic "rn_rec_stmt: LetStmt XHsLocalBindsLR"
+
+rn_rec_stmt _ _ (L _ (LetStmt (L _ (EmptyLocalBinds _))), _)
   = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
 
 rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _)
index 0f6f3a1..5458469 100644 (file)
@@ -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
index 31caffe..07dcff2 100644 (file)
@@ -580,7 +580,7 @@ checkCanonicalInstances cls poly_ty mbinds = do
     isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
     isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]}
         | GRHSs [L _ (GRHS [] body)] lbinds <- grhss
-        , L _ EmptyLocalBinds <- lbinds
+        , L _ (EmptyLocalBinds _) <- lbinds
         , L _ (HsVar _ (L _ rhsName)) <- body  = Just rhsName
     isAliasMG _ = Nothing
 
@@ -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
@@ -2011,8 +2011,8 @@ extendPatSynEnv val_decls local_fix_env thing = do {
             -> [(Name, [FieldLabel])]
             -> TcM [(Name, [FieldLabel])]
     new_ps' bind names
-      | L bind_loc (PatSynBind (PSB { psb_id = L _ n
-                                    , psb_args = RecCon as })) <- bind
+      | L bind_loc (PatSynBind (PSB { psb_id = L _ n
+                                      , psb_args = RecCon as })) <- bind
       = do
           bnd_name <- newTopSrcBinder (L bind_loc n)
           let rnames = map recordPatSynSelectorId as
@@ -2021,7 +2021,7 @@ extendPatSynEnv val_decls local_fix_env thing = do {
               field_occs =  map mkFieldOcc rnames
           flds     <- mapM (newRecordSelector False [bnd_name]) field_occs
           return ((bnd_name, flds): names)
-      | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind
+      | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind
       = do
         bnd_name <- newTopSrcBinder (L bind_loc n)
         return ((bnd_name, []): names)
@@ -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
index f62ceb5..5355cc9 100644 (file)
@@ -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
@@ -337,16 +337,16 @@ badBootDeclErr = text "Illegal declarations in an hs-boot file"
 tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing
              -> TcM (HsLocalBinds GhcTcId, thing)
 
-tcLocalBinds EmptyLocalBinds thing_inside
+tcLocalBinds (EmptyLocalBinds x) thing_inside
   = do  { thing <- thing_inside
-        ; return (EmptyLocalBinds, thing) }
+        ; return (EmptyLocalBinds x, thing) }
 
-tcLocalBinds (HsValBinds (XValBindsLR (NValBinds binds sigs))) thing_inside
+tcLocalBinds (HsValBinds (XValBindsLR (NValBinds binds sigs))) thing_inside
   = do  { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
-        ; return (HsValBinds (XValBindsLR (NValBinds binds' sigs)), thing) }
-tcLocalBinds (HsValBinds (ValBinds {})) _ = panic "tcLocalBinds"
+        ; return (HsValBinds (XValBindsLR (NValBinds binds' sigs)), thing) }
+tcLocalBinds (HsValBinds (ValBinds {})) _ = panic "tcLocalBinds"
 
-tcLocalBinds (HsIPBinds (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,27 +357,31 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
         ; (ev_binds, result) <- checkConstraints (IPSkol ips)
                                   [] given_ips thing_inside
 
-        ; return (HsIPBinds (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 (HsIPBinds _ (XHsIPBinds _ )) _ = panic "tcLocalBinds"
+tcLocalBinds (XHsLocalBindsLR _)           _ = panic "tcLocalBinds"
+
 {- Note [Implicit parameter untouchables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We add the type variables in the types of the implicit parameters
@@ -531,7 +535,7 @@ tc_single :: forall thing.
           -> LHsBind GhcRn -> IsGroupClosed -> TcM thing
           -> TcM (LHsBinds GhcTcId, thing)
 tc_single _top_lvl sig_fn _prag_fn
-          (L _ (PatSynBind psb@PSB{ psb_id = L _ name }))
+          (L _ (PatSynBind psb@PSB{ psb_id = L _ name }))
           _ thing_inside
   = do { (aux_binds, tcg_env) <- tc_pat_syn_decl
        ; thing <- setGblEnv tcg_env thing_inside
@@ -566,6 +570,10 @@ mkEdges sig_fn binds
     -- is still deterministic even if the edges are in nondeterministic order
     -- as explained in Note [Deterministic SCC] in Digraph.
   where
+    bind_fvs (FunBind { fun_ext = fvs }) = fvs
+    bind_fvs (PatBind { pat_ext = fvs }) = fvs
+    bind_fvs _                           = emptyNameSet
+
     no_sig :: Name -> Bool
     no_sig n = not (hasCompleteSig sig_fn n)
 
@@ -717,16 +725,18 @@ tcPolyCheck prag_fn
        ; let bind' = FunBind { fun_id      = L nm_loc mono_id
                              , fun_matches = matches'
                              , fun_co_fn   = co_fn
-                             , bind_fvs    = placeHolderNamesTc
+                             , 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 }
 
              abs_bind = L loc $
-                        AbsBinds { abs_tvs      = skol_tvs
+                        AbsBinds { abs_ext = noExt
+                                 , abs_tvs      = skol_tvs
                                  , abs_ev_vars  = ev_vars
                                  , abs_ev_binds = [ev_binds]
                                  , abs_exports  = [export]
@@ -741,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
@@ -807,7 +817,8 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
        ; loc <- getSrcSpanM
        ; let poly_ids = map abe_poly exports
              abs_bind = L loc $
-                        AbsBinds { abs_tvs = qtvs
+                        AbsBinds { abs_ext = noExt
+                                 , abs_tvs = qtvs
                                  , abs_ev_vars = givens, abs_ev_binds = [ev_binds]
                                  , abs_exports = exports, abs_binds = binds'
                                  , abs_sig = False }
@@ -867,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
@@ -1324,7 +1336,7 @@ tcMonoBinds :: RecFlag  -- Whether the binding is recursive for typechecking pur
             -> TcM (LHsBinds GhcTcId, [MonoBindInfo])
 tcMonoBinds is_rec sig_fn no_gen
            [ L b_loc (FunBind { fun_id = L nm_loc name,
-                                fun_matches = matches, bind_fvs = fvs })]
+                                fun_matches = matches, fun_ext = fvs })]
                              -- Single function binding,
   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS
   , Nothing <- sig_fn name   -- ...with no type signature
@@ -1349,7 +1361,7 @@ tcMonoBinds is_rec sig_fn no_gen
         ; mono_id <- newLetBndr no_gen name rhs_ty
         ; return (unitBag $ L b_loc $
                      FunBind { fun_id = L nm_loc mono_id,
-                               fun_matches = matches', bind_fvs = fvs,
+                               fun_matches = matches', fun_ext = fvs,
                                fun_co_fn = co_fn, fun_tick = [] },
                   [MBI { mbi_poly_name = name
                        , mbi_sig       = Nothing
@@ -1497,7 +1509,7 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
         ; return ( FunBind { fun_id = L loc mono_id
                            , fun_matches = matches'
                            , fun_co_fn = co_fn
-                           , bind_fvs = placeHolderNamesTc
+                           , fun_ext = placeHolderNamesTc
                            , fun_tick = [] } ) }
 
 tcRhs (TcPatBind infos pat' grhss pat_ty)
@@ -1510,8 +1522,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
-                           , bind_fvs = placeHolderNamesTc
+                           , pat_ext = NPatBindTc placeHolderNamesTc pat_ty
                            , pat_ticks = ([],[]) } )}
 
 tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
@@ -1775,16 +1786,18 @@ isClosedBndrGroup type_env binds
     fv_env :: NameEnv NameSet
     fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds
 
-    bindFvs :: HsBindLR GhcRn idR -> [(Name, NameSet)]
-    bindFvs (FunBind { fun_id = L _ f, bind_fvs = fvs })
-       = let open_fvs = filterNameSet (not . is_closed) fvs
+    bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)]
+    bindFvs (FunBind { fun_id = L _ f, fun_ext = fvs })
+       = let open_fvs = get_open_fvs fvs
          in [(f, open_fvs)]
-    bindFvs (PatBind { pat_lhs = pat, bind_fvs = fvs })
-       = let open_fvs = filterNameSet (not . is_closed) fvs
+    bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs })
+       = let open_fvs = get_open_fvs fvs
          in [(b, open_fvs) | b <- collectPatBinders pat]
     bindFvs _
        = []
 
+    get_open_fvs fvs = filterNameSet (not . is_closed) fvs
+
     is_closed :: Name -> ClosedTypeId
     is_closed name
       | Just thing <- lookupNameEnv type_env name
index dcc85af..118a219 100644 (file)
@@ -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]
 
@@ -287,11 +287,13 @@ 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 }
-             full_bind = AbsBinds { abs_tvs      = tyvars
+             full_bind = AbsBinds { abs_ext      = noExt
+                                  , abs_tvs      = tyvars
                                   , abs_ev_vars  = [this_dict]
                                   , abs_exports  = [export]
                                   , abs_ev_binds = [ev_binds]
@@ -358,8 +360,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
@@ -384,8 +386,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]
index e1d53aa..d3cbdb0 100644 (file)
@@ -663,8 +663,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
 
 
index 57549c6..05c6276 100644 (file)
@@ -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)))
index 14b19ef..5be0087 100644 (file)
@@ -401,15 +401,15 @@ zonkTopDecls ev_binds binds rules vects imp_specs fords
 ---------------------------------------------
 zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId
                -> TcM (ZonkEnv, HsLocalBinds GhcTc)
-zonkLocalBinds env EmptyLocalBinds
-  = return (env, EmptyLocalBinds)
+zonkLocalBinds env (EmptyLocalBinds x)
+  = return (env, (EmptyLocalBinds x))
 
-zonkLocalBinds _ (HsValBinds (ValBinds {}))
+zonkLocalBinds _ (HsValBinds (ValBinds {}))
   = panic "zonkLocalBinds" -- Not in typechecker output
 
-zonkLocalBinds env (HsValBinds (XValBindsLR (NValBinds binds sigs)))
+zonkLocalBinds env (HsValBinds (XValBindsLR (NValBinds binds sigs)))
   = do  { (env1, new_binds) <- go env binds
-        ; return (env1, HsValBinds (XValBindsLR (NValBinds new_binds sigs))) }
+        ; return (env1, HsValBinds (XValBindsLR (NValBinds new_binds sigs))) }
   where
     go env []
       = return (env, [])
@@ -418,17 +418,24 @@ zonkLocalBinds env (HsValBinds (XValBindsLR (NValBinds binds sigs)))
            ; (env2, bs') <- go env1 bs
            ; return (env2, (r,b'):bs') }
 
-zonkLocalBinds env (HsIPBinds (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 (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 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
 
 ---------------------------------------------
 zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc)
@@ -446,16 +453,22 @@ 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_id = var, var_rhs = expr, var_inline = inl })
+zonk_bind env (VarBind { var_ext = x
+                       , var_id = var, var_rhs = expr, var_inline = inl })
   = do { new_var  <- zonkIdBndr env var
        ; new_expr <- zonkLExpr env expr
-       ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) }
+       ; return (VarBind { var_ext = x
+                         , var_id = new_var
+                         , var_rhs = new_expr
+                         , var_inline = inl }) }
 
 zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
                             , fun_co_fn = co_fn })
@@ -480,7 +493,8 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
             ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds
             ; new_exports   <- mapM (zonk_export env3) exports
             ; return (new_val_binds, new_exports) }
-       ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
+       ; return (AbsBinds { abs_ext = noExt
+                          , abs_tvs = new_tyvars, abs_ev_vars = new_evs
                           , abs_ev_binds = new_ev_binds
                           , abs_exports = new_exports, abs_binds = new_val_bind
                           , abs_sig = has_sig }) }
@@ -502,32 +516,38 @@ 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 bind@(PSB { psb_id = L loc id
-                                    , psb_args = details
-                                    , psb_def = lpat
-                                    , psb_dir = dir }))
+zonk_bind env (PatSynBind bind@(PSB { psb_id = L loc id
+                                      , psb_args = details
+                                      , psb_def = lpat
+                                      , psb_dir = dir }))
   = do { id' <- zonkIdBndr env id
        ; (env1, lpat') <- zonkPat env lpat
        ; let details' = zonkPatSynDetails env1 details
        ; (_env2, dir') <- zonkPatSynDir env1 dir
-       ; return $ PatSynBind $
+       ; return $ PatSynBind $
                   bind { psb_id = L loc id'
                        , psb_args = details'
                        , psb_def = lpat'
                        , psb_dir = dir' } }
 
+zonk_bind _ (PatSynBind _ (XPatSynBind _)) = panic "zonk_bind"
+zonk_bind _ (XHsBindsLR _)                 = panic "zonk_bind"
+
 zonkPatSynDetails :: ZonkEnv
                   -> HsPatSynDetails (Located TcId)
                   -> HsPatSynDetails (Located Id)
index 5bbcb4a..fb2e345 100644 (file)
@@ -890,12 +890,14 @@ 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 }
                           -- NB: see Note [SPECIALISE instance pragmas]
-             main_bind = AbsBinds { abs_tvs = inst_tyvars
+             main_bind = AbsBinds { abs_ext = noExt
+                                  , abs_tvs = inst_tyvars
                                   , abs_ev_vars = dfun_ev_vars
                                   , abs_exports = [export]
                                   , abs_ev_binds = []
@@ -1039,12 +1041,14 @@ 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 }
                  local_ev_binds = TcEvBinds ev_binds_var
-                 bind = AbsBinds { abs_tvs      = tyvars
+                 bind = AbsBinds { abs_ext      = noExt
+                                 , abs_tvs      = tyvars
                                  , abs_ev_vars  = dfun_evs
                                  , abs_exports  = [export]
                                  , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
@@ -1382,13 +1386,15 @@ 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 }
 
               local_ev_binds = TcEvBinds ev_binds_var
-              full_bind = AbsBinds { abs_tvs      = tyvars
+              full_bind = AbsBinds { abs_ext      = noExt
+                                   , abs_tvs      = tyvars
                                    , abs_ev_vars  = dfun_ev_vars
                                    , abs_exports  = [export]
                                    , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
@@ -1430,13 +1436,14 @@ 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 }
 
        ; return (unitBag $ L (getLoc meth_bind) $
-                 AbsBinds { abs_tvs = [], abs_ev_vars = []
+                 AbsBinds { abs_ext = noExt, abs_tvs = [], abs_ev_vars = []
                           , abs_exports = [export]
                           , abs_binds = tc_bind, abs_ev_binds = []
                           , abs_sig = True }) }
@@ -1582,7 +1589,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
@@ -1805,7 +1812,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
index a4d7966..a759716 100644 (file)
@@ -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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -687,7 +689,7 @@ tcPatSynMatcher (L loc name) lpat
              match = mkMatch (mkPrefixFunRhs (L loc name)) []
                              (mkHsLams (rr_tv:res_tv:univ_tvs)
                              req_dicts body')
-                             (noLoc EmptyLocalBinds)
+                             (noLoc (EmptyLocalBinds noExt))
              mg :: MatchGroup GhcTc (LHsExpr GhcTc)
              mg = MG{ mg_alts = L (getLoc match) [match]
                     , mg_arg_tys = []
@@ -695,10 +697,10 @@ tcPatSynMatcher (L loc name) lpat
                     , mg_origin = Generated
                     }
 
-       ; let bind = FunBind{ fun_id = L loc matcher_id
+       ; let bind = FunBind{ fun_ext = emptyNameSet
+                           , fun_id = L loc matcher_id
                            , fun_matches = mg
                            , fun_co_fn = idHsWrapper
-                           , bind_fvs = emptyNameSet
                            , fun_tick = [] }
              matcher_bind = unitBag (noLoc bind)
 
@@ -780,10 +782,10 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
              match_group' | need_dummy_arg = add_dummy_arg match_group
                           | otherwise      = match_group
 
-             bind = FunBind { fun_id      = L loc (idName builder_id)
+             bind = FunBind { fun_ext = placeHolderNamesTc
+                            , fun_id      = L loc (idName builder_id)
                             , fun_matches = match_group'
                             , fun_co_fn   = idHsWrapper
-                            , bind_fvs    = placeHolderNamesTc
                             , fun_tick    = [] }
 
              sig = completeSigFromId (PatSynCtxt name) builder_id
@@ -808,7 +810,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
             builder_args  = [L loc (VarPat noExt (L loc n)) | L loc n <- args]
             builder_match = mkMatch (mkPrefixFunRhs (L loc name))
                                     builder_args body
-                                    (noLoc EmptyLocalBinds)
+                                    (noLoc (EmptyLocalBinds noExt))
 
     args = case details of
               PrefixCon args     -> args
@@ -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
index 76827fe..70348d3 100644 (file)
@@ -1988,13 +1988,15 @@ tcUserStmt (L loc (BodyStmt expr _ _ _))
               matches   = [mkMatch (mkPrefixFunRhs (L loc fresh_it)) [] rn_expr
                                    (noLoc emptyLocalBinds)]
               -- [it = expr]
-              the_bind  = L loc $ (mkTopFunBind FromSource (L loc fresh_it) matches) { bind_fvs = fvs }
+              the_bind  = L loc $ (mkTopFunBind FromSource
+                                     (L loc fresh_it) matches) { fun_ext = fvs }
                           -- Care here!  In GHCi the expression might have
                           -- free variables, and they in turn may have free type variables
                           -- (if we are at a breakpoint, say).  We must put those free vars
 
               -- [let it = expr]
-              let_stmt  = L loc $ LetStmt $ noLoc $ HsValBinds $ XValBindsLR
+              let_stmt  = L loc $ LetStmt $ noLoc $ HsValBinds noExt
+                           $ XValBindsLR
                                (NValBinds [(NonRecursive,unitBag the_bind)] [])
 
               -- [it <- e]
index e07ff7c..8624735 100644 (file)
@@ -181,20 +181,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 ]
@@ -496,10 +496,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
@@ -532,7 +535,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 ()
 
@@ -684,7 +687,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
@@ -740,8 +743,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
index 0435dda..4363cd3 100644 (file)
@@ -699,8 +699,9 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name
     do  { _ <- tcHsContext ctxt
         ; mapM_ (wrapLocM kc_sig)     sigs }
   where
-    kc_sig (ClassOpSig _ nms op_ty) = kcHsSigType (TyConSkol ClassFlavour name) nms op_ty
-    kc_sig _                        = return ()
+    kc_sig (ClassOpSig _ _ nms op_ty)
+             = kcHsSigType (TyConSkol ClassFlavour name) nms op_ty
+    kc_sig _ = return ()
 
 kcTyClDecl (FamDecl (FamilyDecl { fdLName  = L _ fam_tc_name
                                 , fdInfo   = fd_info }))
index 3a06af6..5f2a629 100644 (file)
@@ -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
index 68ae331..100b420 100644 (file)
   ,({ DumpParsedAst.hs:11:1-23 }
     (ValD
      (FunBind
+      (PlaceHolder)
       ({ DumpParsedAst.hs:11:1-4 }
        (Unqual
         {OccName: main}))
                      "\"hello\"")
                     {FastString: "hello"})))))))]
             ({ <no location info> }
-             (EmptyLocalBinds)))))])
+             (EmptyLocalBinds
+              (PlaceHolder))))))])
        []
        (PlaceHolder)
        (FromSource))
       (WpHole)
-      (PlaceHolder)
       [])))]
   (Nothing)
   (Nothing)))
index 9d6cc6e..cd6bd98 100644 (file)
@@ -11,6 +11,8 @@
        {Bag(Located (HsBind Name)):
         [({ DumpRenamedAst.hs:18:1-23 }
           (FunBind
+           {NameSet:
+            []}
            ({ DumpRenamedAst.hs:18:1-4 }
             {Name: DumpRenamedAst.main})
            (MG
                           "\"hello\"")
                          {FastString: "hello"})))))))]
                  ({ <no location info> }
-                  (EmptyLocalBinds)))))])
+                  (EmptyLocalBinds
+                   (PlaceHolder))))))])
             []
             (PlaceHolder)
             (FromSource))
            (WpHole)
-           {NameSet:
-            []}
            []))]})]
      []))
    []
index b888067..02f0e3c 100644 (file)
@@ -4,6 +4,7 @@
 {Bag(Located (HsBind Var)):
  [({ <no location info> }
    (VarBind
+    (PlaceHolder)
     {Var: DumpTypecheckedAst.$tcPeano}
     ({ <no location info> }
      (HsApp
@@ -69,6 +70,7 @@
     (False)))
  ,({ <no location info> }
    (VarBind
+    (PlaceHolder)
     {Var: DumpTypecheckedAst.$tc'Zero}
     ({ <no location info> }
      (HsApp
     (False)))
  ,({ <no location info> }
    (VarBind
+    (PlaceHolder)
     {Var: DumpTypecheckedAst.$tc'Succ}
     ({ <no location info> }
      (HsApp
     (False)))
  ,({ <no location info> }
    (VarBind
+    (PlaceHolder)
     {Var: $krep}
     ({ <no location info> }
      (HsApp
     (False)))
  ,({ <no location info> }
    (VarBind
+    (PlaceHolder)
     {Var: $krep}
     ({ <no location info> }
      (HsApp
     (False)))
  ,({ <no location info> }
    (VarBind
+    (PlaceHolder)
     {Var: DumpTypecheckedAst.$trModule}
     ({ <no location info> }
      (HsApp
     (False)))
  ,({ DumpTypecheckedAst.hs:11:1-23 }
    (AbsBinds
+    (PlaceHolder)
     []
     []
     [(ABE
+      (PlaceHolder)
       {Var: main}
       {Var: main}
       (WpHole)
     {Bag(Located (HsBind Var)):
      [({ DumpTypecheckedAst.hs:11:1-23 }
        (FunBind
+        {NameSet:
+         []}
         ({ DumpTypecheckedAst.hs:11:1-4 }
          {Var: main})
         (MG
                        "\"hello\"")
                       {FastString: "hello"})))))))]
               ({ <no location info> }
-               (EmptyLocalBinds)))))])
+               (EmptyLocalBinds
+                (PlaceHolder))))))])
          []
          (TyConApp
           ({abstract:TyCon})
             [])])
          (FromSource))
         (WpHole)
-        {NameSet:
-         []}
         []))]}
     (False)))]}
 
index 21d9e18..1a3d21c 100644 (file)
@@ -10,7 +10,7 @@ test('haddock.base',
             # 2017-02-19                        24286343184 (x64/Windows) - Generalize kind of (->)
             # 2017-12-24                        18733710728 (x64/Windows) - Unknown
 
-          ,(wordsize(64), 20980255200, 5)
+          ,(wordsize(64), 18511324808, 5)
             # 2012-08-14:  5920822352 (amd64/Linux)
             # 2012-09-20:  5829972376 (amd64/Linux)
             # 2012-10-08:  5902601224 (amd64/Linux)
@@ -47,6 +47,7 @@ test('haddock.base',
            # 2018-03-31: 20980255200 (x86_64/Linux) - Track type variable scope more carefully
                # previous to this last commit, the allocations were right below the top
                # of the range. This commit adds only ~1.5% allocations.
+           # 2018-04-10: 18511324808 (x86_64/Linux) - TTG HsBinds and Data instances
 
           ,(platform('i386-unknown-mingw32'), 2885173512, 5)
             # 2013-02-10:                     3358693084 (x86/Windows)
@@ -73,7 +74,7 @@ test('haddock.Cabal',
      [extra_files(['../../../../libraries/Cabal/Cabal/dist-install/haddock.t']),
       unless(in_tree_compiler(), skip), req_haddock
      ,stats_num_field('bytes allocated',
-          [(wordsize(64), 25261834904, 5)
+          [(wordsize(64), 23525241536, 5)
             # 2012-08-14:  3255435248 (amd64/Linux)
             # 2012-08-29:  3324606664 (amd64/Linux, new codegen)
             # 2012-10-08:  3373401360 (amd64/Linux)
@@ -126,6 +127,7 @@ test('haddock.Cabal',
             # 2017-11-06: 18936339648 (amd64/Linux) - Unknown
             # 2017-11-09: 20104611952 (amd64/Linux) - Bump Cabal
             # 2018-01-22: 25261834904 (amd64/Linux) - Bump Cabal
+            # 2018-04-10: 23525241536 (amd64/Linux) - TTG HsBinds and Data instances
 
           ,(platform('i386-unknown-mingw32'), 3293415576, 5)
             # 2012-10-30:                     1733638168 (x86/Windows)
@@ -151,7 +153,7 @@ test('haddock.compiler',
      ,stats_num_field('bytes allocated',
           [(platform('x86_64-unknown-mingw32'),   56775301896, 10),
             # 2017-12-24:                     56775301896 (x64/Windows)
-            (wordsize(64), 91115212032, 10)
+            (wordsize(64), 58410358720, 10)
             # 2012-08-14: 26070600504 (amd64/Linux)
             # 2012-08-29: 26353100288 (amd64/Linux, new CG)
             # 2012-09-18: 26882813032 (amd64/Linux)
@@ -174,6 +176,7 @@ test('haddock.compiler',
             # 2017-06-06: 55990521024 (amd64/Linux) Don't pass on -dcore-lint in Haddock.mk
             # 2017-07-12: 51592019560 (amd64/Linux) Use getNameToInstancesIndex
             # 2018-04-08: 91115212032 (amd64/Linux) Trees that grow
+            # 2018-04-10: 58410358720 (amd64/Linux) Trees that grow (HsBinds, Data instances)
 
           ,(platform('i386-unknown-mingw32'),   367546388, 10)
             # 2012-10-30:                     13773051312 (x86/Windows)
index 0596926..5e96f35 100644 (file)
@@ -284,7 +284,9 @@ boundThings modname lbinding =
     PatBind { pat_lhs = lhs } -> patThings lhs []
     VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)]
     AbsBinds { }    -> [] -- nothing interesting in a type abstraction
-    PatSynBind PSB{ psb_id = id } -> [thing id]
+    PatSynBind _ PSB{ psb_id = id } -> [thing id]
+    PatSynBind _ (XPatSynBind _) -> []
+    XHsBindsLR _    -> []
   where thing = foundOfLName modname
         patThings lpat tl =
           let loc = startOfLocated lpat
index c84939c..a8ca2ae 160000 (submodule)
@@ -1 +1 @@
-Subproject commit c84939c8428a9e9ae0753e75ca6b48fcbbc1ecd6
+Subproject commit a8ca2ae8737d29145fe57a7709e59be8cb7a00dc