Restore Trees That Grow reverted commits
authorAlan Zimmerman <alan.zimm@gmail.com>
Sun, 1 Apr 2018 19:33:53 +0000 (21:33 +0200)
committerAlan Zimmerman <alan.zimm@gmail.com>
Mon, 9 Apr 2018 19:29:05 +0000 (21:29 +0200)
The following commits were reverted prior to the release of GHC 8.4.1,
because the time to derive Data instances was too long [1].

 438dd1cbba13d35f3452b4dcef3f94ce9a216905 Phab:D4147
 e3ec2e7ae94524ebd111963faf34b84d942265b4 Phab:D4177
 47ad6578ea460999b53eb4293c3a3b3017a56d65 Phab:D4186

The work is continuing, as the minimum bootstrap compiler is now
GHC 8.2.1, and this allows Plan B[2] for instances to be used.  This
will land in a following commit.

Updates Haddock submodule

[1] https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/Instances
[2] https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/Instances#PLANB

69 files changed:
compiler/deSugar/Check.hs
compiler/deSugar/Coverage.hs
compiler/deSugar/DsArrows.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsGRHSs.hs
compiler/deSugar/DsListComp.hs
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsUtils.hs
compiler/deSugar/Match.hs
compiler/deSugar/MatchLit.hs
compiler/deSugar/PmExpr.hs
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/HsLit.hs
compiler/hsSyn/HsPat.hs
compiler/hsSyn/HsPat.hs-boot
compiler/hsSyn/HsSyn.hs
compiler/hsSyn/HsTypes.hs
compiler/hsSyn/HsUtils.hs
compiler/hsSyn/PlaceHolder.hs
compiler/main/HscStats.hs
compiler/main/InteractiveEval.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/rename/RnBinds.hs
compiler/rename/RnEnv.hs
compiler/rename/RnExpr.hs
compiler/rename/RnFixity.hs
compiler/rename/RnNames.hs
compiler/rename/RnPat.hs
compiler/rename/RnSource.hs
compiler/rename/RnSplice.hs
compiler/rename/RnSplice.hs-boot
compiler/rename/RnTypes.hs
compiler/typecheck/Inst.hs
compiler/typecheck/TcArrows.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcDeriv.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcGenDeriv.hs
compiler/typecheck/TcGenFunctor.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcMatches.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcTyDecls.hs
ghc/GHCi/UI.hs
ghc/GHCi/UI/Info.hs
testsuite/tests/ghc-api/annotations/parseTree.hs
testsuite/tests/ghc-api/annotations/stringSource.hs
testsuite/tests/ghc-api/annotations/t11430.hs
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
testsuite/tests/parser/should_compile/T14189.stderr
testsuite/tests/perf/haddock/all.T
testsuite/tests/quasiquotation/T7918.hs
utils/ghctags/Main.hs
utils/haddock

index 22af2fb..6372967 100644 (file)
@@ -690,12 +690,12 @@ truePattern = nullaryConPattern (RealDataCon trueDataCon)
 -- | A fake guard pattern (True <- _) used to represent cases we cannot handle
 fake_pat :: Pattern
 fake_pat = PmGrd { pm_grd_pv   = [truePattern]
-                 , pm_grd_expr = PmExprOther EWildPat }
+                 , pm_grd_expr = PmExprOther (EWildPat noExt) }
 {-# INLINE fake_pat #-}
 
 -- | Check whether a guard pattern is generated by the checker (unhandled)
 isFakeGuard :: [Pattern] -> PmExpr -> Bool
-isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther EWildPat)
+isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther (EWildPat _))
   | c == trueDataCon = True
   | otherwise        = False
 isFakeGuard _pats _e = False
@@ -738,25 +738,25 @@ mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit }
 
 translatePat :: FamInstEnvs -> Pat GhcTc -> DsM PatVec
 translatePat fam_insts pat = case pat of
-  WildPat ty  -> mkPmVars [ty]
-  VarPat  id  -> return [PmVar (unLoc id)]
-  ParPat    -> translatePat fam_insts (unLoc p)
-  LazyPat _   -> mkPmVars [hsPatType pat] -- like a variable
+  WildPat  ty  -> mkPmVars [ty]
+  VarPat _ id  -> return [PmVar (unLoc id)]
+  ParPat _ p   -> translatePat fam_insts (unLoc p)
+  LazyPat _ _  -> mkPmVars [hsPatType pat] -- like a variable
 
   -- ignore strictness annotations for now
-  BangPat   -> translatePat fam_insts (unLoc p)
+  BangPat _ p  -> translatePat fam_insts (unLoc p)
 
-  AsPat lid p -> do
+  AsPat lid p -> do
      -- Note [Translating As Patterns]
     ps <- translatePat fam_insts (unLoc p)
     let [e] = map vaToPmExpr (coercePatVec ps)
         g   = PmGrd [PmVar (unLoc lid)] e
     return (ps ++ [g])
 
-  SigPatOut p _ty -> translatePat fam_insts (unLoc p)
+  SigPat _ty p -> translatePat fam_insts (unLoc p)
 
   -- See Note [Translate CoPats]
-  CoPat wrapper p ty
+  CoPat wrapper p ty
     | isIdHsWrapper wrapper                   -> translatePat fam_insts p
     | WpCast co <-  wrapper, isReflexiveCo co -> translatePat fam_insts p
     | otherwise -> do
@@ -766,26 +766,26 @@ translatePat fam_insts pat = case pat of
         return [xp,g]
 
   -- (n + k)  ===>   x (True <- x >= k) (n <- x-k)
-  NPlusKPat (L _ _n) _k1 _k2 _ge _minus ty -> mkCanFailPmPat ty
+  NPlusKPat ty (L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty
 
   -- (fun -> pat)   ===>   x (pat <- fun x)
-  ViewPat lexpr lpat arg_ty -> do
+  ViewPat arg_ty lexpr lpat -> do
     ps <- translatePat fam_insts (unLoc lpat)
     -- See Note [Guards and Approximation]
     case all cantFailPattern ps of
       True  -> do
         (xp,xe) <- mkPmId2Forms arg_ty
-        let g = mkGuard ps (HsApp lexpr xe)
+        let g = mkGuard ps (HsApp noExt lexpr xe)
         return [xp,g]
       False -> mkCanFailPmPat arg_ty
 
   -- list
-  ListPat ps ty Nothing -> do
+  ListPat ps ty Nothing -> do
     foldr (mkListPatVec ty) [nilPattern ty]
       <$> translatePatVec fam_insts (map unLoc ps)
 
   -- overloaded list
-  ListPat lpats elem_ty (Just (pat_ty, _to_list))
+  ListPat lpats elem_ty (Just (pat_ty, _to_list))
     | Just e_ty <- splitListTyConApp_maybe pat_ty
     , (_, norm_elem_ty) <- normaliseType fam_insts Nominal elem_ty
          -- elem_ty is frequently something like
@@ -794,7 +794,7 @@ translatePat fam_insts pat = case pat of
         -- We have to ensure that the element types are exactly the same.
         -- Otherwise, one may give an instance IsList [Int] (more specific than
         -- the default IsList [a]) with a different implementation for `toList'
-        translatePat fam_insts (ListPat lpats e_ty Nothing)
+        translatePat fam_insts (ListPat lpats e_ty Nothing)
       -- See Note [Guards and Approximation]
     | otherwise -> mkCanFailPmPat pat_ty
 
@@ -814,26 +814,27 @@ translatePat fam_insts pat = case pat of
                       , pm_con_dicts   = dicts
                       , pm_con_args    = args }]
 
-  NPat (L _ ol) mb_neg _eq ty -> translateNPat fam_insts ol mb_neg ty
+  NPat ty (L _ ol) mb_neg _eq -> translateNPat fam_insts ol mb_neg ty
 
-  LitPat lit
+  LitPat lit
       -- If it is a string then convert it to a list of characters
     | HsString src s <- lit ->
         foldr (mkListPatVec charTy) [nilPattern charTy] <$>
-          translatePatVec fam_insts (map (LitPat . HsChar src) (unpackFS s))
+          translatePatVec fam_insts
+                            (map (LitPat noExt  . HsChar src) (unpackFS s))
     | otherwise -> return [mkLitPattern lit]
 
-  PArrPat ps ty -> do
+  PArrPat ty ps -> do
     tidy_ps <- translatePatVec fam_insts (map unLoc ps)
     let fake_con = RealDataCon (parrFakeCon (length ps))
     return [vanillaConPattern fake_con [ty] (concat tidy_ps)]
 
-  TuplePat ps boxity tys -> do
+  TuplePat tys ps boxity -> do
     tidy_ps <- translatePatVec fam_insts (map unLoc ps)
     let tuple_con = RealDataCon (tupleDataCon boxity (length ps))
     return [vanillaConPattern tuple_con tys (concat tidy_ps)]
 
-  SumPat p alt arity ty -> do
+  SumPat ty p alt arity -> do
     tidy_p <- translatePat fam_insts (unLoc p)
     let sum_con = RealDataCon (sumDataCon alt arity)
     return [vanillaConPattern sum_con ty tidy_p]
@@ -842,23 +843,23 @@ translatePat fam_insts pat = case pat of
   -- Not supposed to happen
   ConPatIn  {} -> panic "Check.translatePat: ConPatIn"
   SplicePat {} -> panic "Check.translatePat: SplicePat"
-  SigPatIn  {} -> panic "Check.translatePat: SigPatIn"
+  XPat      {} -> panic "Check.translatePat: XPat"
 
 -- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs)
 translateNPat :: FamInstEnvs
               -> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> Type
               -> DsM PatVec
-translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty
+translateNPat fam_insts (OverLit (OverLitTc False ty) val _ ) mb_neg outer_ty
   | not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg
-  = translatePat fam_insts (LitPat (HsString src s))
+  = translatePat fam_insts (LitPat noExt (HsString src s))
   | not type_change, isIntTy    ty, HsIntegral i <- val
   = translatePat fam_insts
-                 (LitPat $ case mb_neg of
-                             Nothing -> HsInt def i
-                             Just _  -> HsInt def (negateIntegralLit i))
+                 (LitPat noExt $ case mb_neg of
+                             Nothing -> HsInt noExt i
+                             Just _  -> HsInt noExt (negateIntegralLit i))
   | not type_change, isWordTy   ty, HsIntegral i <- val
   = translatePat fam_insts
-                 (LitPat $ case mb_neg of
+                 (LitPat noExt $ case mb_neg of
                              Nothing -> HsWordPrim (il_text i) (il_value i)
                              Just _  -> let ni = negateIntegralLit i in
                                         HsWordPrim (il_text ni) (il_value ni))
@@ -1231,7 +1232,7 @@ mkPmId ty = getUniqueM >>= \unique ->
 mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc)
 mkPmId2Forms ty = do
   x <- mkPmId ty
-  return (PmVar x, noLoc (HsVar (noLoc x)))
+  return (PmVar x, noLoc (HsVar noExt (noLoc x)))
 
 -- ----------------------------------------------------------------------------
 -- * Converting between Value Abstractions, Patterns and PmExpr
index b353420..1f84114 100644 (file)
@@ -451,15 +451,15 @@ addTickLHsExprNever (L pos e0) = do
 -- general heuristic: expressions which do not denote values are good
 -- break points
 isGoodBreakExpr :: HsExpr GhcTc -> Bool
-isGoodBreakExpr (HsApp {})        = True
-isGoodBreakExpr (HsAppTypeOut {}) = True
-isGoodBreakExpr (OpApp {})        = True
-isGoodBreakExpr _other            = False
+isGoodBreakExpr (HsApp {})     = True
+isGoodBreakExpr (HsAppType {}) = True
+isGoodBreakExpr (OpApp {})     = True
+isGoodBreakExpr _other         = False
 
 isCallSite :: HsExpr GhcTc -> Bool
-isCallSite HsApp{}        = True
-isCallSite HsAppTypeOut{} = True
-isCallSite OpApp{}        = True
+isCallSite HsApp{}     = True
+isCallSite HsAppType{} = True
+isCallSite OpApp{}     = True
 isCallSite _ = False
 
 addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
@@ -481,55 +481,58 @@ addBinTickLHsExpr boxLabel (L pos e0)
 -- in the addTickLHsExpr family of functions.)
 
 addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
-addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e
-addTickHsExpr (HsUnboundVar {})  = panic "addTickHsExpr.HsUnboundVar"
-addTickHsExpr e@(HsConLikeOut con)
+addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e
+addTickHsExpr (HsUnboundVar {})    = panic "addTickHsExpr.HsUnboundVar"
+addTickHsExpr e@(HsConLikeOut con)
   | Just id <- conLikeWrapId_maybe con = do freeVar id; return e
-addTickHsExpr e@(HsIPVar _)      = return e
-addTickHsExpr e@(HsOverLit _)    = return e
-addTickHsExpr e@(HsOverLabel{})  = return e
-addTickHsExpr e@(HsLit _)        = return e
-addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
-addTickHsExpr (HsLamCase mgs)    = liftM HsLamCase (addTickMatchGroup True mgs)
-addTickHsExpr (HsApp e1 e2)      = liftM2 HsApp (addTickLHsExprNever e1)
-                                                (addTickLHsExpr      e2)
-addTickHsExpr (HsAppTypeOut e ty) = liftM2 HsAppTypeOut (addTickLHsExprNever e)
-                                                        (return ty)
-
-addTickHsExpr (OpApp e1 e2 fix e3) =
+addTickHsExpr e@(HsIPVar {})       = return e
+addTickHsExpr e@(HsOverLit {})     = return e
+addTickHsExpr e@(HsOverLabel{})    = return e
+addTickHsExpr e@(HsLit {})         = return e
+addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x)
+                                           (addTickMatchGroup True matchgroup)
+addTickHsExpr (HsLamCase x mgs)    = liftM (HsLamCase x)
+                                           (addTickMatchGroup True mgs)
+addTickHsExpr (HsApp x e1 e2)      = liftM2 (HsApp x) (addTickLHsExprNever e1)
+                                                      (addTickLHsExpr      e2)
+addTickHsExpr (HsAppType ty e)   = liftM2 HsAppType (return ty)
+                                                    (addTickLHsExprNever e)
+
+
+addTickHsExpr (OpApp fix e1 e2 e3) =
         liftM4 OpApp
+                (return fix)
                 (addTickLHsExpr e1)
                 (addTickLHsExprNever e2)
-                (return fix)
                 (addTickLHsExpr e3)
-addTickHsExpr (NegApp e neg) =
-        liftM2 NegApp
+addTickHsExpr (NegApp e neg) =
+        liftM2 (NegApp x)
                 (addTickLHsExpr e)
                 (addTickSyntaxExpr hpcSrcSpan neg)
-addTickHsExpr (HsPar e) =
-        liftM HsPar (addTickLHsExprEvalInner e)
-addTickHsExpr (SectionL e1 e2) =
-        liftM2 SectionL
+addTickHsExpr (HsPar e) =
+        liftM (HsPar x) (addTickLHsExprEvalInner e)
+addTickHsExpr (SectionL e1 e2) =
+        liftM2 (SectionL x)
                 (addTickLHsExpr e1)
                 (addTickLHsExprNever e2)
-addTickHsExpr (SectionR e1 e2) =
-        liftM2 SectionR
+addTickHsExpr (SectionR e1 e2) =
+        liftM2 (SectionR x)
                 (addTickLHsExprNever e1)
                 (addTickLHsExpr e2)
-addTickHsExpr (ExplicitTuple es boxity) =
-        liftM2 ExplicitTuple
+addTickHsExpr (ExplicitTuple es boxity) =
+        liftM2 (ExplicitTuple x)
                 (mapM addTickTupArg es)
                 (return boxity)
-addTickHsExpr (ExplicitSum tag arity e ty) = do
+addTickHsExpr (ExplicitSum ty tag arity e) = do
         e' <- addTickLHsExpr e
-        return (ExplicitSum tag arity e' ty)
-addTickHsExpr (HsCase e mgs) =
-        liftM2 HsCase
+        return (ExplicitSum ty tag arity e')
+addTickHsExpr (HsCase e mgs) =
+        liftM2 (HsCase x)
                 (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
                                    -- be evaluated.
                 (addTickMatchGroup False mgs)
-addTickHsExpr (HsIf cnd e1 e2 e3) =
-        liftM3 (HsIf cnd)
+addTickHsExpr (HsIf cnd e1 e2 e3) =
+        liftM3 (HsIf cnd)
                 (addBinTickLHsExpr (BinBox CondBinBox) e1)
                 (addTickLHsExprOptAlt True e2)
                 (addTickLHsExprOptAlt True e3)
@@ -537,14 +540,14 @@ addTickHsExpr (HsMultiIf ty alts)
   = do { let isOneOfMany = case alts of [_] -> False; _ -> True
        ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
        ; return $ HsMultiIf ty alts' }
-addTickHsExpr (HsLet (L l binds) e) =
+addTickHsExpr (HsLet (L l binds) e) =
         bindLocals (collectLocalBinders binds) $
-          liftM2 (HsLet . L l)
+          liftM2 (HsLet . L l)
                   (addTickHsLocalBinds binds) -- to think about: !patterns.
                   (addTickLHsExprLetBody e)
-addTickHsExpr (HsDo cxt (L l stmts) srcloc)
+addTickHsExpr (HsDo srcloc cxt (L l stmts))
   = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
-       ; return (HsDo cxt (L l stmts') srcloc) }
+       ; return (HsDo srcloc cxt (L l stmts')) }
   where
         forQual = case cxt of
                     ListComp -> Just $ BinBox QualBinBox
@@ -574,12 +577,12 @@ addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
        ; flds' <- mapM addTickHsRecField flds
        ; return (expr { rupd_expr = e', rupd_flds = flds' }) }
 
-addTickHsExpr (ExprWithTySig e ty) =
+addTickHsExpr (ExprWithTySig ty e) =
         liftM2 ExprWithTySig
-                (addTickLHsExprNever e) -- No need to tick the inner expression
-                                    -- for expressions with signatures
                 (return ty)
-addTickHsExpr (ArithSeq  ty wit arith_seq) =
+                (addTickLHsExprNever e) -- No need to tick the inner expression
+                                        -- for expressions with signatures
+addTickHsExpr (ArithSeq ty wit arith_seq) =
         liftM3 ArithSeq
                 (return ty)
                 (addTickWit wit)
@@ -589,26 +592,26 @@ addTickHsExpr (ArithSeq  ty wit arith_seq) =
                                              return (Just fl')
 
 -- We might encounter existing ticks (multiple Coverage passes)
-addTickHsExpr (HsTick t e) =
-        liftM (HsTick t) (addTickLHsExprNever e)
-addTickHsExpr (HsBinTick t0 t1 e) =
-        liftM (HsBinTick t0 t1) (addTickLHsExprNever e)
+addTickHsExpr (HsTick t e) =
+        liftM (HsTick t) (addTickLHsExprNever e)
+addTickHsExpr (HsBinTick t0 t1 e) =
+        liftM (HsBinTick t0 t1) (addTickLHsExprNever e)
 
-addTickHsExpr (HsTickPragma _ _ _ (L pos e0)) = do
+addTickHsExpr (HsTickPragma _ _ _ (L pos e0)) = do
     e2 <- allocTickBox (ExpBox False) False False pos $
                 addTickHsExpr e0
     return $ unLoc e2
-addTickHsExpr (PArrSeq   ty arith_seq) =
+addTickHsExpr (PArrSeq ty arith_seq) =
         liftM2 PArrSeq
                 (return ty)
                 (addTickArithSeqInfo arith_seq)
-addTickHsExpr (HsSCC src nm e) =
-        liftM3 HsSCC
+addTickHsExpr (HsSCC src nm e) =
+        liftM3 (HsSCC x)
                 (return src)
                 (return nm)
                 (addTickLHsExpr e)
-addTickHsExpr (HsCoreAnn src nm e) =
-        liftM3 HsCoreAnn
+addTickHsExpr (HsCoreAnn src nm e) =
+        liftM3 (HsCoreAnn x)
                 (return src)
                 (return nm)
                 (addTickLHsExpr e)
@@ -616,27 +619,23 @@ addTickHsExpr e@(HsBracket     {})   = return e
 addTickHsExpr e@(HsTcBracketOut  {}) = return e
 addTickHsExpr e@(HsRnBracketOut  {}) = return e
 addTickHsExpr e@(HsSpliceE  {})      = return e
-addTickHsExpr (HsProc pat cmdtop) =
-        liftM2 HsProc
+addTickHsExpr (HsProc pat cmdtop) =
+        liftM2 (HsProc x)
                 (addTickLPat pat)
                 (liftL (addTickHsCmdTop) cmdtop)
-addTickHsExpr (HsWrap w e) =
-        liftM2 HsWrap
+addTickHsExpr (HsWrap w e) =
+        liftM2 (HsWrap x)
                 (return w)
                 (addTickHsExpr e)       -- Explicitly no tick on inside
 
-addTickHsExpr (ExprWithTySigOut e ty) =
-        liftM2 ExprWithTySigOut
-               (addTickLHsExprNever e) -- No need to tick the inner expression
-               (return ty)             -- for expressions with signatures
-
 -- Others should never happen in expression content.
 addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
 
 addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
-addTickTupArg (L l (Present e))  = do { e' <- addTickLHsExpr e
-                                      ; return (L l (Present e')) }
+addTickTupArg (L l (Present e))  = do { e' <- addTickLHsExpr e
+                                      ; return (L l (Present e')) }
 addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
+addTickTupArg (L _ (XTupArg _)) = panic "addTickTupArg"
 
 addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
                   -> TM (MatchGroup GhcTc (LHsExpr GhcTc))
@@ -772,11 +771,12 @@ addTickApplicativeArg isGuard (op, arg) =
 
 addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
                       -> TM (ParStmtBlock GhcTc GhcTc)
-addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
-    liftM3 ParStmtBlock
+addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
+    liftM3 (ParStmtBlock x)
         (addTickLStmts isGuard stmts)
         (return ids)
         (addTickSyntaxExpr hpcSrcSpan returnExpr)
+addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders"
 
 addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
 addTickHsLocalBinds (HsValBinds binds) =
@@ -787,15 +787,17 @@ addTickHsLocalBinds (HsIPBinds binds)  =
                 (addTickHsIPBinds binds)
 addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds
 
-addTickHsValBinds :: HsValBindsLR GhcTc a -> TM (HsValBindsLR GhcTc b)
-addTickHsValBinds (ValBindsOut binds sigs) =
-        liftM2 ValBindsOut
+addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
+                  -> TM (HsValBindsLR GhcTc (GhcPass b))
+addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do
+        b <- liftM2 NValBinds
                 (mapM (\ (rec,binds') ->
                                 liftM2 (,)
                                         (return rec)
                                         (addTickLHsBinds binds'))
                         binds)
                 (return sigs)
+        return $ XValBindsLR b
 addTickHsValBinds _ = panic "addTickHsValBinds"
 
 addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
@@ -820,12 +822,11 @@ addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
 addTickLPat pat = return pat
 
 addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
-addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
-        liftM4 HsCmdTop
+addTickHsCmdTop (HsCmdTop x cmd) =
+        liftM2 HsCmdTop
+                (return x)
                 (addTickLHsCmd cmd)
-                (return tys)
-                (return ty)
-                (return syntaxtable)
+addTickHsCmdTop (XCmdTop{}) = panic "addTickHsCmdTop"
 
 addTickLHsCmd ::  LHsCmd GhcTc -> TM (LHsCmd GhcTc)
 addTickLHsCmd (L pos c0) = do
@@ -833,10 +834,10 @@ addTickLHsCmd (L pos c0) = do
         return $ L pos c1
 
 addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
-addTickHsCmd (HsCmdLam matchgroup) =
-        liftM HsCmdLam (addTickCmdMatchGroup matchgroup)
-addTickHsCmd (HsCmdApp c e) =
-        liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e)
+addTickHsCmd (HsCmdLam matchgroup) =
+        liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup)
+addTickHsCmd (HsCmdApp c e) =
+        liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e)
 {-
 addTickHsCmd (OpApp e1 c2 fix c3) =
         liftM4 OpApp
@@ -845,41 +846,43 @@ addTickHsCmd (OpApp e1 c2 fix c3) =
                 (return fix)
                 (addTickLHsCmd c3)
 -}
-addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)
-addTickHsCmd (HsCmdCase e mgs) =
-        liftM2 HsCmdCase
+addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e)
+addTickHsCmd (HsCmdCase e mgs) =
+        liftM2 (HsCmdCase x)
                 (addTickLHsExpr e)
                 (addTickCmdMatchGroup mgs)
-addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
-        liftM3 (HsCmdIf cnd)
+addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
+        liftM3 (HsCmdIf cnd)
                 (addBinTickLHsExpr (BinBox CondBinBox) e1)
                 (addTickLHsCmd c2)
                 (addTickLHsCmd c3)
-addTickHsCmd (HsCmdLet (L l binds) c) =
+addTickHsCmd (HsCmdLet (L l binds) c) =
         bindLocals (collectLocalBinders binds) $
-          liftM2 (HsCmdLet . L l)
+          liftM2 (HsCmdLet . L l)
                    (addTickHsLocalBinds binds) -- to think about: !patterns.
                    (addTickLHsCmd c)
-addTickHsCmd (HsCmdDo (L l stmts) srcloc)
+addTickHsCmd (HsCmdDo srcloc (L l stmts))
   = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
-       ; return (HsCmdDo (L l stmts') srcloc) }
+       ; return (HsCmdDo srcloc (L l stmts')) }
 
-addTickHsCmd (HsCmdArrApp   e1 e2 ty1 arr_ty lr) =
+addTickHsCmd (HsCmdArrApp  arr_ty e1 e2 ty1 lr) =
         liftM5 HsCmdArrApp
+               (return arr_ty)
                (addTickLHsExpr e1)
                (addTickLHsExpr e2)
                (return ty1)
-               (return arr_ty)
                (return lr)
-addTickHsCmd (HsCmdArrForm e f fix cmdtop) =
-        liftM4 HsCmdArrForm
+addTickHsCmd (HsCmdArrForm e f fix cmdtop) =
+        liftM4 (HsCmdArrForm x)
                (addTickLHsExpr e)
                (return f)
                (return fix)
                (mapM (liftL (addTickHsCmdTop)) cmdtop)
 
-addTickHsCmd (HsCmdWrap w cmd)
-  = liftM2 HsCmdWrap (return w) (addTickHsCmd cmd)
+addTickHsCmd (HsCmdWrap x w cmd)
+  = liftM2 (HsCmdWrap x) (return w) (addTickHsCmd cmd)
+
+addTickHsCmd e@(XCmd {})  = pprPanic "addTickHsCmd" (ppr e)
 
 -- Others should never happen in a command context.
 --addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)
@@ -1160,7 +1163,7 @@ allocTickBox boxLabel countEntries topOnly pos m =
     (fvs, e) <- getFreeVars m
     env <- getEnv
     tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
-    return (L pos (HsTick tickish (L pos e)))
+    return (L pos (HsTick noExt tickish (L pos e)))
   ) (do
     e <- m
     return (L pos e)
@@ -1247,13 +1250,14 @@ mkBinTickBoxHpc boxLabel pos e =
       c = tickBoxCount st
       mes = mixEntries st
   in
-             ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) e
-           -- notice that F and T are reversed,
-           -- because we are building the list in
-           -- reverse...
-             , noFVs
-             , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
-             )
+     ( L pos $ HsTick noExt (HpcTick (this_mod env) c)
+          $ L pos $ HsBinTick noExt (c+1) (c+2) e
+   -- notice that F and T are reversed,
+   -- because we are building the list in
+   -- reverse...
+     , noFVs
+     , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
+     )
 
 mkHpcPos :: SrcSpan -> HpcPos
 mkHpcPos pos@(RealSrcSpan s)
index 24d7d8a..61dc7c5 100644 (file)
@@ -313,7 +313,7 @@ dsProcExpr
         :: LPat GhcTc
         -> LHsCmdTop GhcTc
         -> DsM CoreExpr
-dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do
+dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
     (meth_binds, meth_ids) <- mkCmdEnv ids
     let locals = mkVarSet (collectPatBinders pat)
     (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals unitTy cmd_ty cmd
@@ -328,6 +328,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do
                     (Lam var match_code)
                     core_cmd
     return (mkLets meth_binds proc_code)
+dsProcExpr _ (L _ XCmdTop{}) = panic "dsProcExpr"
 
 {-
 Translation of a command judgement of the form
@@ -363,7 +364,7 @@ dsCmd   :: DsCmdEnv             -- arrow combinators
 --              ---> premap (\ ((xs), _stk) -> arg) fun
 
 dsCmd ids local_vars stack_ty res_ty
-        (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _)
+        (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _)
         env_ids = do
     let
         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
@@ -388,7 +389,7 @@ dsCmd ids local_vars stack_ty res_ty
 --              ---> premap (\ ((xs), _stk) -> (fun, arg)) app
 
 dsCmd ids local_vars stack_ty res_ty
-        (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _)
+        (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _)
         env_ids = do
     let
         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
@@ -416,7 +417,7 @@ dsCmd ids local_vars stack_ty res_ty
 --
 --              ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd
 
-dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
+dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
     core_arg <- dsLExpr arg
     let
         arg_ty = exprType core_arg
@@ -449,7 +450,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
 --              ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
 
 dsCmd ids local_vars stack_ty res_ty
-        (HsCmdLam (MG { mg_alts = L _ [L _ (Match { m_pats  = pats
+        (HsCmdLam (MG { mg_alts = L _ [L _ (Match { m_pats  = pats
                                                   , m_grhss = GRHSs [L _ (GRHS [] body)] _ })] }))
         env_ids = do
     let pat_vars = mkVarSet (collectPatsBinders pats)
@@ -479,7 +480,7 @@ dsCmd ids local_vars stack_ty res_ty
     return (do_premap ids in_ty in_ty' res_ty select_code core_body,
             free_vars `udfmMinusUFM` getUniqSet pat_vars)
 
-dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids
+dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids
   = dsLCmd ids local_vars stack_ty res_ty cmd env_ids
 
 -- D, xs |- e :: Bool
@@ -492,7 +493,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids
 --                       if e then Left ((xs1),stk) else Right ((xs2),stk))
 --                     (c1 ||| c2)
 
-dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
+dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
         env_ids = do
     core_cond <- dsLExpr cond
     (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack_ty res_ty then_cmd
@@ -553,8 +554,8 @@ case bodies, containing the following fields:
 -}
 
 dsCmd ids local_vars stack_ty res_ty
-      (HsCmdCase exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys
-                         , mg_origin = origin }))
+      (HsCmdCase exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys
+                           , mg_origin = origin }))
       env_ids = do
     stack_id <- newSysLocalDs stack_ty
 
@@ -575,10 +576,12 @@ dsCmd ids local_vars stack_ty res_ty
     left_con <- dsLookupDataCon leftDataConName
     right_con <- dsLookupDataCon rightDataConName
     let
-        left_id  = HsConLikeOut (RealDataCon left_con)
-        right_id = HsConLikeOut (RealDataCon right_con)
-        left_expr  ty1 ty2 e = noLoc $ HsApp (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
-        right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
+        left_id  = HsConLikeOut noExt (RealDataCon left_con)
+        right_id = HsConLikeOut noExt (RealDataCon right_con)
+        left_expr  ty1 ty2 e = noLoc $ HsApp noExt
+                           (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
+        right_expr ty1 ty2 e = noLoc $ HsApp noExt
+                           (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
 
         -- Prefix each tuple with a distinct series of Left's and Right's,
         -- in a balanced way, keeping track of the types.
@@ -597,9 +600,10 @@ dsCmd ids local_vars stack_ty res_ty
         (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
         in_ty = envStackType env_ids stack_ty
 
-    core_body <- dsExpr (HsCase exp (MG { mg_alts = L l matches'
-                                        , mg_arg_tys = arg_tys
-                                        , mg_res_ty = sum_ty, mg_origin = origin }))
+    core_body <- dsExpr (HsCase noExt exp
+                         (MG { mg_alts = L l matches'
+                             , mg_arg_tys = arg_tys
+                             , mg_res_ty = sum_ty, mg_origin = origin }))
         -- Note that we replace the HsCase result type by sum_ty,
         -- which is the type of matches'
 
@@ -613,7 +617,8 @@ dsCmd ids local_vars stack_ty res_ty
 --
 --              ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
 
-dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids = do
+dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body)
+                                                                    env_ids = do
     let
         defined_vars = mkVarSet (collectLocalBinders binds)
         local_vars' = defined_vars `unionVarSet` local_vars
@@ -638,7 +643,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids
 --
 --              ---> premap (\ (env,stk) -> env) c
 
-dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) env_ids = do
+dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty (L loc stmts))
+                                                                   env_ids = do
     putSrcSpanDs loc $
       dsNoLevPoly stmts_ty
         (text "In the do-command:" <+> ppr do_block)
@@ -658,14 +664,14 @@ dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) e
 -- -----------------------------------
 -- D; xs |-a (|e c1 ... cn|) :: stk --> t       ---> e [t_xs] c1 ... cn
 
-dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ _ args) env_ids = do
+dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do
     let env_ty = mkBigCoreVarTupTy env_ids
     core_op <- dsLExpr op
     (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
     return (mkApps (App core_op (Type env_ty)) core_args,
             unionDVarSets fv_sets)
 
-dsCmd ids local_vars stack_ty res_ty (HsCmdWrap wrap cmd) env_ids = do
+dsCmd ids local_vars stack_ty res_ty (HsCmdWrap wrap cmd) env_ids = do
     (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
     core_wrap <- dsHsWrapper wrap
     return (core_wrap core_cmd, env_ids')
@@ -682,7 +688,8 @@ dsTrimCmdArg
         -> LHsCmdTop GhcTc       -- command argument to desugar
         -> DsM (CoreExpr,       -- desugared expression
                 DIdSet)         -- subset of local vars that occur free
-dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do
+dsTrimCmdArg local_vars env_ids
+                       (L _ (HsCmdTop (CmdTopTc stack_ty cmd_ty ids) cmd )) = do
     (meth_binds, meth_ids) <- mkCmdEnv ids
     (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd
     stack_id <- newSysLocalDs stack_ty
@@ -693,6 +700,7 @@ dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do
         arg_code = if env_ids' == env_ids then core_cmd else
                 do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
     return (mkLets meth_binds arg_code, free_vars)
+dsTrimCmdArg _ _ (L _ XCmdTop{}) = panic "dsTrimCmdArg"
 
 -- Given D; xs |-a c : stk --> t, builds c with xs fed back.
 -- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))
@@ -1187,31 +1195,31 @@ collectl :: LPat GhcTc -> [Id] -> [Id]
 collectl (L _ pat) bndrs
   = go pat
   where
-    go (VarPat (L _ var))         = var : bndrs
+    go (VarPat _ (L _ var))       = var : bndrs
     go (WildPat _)                = bndrs
-    go (LazyPat pat)              = collectl pat bndrs
-    go (BangPat pat)              = collectl pat bndrs
-    go (AsPat (L _ a) pat)        = a : collectl pat bndrs
-    go (ParPat  pat)              = collectl pat bndrs
+    go (LazyPat _ pat)            = collectl pat bndrs
+    go (BangPat _ pat)            = collectl pat bndrs
+    go (AsPat _ (L _ a) pat)      = a : collectl pat bndrs
+    go (ParPat _ pat)             = collectl pat bndrs
 
-    go (ListPat pats _ _)         = foldr collectl bndrs pats
-    go (PArrPat pats _)           = foldr collectl bndrs pats
-    go (TuplePat pats _ _)        = foldr collectl bndrs pats
-    go (SumPat pat _ _ _)         = collectl pat bndrs
+    go (ListPat _ pats _ _)       = foldr collectl bndrs pats
+    go (PArrPat _ pats)           = foldr collectl bndrs pats
+    go (TuplePat _ pats _)        = foldr collectl bndrs pats
+    go (SumPat _ pat _ _)         = collectl pat bndrs
 
     go (ConPatIn _ ps)            = foldr collectl bndrs (hsConPatArgs ps)
     go (ConPatOut {pat_args=ps, pat_binds=ds}) =
                                     collectEvBinders ds
                                     ++ foldr collectl bndrs (hsConPatArgs ps)
-    go (LitPat _)                 = bndrs
+    go (LitPat _ _)               = bndrs
     go (NPat {})                  = bndrs
-    go (NPlusKPat (L _ n) _ _ _ _ _) = n : bndrs
+    go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs
 
-    go (SigPatIn pat _)           = collectl pat bndrs
-    go (SigPatOut pat _)          = collectl pat bndrs
-    go (CoPat _ pat _)            = collectl (noLoc pat) bndrs
-    go (ViewPat _ pat _)          = collectl pat bndrs
+    go (SigPat _ pat)             = collectl pat bndrs
+    go (CoPat _ _ pat _)          = collectl (noLoc pat) bndrs
+    go (ViewPat _ _ pat)          = collectl pat bndrs
     go p@(SplicePat {})           = pprPanic "collectl/go" (ppr p)
+    go p@(XPat {})                = pprPanic "collectl/go" (ppr p)
 
 collectEvBinders :: TcEvBinds -> [Id]
 collectEvBinders (EvBinds bs)   = foldrBag add_ev_bndr [] bs
index 392bacc..0eb5c0e 100644 (file)
@@ -79,8 +79,9 @@ dsLocalBinds (L _ (HsIPBinds binds))    body = dsIPBinds  binds body
 -------------------------
 -- caller sets location
 dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
-dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
-dsValBinds (ValBindsIn {})       _    = panic "dsValBinds ValBindsIn"
+dsValBinds (XValBindsLR (NValBinds binds _)) body
+  = foldrM ds_val_bind body binds
+dsValBinds (ValBinds {})       _    = panic "dsValBinds ValBindsIn"
 
 -------------------------
 dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
@@ -251,17 +252,17 @@ dsExpr = ds_expr False
 ds_expr :: Bool   -- are we directly inside an HsWrap?
                   -- See Wrinkle in Note [Detecting forced eta expansion]
         -> HsExpr GhcTc -> DsM CoreExpr
-ds_expr _ (HsPar e)              = dsLExpr e
-ds_expr _ (ExprWithTySigOut e _) = dsLExpr e
-ds_expr w (HsVar (L _ var))      = dsHsVar w var
+ds_expr _ (HsPar _ e)            = dsLExpr e
+ds_expr _ (ExprWithTySig _ e)    = dsLExpr e
+ds_expr w (HsVar _ (L _ var))    = dsHsVar w var
 ds_expr _ (HsUnboundVar {})      = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
-ds_expr w (HsConLikeOut con)     = dsConLike w con
-ds_expr _ (HsIPVar _)            = panic "dsExpr: HsIPVar"
+ds_expr w (HsConLikeOut _ con)   = dsConLike w con
+ds_expr _ (HsIPVar {})           = panic "dsExpr: HsIPVar"
 ds_expr _ (HsOverLabel{})        = panic "dsExpr: HsOverLabel"
-ds_expr _ (HsLit lit)            = dsLit (convertLit lit)
-ds_expr _ (HsOverLit lit)        = dsOverLit lit
+ds_expr _ (HsLit _ lit)          = dsLit (convertLit lit)
+ds_expr _ (HsOverLit _ lit)      = dsOverLit lit
 
-ds_expr _ (HsWrap co_fn e)
+ds_expr _ (HsWrap co_fn e)
   = do { e' <- ds_expr True e    -- This is the one place where we recurse to
                                  -- ds_expr (passing True), rather than dsExpr
        ; wrap' <- dsHsWrapper co_fn
@@ -272,7 +273,7 @@ ds_expr _ (HsWrap co_fn e)
        ; warnAboutIdentities dflags e' wrapped_ty
        ; return wrapped_e }
 
-ds_expr _ (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral i })))
+ds_expr _ (NegApp _ (L loc (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
                   neg_expr)
   = do { expr' <- putSrcSpanDs loc $ do
           { dflags <- getDynFlags
@@ -281,27 +282,26 @@ ds_expr _ (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral i })))
           ; dsOverLit' dflags lit }
        ; dsSyntaxExpr neg_expr [expr'] }
 
-ds_expr _ (NegApp expr neg_expr)
+ds_expr _ (NegApp expr neg_expr)
   = do { expr' <- dsLExpr expr
        ; dsSyntaxExpr neg_expr [expr'] }
 
-ds_expr _ (HsLam a_Match)
+ds_expr _ (HsLam a_Match)
   = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
 
-ds_expr _ (HsLamCase matches)
+ds_expr _ (HsLamCase matches)
   = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
        ; return $ Lam discrim_var matching_code }
 
-ds_expr _ e@(HsApp fun arg)
+ds_expr _ e@(HsApp fun arg)
   = do { fun' <- dsLExpr fun
        ; dsWhenNoErrs (dsLExprNoLP arg)
                       (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
 
-ds_expr _ (HsAppTypeOut e _)
+ds_expr _ (HsAppType _ e)
     -- ignore type arguments here; they're in the wrappers instead at this point
   = dsLExpr e
 
-
 {-
 Note [Desugaring vars]
 ~~~~~~~~~~~~~~~~~~~~~~
@@ -341,19 +341,19 @@ If \tr{expr} is actually just a variable, say, then the simplifier
 will sort it out.
 -}
 
-ds_expr _ e@(OpApp e1 op _ e2)
+ds_expr _ e@(OpApp _ e1 op e2)
   = -- for the type of y, we need the type of op's 2nd argument
     do { op' <- dsLExpr op
        ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])
                       (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }
 
-ds_expr _ (SectionL expr op)       -- Desugar (e !) to ((!) e)
+ds_expr _ (SectionL expr op)       -- Desugar (e !) to ((!) e)
   = do { op' <- dsLExpr op
        ; dsWhenNoErrs (dsLExprNoLP expr)
                       (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }
 
 -- dsLExpr (SectionR op expr)   -- \ x -> op x expr
-ds_expr _ e@(SectionR op expr) = do
+ds_expr _ e@(SectionR op expr) = do
     core_op <- dsLExpr op
     -- for the type of x, we need the type of op's 2nd argument
     let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
@@ -364,31 +364,32 @@ ds_expr _ e@(SectionR op expr) = do
                                    Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e)
                                                           core_op [Var x_id, Var y_id]))
 
-ds_expr _ (ExplicitTuple tup_args boxity)
+ds_expr _ (ExplicitTuple tup_args boxity)
   = do { let go (lam_vars, args) (L _ (Missing ty))
                     -- For every missing expression, we need
                     -- another lambda in the desugaring.
                = do { lam_var <- newSysLocalDsNoLP ty
                     ; return (lam_var : lam_vars, Var lam_var : args) }
-             go (lam_vars, args) (L _ (Present expr))
+             go (lam_vars, args) (L _ (Present expr))
                     -- Expressions that are present don't generate
                     -- lambdas, just arguments.
                = do { core_expr <- dsLExprNoLP expr
                     ; return (lam_vars, core_expr : args) }
+             go _ (L _ (XTupArg {})) = panic "ds_expr"
 
        ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args))
                 -- The reverse is because foldM goes left-to-right
                       (\(lam_vars, args) -> mkCoreLams lam_vars $
                                             mkCoreTupBoxity boxity args) }
 
-ds_expr _ (ExplicitSum alt arity expr types)
+ds_expr _ (ExplicitSum types alt arity expr)
   = do { dsWhenNoErrs (dsLExprNoLP expr)
                       (\core_expr -> mkCoreConApps (sumDataCon alt arity)
                                      (map (Type . getRuntimeRep) types ++
                                       map Type types ++
                                       [core_expr]) ) }
 
-ds_expr _ (HsSCC _ cc expr@(L loc _)) = do
+ds_expr _ (HsSCC _ cc expr@(L loc _)) = do
     dflags <- getDynFlags
     if gopt Opt_SccProfilingOn dflags
       then do
@@ -400,31 +401,31 @@ ds_expr _ (HsSCC _ cc expr@(L loc _)) = do
                <$> dsLExpr expr
       else dsLExpr expr
 
-ds_expr _ (HsCoreAnn _ _ expr)
+ds_expr _ (HsCoreAnn _ _ expr)
   = dsLExpr expr
 
-ds_expr _ (HsCase discrim matches)
+ds_expr _ (HsCase discrim matches)
   = do { core_discrim <- dsLExpr discrim
        ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches
        ; return (bindNonRec discrim_var core_discrim matching_code) }
 
 -- Pepe: The binds are in scope in the body but NOT in the binding group
 --       This is to avoid silliness in breakpoints
-ds_expr _ (HsLet binds body) = do
+ds_expr _ (HsLet binds body) = do
     body' <- dsLExpr body
     dsLocalBinds binds body'
 
 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
 -- because the interpretation of `stmts' depends on what sort of thing it is.
 --
-ds_expr _ (HsDo ListComp     (L _ stmts) res_ty) = dsListComp stmts res_ty
-ds_expr _ (HsDo PArrComp     (L _ stmts) _)      = dsPArrComp (map unLoc stmts)
-ds_expr _ (HsDo DoExpr       (L _ stmts) _)      = dsDo stmts
-ds_expr _ (HsDo GhciStmtCtxt (L _ stmts) _)      = dsDo stmts
-ds_expr _ (HsDo MDoExpr      (L _ stmts) _)      = dsDo stmts
-ds_expr _ (HsDo MonadComp    (L _ stmts) _)      = dsMonadComp stmts
-
-ds_expr _ (HsIf mb_fun guard_expr then_expr else_expr)
+ds_expr _ (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty
+ds_expr _ (HsDo _ PArrComp      (L _ stmts)) = dsPArrComp (map unLoc stmts)
+ds_expr _ (HsDo _ DoExpr        (L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ GhciStmtCtxt  (L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ MDoExpr       (L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ MonadComp     (L _ stmts)) = dsMonadComp stmts
+
+ds_expr _ (HsIf mb_fun guard_expr then_expr else_expr)
   = do { pred <- dsLExpr guard_expr
        ; b1 <- dsLExpr then_expr
        ; b2 <- dsLExpr else_expr
@@ -458,7 +459,7 @@ ds_expr _ (ExplicitList elt_ty wit xs)
 -- We desugar [:x1, ..., xn:] as
 --   singletonP x1 +:+ ... +:+ singletonP xn
 --
-ds_expr _ (ExplicitPArr ty []) = do
+ds_expr _ (ExplicitPArr  ty []) = do
     emptyP <- dsDPHBuiltin emptyPVar
     return (Var emptyP `App` Type ty)
 ds_expr _ (ExplicitPArr ty xs) = do
@@ -540,8 +541,9 @@ We also handle @C{}@ as valid construction syntax for an unlabelled
 constructor @C@, setting all of @C@'s fields to bottom.
 -}
 
-ds_expr _ (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds
-                     , rcon_con_like = con_like })
+ds_expr _ (RecordCon { rcon_flds = rbinds
+                     , rcon_ext = RecordConTc { rcon_con_expr = con_expr
+                                              , rcon_con_like = con_like }})
   = do { con_expr' <- dsExpr con_expr
        ; let
              (arg_tys, _) = tcSplitFunTys (exprType con_expr')
@@ -600,9 +602,11 @@ So we need to cast (T a Int) to (T a b).  Sigh.
 -}
 
 ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
-                          , rupd_cons = cons_to_upd
-                          , rupd_in_tys = in_inst_tys, rupd_out_tys = out_inst_tys
-                          , rupd_wrap = dict_req_wrap } )
+                          , rupd_ext = RecordUpdTc
+                              { rupd_cons = cons_to_upd
+                              , rupd_in_tys = in_inst_tys
+                              , rupd_out_tys = out_inst_tys
+                              , rupd_wrap = dict_req_wrap }} )
   | null fields
   = dsLExpr record_expr
   | otherwise
@@ -666,7 +670,7 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
                  mk_val_arg fl pat_arg_id
                      = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
 
-                 inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut con)
+                 inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExt con)
                         -- Reconstruct with the WrapId so that unpacking happens
                  -- The order here is because of the order in `TcPatSyn`.
                  wrap = mkWpEvVarApps theta_vars                                <.>
@@ -718,16 +722,16 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
 
 -- Template Haskell stuff
 
-ds_expr _ (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"
-ds_expr _ (HsTcBracketOut x ps) = dsBracket x ps
-ds_expr _ (HsSpliceE s)  = pprPanic "dsExpr:splice" (ppr s)
+ds_expr _ (HsRnBracketOut _ _ _)  = panic "dsExpr HsRnBracketOut"
+ds_expr _ (HsTcBracketOut x ps) = dsBracket x ps
+ds_expr _ (HsSpliceE _ s)         = pprPanic "dsExpr:splice" (ppr s)
 
 -- Arrow notation extension
-ds_expr _ (HsProc pat cmd) = dsProcExpr pat cmd
+ds_expr _ (HsProc pat cmd) = dsProcExpr pat cmd
 
 -- Hpc Support
 
-ds_expr _ (HsTick tickish e) = do
+ds_expr _ (HsTick tickish e) = do
   e' <- dsLExpr e
   return (Tick tickish e')
 
@@ -738,20 +742,19 @@ ds_expr _ (HsTick tickish e) = do
 -- (did you go here: YES or NO), but will effect accurate
 -- tick counting.
 
-ds_expr _ (HsBinTick ixT ixF e) = do
+ds_expr _ (HsBinTick ixT ixF e) = do
   e2 <- dsLExpr e
   do { ASSERT(exprType e2 `eqType` boolTy)
        mkBinaryTickBox ixT ixF e2
      }
 
-ds_expr _ (HsTickPragma _ _ _ expr) = do
+ds_expr _ (HsTickPragma _ _ _ expr) = do
   dflags <- getDynFlags
   if gopt Opt_Hpc dflags
     then panic "dsExpr:HsTickPragma"
     else dsLExpr expr
 
 -- HsSyn constructs that just shouldn't be here:
-ds_expr _ (ExprWithTySig {})  = panic "dsExpr:ExprWithTySig"
 ds_expr _ (HsBracket     {})  = panic "dsExpr:HsBracket"
 ds_expr _ (HsArrApp      {})  = panic "dsExpr:HsArrApp"
 ds_expr _ (HsArrForm     {})  = panic "dsExpr:HsArrForm"
@@ -759,9 +762,10 @@ ds_expr _ (EWildPat      {})  = panic "dsExpr:EWildPat"
 ds_expr _ (EAsPat        {})  = panic "dsExpr:EAsPat"
 ds_expr _ (EViewPat      {})  = panic "dsExpr:EViewPat"
 ds_expr _ (ELazyPat      {})  = panic "dsExpr:ELazyPat"
-ds_expr _ (HsAppType     {})  = panic "dsExpr:HsAppType" -- removed by typechecker
 ds_expr _ (HsDo          {})  = panic "dsExpr:HsDo"
 ds_expr _ (HsRecFld      {})  = panic "dsExpr:HsRecFld"
+ds_expr _ (XExpr         {})  = panic "dsExpr: XExpr"
+
 
 ------------------------------
 dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
@@ -938,9 +942,9 @@ dsDo stmts
 
            ; rhss' <- sequence rhss
 
-           ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty
+           ; let body' = noLoc $ HsDo body_ty DoExpr (noLoc stmts)
 
-           ; let fun = L noSrcSpan $ HsLam $
+           ; let fun = L noSrcSpan $ HsLam noExt $
                    MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats
                                                        body']
                       , mg_arg_tys = arg_tys
@@ -972,15 +976,15 @@ dsDo stmts
         later_pats   = rec_tup_pats
         rets         = map noLoc rec_rets
         mfix_app     = nlHsSyntaxApps mfix_op [mfix_arg]
-        mfix_arg     = noLoc $ HsLam
+        mfix_arg     = noLoc $ HsLam noExt
                            (MG { mg_alts = noLoc [mkSimpleMatch
                                                     LambdaExpr
                                                     [mfix_pat] body]
                                , mg_arg_tys = [tup_ty], mg_res_ty = body_ty
                                , mg_origin = Generated })
-        mfix_pat     = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats
-        body         = noLoc $ HsDo
-                                DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty
+        mfix_pat     = noLoc $ LazyPat noExt $ mkBigLHsPatTupId rec_tup_pats
+        body         = noLoc $ HsDo body_ty
+                                DoExpr (noLoc (rec_stmts ++ [ret_stmt]))
         ret_app      = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
         ret_stmt     = noLoc $ mkLastStmt ret_app
                      -- This LastStmt will be desugared with dsDo,
@@ -1142,9 +1146,9 @@ we're not directly in an HsWrap, reject.
 checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM ()
 checkForcedEtaExpansion expr ty
   | Just var <- case expr of
-                  HsVar (L _ var)               -> Just var
-                  HsConLikeOut (RealDataCon dc) -> Just (dataConWrapId dc)
-                  _                             -> Nothing
+                  HsVar (L _ var)               -> Just var
+                  HsConLikeOut (RealDataCon dc) -> Just (dataConWrapId dc)
+                  _                               -> Nothing
   , let bad_tys = badUseOfLevPolyPrimop var ty
   , not (null bad_tys)
   = levPolyPrimopErr var ty bad_tys
index e4127ad..b0470ef 100644 (file)
@@ -135,24 +135,25 @@ isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
 --        * Trivial wappings of these
 -- The arguments to Just are any HsTicks that we have found,
 -- because we still want to tick then, even it they are always evaluated.
-isTrueLHsExpr (L _ (HsVar (L _ v))) |  v `hasKey` otherwiseIdKey
-                                    || v `hasKey` getUnique trueDataConId
-                                            = Just return
+isTrueLHsExpr (L _ (HsVar (L _ v))) |  v `hasKey` otherwiseIdKey
+                                      || v `hasKey` getUnique trueDataConId
+                                              = Just return
         -- trueDataConId doesn't have the same unique as trueDataCon
-isTrueLHsExpr (L _ (HsConLikeOut con)) | con `hasKey` getUnique trueDataCon = Just return
-isTrueLHsExpr (L _ (HsTick tickish e))
+isTrueLHsExpr (L _ (HsConLikeOut _ con))
+  | con `hasKey` getUnique trueDataCon = Just return
+isTrueLHsExpr (L _ (HsTick _ tickish e))
     | Just ticks <- isTrueLHsExpr e
     = Just (\x -> do wrapped <- ticks x
                      return (Tick tickish wrapped))
    -- This encodes that the result is constant True for Hpc tick purposes;
    -- which is specifically what isTrueLHsExpr is trying to find out.
-isTrueLHsExpr (L _ (HsBinTick ixT _ e))
+isTrueLHsExpr (L _ (HsBinTick ixT _ e))
     | Just ticks <- isTrueLHsExpr e
     = Just (\x -> do e <- ticks x
                      this_mod <- getModule
                      return (Tick (HpcTick this_mod ixT) e))
 
-isTrueLHsExpr (L _ (HsPar e))         = isTrueLHsExpr e
+isTrueLHsExpr (L _ (HsPar e))         = isTrueLHsExpr e
 isTrueLHsExpr _                       = Nothing
 
 {-
index 7ca85eb..36c2730 100644 (file)
@@ -82,7 +82,7 @@ dsListComp lquals res_ty = do
 -- of that comprehension that we need in the outer comprehension into such an expression
 -- and the type of the elements that it outputs (tuples of binders)
 dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type)
-dsInnerListComp (ParStmtBlock stmts bndrs _)
+dsInnerListComp (ParStmtBlock stmts bndrs _)
   = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs
              list_ty          = mkListTy bndrs_tuple_type
 
@@ -90,6 +90,7 @@ dsInnerListComp (ParStmtBlock stmts bndrs _)
        ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty
 
        ; return (expr, bndrs_tuple_type) }
+dsInnerListComp (XParStmtBlock{}) = panic "dsInnerListComp"
 
 -- This function factors out commonality between the desugaring strategies for GroupStmt.
 -- Given such a statement it gives you back an expression representing how to compute the transformed
@@ -105,7 +106,8 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM
         to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys
 
     -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
-    (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr)
+    (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExt stmts
+                                                        from_bndrs noSyntaxExpr)
 
     -- Work out what arguments should be supplied to that expression: i.e. is an extraction
     -- function required? If so, create that desugared function and add to arguments
@@ -253,7 +255,7 @@ deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list
        ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
                     quals list }
   where
-        bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs]
+        bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs]
 
         -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
         pat  = mkBigLHsPatTupId pats
@@ -623,13 +625,15 @@ dePArrParComp qss quals = do
     deParStmt []             =
       -- empty parallel statement lists have no source representation
       panic "DsListComp.dePArrComp: Empty parallel list comprehension"
-    deParStmt (ParStmtBlock qs xs _:qss) = do        -- first statement
+    deParStmt (ParStmtBlock qs xs _:qss) = do        -- first statement
       let res_expr = mkLHsVarTuple xs
       cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
       parStmts qss (mkLHsVarPatTup xs) cqs
+    deParStmt (XParStmtBlock{}:_) = panic "dePArrParComp"
     ---
     parStmts []             pa cea = return (pa, cea)
-    parStmts (ParStmtBlock qs xs _:qss) pa cea = do  -- subsequent statements (zip'ed)
+    parStmts (ParStmtBlock _ qs xs _:qss) pa cea = do
+                                              -- subsequent statements (zip'ed)
       zipP <- dsDPHBuiltin zipPVar
       let pa'      = mkLHsPatTup [pa, mkLHsVarPatTup xs]
           ty'cea   = parrElemType cea
@@ -638,6 +642,7 @@ dePArrParComp qss quals = do
       let ty'cqs = parrElemType cqs
           cea'   = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
       parStmts qss pa' cea'
+    parStmts (XParStmtBlock{}:_) _ _ = panic "dePArrParComp"
 
 -- generate Core corresponding to `\p -> e'
 --
@@ -777,7 +782,7 @@ dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest
        ; mzip_op'    <- dsExpr mzip_op
 
        ; let -- The pattern variables
-             pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ bs _ <- blocks]
+             pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ bs _ <- blocks]
              -- Pattern with tuples of variables
              -- [v1,v2,v3]  =>  (v1, (v2, v3))
              pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
@@ -788,9 +793,10 @@ dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest
 
        ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest }
   where
-    ds_inner (ParStmtBlock stmts bndrs return_op)
+    ds_inner (ParStmtBlock stmts bndrs return_op)
        = do { exp <- dsInnerMonadComp stmts bndrs return_op
             ; return (exp, mkBigCoreVarTupTy bndrs) }
+    ds_inner (XParStmtBlock{}) = panic "dsMcStmt"
 
 dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
 
index c8f70e0..fd8da26 100644 (file)
@@ -77,13 +77,14 @@ dsBracket brack splices
   where
     new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices]
 
-    do_brack (VarBr _ n) = do { MkC e1  <- lookupOcc n ; return e1 }
-    do_brack (ExpBr e)   = do { MkC e1  <- repLE e     ; return e1 }
-    do_brack (PatBr p)   = do { MkC p1  <- repTopP p   ; return p1 }
-    do_brack (TypBr t)   = do { MkC t1  <- repLTy t    ; return t1 }
-    do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
-    do_brack (DecBrL _)  = panic "dsBracket: unexpected DecBrL"
-    do_brack (TExpBr e)  = do { MkC e1  <- repLE e     ; return e1 }
+    do_brack (VarBr _ _ n) = do { MkC e1  <- lookupOcc n ; return e1 }
+    do_brack (ExpBr _ e)   = do { MkC e1  <- repLE e     ; return e1 }
+    do_brack (PatBr _ p)   = do { MkC p1  <- repTopP p   ; return p1 }
+    do_brack (TypBr _ t)   = do { MkC t1  <- repLTy t    ; return t1 }
+    do_brack (DecBrG _ gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
+    do_brack (DecBrL {})   = panic "dsBracket: unexpected DecBrL"
+    do_brack (TExpBr _ e)  = do { MkC e1  <- repLE e     ; return e1 }
+    do_brack (XBracket {}) = panic "dsBracket: unexpected XBracket"
 
 {- -------------- Examples --------------------
 
@@ -187,8 +188,8 @@ hsSigTvBinders binds
   = concatMap get_scoped_tvs sigs
   where
     sigs = case binds of
-             ValBindsIn  _ sigs -> sigs
-             ValBindsOut _ sigs -> sigs
+             ValBinds           _ _ sigs  -> sigs
+             XValBindsLR (NValBinds _ sigs) -> sigs
 
 get_scoped_tvs :: LSig GhcRn -> [Name]
 get_scoped_tvs (L _ signature)
@@ -724,7 +725,7 @@ repBangTy ty = do
   rep2 bangTypeName [b, t]
   where
     (su', ss', ty') = case ty of
-            L _ (HsBangTy (HsSrcBang _ su ss) ty) -> (su, ss, ty)
+            L _ (HsBangTy (HsSrcBang _ su ss) ty) -> (su, ss, ty)
             _ -> (NoSrcUnpack, NoSrcStrict, ty)
 
 -------------------------------------------------------
@@ -980,18 +981,20 @@ addTyClTyVarBinds tvs m
 --
 repTyVarBndrWithKind :: LHsTyVarBndr GhcRn
                      -> Core TH.Name -> DsM (Core TH.TyVarBndrQ)
-repTyVarBndrWithKind (L _ (UserTyVar _)) nm
+repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm
   = repPlainTV nm
-repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
+repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
   = repLTy ki >>= repKindedTV nm
+repTyVarBndrWithKind (L _ (XTyVarBndr{})) _ = panic "repTyVarBndrWithKind"
 
 -- | Represent a type variable binder
 repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
-repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm
-                                             ; repPlainTV nm' }
-repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm
-                                                  ; ki' <- repLTy ki
-                                                  ; repKindedTV nm' ki' }
+repTyVarBndr (L _ (UserTyVar _ (L _ nm)) )= do { nm' <- lookupBinder nm
+                                               ; repPlainTV nm' }
+repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki)) = do { nm' <- lookupBinder nm
+                                                    ; ki' <- repLTy ki
+                                                    ; repKindedTV nm' ki' }
+repTyVarBndr (L _ (XTyVarBndr{})) = panic "repTyVarBndr"
 
 -- represent a type context
 --
@@ -1040,7 +1043,7 @@ repTy :: HsType GhcRn -> DsM (Core TH.TypeQ)
 repTy ty@(HsForAllTy {}) = repForall ty
 repTy ty@(HsQualTy {})   = repForall ty
 
-repTy (HsTyVar _ (L _ n))
+repTy (HsTyVar _ (L _ n))
   | isLiftedTypeKindTyConName n       = repTStar
   | n `hasKey` constraintKindTyConKey = repTConstraint
   | n `hasKey` funTyConKey            = repArrowTyCon
@@ -1054,47 +1057,47 @@ repTy (HsTyVar _ (L _ n))
   where
     occ = nameOccName n
 
-repTy (HsAppTy f a)         = do
+repTy (HsAppTy _ f a)       = do
                                 f1 <- repLTy f
                                 a1 <- repLTy a
                                 repTapp f1 a1
-repTy (HsFunTy f a)         = do
+repTy (HsFunTy _ f a)       = do
                                 f1   <- repLTy f
                                 a1   <- repLTy a
                                 tcon <- repArrowTyCon
                                 repTapps tcon [f1, a1]
-repTy (HsListTy t)          = do
+repTy (HsListTy _ t)        = do
                                 t1   <- repLTy t
                                 tcon <- repListTyCon
                                 repTapp tcon t1
-repTy (HsPArrTy t)     = do
+repTy (HsPArrTy _ t)   = do
                            t1   <- repLTy t
-                           tcon <- repTy (HsTyVar NotPromoted
+                           tcon <- repTy (HsTyVar noExt NotPromoted
                                                   (noLoc (tyConName parrTyCon)))
                            repTapp tcon t1
-repTy (HsTupleTy HsUnboxedTuple tys) = do
+repTy (HsTupleTy HsUnboxedTuple tys) = do
                                 tys1 <- repLTys tys
                                 tcon <- repUnboxedTupleTyCon (length tys)
                                 repTapps tcon tys1
-repTy (HsTupleTy _ tys)     = do tys1 <- repLTys tys
+repTy (HsTupleTy _ _ tys)   = do tys1 <- repLTys tys
                                  tcon <- repTupleTyCon (length tys)
                                  repTapps tcon tys1
-repTy (HsSumTy tys)         = do tys1 <- repLTys tys
+repTy (HsSumTy _ tys)       = do tys1 <- repLTys tys
                                  tcon <- repUnboxedSumTyCon (length tys)
                                  repTapps tcon tys1
-repTy (HsOpTy ty1 n ty2)    = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
+repTy (HsOpTy _ ty1 n ty2)  = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
                                    `nlHsAppTy` ty2)
-repTy (HsParTy t)           = repLTy t
-repTy (HsEqTy t1 t2) = do
+repTy (HsParTy _ t)         = repLTy t
+repTy (HsEqTy t1 t2) = do
                          t1' <- repLTy t1
                          t2' <- repLTy t2
                          eq  <- repTequality
                          repTapps eq [t1', t2']
-repTy (HsKindSig t k)       = do
+repTy (HsKindSig _ t k)     = do
                                 t1 <- repLTy t
                                 k1 <- repLTy k
                                 repTSig t1 k1
-repTy (HsSpliceTy splice _)     = repSplice splice
+repTy (HsSpliceTy _ splice)      = repSplice splice
 repTy (HsExplicitListTy _ _ tys) = do
                                     tys1 <- repLTys tys
                                     repTPromotedList tys1
@@ -1102,9 +1105,9 @@ repTy (HsExplicitTupleTy _ tys) = do
                                     tys1 <- repLTys tys
                                     tcon <- repPromotedTupleTyCon (length tys)
                                     repTapps tcon tys1
-repTy (HsTyLit lit) = do
-                        lit' <- repTyLit lit
-                        repTLit lit'
+repTy (HsTyLit lit) = do
+                          lit' <- repTyLit lit
+                          repTLit lit'
 repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard
 
 repTy ty                      = notHandled "Exotic form of type" (ppr ty)
@@ -1138,10 +1141,11 @@ repRole (L _ Nothing)                 = rep2 inferRName []
 repSplice :: HsSplice GhcRn -> DsM (Core a)
 -- See Note [How brackets and nested splices are handled] in TcSplice
 -- We return a CoreExpr of any old type; the context should know
-repSplice (HsTypedSplice   _ n _) = rep_splice n
-repSplice (HsUntypedSplice _ n _) = rep_splice n
-repSplice (HsQuasiQuote n _ _ _)  = rep_splice n
-repSplice e@(HsSpliced _ _)       = pprPanic "repSplice" (ppr e)
+repSplice (HsTypedSplice   _ _ n _) = rep_splice n
+repSplice (HsUntypedSplice _ _ n _) = rep_splice n
+repSplice (HsQuasiQuote _ n _ _ _)  = rep_splice n
+repSplice e@(HsSpliced {})          = pprPanic "repSplice" (ppr e)
+repSplice e@(XSplice {})            = pprPanic "repSplice" (ppr e)
 
 rep_splice :: Name -> DsM (Core a)
 rep_splice splice_name
@@ -1166,7 +1170,7 @@ repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ)
 repLE (L loc e) = putSrcSpanDs loc (repE e)
 
 repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ)
-repE (HsVar (L _ x))            =
+repE (HsVar (L _ x))            =
   do { mb_val <- dsLookupMetaEnv x
      ; case mb_val of
         Nothing            -> do { str <- globalVar x
@@ -1174,45 +1178,46 @@ repE (HsVar (L _ x))            =
         Just (DsBound y)   -> repVarOrCon x (coreVar y)
         Just (DsSplice e)  -> do { e' <- dsExpr e
                                  ; return (MkC e') } }
-repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
-repE (HsOverLabel _ s) = repOverLabel s
+repE e@(HsIPVar {}) = notHandled "Implicit parameters" (ppr e)
+repE (HsOverLabel _ s) = repOverLabel s
 
-repE e@(HsRecFld f) = case f of
-  Unambiguous _ x -> repE (HsVar (noLoc x))
+repE e@(HsRecFld f) = case f of
+  Unambiguous x _ -> repE (HsVar noExt (noLoc x))
   Ambiguous{}     -> notHandled "Ambiguous record selectors" (ppr e)
+  XAmbiguousFieldOcc{} -> notHandled "XAmbiguous record selectors" (ppr e)
 
         -- Remember, we're desugaring renamer output here, so
         -- HsOverlit can definitely occur
-repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
-repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
-repE (HsLam (MG { mg_alts = L _ [m] })) = repLambda m
-repE (HsLamCase (MG { mg_alts = L _ ms }))
+repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
+repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
+repE (HsLam (MG { mg_alts = L _ [m] })) = repLambda m
+repE (HsLamCase (MG { mg_alts = L _ ms }))
                    = do { ms' <- mapM repMatchTup ms
                         ; core_ms <- coreList matchQTyConName ms'
                         ; repLamCase core_ms }
-repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
-repE (HsAppType e t) = do { a <- repLE e
+repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
+repE (HsAppType t e) = do { a <- repLE e
                           ; s <- repLTy (hswc_body t)
                           ; repAppType a s }
 
-repE (OpApp e1 op _ e2) =
+repE (OpApp _ e1 op e2) =
   do { arg1 <- repLE e1;
        arg2 <- repLE e2;
        the_op <- repLE op ;
        repInfixApp arg1 the_op arg2 }
-repE (NegApp x _)        = do
+repE (NegApp _ x _)      = do
                               a         <- repLE x
                               negateVar <- lookupOcc negateName >>= repVar
                               negateVar `repApp` a
-repE (HsPar x)            = repLE x
-repE (SectionL x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }
-repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }
-repE (HsCase e (MG { mg_alts = L _ ms }))
+repE (HsPar x)            = repLE x
+repE (SectionL x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }
+repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }
+repE (HsCase e (MG { mg_alts = L _ ms }))
                           = do { arg <- repLE e
                                ; ms2 <- mapM repMatchTup ms
                                ; core_ms2 <- coreList matchQTyConName ms2
                                ; repCaseE arg core_ms2 }
-repE (HsIf _ x y z)         = do
+repE (HsIf _ _ x y z)       = do
                               a <- repLE x
                               b <- repLE y
                               c <- repLE z
@@ -1221,13 +1226,13 @@ repE (HsMultiIf _ alts)
   = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
        ; expr' <- repMultiIf (nonEmptyCoreList alts')
        ; wrapGenSyms (concat binds) expr' }
-repE (HsLet (L _ bs) e)         = do { (ss,ds) <- repBinds bs
+repE (HsLet _ (L _ bs) e)       = do { (ss,ds) <- repBinds bs
                                      ; e2 <- addBinds ss (repLE e)
                                      ; z <- repLetE ds e2
                                      ; wrapGenSyms ss z }
 
 -- FIXME: I haven't got the types here right yet
-repE e@(HsDo ctxt (L _ sts) _)
+repE e@(HsDo _ ctxt (L _ sts))
  | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
  = do { (ss,zs) <- repLSts sts;
         e'      <- repDoE (nonEmptyCoreList zs);
@@ -1243,13 +1248,13 @@ repE e@(HsDo ctxt (L _ sts) _)
 
 repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
-repE e@(ExplicitTuple es boxed)
+repE e@(ExplicitTuple es boxed)
   | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
-  | isBoxed boxed  = do { xs <- repLEs [e | L _ (Present e) <- es]; repTup xs }
-  | otherwise      = do { xs <- repLEs [e | L _ (Present e) <- es]
-                        ; repUnboxedTup xs }
+  | isBoxed boxed = do { xs <- repLEs [e | L _ (Present _ e) <- es]; repTup xs }
+  | otherwise     = do { xs <- repLEs [e | L _ (Present _ e) <- es]
+                       ; repUnboxedTup xs }
 
-repE (ExplicitSum alt arity e _)
+repE (ExplicitSum _ alt arity e)
  = do { e1 <- repLE e
       ; repUnboxedSum e1 alt arity }
 
@@ -1262,7 +1267,7 @@ repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
         fs <- repUpdFields flds;
         repRecUpd x fs }
 
-repE (ExprWithTySig e ty)
+repE (ExprWithTySig ty e)
   = do { e1 <- repLE e
        ; t1 <- repHsSigWcType ty
        ; repSigExp e1 t1 }
@@ -1284,9 +1289,9 @@ repE (ArithSeq _ _ aseq) =
                              ds3 <- repLE e3
                              repFromThenTo ds1 ds2 ds3
 
-repE (HsSpliceE splice)    = repSplice splice
+repE (HsSpliceE _ splice)  = repSplice splice
 repE (HsStatic _ e)        = repLE e >>= rep2 staticEName . (:[]) . unC
-repE (HsUnboundVar uv)     = do
+repE (HsUnboundVar _ uv)   = do
                                occ   <- occNameLit (unboundVarOcc uv)
                                sname <- repNameS occ
                                repUnboundVar sname
@@ -1295,7 +1300,6 @@ repE e@(PArrSeq {})        = notHandled "Parallel arrays" (ppr e)
 repE e@(HsCoreAnn {})      = notHandled "Core annotations" (ppr e)
 repE e@(HsSCC {})          = notHandled "Cost centres" (ppr e)
 repE e@(HsTickPragma {})   = notHandled "Tick Pragma" (ppr e)
-repE e@(HsTcBracketOut {}) = notHandled "TH brackets" (ppr e)
 repE e                     = notHandled "Expression form" (ppr e)
 
 -----------------------------------------------------------------------------
@@ -1359,7 +1363,7 @@ repUpdFields = repList fieldExpQTyConName rep_fld
   where
     rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp))
     rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of
-      Unambiguous _ sel_name -> do { fn <- lookupLOcc (L l sel_name)
+      Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)
                                    ; e  <- repLE (hsRecFieldArg fld)
                                    ; repFieldExp fn e }
       _                      -> notHandled "Ambiguous record updates" (ppr fld)
@@ -1423,10 +1427,11 @@ repSts (ParStmt stmt_blocks _ _ _ : ss) =
    where
      rep_stmt_block :: ParStmtBlock GhcRn GhcRn
                     -> DsM ([GenSymBind], Core [TH.StmtQ])
-     rep_stmt_block (ParStmtBlock stmts _ _) =
+     rep_stmt_block (ParStmtBlock stmts _ _) =
        do { (ss1, zs) <- repSts (map unLoc stmts)
           ; zs1 <- coreList stmtQTyConName zs
           ; return (ss1, zs1) }
+     rep_stmt_block (XParStmtBlock{}) = panic "repSts"
 repSts [LastStmt e _ _]
   = do { e2 <- repLE e
        ; z <- repNoBindSt e2
@@ -1461,12 +1466,12 @@ repBinds (HsValBinds decs)
 
 rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
 -- Assumes: all the binders of the binding are already in the meta-env
-rep_val_binds (ValBindsOut binds sigs)
+rep_val_binds (XValBindsLR (NValBinds binds sigs))
  = do { core1 <- rep_binds (unionManyBags (map snd binds))
       ; core2 <- rep_sigs sigs
       ; return (core1 ++ core2) }
-rep_val_binds (ValBindsIn _ _)
- = panic "rep_val_binds: ValBindsIn"
+rep_val_binds (ValBinds _ _ _)
+ = panic "rep_val_binds: ValBinds"
 
 rep_binds :: LHsBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
 rep_binds = mapM rep_bind . bagToList
@@ -1648,19 +1653,23 @@ repLP :: LPat GhcRn -> DsM (Core TH.PatQ)
 repLP (L _ p) = repP p
 
 repP :: Pat GhcRn -> DsM (Core TH.PatQ)
-repP (WildPat _)       = repPwild
-repP (LitPat l)        = do { l2 <- repLiteral l; repPlit l2 }
-repP (VarPat (L _ x))  = do { x' <- lookupBinder x; repPvar x' }
-repP (LazyPat p)       = do { p1 <- repLP p; repPtilde p1 }
-repP (BangPat p)       = do { p1 <- repLP p; repPbang p1 }
-repP (AsPat x p)       = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
-repP (ParPat p)        = repLP p
-repP (ListPat ps _ Nothing)    = do { qs <- repLPs ps; repPlist qs }
-repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE (syn_expr e); repPview e' p}
-repP (TuplePat ps boxed _)
+repP (WildPat _)        = repPwild
+repP (LitPat _ l)       = do { l2 <- repLiteral l; repPlit l2 }
+repP (VarPat _ (L _ x)) = do { x' <- lookupBinder x; repPvar x' }
+repP (LazyPat _ p)      = do { p1 <- repLP p; repPtilde p1 }
+repP (BangPat _ p)      = do { p1 <- repLP p; repPbang p1 }
+repP (AsPat _ x p)      = do { x' <- lookupLBinder x; p1 <- repLP p
+                             ; repPaspat x' p1 }
+repP (ParPat _ p)       = repLP p
+repP (ListPat _ ps _ Nothing)    = do { qs <- repLPs ps; repPlist qs }
+repP (ListPat x ps ty1 (Just (_,e))) = do { p <- repP (ListPat x ps ty1 Nothing)
+                                          ; e' <- repE (syn_expr e)
+                                          ; repPview e' p}
+repP (TuplePat _ ps boxed)
   | isBoxed boxed       = do { qs <- repLPs ps; repPtup qs }
   | otherwise           = do { qs <- repLPs ps; repPunboxedTup qs }
-repP (SumPat p alt arity _) = do { p1 <- repLP p; repPunboxedSum p1 alt arity }
+repP (SumPat _ p alt arity) = do { p1 <- repLP p
+                                 ; repPunboxedSum p1 alt arity }
 repP (ConPatIn dc details)
  = do { con_str <- lookupLOcc dc
       ; case details of
@@ -1677,13 +1686,13 @@ repP (ConPatIn dc details)
                           ; MkC p <- repLP (hsRecFieldArg fld)
                           ; rep2 fieldPatName [v,p] }
 
-repP (NPat (L _ l) Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }
-repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
-repP p@(NPat _ (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p)
-repP (SigPatIn p t) = do { p' <- repLP p
-                         ; t' <- repLTy (hsSigWcType t)
-                         ; repPsig p' t' }
-repP (SplicePat splice) = repSplice splice
+repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
+repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
+repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
+repP (SigPat t p) = do { p' <- repLP p
+                       ; t' <- repLTy (hsSigWcType t)
+                       ; repPsig p' t' }
+repP (SplicePat splice) = repSplice splice
 
 repP other = notHandled "Exotic pattern" (ppr other)
 
@@ -2234,7 +2243,7 @@ repConstr (RecCon (L _ ips)) resTy cons
       rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
 
       rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a)
-      rep_one_ip t n = do { MkC v  <- lookupOcc (selectorFieldOcc $ unLoc n)
+      rep_one_ip t n = do { MkC v  <- lookupOcc (extFieldOcc $ unLoc n)
                           ; MkC ty <- repBangTy  t
                           ; rep2 varBangTypeName [v,ty] }
 
@@ -2394,7 +2403,7 @@ mk_integer  i = do integer_ty <- lookupType integerTyConName
 
 mk_rational :: FractionalLit -> DsM (HsLit GhcRn)
 mk_rational r = do rat_ty <- lookupType rationalTyConName
-                   return $ HsRat def r rat_ty
+                   return $ HsRat noExt r rat_ty
 mk_string :: FastString -> DsM (HsLit GhcRn)
 mk_string s = return $ HsString NoSourceText s
 
@@ -2407,6 +2416,7 @@ repOverloadedLiteral (OverLit { ol_val = val})
         -- The type Rational will be in the environment, because
         -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
         -- and rationalL is sucked in when any TH stuff is used
+repOverloadedLiteral XOverLit{} = panic "repOverloadedLiteral"
 
 mk_lit :: OverLitVal -> DsM (HsLit GhcRn)
 mk_lit (HsIntegral i)     = mk_integer  (il_value i)
index f4d669c..7bec30a 100644 (file)
@@ -9,6 +9,8 @@ This module exports some utility functions of no great interest.
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
 
 -- | Utility functions for constructing Core syntax, principally for desugaring
 module DsUtils (
@@ -117,13 +119,13 @@ selectMatchVars :: [Pat GhcTc] -> DsM [Id]
 selectMatchVars ps = mapM selectMatchVar ps
 
 selectMatchVar :: Pat GhcTc -> DsM Id
-selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
-selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
-selectMatchVar (ParPat pat)  = selectMatchVar (unLoc pat)
-selectMatchVar (VarPat var)  = return (localiseId (unLoc var))
+selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
+selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
+selectMatchVar (ParPat pat)  = selectMatchVar (unLoc pat)
+selectMatchVar (VarPat var)  = return (localiseId (unLoc var))
                                   -- Note [Localise pattern binders]
-selectMatchVar (AsPat var _) = return (unLoc var)
-selectMatchVar other_pat     = newSysLocalDsNoLP (hsPatType other_pat)
+selectMatchVar (AsPat var _) = return (unLoc var)
+selectMatchVar other_pat       = newSysLocalDsNoLP (hsPatType other_pat)
                                   -- OK, better make up one...
 
 {-
@@ -736,7 +738,7 @@ mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
                 -- and all the desugared binds
 
 mkSelectorBinds ticks pat val_expr
-  | L _ (VarPat (L _ v)) <- pat'     -- Special case (A)
+  | L _ (VarPat (L _ v)) <- pat'     -- Special case (A)
   = return (v, [(v, val_expr)])
 
   | is_flat_prod_lpat pat'           -- Special case (B)
@@ -783,17 +785,17 @@ mkSelectorBinds ticks pat val_expr
 
 strip_bangs :: LPat a -> LPat a
 -- Remove outermost bangs and parens
-strip_bangs (L _ (ParPat p))  = strip_bangs p
-strip_bangs (L _ (BangPat p)) = strip_bangs p
-strip_bangs lp                = lp
+strip_bangs (L _ (ParPat p))  = strip_bangs p
+strip_bangs (L _ (BangPat p)) = strip_bangs p
+strip_bangs lp                  = lp
 
 is_flat_prod_lpat :: LPat a -> Bool
 is_flat_prod_lpat p = is_flat_prod_pat (unLoc p)
 
 is_flat_prod_pat :: Pat a -> Bool
-is_flat_prod_pat (ParPat p)            = is_flat_prod_lpat p
-is_flat_prod_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
-is_flat_prod_pat (ConPatOut { pat_con = L _ pcon, pat_args = ps})
+is_flat_prod_pat (ParPat _ p)          = is_flat_prod_lpat p
+is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps
+is_flat_prod_pat (ConPatOut { pat_con  = L _ pcon, pat_args = ps})
   | RealDataCon con <- pcon
   , isProductTyCon (dataConTyCon con)
   = all is_triv_lpat (hsConPatArgs ps)
@@ -803,10 +805,10 @@ is_triv_lpat :: LPat a -> Bool
 is_triv_lpat p = is_triv_pat (unLoc p)
 
 is_triv_pat :: Pat a -> Bool
-is_triv_pat (VarPat _)  = True
-is_triv_pat (WildPat _) = True
-is_triv_pat (ParPat p)  = is_triv_lpat p
-is_triv_pat _           = False
+is_triv_pat (VarPat {})  = True
+is_triv_pat (WildPat{})  = True
+is_triv_pat (ParPat _ p) = is_triv_lpat p
+is_triv_pat _            = False
 
 
 {- *********************************************************************
@@ -828,7 +830,7 @@ mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)
 
 mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
 -- A vanilla tuple pattern simply gets its type from its sub-patterns
-mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats)
+mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box
 
 -- The Big equivalents for the source tuple expressions
 mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
@@ -983,8 +985,8 @@ mkBinaryTickBox ixT ixF e = do
 -- pat     => !pat   -- when -XStrict
 -- pat     => pat    -- otherwise
 decideBangHood :: DynFlags
-               -> LPat id  -- ^ Original pattern
-               -> LPat id  -- Pattern with bang if necessary
+               -> LPat GhcTc  -- ^ Original pattern
+               -> LPat GhcTc  -- Pattern with bang if necessary
 decideBangHood dflags lpat
   | not (xopt LangExt.Strict dflags)
   = lpat
@@ -993,19 +995,20 @@ decideBangHood dflags lpat
   where
     go lp@(L l p)
       = case p of
-           ParPat p    -> L l (ParPat (go p))
-           LazyPat lp' -> lp'
-           BangPat _   -> lp
-           _           -> L l (BangPat lp)
+           ParPat x p    -> L l (ParPat x (go p))
+           LazyPat lp' -> lp'
+           BangPat _   -> lp
+           _             -> L l (BangPat noExt lp)
 
 -- | Unconditionally make a 'Pat' strict.
-addBang :: LPat id -- ^ Original pattern
-        -> LPat id -- ^ Banged pattern
+addBang :: LPat GhcTc -- ^ Original pattern
+        -> LPat GhcTc -- ^ Banged pattern
 addBang = go
   where
     go lp@(L l p)
       = case p of
-           ParPat p    -> L l (ParPat (go p))
-           LazyPat lp' -> L l (BangPat lp')
-           BangPat _   -> lp
-           _           -> L l (BangPat lp)
+           ParPat x p    -> L l (ParPat x (go p))
+           LazyPat _ lp' -> L l (BangPat noExt lp')
+                                  -- Should we bring the extension value over?
+           BangPat _ _   -> lp
+           _             -> L l (BangPat noExt lp)
index 5f9f8dc..c4fb7e7 100644 (file)
@@ -251,7 +251,7 @@ matchBangs [] _ _ = panic "matchBangs"
 matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
 -- Apply the coercion to the match variable and then match that
 matchCoercion (var:vars) ty (eqns@(eqn1:_))
-  = do  { let CoPat co pat _ = firstPat eqn1
+  = do  { let CoPat co pat _ = firstPat eqn1
         ; let pat_ty' = hsPatType pat
         ; var' <- newUniqueId var pat_ty'
         ; match_result <- match (var':vars) ty $
@@ -267,7 +267,7 @@ matchView (var:vars) ty (eqns@(eqn1:_))
   = do  { -- we could pass in the expr from the PgView,
          -- but this needs to extract the pat anyway
          -- to figure out the type of the fresh variable
-         let ViewPat viewExpr (L _ pat) _ = firstPat eqn1
+         let ViewPat _ viewExpr (L _ pat) = firstPat eqn1
          -- do the rest of the compilation
         ; let pat_ty' = hsPatType pat
         ; var' <- newUniqueId var pat_ty'
@@ -284,7 +284,7 @@ matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
 matchOverloadedList (var:vars) ty (eqns@(eqn1:_))
 -- Since overloaded list patterns are treated as view patterns,
 -- the code is roughly the same as for matchView
-  = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1
+  = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1
        ; var' <- newUniqueId var (mkListTy elt_ty)  -- we construct the overall type by hand
        ; match_result <- match (var':vars) ty $
                             map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern
@@ -299,13 +299,13 @@ decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
 decomposeFirstPat _ _ = panic "decomposeFirstPat"
 
 getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc
-getCoPat (CoPat _ pat _)     = pat
+getCoPat (CoPat _ _ pat _)   = pat
 getCoPat _                   = panic "getCoPat"
-getBangPat (BangPat pat  )   = unLoc pat
+getBangPat (BangPat _ pat  ) = unLoc pat
 getBangPat _                 = panic "getBangPat"
-getViewPat (ViewPat _ pat _) = unLoc pat
+getViewPat (ViewPat _ _ pat) = unLoc pat
 getViewPat _                 = panic "getViewPat"
-getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing
+getOLPat (ListPat x pats ty (Just _)) = ListPat x pats ty Nothing
 getOLPat _                   = panic "getOLPat"
 
 {-
@@ -398,19 +398,19 @@ tidy1 :: Id                  -- The Id being scrutinised
 -- It eliminates many pattern forms (as-patterns, variable patterns,
 -- list patterns, etc) and returns any created bindings in the wrapper.
 
-tidy1 v (ParPat pat)      = tidy1 v (unLoc pat)
-tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat)
-tidy1 _ (WildPat ty)      = return (idDsWrapper, WildPat ty)
-tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p
+tidy1 v (ParPat pat)      = tidy1 v (unLoc pat)
+tidy1 v (SigPat _ pat)      = tidy1 v (unLoc pat)
+tidy1 _ (WildPat ty)        = return (idDsWrapper, WildPat ty)
+tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p
 
         -- case v of { x -> mr[] }
         -- = case v of { _ -> let x=v in mr[] }
-tidy1 v (VarPat (L _ var))
+tidy1 v (VarPat (L _ var))
   = return (wrapBind var v, WildPat (idType var))
 
         -- case v of { x@p -> mr[] }
         -- = case v of { p -> let x=v in mr[] }
-tidy1 v (AsPat (L _ var) pat)
+tidy1 v (AsPat (L _ var) pat)
   = do  { (wrap, pat') <- tidy1 v (unLoc pat)
         ; return (wrapBind var v . wrap, pat') }
 
@@ -425,7 +425,7 @@ tidy1 v (AsPat (L _ var) pat)
     The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
 -}
 
-tidy1 v (LazyPat pat)
+tidy1 v (LazyPat pat)
     -- This is a convenient place to check for unlifted types under a lazy pattern.
     -- Doing this check during type-checking is unsatisfactory because we may
     -- not fully know the zonked types yet. We sure do here.
@@ -441,7 +441,7 @@ tidy1 v (LazyPat pat)
         ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
         ; return (mkCoreLets sel_binds, WildPat (idType v)) }
 
-tidy1 _ (ListPat pats ty Nothing)
+tidy1 _ (ListPat pats ty Nothing)
   = return (idDsWrapper, unLoc list_ConPat)
   where
     list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
@@ -450,29 +450,29 @@ tidy1 _ (ListPat pats ty Nothing)
 
 -- Introduce fake parallel array constructors to be able to handle parallel
 -- arrays with the existing machinery for constructor pattern
-tidy1 _ (PArrPat pats ty)
+tidy1 _ (PArrPat ty pats)
   = return (idDsWrapper, unLoc parrConPat)
   where
     arity      = length pats
     parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty]
 
-tidy1 _ (TuplePat pats boxity tys)
+tidy1 _ (TuplePat tys pats boxity)
   = return (idDsWrapper, unLoc tuple_ConPat)
   where
     arity = length pats
     tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys
 
-tidy1 _ (SumPat pat alt arity tys)
+tidy1 _ (SumPat tys pat alt arity)
   = return (idDsWrapper, unLoc sum_ConPat)
   where
     sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys
 
 -- LitPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ (LitPat lit)
+tidy1 _ (LitPat lit)
   = return (idDsWrapper, tidyLitPat lit)
 
 -- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ (NPat (L _ lit) mb_neg eq ty)
+tidy1 _ (NPat ty (L _ lit) mb_neg eq)
   = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq ty)
 
 -- Everything else goes through unchanged...
@@ -484,13 +484,14 @@ tidy1 _ non_interesting_pat
 tidy_bang_pat :: Id -> SrcSpan -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
 
 -- Discard par/sig under a bang
-tidy_bang_pat v _ (ParPat (L l p))      = tidy_bang_pat v l p
-tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p
+tidy_bang_pat v _ (ParPat _ (L l p)) = tidy_bang_pat v l p
+tidy_bang_pat v _ (SigPat _ (L l p)) = tidy_bang_pat v l p
 
 -- Push the bang-pattern inwards, in the hope that
 -- it may disappear next time
-tidy_bang_pat v l (AsPat v' p)  = tidy1 v (AsPat v' (L l (BangPat p)))
-tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t)
+tidy_bang_pat v l (AsPat x v' p) = tidy1 v (AsPat x v' (L l (BangPat noExt p)))
+tidy_bang_pat v l (CoPat x w p t)
+  = tidy1 v (CoPat x w (BangPat noExt (L l p)) t)
 
 -- Discard bang around strict pattern
 tidy_bang_pat v _ p@(LitPat {})    = tidy1 v p
@@ -526,7 +527,7 @@ tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc)
 --
 -- NB: SigPatIn, ConPatIn should not happen
 
-tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p))
+tidy_bang_pat _ l p = return (idDsWrapper, BangPat noExt (L l p))
 
 -------------------
 push_bang_into_newtype_arg :: SrcSpan
@@ -537,15 +538,16 @@ push_bang_into_newtype_arg :: SrcSpan
 -- We are transforming   !(N p)   into   (N !p)
 push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))
   = ASSERT( null args)
-    PrefixCon [L l (BangPat arg)]
+    PrefixCon [L l (BangPat noExt arg)]
 push_bang_into_newtype_arg l _ty (RecCon rf)
   | HsRecFields { rec_flds = L lf fld : flds } <- rf
   , HsRecField { hsRecFieldArg = arg } <- fld
   = ASSERT( null flds)
-    RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg = L l (BangPat arg) })] })
+    RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg
+                                           = L l (BangPat noExt arg) })] })
 push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
   | HsRecFields { rec_flds = [] } <- rf
-  = PrefixCon [L l (BangPat (noLoc (WildPat ty)))]
+  = PrefixCon [L l (BangPat noExt (noLoc (WildPat ty)))]
 push_bang_into_newtype_arg _ _ cd
   = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
 
@@ -975,18 +977,18 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool
     -- real comparison is on HsExpr's
     -- strip parens
-    exp (HsPar (L _ e)) e'   = exp e e'
-    exp e (HsPar (L _ e'))   = exp e e'
+    exp (HsPar (L _ e)) e'   = exp e e'
+    exp e (HsPar (L _ e'))   = exp e e'
     -- because the expressions do not necessarily have the same type,
     -- we have to compare the wrappers
-    exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'
-    exp (HsVar i) (HsVar i') =  i == i'
-    exp (HsConLikeOut c) (HsConLikeOut c') = c == c'
+    exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e'
+    exp (HsVar _ i) (HsVar _ i') =  i == i'
+    exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c'
     -- the instance for IPName derives using the id, so this works if the
     -- above does
-    exp (HsIPVar i) (HsIPVar i') = i == i'
-    exp (HsOverLabel l x) (HsOverLabel l' x') = l == l' && x == x'
-    exp (HsOverLit l) (HsOverLit l') =
+    exp (HsIPVar _ i) (HsIPVar _ i') = i == i'
+    exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x'
+    exp (HsOverLit _ l) (HsOverLit _ l') =
         -- Overloaded lits are equal if they have the same type
         -- and the data is the same.
         -- this is coarser than comparing the SyntaxExpr's in l and l',
@@ -994,20 +996,20 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
         -- because these expressions get written as a bunch of different variables
         -- (presumably to improve sharing)
         eqType (overLitType l) (overLitType l') && l == l'
-    exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
+    exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2'
     -- the fixities have been straightened out by now, so it's safe
     -- to ignore them?
-    exp (OpApp l o _ ri) (OpApp l' o' _ ri') =
+    exp (OpApp _ l o ri) (OpApp _ l' o' ri') =
         lexp l l' && lexp o o' && lexp ri ri'
-    exp (NegApp e n) (NegApp e' n') = lexp e e' && syn_exp n n'
-    exp (SectionL e1 e2) (SectionL e1' e2') =
+    exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n'
+    exp (SectionL _ e1 e2) (SectionL _ e1' e2') =
         lexp e1 e1' && lexp e2 e2'
-    exp (SectionR e1 e2) (SectionR e1' e2') =
+    exp (SectionR _ e1 e2) (SectionR _ e1' e2') =
         lexp e1 e1' && lexp e2 e2'
-    exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =
+    exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) =
         eq_list tup_arg es1 es2
-    exp (ExplicitSum _ _ e _) (ExplicitSum _ _ e' _) = lexp e e'
-    exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =
+    exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e'
+    exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') =
         lexp e e' && lexp e1 e1' && lexp e2 e2'
 
     -- Enhancement: could implement equality for more expressions
@@ -1029,8 +1031,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
         wrap res_wrap1 res_wrap2
 
     ---------
-    tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2
-    tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2
+    tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2
+    tup_arg (L _ (Missing t1))   (L _ (Missing t2))   = eqType t1 t2
     tup_arg _ _ = False
 
     ---------
@@ -1071,7 +1073,7 @@ patGroup _ (ConPatOut { pat_con = L _ con
  | PatSynCon psyn <- con                = PgSyn psyn tys
 patGroup _ (WildPat {})                 = PgAny
 patGroup _ (BangPat {})                 = PgBang
-patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) =
+patGroup _ (NPat _ (L _ OverLit {ol_val=oval}) mb_neg _) =
   case (oval, isJust mb_neg) of
    (HsIntegral   i, False) -> PgN (fromInteger (il_value i))
    (HsIntegral   i, True ) -> PgN (-fromInteger (il_value i))
@@ -1079,14 +1081,15 @@ patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) =
    (HsFractional r, True ) -> PgN (-fl_value r)
    (HsIsString _ s, _) -> ASSERT(isNothing mb_neg)
                           PgOverS s
-patGroup _ (NPlusKPat _ (L _ OverLit {ol_val=oval}) _ _ _ _) =
+patGroup _ (NPlusKPat _ _ (L _ OverLit {ol_val=oval}) _ _ _) =
   case oval of
    HsIntegral i -> PgNpK (il_value i)
    _ -> pprPanic "patGroup NPlusKPat" (ppr oval)
-patGroup _ (CoPat _ p _)                = PgCo  (hsPatType p) -- Type of innelexp pattern
-patGroup _ (ViewPat expr p _)           = PgView expr (hsPatType (unLoc p))
-patGroup _ (ListPat _ _ (Just _))       = PgOverloadedList
-patGroup dflags (LitPat lit)            = PgLit (hsLitKey dflags lit)
+patGroup _ (CoPat _ _ p _)              = PgCo  (hsPatType p)
+                                                    -- Type of innelexp pattern
+patGroup _ (ViewPat _ expr p)           = PgView expr (hsPatType (unLoc p))
+patGroup _ (ListPat _ _ _ (Just _))     = PgOverloadedList
+patGroup dflags (LitPat _ lit)          = PgLit (hsLitKey dflags lit)
 patGroup _ pat                          = pprPanic "patGroup" (ppr pat)
 
 {-
index 355927d..c7bff64 100644 (file)
@@ -102,6 +102,8 @@ dsLit (HsRat _ (FL _ _ val) ty) = do
                                    (head (tyConDataCons tycon), i_ty)
                 x -> pprPanic "dsLit" (ppr x)
 
+dsLit (XLit x)  = pprPanic "dsLit" (ppr x)
+
 dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
 dsOverLit lit = do { dflags <- getDynFlags
                    ; warnAboutOverflowedLiterals dflags lit
@@ -110,12 +112,12 @@ dsOverLit lit = do { dflags <- getDynFlags
 dsOverLit' :: DynFlags -> HsOverLit GhcTc -> DsM CoreExpr
 -- Post-typechecker, the HsExpr field of an OverLit contains
 -- (an expression for) the literal value itself
-dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable
-                           , ol_witness = witness, ol_type = ty })
+dsOverLit' dflags (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty
+                           , ol_witness = witness })
   | not rebindable
   , Just expr <- shortCutLit dflags val ty = dsExpr expr        -- Note [Literal short cut]
   | otherwise                              = dsExpr witness
-
+dsOverLit' _ XOverLit{} = panic "dsOverLit'"
 {-
 Note [Literal short cut]
 ~~~~~~~~~~~~~~~~~~~~~~~~
@@ -239,14 +241,14 @@ warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
 getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)
 -- See if the expression is an Integral literal
 -- Remember to look through automatically-added tick-boxes! (Trac #8384)
-getLHsIntegralLit (L _ (HsPar e))            = getLHsIntegralLit e
-getLHsIntegralLit (L _ (HsTick _ e))         = getLHsIntegralLit e
-getLHsIntegralLit (L _ (HsBinTick _ _ e))    = getLHsIntegralLit e
-getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit
+getLHsIntegralLit (L _ (HsPar e))            = getLHsIntegralLit e
+getLHsIntegralLit (L _ (HsTick _ e))         = getLHsIntegralLit e
+getLHsIntegralLit (L _ (HsBinTick _ _ e))    = getLHsIntegralLit e
+getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit
 getLHsIntegralLit _ = Nothing
 
 getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name)
-getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty })
+getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty })
   | Just tc <- tyConAppTyCon_maybe ty
   = Just (il_value i, tyConName tc)
 getIntegralLit _ = Nothing
@@ -273,7 +275,7 @@ tidyLitPat (HsString src s)
                   (mkNilPat charTy) (unpackFS s)
         -- The stringTy is the type of the whole pattern, not
         -- the type to instantiate (:) or [] with!
-tidyLitPat lit = LitPat lit
+tidyLitPat lit = LitPat noExt lit
 
 ----------------
 tidyNPat :: (HsLit GhcTc -> Pat GhcTc)   -- How to tidy a LitPat
@@ -284,7 +286,7 @@ tidyNPat :: (HsLit GhcTc -> Pat GhcTc)   -- How to tidy a LitPat
          -> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc
          -> Type
          -> Pat GhcTc
-tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty
+tidyNPat tidy_lit_pat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty
         -- False: Take short cuts only if the literal is not using rebindable syntax
         --
         -- Once that is settled, look for cases where the type of the
@@ -313,7 +315,8 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty
     type_change = not (outer_ty `eqType` ty)
 
     mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc
-    mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
+    mk_con_pat con lit
+      = unLoc (mkPrefixConPat con [noLoc $ LitPat noExt lit] [])
 
     mb_int_lit :: Maybe Integer
     mb_int_lit = case (mb_neg, val) of
@@ -327,7 +330,7 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty
                    _ -> Nothing
 
 tidyNPat _ over_lit mb_neg eq outer_ty
-  = NPat (noLoc over_lit) mb_neg eq outer_ty
+  = NPat outer_ty (noLoc over_lit) mb_neg eq
 
 {-
 ************************************************************************
@@ -361,7 +364,7 @@ matchLiterals (var:vars) ty sub_groups
     match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
     match_group eqns
         = do dflags <- getDynFlags
-             let LitPat hs_lit = firstPat (head eqns)
+             let LitPat hs_lit = firstPat (head eqns)
              match_result <- match vars ty (shiftEqns eqns)
              return (hsLitKey dflags hs_lit, match_result)
 
@@ -409,7 +412,7 @@ hsLitKey _      l                  = pprPanic "hsLitKey" (ppr l)
 
 matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 matchNPats (var:vars) ty (eqn1:eqns)    -- All for the same literal
-  = do  { let NPat (L _ lit) mb_neg eq_chk _ = firstPat eqn1
+  = do  { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1
         ; lit_expr <- dsOverLit lit
         ; neg_lit <- case mb_neg of
                             Nothing  -> return lit_expr
@@ -440,7 +443,7 @@ We generate:
 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 -- All NPlusKPats, for the *same* literal k
 matchNPlusKPats (var:vars) ty (eqn1:eqns)
-  = do  { let NPlusKPat (L _ n1) (L _ lit1) lit2 ge minus _ = firstPat eqn1
+  = do  { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus = firstPat eqn1
         ; lit1_expr   <- dsOverLit lit1
         ; lit2_expr   <- dsOverLit lit2
         ; pred_expr   <- dsSyntaxExpr ge    [Var var, lit1_expr]
@@ -452,7 +455,7 @@ matchNPlusKPats (var:vars) ty (eqn1:eqns)
                    adjustMatchResult (foldr1 (.) wraps)         $
                    match_result) }
   where
-    shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ _ _ : pats })
+    shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats })
         = (wrapBind n n1, eqn { eqn_pats = pats })
         -- The wrapBind is a no-op for the first equation
     shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
index aa1bc81..f008a31 100644 (file)
@@ -236,32 +236,32 @@ lhsExprToPmExpr (L _ e) = hsExprToPmExpr e
 
 hsExprToPmExpr :: HsExpr GhcTc -> PmExpr
 
-hsExprToPmExpr (HsVar         x) = PmExprVar (idName (unLoc x))
-hsExprToPmExpr (HsConLikeOut  c) = PmExprVar (conLikeName c)
-hsExprToPmExpr (HsOverLit  olit) = PmExprLit (PmOLit False olit)
-hsExprToPmExpr (HsLit       lit) = PmExprLit (PmSLit lit)
+hsExprToPmExpr (HsVar        _ x) = PmExprVar (idName (unLoc x))
+hsExprToPmExpr (HsConLikeOut _ c) = PmExprVar (conLikeName c)
+hsExprToPmExpr (HsOverLit _ olit) = PmExprLit (PmOLit False olit)
+hsExprToPmExpr (HsLit      _ lit) = PmExprLit (PmSLit lit)
 
-hsExprToPmExpr e@(NegApp _ neg_e)
+hsExprToPmExpr e@(NegApp _ neg_e)
   | PmExprLit (PmOLit False ol) <- synExprToPmExpr neg_e
   = PmExprLit (PmOLit True ol)
   | otherwise = PmExprOther e
-hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e
+hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e
 
-hsExprToPmExpr e@(ExplicitTuple ps boxity)
+hsExprToPmExpr e@(ExplicitTuple ps boxity)
   | all tupArgPresent ps = mkPmExprData tuple_con tuple_args
   | otherwise            = PmExprOther e
   where
     tuple_con  = tupleDataCon boxity (length ps)
-    tuple_args = [ lhsExprToPmExpr e | L _ (Present e) <- ps ]
+    tuple_args = [ lhsExprToPmExpr e | L _ (Present e) <- ps ]
 
-hsExprToPmExpr e@(ExplicitList _elem_ty mb_ol elems)
+hsExprToPmExpr e@(ExplicitList _  mb_ol elems)
   | Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems)
   | otherwise        = PmExprOther e {- overloaded list: No PmExprApp -}
   where
     cons x xs = mkPmExprData consDataCon [x,xs]
     nil       = mkPmExprData nilDataCon  []
 
-hsExprToPmExpr (ExplicitPArr _elem_ty elems)
+hsExprToPmExpr (ExplicitPArr _ elems)
   = mkPmExprData (parrFakeCon (length elems)) (map lhsExprToPmExpr elems)
 
 
@@ -272,16 +272,15 @@ hsExprToPmExpr (ExplicitPArr _elem_ty elems)
 --   con  <- dsLookupDataCon (unLoc c)
 --   args <- mapM lhsExprToPmExpr (hsRecFieldsArgs binds)
 --   return (PmExprCon con args)
-hsExprToPmExpr e@(RecordCon   _ _ _ _) = PmExprOther e
-
-hsExprToPmExpr (HsTick            _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (HsBinTick       _ _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (HsTickPragma  _ _ _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (HsSCC           _ _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (HsCoreAnn       _ _ e) = lhsExprToPmExpr e
-hsExprToPmExpr (ExprWithTySig     e _) = lhsExprToPmExpr e
-hsExprToPmExpr (ExprWithTySigOut  e _) = lhsExprToPmExpr e
-hsExprToPmExpr (HsWrap            _ e) =  hsExprToPmExpr e
+hsExprToPmExpr e@(RecordCon {}) = PmExprOther e
+
+hsExprToPmExpr (HsTick           _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsBinTick      _ _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsTickPragma _ _ _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsSCC          _ _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsCoreAnn      _ _ _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (ExprWithTySig      _ e) = lhsExprToPmExpr e
+hsExprToPmExpr (HsWrap           _ _ e) =  hsExprToPmExpr e
 hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle
 
 synExprToPmExpr :: SyntaxExpr GhcTc -> PmExpr
index 3bb61e0..f766074 100644 (file)
@@ -8,6 +8,7 @@ This module converts Template Haskell syntax into HsSyn
 
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
                 convertToHsType,
@@ -213,7 +214,7 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs)
         ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
                                         , tcdFixity = Prefix
                                         , tcdDataDefn = defn
-                                        , tcdDataCusk = PlaceHolder
+                                        , tcdDataCusk = placeHolder
                                         , tcdFVs = placeHolderNames }) }
 
 cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
@@ -229,7 +230,7 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
         ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
                                     , tcdFixity = Prefix
                                     , tcdDataDefn = defn
-                                    , tcdDataCusk = PlaceHolder
+                                    , tcdDataCusk = placeHolder
                                     , tcdFVs = placeHolderNames }) }
 
 cvtDec (ClassD ctxt cl tvs fds decs)
@@ -539,7 +540,8 @@ cvtConstr (RecGadtC c varstrtys ty)
   = do  { c'       <- mapM cNameL c
         ; ty'      <- cvtType ty
         ; rec_flds <- mapM cvt_id_arg varstrtys
-        ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty')
+        ; let rec_ty = noLoc (HsFunTy noExt
+                                           (noLoc $ HsRecTy noExt rec_flds) ty')
         ; returnL $ mkGadtDecl c' rec_ty }
 
 cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
@@ -558,7 +560,7 @@ cvt_arg (Bang su ss, ty)
        ; ty' <- wrap_apps ty''
        ; let su' = cvtSrcUnpackedness su
        ; let ss' = cvtSrcStrictness ss
-       ; returnL $ HsBangTy (HsSrcBang NoSourceText su' ss') ty' }
+       ; returnL $ HsBangTy noExt (HsSrcBang NoSourceText su' ss') ty' }
 
 cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
 cvt_id_arg (i, str, ty)
@@ -566,7 +568,7 @@ cvt_id_arg (i, str, ty)
         ; ty' <- cvt_arg (str,ty)
         ; return $ noLoc (ConDeclField
                           { cd_fld_names
-                              = [L li $ FieldOcc (L li i') PlaceHolder]
+                              = [L li $ FieldOcc noExt (L li i')]
                           , cd_fld_type =  ty'
                           , cd_fld_doc = Nothing}) }
 
@@ -751,7 +753,7 @@ cvtLocalDecs doc 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 (ValBindsIn (listToBag binds) sigs)) }
+       ; return (HsValBinds (ValBinds noExt (listToBag binds) sigs)) }
 
 cvtClause :: HsMatchContext RdrName
           -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
@@ -770,11 +772,11 @@ cvtClause ctxt (Clause ps body wheres)
 cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)
 cvtl e = wrapL (cvt e)
   where
-    cvt (VarE s)        = do { s' <- vName s; return $ HsVar (noLoc s') }
-    cvt (ConE s)        = do { s' <- cName s; return $ HsVar (noLoc s') }
+    cvt (VarE s)        = do { s' <- vName s; return $ HsVar noExt (noLoc s') }
+    cvt (ConE s)        = do { s' <- cName s; return $ HsVar noExt (noLoc s') }
     cvt (LitE l)
-      | overloadedLit l = go cvtOverLit HsOverLit isCompoundHsOverLit
-      | otherwise       = go cvtLit     HsLit     isCompoundHsLit
+      | overloadedLit l = go cvtOverLit (HsOverLit noExt) isCompoundHsOverLit
+      | otherwise       = go cvtLit     (HsLit     noExt) isCompoundHsLit
       where
         go :: (Lit -> CvtM (l GhcPs))
            -> (l GhcPs -> HsExpr GhcPs)
@@ -783,55 +785,63 @@ cvtl e = wrapL (cvt e)
         go cvt_lit mk_expr is_compound_lit = do
           l' <- cvt_lit l
           let e' = mk_expr l'
-          return $ if is_compound_lit l' then HsPar (noLoc e') else e'
+          return $ if is_compound_lit l' then HsPar noExt (noLoc e') else e'
     cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y
-                                   ; return $ HsApp (mkLHsPar x') (mkLHsPar y')}
+                                   ; return $ HsApp noExt (mkLHsPar x')
+                                                          (mkLHsPar y')}
     cvt (AppE x y)            = do { x' <- cvtl x; y' <- cvtl y
-                                   ; return $ HsApp (mkLHsPar x') (mkLHsPar y')}
+                                   ; return $ HsApp noExt (mkLHsPar x')
+                                                          (mkLHsPar y')}
     cvt (AppTypeE e t) = do { e' <- cvtl e
                             ; t' <- cvtType t
                             ; tp <- wrap_apps t'
-                            ; return $ HsAppType e' $ mkHsWildCardBndrs tp }
+                            ; return $ HsAppType (mkHsWildCardBndrs tp) e' }
     cvt (LamE [] e)    = cvt e -- Degenerate case. We convert the body as its
                                -- own expression to avoid pretty-printing
                                -- oddities that can result from zero-argument
                                -- lambda expressions. See #13856.
     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
                             ; let pats = map parenthesizeCompoundPat ps'
-                            ; return $ HsLam (mkMatchGroup FromSource
+                            ; return $ HsLam noExt (mkMatchGroup FromSource
                                              [mkSimpleMatch LambdaExpr
                                              pats e'])}
     cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch LambdaExpr) ms
-                            ; return $ HsLamCase (mkMatchGroup FromSource ms')
+                            ; return $ HsLamCase noExt
+                                                   (mkMatchGroup FromSource ms')
                             }
-    cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar e' }
+    cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar noExt e' }
                                  -- Note [Dropping constructors]
                                  -- Singleton tuples treated like nothing (just parens)
     cvt (TupE es)      = do { es' <- mapM cvtl es
-                            ; return $ ExplicitTuple (map (noLoc . Present) es')
-                                                      Boxed }
+                            ; return $ ExplicitTuple noExt
+                                             (map (noLoc . (Present noExt)) es')
+                                                                         Boxed }
     cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es
-                                   ; return $ ExplicitTuple
-                                           (map (noLoc . Present) es') Unboxed }
+                                   ; return $ ExplicitTuple noExt
+                                           (map (noLoc . (Present noExt)) es')
+                                                                       Unboxed }
     cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
                                        ; unboxedSumChecks alt arity
-                                       ; return $ ExplicitSum
-                                             alt arity e' placeHolderType }
+                                       ; return $ ExplicitSum noExt
+                                                                   alt arity e'}
     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
-                            ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
+                            ; return $ HsIf noExt (Just noSyntaxExpr) x' y' z' }
     cvt (MultiIfE alts)
       | null alts      = failWith (text "Multi-way if-expression with no alternatives")
       | otherwise      = do { alts' <- mapM cvtpair alts
                             ; return $ HsMultiIf placeHolderType alts' }
     cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (text "a let expression") ds
-                            ; e' <- cvtl e; return $ HsLet (noLoc ds') e' }
+                            ; e' <- cvtl e; return $ HsLet noExt (noLoc ds') e'}
     cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
-                            ; return $ HsCase e' (mkMatchGroup FromSource ms') }
+                            ; return $ HsCase noExt e'
+                                                 (mkMatchGroup FromSource ms') }
     cvt (DoE ss)       = cvtHsDo DoExpr ss
     cvt (CompE ss)     = cvtHsDo ListComp ss
-    cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' }
+    cvt (ArithSeqE dd) = do { dd' <- cvtDD dd
+                            ; return $ ArithSeq noExt Nothing dd' }
     cvt (ListE xs)
-      | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s); return (HsLit l') }
+      | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s)
+                                          ; return (HsLit noExt l') }
              -- Note [Converting strings]
       | otherwise       = do { xs' <- mapM cvtl xs
                              ; return $ ExplicitList placeHolderType Nothing xs'
@@ -839,19 +849,23 @@ cvtl e = wrapL (cvt e)
 
     -- Infix expressions
     cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
-                                          ; wrapParL HsPar $
-                                            OpApp (mkLHsPar x') s' undefined (mkLHsPar y') }
+                                          ; wrapParL (HsPar noExt) $
+                                            OpApp noExt (mkLHsPar x') s'
+                                                        (mkLHsPar y') }
                                             -- Parenthesise both arguments and result,
                                             -- to ensure this operator application does
                                             -- does not get re-associated
                             -- See Note [Operator association]
     cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
-                                          ; wrapParL HsPar $ SectionR s' y' }
+                                          ; wrapParL (HsPar noExt) $
+                                                          SectionR noExt s' y' }
                                             -- See Note [Sections in HsSyn] in HsExpr
     cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
-                                          ; wrapParL HsPar $ SectionL x' s' }
+                                          ; wrapParL (HsPar noExt) $
+                                                          SectionL noExt x' s' }
 
-    cvt (InfixE Nothing  s Nothing ) = do { s' <- cvtl s; return $ HsPar s' }
+    cvt (InfixE Nothing  s Nothing ) = do { s' <- cvtl s
+                                          ; return $ HsPar noExt s' }
                                        -- Can I indicate this is an infix thing?
                                        -- Note [Dropping constructors]
 
@@ -861,9 +875,9 @@ cvtl e = wrapL (cvt e)
                                             _ -> mkLHsPar x'
                               ; cvtOpApp x'' s y } --  Note [Converting UInfix]
 
-    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar e' }
+    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar noExt e' }
     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
-                              ; return $ ExprWithTySig e' (mkLHsSigWcType t') }
+                              ; return $ ExprWithTySig (mkLHsSigWcType t') e' }
     cvt (RecConE c flds) = do { c' <- cNameL c
                               ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds
                               ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
@@ -872,9 +886,9 @@ cvtl e = wrapL (cvt e)
                                   <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))
                                            flds
                               ; return $ mkRdrRecordUpd e' flds' }
-    cvt (StaticE e)      = fmap (HsStatic placeHolderNames) $ cvtl e
-    cvt (UnboundVarE s)  = do { s' <- vName s; return $ HsVar (noLoc s') }
-    cvt (LabelE s)       = do { return $ HsOverLabel Nothing (fsLit s) }
+    cvt (StaticE e)      = fmap (HsStatic noExt) $ cvtl e
+    cvt (UnboundVarE s)  = do { s' <- vName s; return $ HsVar noExt (noLoc s') }
+    cvt (LabelE s)       = do { return $ HsOverLabel noExt Nothing (fsLit s) }
 
 {- Note [Dropping constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -965,7 +979,7 @@ cvtOpApp x op1 (UInfixE y op2 z)
 cvtOpApp x op y
   = do { op' <- cvtl op
        ; y' <- cvtl y
-       ; return (OpApp x op' undefined y') }
+       ; return (OpApp noExt x op' y') }
 
 -------------------------------------
 --      Do notation and statements
@@ -982,7 +996,7 @@ cvtHsDo do_or_lc stmts
                     L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body))
                     _ -> failWith (bad_last last')
 
-        ; return $ HsDo do_or_lc (noLoc (stmts'' ++ [last''])) placeHolderType }
+        ; return $ HsDo noExt do_or_lc (noLoc (stmts'' ++ [last''])) }
   where
     bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon
                          , nest 2 $ Outputable.ppr stmt
@@ -997,8 +1011,9 @@ cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt
 cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (text "a let binding") ds
                             ; returnL $ LetStmt (noLoc ds') }
 cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noExpr noSyntaxExpr placeHolderType }
-                       where
-                         cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }
+  where
+    cvt_one ds = do { ds' <- cvtStmts ds
+                    ; return (ParStmtBlock noExt ds' undefined noSyntaxExpr) }
 
 cvtMatch :: HsMatchContext RdrName
          -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
@@ -1024,13 +1039,13 @@ cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
 
 cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)
 cvtOverLit (IntegerL i)
-  = do { force i; return $ mkHsIntegral   (mkIntegralLit i)   placeHolderType}
+  = do { force i; return $ mkHsIntegral   (mkIntegralLit i) }
 cvtOverLit (RationalL r)
-  = do { force r; return $ mkHsFractional (mkFractionalLit r) placeHolderType}
+  = do { force r; return $ mkHsFractional (mkFractionalLit r) }
 cvtOverLit (StringL s)
   = do { let { s' = mkFastString s }
        ; force s'
-       ; return $ mkHsIsString (quotedSourceText s) s' placeHolderType
+       ; return $ mkHsIsString (quotedSourceText s) s'
        }
 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
 -- An Integer is like an (overloaded) '3' in a Haskell source program
@@ -1061,9 +1076,9 @@ cvtLit :: Lit -> CvtM (HsLit GhcPs)
 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim NoSourceText i }
 cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim NoSourceText w }
 cvtLit (FloatPrimL f)
-  = do { force f; return $ HsFloatPrim def (mkFractionalLit f) }
+  = do { force f; return $ HsFloatPrim noExt (mkFractionalLit f) }
 cvtLit (DoublePrimL f)
-  = do { force f; return $ HsDoublePrim def (mkFractionalLit f) }
+  = do { force f; return $ HsDoublePrim noExt (mkFractionalLit f) }
 cvtLit (CharL c)       = do { force c; return $ HsChar NoSourceText c }
 cvtLit (CharPrimL c)   = do { force c; return $ HsCharPrim NoSourceText c }
 cvtLit (StringL s)     = do { let { s' = mkFastString s }
@@ -1092,40 +1107,46 @@ cvtp (TH.LitP l)
                             ; return (mkNPat (noLoc l') Nothing) }
                                   -- Not right for negative patterns;
                                   -- need to think about that!
-  | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat l' }
-cvtp (TH.VarP s)       = do { s' <- vName s; return $ Hs.VarPat (noLoc s') }
-cvtp (TupP [p])        = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors]
-cvtp (TupP ps)         = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed   [] }
-cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] }
+  | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat noExt l' }
+cvtp (TH.VarP s)       = do { s' <- vName s
+                            ; return $ Hs.VarPat noExt (noLoc s') }
+cvtp (TupP [p])        = do { p' <- cvtPat p; return $ ParPat noExt p' }
+                                         -- Note [Dropping constructors]
+cvtp (TupP ps)         = do { ps' <- cvtPats ps
+                            ; return $ TuplePat noExt ps' Boxed }
+cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps
+                            ; return $ TuplePat noExt ps' Unboxed }
 cvtp (UnboxedSumP p alt arity)
                        = do { p' <- cvtPat p
                             ; unboxedSumChecks alt arity
-                            ; return $ SumPat p' alt arity placeHolderType }
+                            ; return $ SumPat noExt p' alt arity }
 cvtp (ConP s ps)       = do { s' <- cNameL s; ps' <- cvtPats ps
                             ; pps <- mapM wrap_conpat ps'
                             ; return $ ConPatIn s' (PrefixCon pps) }
 cvtp (InfixP p1 s p2)  = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
-                            ; wrapParL ParPat $
+                            ; wrapParL (ParPat noExt) $
                               ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) }
                             -- See Note [Operator association]
 cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
 cvtp (ParensP p)       = do { p' <- cvtPat p;
                             ; case p' of  -- may be wrapped ConPatIn
                                 (L _ (ParPat {})) -> return $ unLoc p'
-                                _                 -> return $ ParPat p' }
-cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat p' }
-cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat p' }
-cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
-cvtp TH.WildP          = return $ WildPat placeHolderType
+                                _                 -> return $ ParPat noExt p' }
+cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat noExt p' }
+cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat noExt p' }
+cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p
+                            ; return $ AsPat noExt s' p' }
+cvtp TH.WildP          = return $ WildPat noExt
 cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
                             ; return $ ConPatIn c'
                                      $ Hs.RecCon (HsRecFields fs' Nothing) }
 cvtp (ListP ps)        = do { ps' <- cvtPats ps
-                            ; return $ ListPat ps' placeHolderType Nothing }
+                            ; return
+                                   $ ListPat noExt ps' placeHolderType Nothing }
 cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t
-                            ; return $ SigPatIn p' (mkLHsSigWcType t') }
+                            ; return $ SigPat (mkLHsSigWcType t') p' }
 cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p
-                            ; return $ ViewPat e' p' placeHolderType }
+                            ; return $ ViewPat noExt e' p'}
 
 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
 cvtPatFld (s,p)
@@ -1136,9 +1157,9 @@ cvtPatFld (s,p)
                                      , hsRecPun      = False}) }
 
 wrap_conpat :: Hs.LPat GhcPs -> CvtM (Hs.LPat GhcPs)
-wrap_conpat p@(L _ (ConPatIn _ (InfixCon{})))   = returnL $ ParPat p
+wrap_conpat p@(L _ (ConPatIn _ (InfixCon{})))   = returnL $ ParPat noExt p
 wrap_conpat p@(L _ (ConPatIn _ (PrefixCon []))) = return p
-wrap_conpat p@(L _ (ConPatIn _ (PrefixCon _)))  = returnL $ ParPat p
+wrap_conpat p@(L _ (ConPatIn _ (PrefixCon _)))  = returnL $ ParPat noExt p
 wrap_conpat p                                   = return p
 
 {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
@@ -1164,11 +1185,11 @@ cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)
 cvt_tv (TH.PlainTV nm)
   = do { nm' <- tNameL nm
-       ; returnL $ UserTyVar nm' }
+       ; returnL $ UserTyVar noExt nm' }
 cvt_tv (TH.KindedTV nm ki)
   = do { nm' <- tNameL nm
        ; ki' <- cvtKind ki
-       ; returnL $ KindedTyVar nm' ki' }
+       ; returnL $ KindedTyVar noExt nm' ki' }
 
 cvtRole :: TH.Role -> Maybe Coercion.Role
 cvtRole TH.NominalR          = Just Coercion.Nominal
@@ -1205,17 +1226,18 @@ cvtTypeKind ty_str ty
              | tys' `lengthIs` n         -- Saturated
              -> if n==1 then return (head tys') -- Singleton tuples treated
                                                 -- like nothing (ie just parens)
-                        else returnL (HsTupleTy HsBoxedOrConstraintTuple tys')
+                        else returnL (HsTupleTy noExt
+                                                  HsBoxedOrConstraintTuple tys')
              | n == 1
              -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
              | otherwise
-             -> mk_apps (HsTyVar NotPromoted
+             -> mk_apps (HsTyVar noExt NotPromoted
                                (noLoc (getRdrName (tupleTyCon Boxed n)))) tys'
            UnboxedTupleT n
              | tys' `lengthIs` n         -- Saturated
-             -> returnL (HsTupleTy HsUnboxedTuple tys')
+             -> returnL (HsTupleTy noExt HsUnboxedTuple tys')
              | otherwise
-             -> mk_apps (HsTyVar NotPromoted
+             -> mk_apps (HsTyVar noExt NotPromoted
                              (noLoc (getRdrName (tupleTyCon Unboxed n)))) tys'
            UnboxedSumT n
              | n < 2
@@ -1224,29 +1246,33 @@ cvtTypeKind ty_str ty
                         , nest 2 $
                             text "Sums must have an arity of at least 2" ]
              | tys' `lengthIs` n -- Saturated
-             -> returnL (HsSumTy tys')
+             -> returnL (HsSumTy noExt tys')
              | otherwise
-             -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (sumTyCon n))))
+             -> mk_apps (HsTyVar noExt NotPromoted
+                                              (noLoc (getRdrName (sumTyCon n))))
                         tys'
            ArrowT
              | [x',y'] <- tys' -> do
                  x'' <- case x' of
-                          L _ HsFunTy{}    -> returnL (HsParTy x')
-                          L _ HsForAllTy{} -> returnL (HsParTy x') -- #14646
+                          L _ HsFunTy{}    -> returnL (HsParTy noExt x')
+                          L _ HsForAllTy{} -> returnL (HsParTy noExt x')
+                                                                       -- #14646
                           _                -> return x'
-                 returnL (HsFunTy x'' y')
+                 returnL (HsFunTy noExt x'' y')
              | otherwise ->
-                  mk_apps (HsTyVar NotPromoted (noLoc (getRdrName funTyCon)))
+                  mk_apps (HsTyVar noExt NotPromoted
+                           (noLoc (getRdrName funTyCon)))
                           tys'
            ListT
-             | [x']    <- tys' -> returnL (HsListTy x')
+             | [x']    <- tys' -> returnL (HsListTy noExt x')
              | otherwise ->
-                  mk_apps (HsTyVar NotPromoted (noLoc (getRdrName listTyCon)))
+                  mk_apps (HsTyVar noExt NotPromoted
+                           (noLoc (getRdrName listTyCon)))
                            tys'
            VarT nm -> do { nm' <- tNameL nm
-                         ; mk_apps (HsTyVar NotPromoted nm') tys' }
+                         ; mk_apps (HsTyVar noExt NotPromoted nm') tys' }
            ConT nm -> do { nm' <- tconName nm
-                         ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' }
+                         ; mk_apps (HsTyVar noExt NotPromoted (noLoc nm')) tys'}
 
            ForallT tvs cxt ty
              | null tys'
@@ -1262,11 +1288,11 @@ cvtTypeKind ty_str ty
            SigT ty ki
              -> do { ty' <- cvtType ty
                    ; ki' <- cvtKind ki
-                   ; mk_apps (HsKindSig ty' ki') tys'
+                   ; mk_apps (HsKindSig noExt ty' ki') tys'
                    }
 
            LitT lit
-             -> returnL (HsTyLit (cvtTyLit lit))
+             -> returnL (HsTyLit noExt (cvtTyLit lit))
 
            WildCardT
              -> mk_apps mkAnonWildCardTy tys'
@@ -1275,7 +1301,7 @@ cvtTypeKind ty_str ty
              -> do { s'  <- tconName s
                    ; t1' <- cvtType t1
                    ; t2' <- cvtType t2
-                   ; mk_apps (HsTyVar NotPromoted (noLoc s')) [t1', t2']
+                   ; mk_apps (HsTyVar noExt NotPromoted (noLoc s')) [t1', t2']
                    }
 
            UInfixT t1 s t2
@@ -1287,49 +1313,49 @@ cvtTypeKind ty_str ty
 
            ParensT t
              -> do { t' <- cvtType t
-                   ; returnL $ HsParTy t'
+                   ; returnL $ HsParTy noExt t'
                    }
 
            PromotedT nm -> do { nm' <- cName nm
-                              ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' }
+                              ; mk_apps (HsTyVar noExt NotPromoted
+                                                             (noLoc nm')) tys' }
                  -- Promoted data constructor; hence cName
 
            PromotedTupleT n
              | n == 1
              -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
              | m == n   -- Saturated
-             -> do  { let kis = replicate m placeHolderKind
-                    ; returnL (HsExplicitTupleTy kis tys')
-                    }
+             -> returnL (HsExplicitTupleTy noExt tys')
              | otherwise
-             -> mk_apps (HsTyVar NotPromoted
+             -> mk_apps (HsTyVar noExt NotPromoted
                                (noLoc (getRdrName (tupleDataCon Boxed n)))) tys'
              where
                m = length tys'
 
            PromotedNilT
-             -> returnL (HsExplicitListTy Promoted placeHolderKind [])
+             -> returnL (HsExplicitListTy noExt Promoted [])
 
            PromotedConsT  -- See Note [Representing concrete syntax in types]
                           -- in Language.Haskell.TH.Syntax
-             | [ty1, L _ (HsExplicitListTy ip _ tys2)] <- tys'
-             -> returnL (HsExplicitListTy ip placeHolderKind (ty1:tys2))
+             | [ty1, L _ (HsExplicitListTy _ ip tys2)] <- tys'
+             -> returnL (HsExplicitListTy noExt ip (ty1:tys2))
              | otherwise
-             -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName consDataCon)))
+             -> mk_apps (HsTyVar noExt NotPromoted
+                         (noLoc (getRdrName consDataCon)))
                         tys'
 
            StarT
-             -> returnL (HsTyVar NotPromoted (noLoc
+             -> returnL (HsTyVar noExt NotPromoted (noLoc
                                               (getRdrName liftedTypeKindTyCon)))
 
            ConstraintT
-             -> returnL (HsTyVar NotPromoted
+             -> returnL (HsTyVar noExt NotPromoted
                               (noLoc (getRdrName constraintKindTyCon)))
 
            EqualityT
-             | [x',y'] <- tys' -> returnL (HsEqTy x' y')
+             | [x',y'] <- tys' -> returnL (HsEqTy noExt x' y')
              | otherwise ->
-                   mk_apps (HsTyVar NotPromoted
+                   mk_apps (HsTyVar noExt NotPromoted
                             (noLoc (getRdrName eqPrimTyCon))) tys'
 
            _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
@@ -1341,15 +1367,15 @@ mk_apps head_ty []       = returnL head_ty
 mk_apps head_ty (ty:tys) =
   do { head_ty' <- returnL head_ty
      ; p_ty      <- add_parens ty
-     ; mk_apps (HsAppTy head_ty' p_ty) tys }
+     ; mk_apps (HsAppTy noExt head_ty' p_ty) tys }
   where
     -- See Note [Adding parens for splices]
     add_parens t
-      | isCompoundHsType t = returnL (HsParTy t)
+      | isCompoundHsType t = returnL (HsParTy noExt t)
       | otherwise          = return t
 
 wrap_apps  :: LHsType GhcPs -> CvtM (LHsType GhcPs)
-wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy t)
+wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy noExt t)
 wrap_apps t                  = return t
 
 -- ---------------------------------------------------------------------
@@ -1380,7 +1406,7 @@ mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs)
 mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL
     where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs)
           go arg ret_ty = do { ret_ty_l <- returnL ret_ty
-                             ; return (HsFunTy arg ret_ty_l) }
+                             ; return (HsFunTy noExt arg ret_ty_l) }
 
 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType GhcPs])
 split_ty_app ty = go ty []
@@ -1398,17 +1424,17 @@ cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)
 cvtOpAppT :: LHsType GhcPs -> RdrName -> LHsType GhcPs -> LHsType GhcPs
 cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _)
   = L (combineSrcSpans loc1 loc2) $
-    HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noLoc op)] ++ t2')
+    HsAppsTy noExt (t1' ++ [noLoc $ HsAppInfix noExt (noLoc op)] ++ t2')
   where
-    t1' | L _ (HsAppsTy t1s) <- t1
+    t1' | L _ (HsAppsTy t1s) <- t1
         = t1s
         | otherwise
-        = [noLoc $ HsAppPrefix t1]
+        = [noLoc $ HsAppPrefix noExt t1]
 
-    t2' | L _ (HsAppsTy t2s) <- t2
+    t2' | L _ (HsAppsTy t2s) <- t2
         = t2s
         | otherwise
-        = [noLoc $ HsAppPrefix t2]
+        = [noLoc $ HsAppPrefix noExt t2]
 
 cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)
 cvtKind = cvtTypeKind "kind"
@@ -1448,13 +1474,16 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
   | null univs, null reqs = do { l   <- getL
                                ; ty' <- cvtType (ForallT exis provs ty)
                                ; return $ L l (HsQualTy { hst_ctxt = L l []
+                                                        , hst_xqual = noExt
                                                         , hst_body = ty' }) }
   | null reqs             = do { l      <- getL
                                ; univs' <- hsQTvExplicit <$> cvtTvs univs
                                ; ty'    <- cvtType (ForallT exis provs ty)
                                ; let forTy = HsForAllTy { hst_bndrs = univs'
+                                                        , hst_xforall = noExt
                                                         , hst_body = L l cxtTy }
                                      cxtTy = HsQualTy { hst_ctxt = L l []
+                                                      , hst_xqual = noExt
                                                       , hst_body = ty' }
                                ; return $ L l forTy }
   | otherwise             = cvtType (ForallT univs reqs (ForallT exis provs ty))
@@ -1504,15 +1533,16 @@ mkHsForAllTy :: [TH.TyVarBndr]
              -> SrcSpan
              -- ^ The location of the returned 'LHsType' if it needs an
              --   explicit forall
-             -> LHsQTyVars name
+             -> LHsQTyVars GhcPs
              -- ^ The converted type variable binders
-             -> LHsType name
+             -> LHsType GhcPs
              -- ^ The converted rho type
-             -> LHsType name
+             -> LHsType GhcPs
              -- ^ The complete type, quantified with a forall if necessary
 mkHsForAllTy tvs loc tvs' rho_ty
   | null tvs  = rho_ty
   | otherwise = L loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
+                                   , hst_xforall = noExt
                                    , hst_body = rho_ty }
 
 -- | If passed an empty 'TH.Cxt', this simply returns the third argument
@@ -1527,15 +1557,16 @@ mkHsQualTy :: TH.Cxt
            -> SrcSpan
            -- ^ The location of the returned 'LHsType' if it needs an
            --   explicit context
-           -> LHsContext name
+           -> LHsContext GhcPs
            -- ^ The converted context
-           -> LHsType name
+           -> LHsType GhcPs
            -- ^ The converted tau type
-           -> LHsType name
+           -> LHsType GhcPs
            -- ^ The complete type, qualified with a context if necessary
 mkHsQualTy ctxt loc ctxt' ty
   | null ctxt = ty
-  | otherwise = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = ty }
+  | otherwise = L loc $ HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt'
+                                 , hst_body = ty }
 
 --------------------------------------------------------------------
 --      Turning Name back into RdrName
index 0724420..5fa0a62 100644 (file)
@@ -25,6 +25,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
                                GRHSs, pprPatBind )
 import {-# SOURCE #-} HsPat  ( LPat )
 
+import PlaceHolder
 import HsExtension
 import HsTypes
 import PprCore ()
@@ -89,7 +90,7 @@ data HsLocalBindsLR idL idR
 
 type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR)
 
-deriving instance (DataId idL, DataId idR) => Data (HsLocalBindsLR idL idR)
+deriving instance (DataIdLR idL idR) => Data (HsLocalBindsLR idL idR)
 
 -- | Haskell Value Bindings
 type HsValBinds id = HsValBindsLR id id
@@ -104,18 +105,34 @@ data HsValBindsLR idL idR
     -- Before renaming RHS; idR is always RdrName
     -- Not dependency analysed
     -- Recursive by default
-    ValBindsIn
+    ValBinds
+        (XValBinds idL idR)
         (LHsBindsLR idL idR) [LSig idR]
 
     -- | Value Bindings Out
     --
     -- After renaming RHS; idR can be Name or Id Dependency analysed,
     -- later bindings in the list may depend on earlier ones.
-  | ValBindsOut
-        [(RecFlag, LHsBinds idL)]
-        [LSig GhcRn] -- AZ: how to do this?
+  | XValBindsLR
+      (XXValBindsLR idL idR)
 
-deriving instance (DataId idL, DataId idR) => Data (HsValBindsLR idL idR)
+deriving instance (DataIdLR idL idR) => Data (HsValBindsLR idL idR)
+
+-- ---------------------------------------------------------------------
+-- Deal with ValBindsOut
+
+-- TODO: make this the only type for ValBinds
+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)
+            = NHsValBindsLR (GhcPass pL)
+
+-- ---------------------------------------------------------------------
 
 -- | Located Haskell Binding
 type LHsBind  id = LHsBindLR  id id
@@ -286,7 +303,7 @@ data HsBindLR idL idR
 
         -- For details on above see note [Api annotations] in ApiAnnotation
 
-deriving instance (DataId idL, DataId idR) => Data (HsBindLR idL idR)
+deriving instance (DataIdLR idL idR) => Data (HsBindLR idL idR)
 
         -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
         --
@@ -326,7 +343,7 @@ data PatSynBind idL idR
           psb_def  :: LPat idR,                -- ^ Right-hand side
           psb_dir  :: HsPatSynDir idR          -- ^ Directionality
   }
-deriving instance (DataId idL, DataId idR) => Data (PatSynBind idL idR)
+deriving instance (DataIdLR idL idR) => Data (PatSynBind idL idR)
 
 {-
 Note [AbsBinds]
@@ -571,10 +588,10 @@ instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
 instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
           OutputableBndrId idL, OutputableBndrId idR)
         => Outputable (HsValBindsLR idL idR) where
-  ppr (ValBindsIn binds sigs)
+  ppr (ValBinds _ binds sigs)
    = pprDeclList (pprLHsBindsForUser binds sigs)
 
-  ppr (ValBindsOut sccs sigs)
+  ppr (XValBindsLR (NValBinds sccs sigs))
     = getPprStyle $ \ sty ->
       if debugStyle sty then    -- Print with sccs showing
         vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
@@ -626,7 +643,7 @@ pprDeclList ds = pprDeeperList vcat ds
 emptyLocalBinds :: HsLocalBindsLR a b
 emptyLocalBinds = EmptyLocalBinds
 
-isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
+isEmptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool
 isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
 isEmptyLocalBinds (HsIPBinds ds)  = isEmptyIPBinds ds
 isEmptyLocalBinds EmptyLocalBinds = True
@@ -635,13 +652,13 @@ eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
 eqEmptyLocalBinds EmptyLocalBinds = True
 eqEmptyLocalBinds _               = False
 
-isEmptyValBinds :: HsValBindsLR a b -> Bool
-isEmptyValBinds (ValBindsIn ds sigs)  = isEmptyLHsBinds ds && null sigs
-isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
+isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool
+isEmptyValBinds (ValBinds _ ds sigs)  = isEmptyLHsBinds ds && null sigs
+isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs
 
-emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b
-emptyValBindsIn  = ValBindsIn emptyBag []
-emptyValBindsOut = ValBindsOut []      []
+emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b)
+emptyValBindsIn  = ValBinds noExt emptyBag []
+emptyValBindsOut = XValBindsLR (NValBinds [] [])
 
 emptyLHsBinds :: LHsBindsLR idL idR
 emptyLHsBinds = emptyBag
@@ -650,11 +667,13 @@ isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
 isEmptyLHsBinds = isEmptyBag
 
 ------------
-plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
-plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
-  = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
-plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
-  = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
+plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
+               -> HsValBinds(GhcPass a)
+plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2)
+  = ValBinds noExt (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
+plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1))
+               (XValBindsLR (NValBinds ds2 sigs2))
+  = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2))
 plusHsValBinds _ _
   = panic "HsBinds.plusHsValBinds"
 
@@ -749,7 +768,7 @@ data HsIPBinds id
         [LIPBind id]
         TcEvBinds       -- Only in typechecker output; binds
                         -- uses of the implicit parameters
-deriving instance (DataId id) => Data (HsIPBinds id)
+deriving instance (DataIdLR id id) => Data (HsIPBinds id)
 
 isEmptyIPBinds :: HsIPBinds id -> Bool
 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
@@ -773,7 +792,7 @@ 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 (DataId name) => Data (IPBind name)
+deriving instance (DataIdLR id id) => Data (IPBind id)
 
 instance (p ~ GhcPass pass, OutputableBndrId p)
        => Outputable (HsIPBinds p) where
@@ -946,7 +965,7 @@ data Sig pass
                      (Located [Located (IdP pass)])
                      (Maybe (Located (IdP pass)))
 
-deriving instance (DataId pass) => Data (Sig pass)
+deriving instance (DataIdLR pass pass) => Data (Sig pass)
 
 -- | Located Fixity Signature
 type LFixitySig pass = Located (FixitySig pass)
@@ -1196,4 +1215,4 @@ data HsPatSynDir id
   = Unidirectional
   | ImplicitBidirectional
   | ExplicitBidirectional (MatchGroup id (LHsExpr id))
-deriving instance (DataId id) => Data (HsPatSynDir id)
+deriving instance (DataIdLR id id) => Data (HsPatSynDir id)
index f29e7e2..54314a9 100644 (file)
@@ -99,7 +99,7 @@ import Name
 import BasicTypes
 import Coercion
 import ForeignCall
-import PlaceHolder ( PlaceHolder(..) )
+import PlaceHolder ( PlaceHolder, placeHolder )
 import HsExtension
 import NameSet
 
@@ -147,7 +147,7 @@ data HsDecl id
                                    -- (Includes quasi-quotes)
   | DocD        (DocDecl)          -- ^ Documentation comment declaration
   | RoleAnnotD  (RoleAnnotDecl id) -- ^ Role annotation declaration
-deriving instance (DataId id) => Data (HsDecl id)
+deriving instance (DataIdLR id id) => Data (HsDecl id)
 
 
 -- NB: all top-level fixity decls are contained EITHER
@@ -193,9 +193,9 @@ data HsGroup id
 
         hs_docs   :: [LDocDecl]
   }
-deriving instance (DataId id) => Data (HsGroup id)
+deriving instance (DataIdLR id id) => Data (HsGroup id)
 
-emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
+emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass a)
 emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
 emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }
 
@@ -210,7 +210,8 @@ emptyGroup = HsGroup { hs_tyclds = [],
                        hs_splcds = [],
                        hs_docs = [] }
 
-appendGroups :: HsGroup a -> HsGroup a -> HsGroup a
+appendGroups :: HsGroup (GhcPass a) -> HsGroup (GhcPass a)
+             -> HsGroup (GhcPass a)
 appendGroups
     HsGroup {
         hs_valds  = val_groups1,
@@ -311,7 +312,7 @@ data SpliceDecl id
   = SpliceDecl                  -- Top level splice
         (Located (HsSplice id))
         SpliceExplicitFlag
-deriving instance (DataId id) => Data (SpliceDecl id)
+deriving instance (DataIdLR id id) => Data (SpliceDecl id)
 
 instance (p ~ GhcPass pass, OutputableBndrId p)
        => Outputable (SpliceDecl p) where
@@ -534,7 +535,7 @@ data TyClDecl pass
 
         -- For details on above see note [Api annotations] in ApiAnnotation
 
-deriving instance (DataId id) => Data (TyClDecl id)
+deriving instance (DataIdLR id id) => Data (TyClDecl id)
 
 
 -- Simple classifiers for TyClDecl
@@ -629,9 +630,9 @@ hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
   = hsTvbAllKinded tyvars && rhs_annotated rhs
   where
     rhs_annotated (L _ ty) = case ty of
-      HsParTy lty  -> rhs_annotated lty
-      HsKindSig {} -> True
-      _            -> False
+      HsParTy lty  -> rhs_annotated lty
+      HsKindSig {}   -> True
+      _              -> False
 hsDeclHasCusk (DataDecl { tcdDataCusk = cusk }) = cusk
 hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
 
@@ -778,7 +779,7 @@ data TyClGroup pass  -- See Note [TyClGroups and dependency analysis]
   = TyClGroup { group_tyclds :: [LTyClDecl pass]
               , group_roles  :: [LRoleAnnotDecl pass]
               , group_instds :: [LInstDecl pass] }
-deriving instance (DataId id) => Data (TyClGroup id)
+deriving instance (DataIdLR id id) => Data (TyClGroup id)
 
 emptyTyClGroup :: TyClGroup pass
 emptyTyClGroup = TyClGroup [] [] []
@@ -894,7 +895,7 @@ data FamilyResultSig pass = -- see Note [FamilyResultSig]
 
   -- For details on above see note [Api annotations] in ApiAnnotation
 
-deriving instance (DataId pass) => Data (FamilyResultSig pass)
+deriving instance (DataIdLR pass pass) => Data (FamilyResultSig pass)
 
 -- | Located type Family Declaration
 type LFamilyDecl pass = Located (FamilyDecl pass)
@@ -917,7 +918,7 @@ data FamilyDecl pass = FamilyDecl
 
   -- For details on above see note [Api annotations] in ApiAnnotation
 
-deriving instance (DataId id) => Data (FamilyDecl id)
+deriving instance (DataIdLR id id) => Data (FamilyDecl id)
 
 -- | Located Injectivity Annotation
 type LInjectivityAnn pass = Located (InjectivityAnn pass)
@@ -944,7 +945,7 @@ 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 (DataId pass) => Data (FamilyInfo pass)
+deriving instance (DataIdLR pass pass) => Data (FamilyInfo pass)
 
 -- | Does this family declaration have a complete, user-supplied kind signature?
 famDeclHasCusk :: Maybe Bool
@@ -960,7 +961,7 @@ famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True
 -- | Does this family declaration have user-supplied return kind signature?
 hasReturnKindSignature :: FamilyResultSig a -> Bool
 hasReturnKindSignature NoSig                          = False
-hasReturnKindSignature (TyVarSig (L _ (UserTyVar _))) = False
+hasReturnKindSignature (TyVarSig (L _ (UserTyVar{}))) = False
 hasReturnKindSignature _                              = True
 
 -- | Maybe return name of the result type variable
@@ -1052,7 +1053,7 @@ data HsDataDefn pass   -- The payload of a data type defn
 
              -- For details on above see note [Api annotations] in ApiAnnotation
    }
-deriving instance (DataId id) => Data (HsDataDefn id)
+deriving instance (DataIdLR id id) => Data (HsDataDefn id)
 
 -- | Haskell Deriving clause
 type HsDeriving pass = Located [LHsDerivingClause pass]
@@ -1088,7 +1089,7 @@ data HsDerivingClause pass
       --
       -- should produce a derived instance for @C [a] (T b)@.
     }
-deriving instance (DataId id) => Data (HsDerivingClause id)
+deriving instance (DataIdLR id id) => Data (HsDerivingClause id)
 
 instance (p ~ GhcPass pass, OutputableBndrId p)
        => Outputable (HsDerivingClause p) where
@@ -1182,7 +1183,7 @@ data ConDecl pass
       , con_doc       :: Maybe LHsDocString
           -- ^ A possible Haddock comment.
       }
-deriving instance (DataId pass) => Data (ConDecl pass)
+deriving instance (DataIdLR pass pass) => Data (ConDecl pass)
 
 {- Note [GADT abstract syntax]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1415,7 +1416,7 @@ newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }
     --           'ApiAnnotation.AnnInstance',
 
     -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance DataId pass => Data (TyFamInstDecl pass)
+deriving instance DataIdLR pass pass => Data (TyFamInstDecl pass)
 
 ----------------- Data family instances -------------
 
@@ -1433,7 +1434,7 @@ newtype DataFamInstDecl pass
     --           'ApiAnnotation.AnnClose'
 
     -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance DataId pass => Data (DataFamInstDecl pass)
+deriving instance DataIdLR pass pass => Data (DataFamInstDecl pass)
 
 ----------------- Family instances (common types) -------------
 
@@ -1493,7 +1494,7 @@ data ClsInstDecl pass
     --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
 
     -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId id) => Data (ClsInstDecl id)
+deriving instance (DataIdLR id id) => Data (ClsInstDecl id)
 
 
 ----------------- Instances of all kinds -------------
@@ -1509,7 +1510,7 @@ data InstDecl pass  -- Both class and family instances
       { dfid_inst :: DataFamInstDecl pass }
   | TyFamInstD              -- type family instance
       { tfid_inst :: TyFamInstDecl pass }
-deriving instance (DataId id) => Data (InstDecl id)
+deriving instance (DataIdLR id id) => Data (InstDecl id)
 
 instance (p ~ GhcPass pass, OutputableBndrId p)
        => Outputable (TyFamInstDecl p) where
@@ -1679,7 +1680,7 @@ data DerivDecl pass = DerivDecl
 
   -- For details on above see note [Api annotations] in ApiAnnotation
         }
-deriving instance (DataId pass) => Data (DerivDecl pass)
+deriving instance (DataIdLR pass pass) => Data (DerivDecl pass)
 
 instance (p ~ GhcPass pass, OutputableBndrId p)
        => Outputable (DerivDecl p) where
@@ -1714,7 +1715,7 @@ data DefaultDecl pass
         --          'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (DefaultDecl pass)
+deriving instance (DataIdLR pass pass) => Data (DefaultDecl pass)
 
 instance (p ~ GhcPass pass, OutputableBndrId p)
        => Outputable (DefaultDecl p) where
@@ -1758,7 +1759,7 @@ data ForeignDecl pass
 
         -- For details on above see note [Api annotations] in ApiAnnotation
 
-deriving instance (DataId pass) => Data (ForeignDecl pass)
+deriving instance (DataIdLR pass pass) => Data (ForeignDecl pass)
 {-
     In both ForeignImport and ForeignExport:
         sig_ty is the type given in the Haskell code
@@ -1769,10 +1770,10 @@ deriving instance (DataId pass) => Data (ForeignDecl pass)
 -}
 
 noForeignImportCoercionYet :: PlaceHolder
-noForeignImportCoercionYet = PlaceHolder
+noForeignImportCoercionYet = placeHolder
 
 noForeignExportCoercionYet :: PlaceHolder
-noForeignExportCoercionYet = PlaceHolder
+noForeignExportCoercionYet = placeHolder
 
 -- Specification Of an imported external entity in dependence on the calling
 -- convention
@@ -1875,7 +1876,7 @@ type LRuleDecls pass = Located (RuleDecls pass)
 -- | Rule Declarations
 data RuleDecls pass = HsRules { rds_src   :: SourceText
                               , rds_rules :: [LRuleDecl pass] }
-deriving instance (DataId pass) => Data (RuleDecls pass)
+deriving instance (DataIdLR pass pass) => Data (RuleDecls pass)
 
 -- | Located Rule Declaration
 type LRuleDecl pass = Located (RuleDecl pass)
@@ -1901,7 +1902,7 @@ data RuleDecl pass
         --           'ApiAnnotation.AnnEqual',
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (RuleDecl pass)
+deriving instance (DataIdLR pass pass) => Data (RuleDecl pass)
 
 flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass]
 flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls
@@ -1918,7 +1919,7 @@ data RuleBndr pass
         --     'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (RuleBndr pass)
+deriving instance (DataIdLR pass pass) => Data (RuleBndr pass)
 
 collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass]
 collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
@@ -2009,7 +2010,7 @@ data VectDecl pass
       (LHsSigType pass)
   | HsVectInstOut               -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now
       ClsInst
-deriving instance (DataId pass) => Data (VectDecl pass)
+deriving instance (DataIdLR pass pass) => Data (VectDecl pass)
 
 lvectDeclName :: NamedThing (IdP pass) => LVectDecl pass -> Name
 lvectDeclName (L _ (HsVect _       (L _ name) _))    = getName name
@@ -2147,7 +2148,7 @@ data AnnDecl pass = HsAnnotation
       --           'ApiAnnotation.AnnClose'
 
       -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (AnnDecl pass)
+deriving instance (DataIdLR pass pass) => Data (AnnDecl pass)
 
 instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (AnnDecl p) where
     ppr (HsAnnotation _ provenance expr)
index 51d47b9..92797fa 100644 (file)
@@ -21,6 +21,7 @@ module HsExpr where
 -- friends:
 import GhcPrelude
 
+import PlaceHolder
 import HsDecls
 import HsPat
 import HsLit
@@ -83,7 +84,7 @@ type PostTcExpr  = HsExpr GhcTc
 type PostTcTable = [(Name, PostTcExpr)]
 
 noPostTcExpr :: PostTcExpr
-noPostTcExpr = HsLit (HsString NoSourceText (fsLit "noPostTcExpr"))
+noPostTcExpr = HsLit noExt (HsString NoSourceText (fsLit "noPostTcExpr"))
 
 noPostTcTable :: PostTcTable
 noPostTcTable = []
@@ -110,17 +111,17 @@ noPostTcTable = []
 data SyntaxExpr p = SyntaxExpr { syn_expr      :: HsExpr p
                                , syn_arg_wraps :: [HsWrapper]
                                , syn_res_wrap  :: HsWrapper }
-deriving instance (DataId p) => Data (SyntaxExpr p)
+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)
 noExpr :: HsExpr (GhcPass p)
-noExpr = HsLit (HsString (SourceText  "noExpr") (fsLit "noExpr"))
+noExpr = HsLit noExt (HsString (SourceText  "noExpr") (fsLit "noExpr"))
 
 noSyntaxExpr :: SyntaxExpr (GhcPass p)
                               -- Before renaming, and sometimes after,
                               -- (if the syntax slot makes no sense)
-noSyntaxExpr = SyntaxExpr { syn_expr      = HsLit (HsString NoSourceText
+noSyntaxExpr = SyntaxExpr { syn_expr      = HsLit noExt (HsString NoSourceText
                                                         (fsLit "noSyntaxExpr"))
                           , syn_arg_wraps = []
                           , syn_res_wrap  = WpHole }
@@ -128,7 +129,7 @@ noSyntaxExpr = SyntaxExpr { syn_expr      = HsLit (HsString NoSourceText
 -- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the
 -- renamer), missing its HsWrappers.
 mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn
-mkRnSyntaxExpr name = SyntaxExpr { syn_expr      = HsVar $ noLoc name
+mkRnSyntaxExpr name = SyntaxExpr { syn_expr      = HsVar noExt $ noLoc name
                                  , syn_arg_wraps = []
                                  , syn_res_wrap  = WpHole }
   -- don't care about filling in syn_arg_wraps because we're clearly
@@ -279,11 +280,13 @@ information to use is the GlobalRdrEnv itself.
 
 -- | A Haskell expression.
 data HsExpr p
-  = HsVar     (Located (IdP p)) -- ^ Variable
+  = HsVar     (XVar p)
+              (Located (IdP p)) -- ^ Variable
 
                              -- See Note [Located RdrNames]
 
-  | HsUnboundVar UnboundVar  -- ^ Unbound variable; also used for "holes"
+  | HsUnboundVar (XUnboundVar p)
+                 UnboundVar  -- ^ Unbound variable; also used for "holes"
                              --   (_ or _x).
                              -- Turned from HsVar to HsUnboundVar by the
                              --   renamer, when it finds an out-of-scope
@@ -291,24 +294,31 @@ data HsExpr p
                              -- Turned into HsVar by type checker, to support
                              --   deferred type errors.
 
-  | HsConLikeOut ConLike     -- ^ After typechecker only; must be different
+  | HsConLikeOut (XConLikeOut p)
+                 ConLike     -- ^ After typechecker only; must be different
                              -- HsVar for pretty printing
 
-  | HsRecFld (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector
+  | HsRecFld  (XRecFld p)
+              (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector
                                     -- Not in use after typechecking
 
-  | HsOverLabel (Maybe (IdP p)) FastString
+  | HsOverLabel (XOverLabel p)
+                (Maybe (IdP p)) FastString
      -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels)
      --   @Just id@ means @RebindableSyntax@ is in use, and gives the id of the
      --   in-scope 'fromLabel'.
      --   NB: Not in use after typechecking
 
-  | HsIPVar   HsIPName       -- ^ Implicit parameter (not in use after typechecking)
-  | HsOverLit (HsOverLit p)  -- ^ Overloaded literals
+  | HsIPVar   (XIPVar p)
+              HsIPName   -- ^ Implicit parameter (not in use after typechecking)
+  | HsOverLit (XOverLitE p)
+              (HsOverLit p)  -- ^ Overloaded literals
 
-  | HsLit     (HsLit p)      -- ^ Simple (non-overloaded) literals
+  | HsLit     (XLitE p)
+              (HsLit p)      -- ^ Simple (non-overloaded) literals
 
-  | HsLam     (MatchGroup p (LHsExpr p))
+  | HsLam     (XLam p)
+              (MatchGroup p (LHsExpr p))
                        -- ^ Lambda abstraction. Currently always a single match
        --
        -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
@@ -316,7 +326,7 @@ data HsExpr p
 
        -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsLamCase (MatchGroup p (LHsExpr p)) -- ^ Lambda-case
+  | HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p)) -- ^ Lambda-case
        --
        -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
        --           'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen',
@@ -324,28 +334,24 @@ data HsExpr p
 
        -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsApp     (LHsExpr p) (LHsExpr p) -- ^ Application
+  | HsApp     (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application
 
-  | HsAppType (LHsExpr p) (LHsWcType p) -- ^ Visible type application
+  | HsAppType (XAppTypeE p) (LHsExpr p)  -- ^ Visible type application
        --
        -- Explicit type argument; e.g  f @Int x y
        -- NB: Has wildcards, but no implicit quantification
        --
        -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt',
 
-  -- TODO:AZ: Sort out Name
-  | HsAppTypeOut (LHsExpr p) (LHsWcType GhcRn) -- just for pretty-printing
-
-
   -- | Operator applications:
   -- NB Bracketed ops such as (+) come out as Vars.
 
   -- NB We need an expr for the operator in an OpApp/Section since
   -- the typechecker may need to apply the operator to a few types.
 
-  | OpApp       (LHsExpr p)       -- left operand
+  | OpApp       (XOpApp p)
+                (LHsExpr p)       -- left operand
                 (LHsExpr p)       -- operator
-                (PostRn p Fixity) -- Renamer adds fixity; bottom until then
                 (LHsExpr p)       -- right operand
 
   -- | Negation operator. Contains the negated expression and the name
@@ -354,18 +360,22 @@ data HsExpr p
   --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnMinus'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | NegApp      (LHsExpr p)
+  | NegApp      (XNegApp p)
+                (LHsExpr p)
                 (SyntaxExpr p)
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
   --             'ApiAnnotation.AnnClose' @')'@
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsPar       (LHsExpr p)  -- ^ Parenthesised expr; see Note [Parens in HsSyn]
+  | HsPar       (XPar p)
+                (LHsExpr p)  -- ^ Parenthesised expr; see Note [Parens in HsSyn]
 
-  | SectionL    (LHsExpr p)    -- operand; see Note [Sections in HsSyn]
+  | SectionL    (XSectionL p)
+                (LHsExpr p)    -- operand; see Note [Sections in HsSyn]
                 (LHsExpr p)    -- operator
-  | SectionR    (LHsExpr p)    -- operator; see Note [Sections in HsSyn]
+  | SectionR    (XSectionR p)
+                (LHsExpr p)    -- operator; see Note [Sections in HsSyn]
                 (LHsExpr p)    -- operand
 
   -- | Used for explicit tuples and sections thereof
@@ -375,6 +385,7 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | ExplicitTuple
+        (XExplicitTuple p)
         [LHsTupArg p]
         Boxity
 
@@ -386,17 +397,18 @@ data HsExpr p
   --  There will be multiple 'ApiAnnotation.AnnVbar', (1 - alternative) before
   --  the expression, (arity - alternative) after it
   | ExplicitSum
+          (XExplicitSum p)
           ConTag --  Alternative (one-based)
           Arity  --  Sum arity
           (LHsExpr p)
-          (PostTc p [Type])   -- the type arguments
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',
   --       'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@,
   --       'ApiAnnotation.AnnClose' @'}'@
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsCase      (LHsExpr p)
+  | HsCase      (XCase p)
+                (LHsExpr p)
                 (MatchGroup p (LHsExpr p))
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf',
@@ -405,7 +417,8 @@ data HsExpr p
   --       'ApiAnnotation.AnnElse',
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsIf        (Maybe (SyntaxExpr p)) -- cond function
+  | HsIf        (XIf p)
+                (Maybe (SyntaxExpr p)) -- cond function
                                         -- Nothing => use the built-in 'if'
                                         -- See Note [Rebindable if]
                 (LHsExpr p)    --  predicate
@@ -418,7 +431,7 @@ data HsExpr p
   --       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsMultiIf   (PostTc p Type) [LGRHS p (LHsExpr p)]
+  | HsMultiIf   (XMultiIf p) [LGRHS p (LHsExpr p)]
 
   -- | let(rec)
   --
@@ -427,7 +440,8 @@ data HsExpr p
   --       'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsLet       (LHsLocalBinds p)
+  | HsLet       (XLet p)
+                (LHsLocalBinds p)
                 (LHsExpr  p)
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',
@@ -436,11 +450,11 @@ data HsExpr p
   --             'ApiAnnotation.AnnClose'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsDo        (HsStmtContext Name)     -- The parameterisation is unimportant
+  | HsDo        (XDo p)                  -- Type of the whole expression
+                (HsStmtContext Name)     -- The parameterisation is unimportant
                                          -- because in this context we never use
                                          -- the PatGuard or ParStmt variant
                 (Located [ExprLStmt p]) -- "do":one or more stmts
-                (PostTc p Type)         -- Type of the whole expression
 
   -- | Syntactic list: [a,b,c,...]
   --
@@ -449,7 +463,7 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | ExplicitList
-                (PostTc p Type)        -- Gives type of components of list
+                (XExplicitList p)  -- Gives type of components of list
                 (Maybe (SyntaxExpr p))
                                    -- For OverloadedLists, the fromListN witness
                 [LHsExpr p]
@@ -463,7 +477,7 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | ExplicitPArr
-                (PostTc p Type)   -- type of elements of the parallel array
+                (XExplicitPArr p) -- type of elements of the parallel array
                 [LHsExpr p]
 
   -- | Record construction
@@ -473,11 +487,9 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | RecordCon
-      { rcon_con_name :: Located (IdP p)    -- The constructor name;
+      { rcon_ext      :: XRecordCon p
+      , rcon_con_name :: Located (IdP p)    -- The constructor name;
                                             --  not used after type checking
-      , rcon_con_like :: PostTc p ConLike
-                                      -- The data constructor or pattern synonym
-      , rcon_con_expr :: PostTcExpr         -- Instantiated constructor function
       , rcon_flds     :: HsRecordBinds p }  -- The fields
 
   -- | Record update
@@ -487,18 +499,9 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | RecordUpd
-      { rupd_expr :: LHsExpr p
+      { rupd_ext  :: XRecordUpd p
+      , rupd_expr :: LHsExpr p
       , rupd_flds :: [LHsRecUpdField p]
-      , rupd_cons :: PostTc p [ConLike]
-                -- Filled in by the type checker to the
-                -- _non-empty_ list of DataCons that have
-                -- all the upd'd fields
-
-      , rupd_in_tys  :: PostTc p [Type] -- Argument types of *input* record type
-      , rupd_out_tys :: PostTc p [Type] --             and  *output* record type
-                                       -- The original type can be reconstructed
-                                       -- with conLikeResTy
-      , rupd_wrap :: PostTc p HsWrapper  -- See note [Record Update HsWrapper]
       }
   -- For a type family, the arg types are of the *instance* tycon,
   -- not the family tycon
@@ -509,14 +512,10 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | ExprWithTySig
-                (LHsExpr p)
-                (LHsSigWcType p)
-
-  | ExprWithTySigOut              -- Post typechecking
-                (LHsExpr p)
-                (LHsSigWcType GhcRn)  -- Retain the signature,
+                (XExprWithTySig p)   -- Retain the signature,
                                      -- as HsSigType Name, for
                                      -- round-tripping purposes
+                (LHsExpr p)
 
   -- | Arithmetic sequence
   --
@@ -526,7 +525,7 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | ArithSeq
-                PostTcExpr
+                (XArithSeq p)
                 (Maybe (SyntaxExpr p))
                                   -- For OverloadedLists, the fromList witness
                 (ArithSeqInfo p)
@@ -542,7 +541,7 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | PArrSeq
-                PostTcExpr
+                (XPArrSeq p)
                 (ArithSeqInfo p)
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# SCC'@,
@@ -550,7 +549,8 @@ data HsExpr p
   --              'ApiAnnotation.AnnClose' @'\#-}'@
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsSCC       SourceText            -- Note [Pragma source text] in BasicTypes
+  | HsSCC       (XSCC p)
+                SourceText            -- Note [Pragma source text] in BasicTypes
                 StringLiteral         -- "set cost centre" SCC pragma
                 (LHsExpr p)           -- expr whose cost is to be measured
 
@@ -558,7 +558,8 @@ data HsExpr p
   --             'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsCoreAnn   SourceText            -- Note [Pragma source text] in BasicTypes
+  | HsCoreAnn   (XCoreAnn p)
+                SourceText            -- Note [Pragma source text] in BasicTypes
                 StringLiteral         -- hdaume: core annotation
                 (LHsExpr p)
 
@@ -570,15 +571,17 @@ data HsExpr p
   --         'ApiAnnotation.AnnClose','ApiAnnotation.AnnCloseQ'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsBracket    (HsBracket p)
+  | HsBracket    (XBracket p) (HsBracket p)
 
     -- See Note [Pending Splices]
   | HsRnBracketOut
+      (XRnBracketOut p)
       (HsBracket GhcRn)    -- Output of the renamer is the *original* renamed
                            -- expression, plus
       [PendingRnSplice]    -- _renamed_ splices to be type checked
 
   | HsTcBracketOut
+      (XTcBracketOut p)
       (HsBracket GhcRn)    -- Output of the type checker is the *original*
                            -- renamed expression, plus
       [PendingTcSplice]    -- _typechecked_ splices to be
@@ -588,7 +591,7 @@ data HsExpr p
   --         'ApiAnnotation.AnnClose'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsSpliceE  (HsSplice p)
+  | HsSpliceE  (XSpliceE p) (HsSplice p)
 
   -----------------------------------------------------------
   -- Arrow notation extension
@@ -599,7 +602,8 @@ data HsExpr p
   --          'ApiAnnotation.AnnRarrow'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsProc      (LPat p)               -- arrow abstraction, proc
+  | HsProc      (XProc p)
+                (LPat p)               -- arrow abstraction, proc
                 (LHsCmdTop p)          -- body of the abstraction
                                        -- always has an empty stack
 
@@ -608,7 +612,7 @@ data HsExpr p
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic',
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsStatic (PostRn p NameSet) -- Free variables of the body
+  | HsStatic (XStatic p) -- Free variables of the body
              (LHsExpr p)        -- Body
 
   ---------------------------------------
@@ -622,10 +626,10 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | HsArrApp             -- Arrow tail, or arrow application (f -< arg)
+        (XArrApp p)     -- type of the arrow expressions f,
+                        -- of the form a t t', where arg :: t
         (LHsExpr p)     -- arrow expression, f
         (LHsExpr p)     -- input expression, arg
-        (PostTc p Type) -- type of the arrow expressions f,
-                        -- of the form a t t', where arg :: t
         HsArrAppType    -- higher-order (-<<) or first-order (-<)
         Bool            -- True => right-to-left (f -< arg)
                         -- False => left-to-right (arg >- f)
@@ -635,6 +639,7 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | HsArrForm            -- Command formation,  (| e cmd1 .. cmdn |)
+        (XArrForm p)
         (LHsExpr p)      -- the operator
                          -- after type-checking, a type abstraction to be
                          -- applied to the type of the local environment tuple
@@ -646,10 +651,12 @@ data HsExpr p
   -- Haskell program coverage (Hpc) Support
 
   | HsTick
+     (XTick p)
      (Tickish (IdP p))
      (LHsExpr p)                       -- sub-expression
 
   | HsBinTick
+     (XBinTick p)
      Int                                -- module-local tick number for True
      Int                                -- module-local tick number for False
      (LHsExpr p)                        -- sub-expression
@@ -665,6 +672,7 @@ data HsExpr p
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | HsTickPragma                      -- A pragma introduced tick
+     (XTickPragma p)
      SourceText                       -- Note [Pragma source text] in BasicTypes
      (StringLiteral,(Int,Int),(Int,Int))
                                       -- external span for this tick
@@ -677,24 +685,26 @@ data HsExpr p
   -- These constructors only appear temporarily in the parser.
   -- The renamer translates them into the Right Thing.
 
-  | EWildPat                 -- wildcard
+  | EWildPat (XEWildPat p)        -- wildcard
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | EAsPat      (Located (IdP p)) -- as pattern
+  | EAsPat      (XEAsPat p)
+                (Located (IdP p)) -- as pattern
                 (LHsExpr p)
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | EViewPat    (LHsExpr p) -- view pattern
+  | EViewPat    (XEViewPat p)
+                (LHsExpr p) -- view pattern
                 (LHsExpr p)
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | ELazyPat    (LHsExpr p) -- ~ pattern
+  | ELazyPat    (XELazyPat p) (LHsExpr p) -- ~ pattern
 
 
   ---------------------------------------
@@ -703,10 +713,138 @@ data HsExpr p
   -- See Note [Detecting forced eta expansion] in DsExpr. This invariant
   -- is maintained by HsUtils.mkHsWrap.
 
-  |  HsWrap     HsWrapper    -- TRANSLATION
+  |  HsWrap     (XWrap p)
+                HsWrapper    -- TRANSLATION
                 (HsExpr p)
 
-deriving instance (DataId p) => 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
+      { rupd_cons :: [ConLike]
+                -- Filled in by the type checker to the
+                -- _non-empty_ list of DataCons that have
+                -- all the upd'd fields
+
+      , rupd_in_tys  :: [Type] -- Argument types of *input* record type
+      , rupd_out_tys :: [Type] --             and  *output* record type
+                               -- The original type can be reconstructed
+                               -- with conLikeResTy
+      , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper]
+      } deriving Data
+
+-- ---------------------------------------------------------------------
+
+type instance XVar           (GhcPass _) = PlaceHolder
+type instance XUnboundVar    (GhcPass _) = PlaceHolder
+type instance XConLikeOut    (GhcPass _) = PlaceHolder
+type instance XRecFld        (GhcPass _) = PlaceHolder
+type instance XOverLabel     (GhcPass _) = PlaceHolder
+type instance XIPVar         (GhcPass _) = PlaceHolder
+type instance XOverLitE      (GhcPass _) = PlaceHolder
+type instance XLitE          (GhcPass _) = PlaceHolder
+type instance XLam           (GhcPass _) = PlaceHolder
+type instance XLamCase       (GhcPass _) = PlaceHolder
+type instance XApp           (GhcPass _) = PlaceHolder
+
+type instance XAppTypeE      GhcPs = LHsWcType GhcPs
+type instance XAppTypeE      GhcRn = LHsWcType GhcRn
+type instance XAppTypeE      GhcTc = LHsWcType GhcRn
+
+type instance XOpApp         GhcPs = PlaceHolder
+type instance XOpApp         GhcRn = Fixity
+type instance XOpApp         GhcTc = Fixity
+
+type instance XNegApp        (GhcPass _) = PlaceHolder
+type instance XPar           (GhcPass _) = PlaceHolder
+type instance XSectionL      (GhcPass _) = PlaceHolder
+type instance XSectionR      (GhcPass _) = PlaceHolder
+type instance XExplicitTuple (GhcPass _) = PlaceHolder
+
+type instance XExplicitSum   GhcPs = PlaceHolder
+type instance XExplicitSum   GhcRn = PlaceHolder
+type instance XExplicitSum   GhcTc = [Type]
+
+type instance XCase          (GhcPass _) = PlaceHolder
+type instance XIf            (GhcPass _) = PlaceHolder
+
+type instance XMultiIf       GhcPs = PlaceHolder
+type instance XMultiIf       GhcRn = PlaceHolder
+type instance XMultiIf       GhcTc = Type
+
+type instance XLet           (GhcPass _) = PlaceHolder
+
+type instance XDo            GhcPs = PlaceHolder
+type instance XDo            GhcRn = PlaceHolder
+type instance XDo            GhcTc = Type
+
+type instance XExplicitList  GhcPs = PlaceHolder
+type instance XExplicitList  GhcRn = PlaceHolder
+type instance XExplicitList  GhcTc = Type
+
+type instance XExplicitPArr  GhcPs = PlaceHolder
+type instance XExplicitPArr  GhcRn = PlaceHolder
+type instance XExplicitPArr  GhcTc = Type
+
+type instance XRecordCon     GhcPs = PlaceHolder
+type instance XRecordCon     GhcRn = PlaceHolder
+type instance XRecordCon     GhcTc = RecordConTc
+
+type instance XRecordUpd     GhcPs = PlaceHolder
+type instance XRecordUpd     GhcRn = PlaceHolder
+type instance XRecordUpd     GhcTc = RecordUpdTc
+
+type instance XExprWithTySig GhcPs = (LHsSigWcType GhcPs)
+type instance XExprWithTySig GhcRn = (LHsSigWcType GhcRn)
+type instance XExprWithTySig GhcTc = (LHsSigWcType GhcRn)
+
+type instance XArithSeq      GhcPs = PlaceHolder
+type instance XArithSeq      GhcRn = PlaceHolder
+type instance XArithSeq      GhcTc = PostTcExpr
+
+type instance XPArrSeq       GhcPs = PlaceHolder
+type instance XPArrSeq       GhcRn = PlaceHolder
+type instance XPArrSeq       GhcTc = PostTcExpr
+
+type instance XSCC           (GhcPass _) = PlaceHolder
+type instance XCoreAnn       (GhcPass _) = PlaceHolder
+type instance XBracket       (GhcPass _) = PlaceHolder
+
+type instance XRnBracketOut  (GhcPass _) = PlaceHolder
+type instance XTcBracketOut  (GhcPass _) = PlaceHolder
+
+type instance XSpliceE       (GhcPass _) = PlaceHolder
+type instance XProc          (GhcPass _) = PlaceHolder
+
+type instance XStatic        GhcPs = PlaceHolder
+type instance XStatic        GhcRn = NameSet
+type instance XStatic        GhcTc = NameSet
+
+type instance XArrApp        GhcPs = PlaceHolder
+type instance XArrApp        GhcRn = PlaceHolder
+type instance XArrApp        GhcTc = Type
+
+type instance XArrForm       (GhcPass _) = PlaceHolder
+type instance XTick          (GhcPass _) = PlaceHolder
+type instance XBinTick       (GhcPass _) = PlaceHolder
+type instance XTickPragma    (GhcPass _) = PlaceHolder
+type instance XEWildPat      (GhcPass _) = PlaceHolder
+type instance XEAsPat        (GhcPass _) = PlaceHolder
+type instance XEViewPat      (GhcPass _) = PlaceHolder
+type instance XELazyPat      (GhcPass _) = PlaceHolder
+type instance XWrap          (GhcPass _) = PlaceHolder
+type instance XXExpr         (GhcPass _) = PlaceHolder
+
+-- ---------------------------------------------------------------------
 
 -- | Located Haskell Tuple Argument
 --
@@ -721,13 +859,23 @@ type LHsTupArg id = Located (HsTupArg id)
 
 -- | Haskell Tuple Argument
 data HsTupArg id
-  = Present (LHsExpr id)     -- ^ The argument
-  | Missing (PostTc id Type) -- ^ The argument is missing, but this is its type
-deriving instance (DataId id) => 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
+
+type instance XMissing         GhcPs = PlaceHolder
+type instance XMissing         GhcRn = PlaceHolder
+type instance XMissing         GhcTc = Type
+
+type instance XXTupArg         (GhcPass _) = PlaceHolder
 
 tupArgPresent :: LHsTupArg id -> Bool
 tupArgPresent (L _ (Present {})) = True
 tupArgPresent (L _ (Missing {})) = False
+tupArgPresent (L _ (XTupArg {})) = False
 
 {-
 Note [Parens in HsSyn]
@@ -818,12 +966,11 @@ isQuietHsExpr :: HsExpr id -> Bool
 -- Parentheses do display something, but it gives little info and
 -- if we go deeper when we go inside them then we get ugly things
 -- like (...)
-isQuietHsExpr (HsPar _)          = True
+isQuietHsExpr (HsPar {})        = True
 -- applications don't display anything themselves
-isQuietHsExpr (HsApp _ _)        = True
-isQuietHsExpr (HsAppType _ _)    = True
-isQuietHsExpr (HsAppTypeOut _ _) = True
-isQuietHsExpr (OpApp _ _ _ _)    = True
+isQuietHsExpr (HsApp {})        = True
+isQuietHsExpr (HsAppType {})    = True
+isQuietHsExpr (OpApp {})        = True
 isQuietHsExpr _ = False
 
 pprBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
@@ -836,38 +983,37 @@ ppr_lexpr e = ppr_expr (unLoc e)
 
 ppr_expr :: forall p. (OutputableBndrId (GhcPass p))
          => HsExpr (GhcPass p) -> SDoc
-ppr_expr (HsVar (L _ v))  = pprPrefixOcc v
-ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv)
-ppr_expr (HsConLikeOut c) = pprPrefixOcc c
-ppr_expr (HsIPVar v)      = ppr v
-ppr_expr (HsOverLabel _ l)= char '#' <> ppr l
-ppr_expr (HsLit lit)      = ppr lit
-ppr_expr (HsOverLit lit)  = ppr lit
-ppr_expr (HsPar e)        = parens (ppr_lexpr e)
-
-ppr_expr (HsCoreAnn stc (StringLiteral sta s) e)
+ppr_expr (HsVar (L _ v))  = pprPrefixOcc v
+ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv)
+ppr_expr (HsConLikeOut c) = pprPrefixOcc c
+ppr_expr (HsIPVar v)      = ppr v
+ppr_expr (HsOverLabel _ l)= char '#' <> ppr l
+ppr_expr (HsLit lit)      = ppr lit
+ppr_expr (HsOverLit lit)  = ppr lit
+ppr_expr (HsPar e)        = parens (ppr_lexpr e)
+
+ppr_expr (HsCoreAnn stc (StringLiteral sta s) e)
   = vcat [pprWithSourceText stc (text "{-# CORE")
           <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}"
          , ppr_lexpr e]
 
 ppr_expr e@(HsApp {})        = ppr_apps e []
 ppr_expr e@(HsAppType {})    = ppr_apps e []
-ppr_expr e@(HsAppTypeOut {}) = ppr_apps e []
 
-ppr_expr (OpApp e1 op _ e2)
+ppr_expr (OpApp _ e1 op e2)
   | Just pp_op <- should_print_infix (unLoc op)
   = pp_infixly pp_op
   | otherwise
   = pp_prefixly
 
   where
-    should_print_infix (HsVar (L _ v)) = Just (pprInfixOcc v)
-    should_print_infix (HsConLikeOut c)= Just (pprInfixOcc (conLikeName c))
-    should_print_infix (HsRecFld f)    = Just (pprInfixOcc f)
-    should_print_infix (HsUnboundVar h@TrueExprHole{})
+    should_print_infix (HsVar (L _ v)) = Just (pprInfixOcc v)
+    should_print_infix (HsConLikeOut c)= Just (pprInfixOcc (conLikeName c))
+    should_print_infix (HsRecFld f)    = Just (pprInfixOcc f)
+    should_print_infix (HsUnboundVar h@TrueExprHole{})
                                        = Just (pprInfixOcc (unboundVarOcc h))
-    should_print_infix EWildPat        = Just (text "`_`")
-    should_print_infix (HsWrap _ e)    = should_print_infix e
+    should_print_infix (EWildPat _)    = Just (text "`_`")
+    should_print_infix (HsWrap _ _ e)  = should_print_infix e
     should_print_infix _               = Nothing
 
     pp_e1 = pprDebugParendExpr e1   -- In debug mode, add parens
@@ -879,15 +1025,15 @@ ppr_expr (OpApp e1 op _ e2)
     pp_infixly pp_op
       = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2])
 
-ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
+ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
 
-ppr_expr (SectionL expr op)
+ppr_expr (SectionL expr op)
   = case unLoc op of
-      HsVar (L _ v)  -> pp_infixly v
-      HsConLikeOut c -> pp_infixly (conLikeName c)
-      HsUnboundVar h@TrueExprHole{}
-                     -> pp_infixly (unboundVarOcc h)
-      _              -> pp_prefixly
+      HsVar (L _ v)  -> pp_infixly v
+      HsConLikeOut c -> pp_infixly (conLikeName c)
+      HsUnboundVar h@TrueExprHole{}
+                       -> pp_infixly (unboundVarOcc h)
+      _                -> pp_prefixly
   where
     pp_expr = pprDebugParendExpr expr
 
@@ -897,13 +1043,13 @@ ppr_expr (SectionL expr op)
     pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc
     pp_infixly v = (sep [pp_expr, pprInfixOcc v])
 
-ppr_expr (SectionR op expr)
+ppr_expr (SectionR op expr)
   = case unLoc op of
-      HsVar (L _ v)  -> pp_infixly v
-      HsConLikeOut c -> pp_infixly (conLikeName c)
-      HsUnboundVar h@TrueExprHole{}
-                     -> pp_infixly (unboundVarOcc h)
-      _              -> pp_prefixly
+      HsVar (L _ v)  -> pp_infixly v
+      HsConLikeOut c -> pp_infixly (conLikeName c)
+      HsUnboundVar h@TrueExprHole{}
+                       -> pp_infixly (unboundVarOcc h)
+      _                -> pp_prefixly
   where
     pp_expr = pprDebugParendExpr expr
 
@@ -913,37 +1059,39 @@ ppr_expr (SectionR op expr)
     pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc
     pp_infixly v = sep [pprInfixOcc v, pp_expr]
 
-ppr_expr (ExplicitTuple exprs boxity)
+ppr_expr (ExplicitTuple exprs boxity)
   = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs))
   where
     ppr_tup_args []               = []
-    ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
-    ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es
+    ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
+    ppr_tup_args (Missing _   : es) = punc es : ppr_tup_args es
+    ppr_tup_args (XTupArg x   : es) = (ppr x <> punc es) : ppr_tup_args es
 
     punc (Present {} : _) = comma <> space
     punc (Missing {} : _) = comma
+    punc (XTupArg {} : _) = comma <> space
     punc []               = empty
 
-ppr_expr (ExplicitSum alt arity expr _)
+ppr_expr (ExplicitSum _ alt arity expr)
   = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)"
   where
     ppr_bars n = hsep (replicate n (char '|'))
 
-ppr_expr (HsLam matches)
+ppr_expr (HsLam matches)
   = pprMatches matches
 
-ppr_expr (HsLamCase matches)
+ppr_expr (HsLamCase matches)
   = sep [ sep [text "\\case"],
           nest 2 (pprMatches matches) ]
 
-ppr_expr (HsCase expr matches@(MG { mg_alts = L _ [_] }))
+ppr_expr (HsCase expr matches@(MG { mg_alts = L _ [_] }))
   = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")],
           nest 2 (pprMatches matches) <+> char '}']
-ppr_expr (HsCase expr matches)
+ppr_expr (HsCase expr matches)
   = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],
           nest 2 (pprMatches matches) ]
 
-ppr_expr (HsIf _ e1 e2 e3)
+ppr_expr (HsIf _ e1 e2 e3)
   = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")],
          nest 4 (ppr e2),
          text "else",
@@ -960,15 +1108,15 @@ ppr_expr (HsMultiIf _ alts)
                       , text "->" <+> pprDeeper (ppr expr) ]
 
 -- special case: let ... in let ...
-ppr_expr (HsLet (L _ binds) expr@(L _ (HsLet _ _)))
+ppr_expr (HsLet _ (L _ binds) expr@(L _ (HsLet _ _ _)))
   = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),
          ppr_lexpr expr]
 
-ppr_expr (HsLet (L _ binds) expr)
+ppr_expr (HsLet (L _ binds) expr)
   = sep [hang (text "let") 2 (pprBinds binds),
          hang (text "in")  2 (ppr expr)]
 
-ppr_expr (HsDo do_or_list_comp (L _ stmts) _) = pprDo do_or_list_comp stmts
+ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts
 
 ppr_expr (ExplicitList _ _ exprs)
   = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
@@ -982,49 +1130,48 @@ ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds })
 ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds })
   = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))
 
-ppr_expr (ExprWithTySig expr sig)
-  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
-         4 (ppr sig)
-ppr_expr (ExprWithTySigOut expr sig)
+ppr_expr (ExprWithTySig sig expr)
   = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
          4 (ppr sig)
 
 ppr_expr (ArithSeq _ _ info) = brackets (ppr info)
-ppr_expr (PArrSeq  _ info) = paBrackets (ppr info)
+ppr_expr (PArrSeq  _ info)   = paBrackets (ppr info)
 
-ppr_expr EWildPat       = char '_'
-ppr_expr (ELazyPat e)   = char '~' <> ppr e
-ppr_expr (EAsPat v e)   = ppr v <> char '@' <> ppr e
-ppr_expr (EViewPat p e) = ppr p <+> text "->" <+> ppr e
+ppr_expr (EWildPat _)     = char '_'
+ppr_expr (ELazyPat e)   = char '~' <> ppr e
+ppr_expr (EAsPat v e)   = ppr v <> char '@' <> ppr e
+ppr_expr (EViewPat p e) = ppr p <+> text "->" <+> ppr e
 
-ppr_expr (HsSCC st (StringLiteral stl lbl) expr)
+ppr_expr (HsSCC st (StringLiteral stl lbl) expr)
   = sep [ pprWithSourceText st (text "{-# SCC")
          -- no doublequotes if stl empty, for the case where the SCC was written
          -- without quotes.
           <+> pprWithSourceText stl (ftext lbl) <+> text "#-}",
           ppr expr ]
 
-ppr_expr (HsWrap co_fn e)
+ppr_expr (HsWrap co_fn e)
   = pprHsWrapper co_fn (\parens -> if parens then pprExpr e
                                              else pprExpr e)
 
-ppr_expr (HsSpliceE s)         = pprSplice s
-ppr_expr (HsBracket b)         = pprHsBracket b
-ppr_expr (HsRnBracketOut e []) = ppr e
-ppr_expr (HsRnBracketOut e ps) = ppr e $$ text "pending(rn)" <+> ppr ps
-ppr_expr (HsTcBracketOut e []) = ppr e
-ppr_expr (HsTcBracketOut e ps) = ppr e $$ text "pending(tc)" <+> ppr ps
+ppr_expr (HsSpliceE s)         = pprSplice s
+ppr_expr (HsBracket b)         = pprHsBracket b
+ppr_expr (HsRnBracketOut e []) = ppr e
+ppr_expr (HsRnBracketOut e ps) = ppr e $$ text "pending(rn)" <+> ppr ps
+ppr_expr (HsTcBracketOut e []) = ppr e
+ppr_expr (HsTcBracketOut e ps) = ppr e $$ text "pending(tc)" <+> ppr ps
 
-ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
+ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))
   = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd]
+ppr_expr (HsProc _ pat (L _ (XCmdTop x)))
+  = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr x]
 
 ppr_expr (HsStatic _ e)
   = hsep [text "static", ppr e]
 
-ppr_expr (HsTick tickish exp)
+ppr_expr (HsTick tickish exp)
   = pprTicks (ppr exp) $
     ppr tickish <+> ppr_lexpr exp
-ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
+ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
   = pprTicks (ppr exp) $
     hcat [text "bintick<",
           ppr tickIdTrue,
@@ -1032,7 +1179,7 @@ ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
           ppr tickIdFalse,
           text ">(",
           ppr exp, text ")"]
-ppr_expr (HsTickPragma _ externalSrcLoc _ exp)
+ppr_expr (HsTickPragma _ externalSrcLoc _ exp)
   = pprTicks (ppr exp) $
     hcat [text "tickpragma<",
           pprExternalSrcLoc externalSrcLoc,
@@ -1040,45 +1187,40 @@ ppr_expr (HsTickPragma _ externalSrcLoc _ exp)
           ppr exp,
           text ")"]
 
-ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True)
+ppr_expr (HsArrApp _ arrow arg HsFirstOrderApp True)
   = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
-ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False)
+ppr_expr (HsArrApp _ arrow arg HsFirstOrderApp False)
   = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]
-ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True)
+ppr_expr (HsArrApp _ arrow arg HsHigherOrderApp True)
   = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]
-ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)
+ppr_expr (HsArrApp _ arrow arg HsHigherOrderApp False)
   = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
 
-ppr_expr (HsArrForm (L _ (HsVar (L _ v))) (Just _) [arg1, arg2])
+ppr_expr (HsArrForm _ (L _ (HsVar _ (L _ v))) (Just _) [arg1, arg2])
   = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
-ppr_expr (HsArrForm (L _ (HsConLikeOut c)) (Just _) [arg1, arg2])
+ppr_expr (HsArrForm _ (L _ (HsConLikeOut _ c)) (Just _) [arg1, arg2])
   = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc (conLikeName c), pprCmdArg (unLoc arg2)]]
-ppr_expr (HsArrForm op _ args)
+ppr_expr (HsArrForm op _ args)
   = hang (text "(|" <+> ppr_lexpr op)
          4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")
-ppr_expr (HsRecFld f) = ppr f
-
--- We must tiresomely make the "id" parameter to the LHsWcType existential
--- because it's different in the HsAppType case and the HsAppTypeOut case
--- | Located Haskell Wildcard Type Expression
-data LHsWcTypeX = forall p. (OutputableBndrId (GhcPass p))
-                            => LHsWcTypeX (LHsWcType (GhcPass p))
+ppr_expr (HsRecFld _ f) = ppr f
+ppr_expr (XExpr x) = ppr x
 
 ppr_apps :: (OutputableBndrId (GhcPass p))
          => HsExpr (GhcPass p)
-         -> [Either (LHsExpr (GhcPass p)) LHsWcTypeX]
+         -> [Either (LHsExpr (GhcPass p)) (XAppTypeE (GhcPass p))]
          -> SDoc
-ppr_apps (HsApp (L _ fun) arg)        args
+ppr_apps (HsApp (L _ fun) arg)        args
   = ppr_apps fun (Left arg : args)
-ppr_apps (HsAppType (L _ fun) arg)    args
-  = ppr_apps fun (Right (LHsWcTypeX arg) : args)
-ppr_apps (HsAppTypeOut (L _ fun) arg) args
-  = ppr_apps fun (Right (LHsWcTypeX arg) : args)
+ppr_apps (HsAppType arg (L _ fun))    args
+  = ppr_apps fun (Right arg : args)
 ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args))
   where
     pp (Left arg)                             = ppr arg
-    pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))
-      = char '@' <> pprHsType arg
+    -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))
+    --   = char '@' <> pprHsType arg
+    pp (Right arg)
+      = char '@' <> ppr arg
 
 pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc
 pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))
@@ -1132,13 +1274,13 @@ hsExprNeedsParens (HsPar {})          = False
 hsExprNeedsParens (HsBracket {})      = False
 hsExprNeedsParens (HsRnBracketOut {}) = False
 hsExprNeedsParens (HsTcBracketOut {}) = False
-hsExprNeedsParens (HsDo sc _ _)
+hsExprNeedsParens (HsDo _ sc _)
        | isListCompExpr sc            = False
 hsExprNeedsParens (HsRecFld{})        = False
 hsExprNeedsParens (RecordCon{})       = False
 hsExprNeedsParens (HsSpliceE{})       = False
 hsExprNeedsParens (RecordUpd{})       = False
-hsExprNeedsParens (HsWrap _ e)        = hsExprNeedsParens e
+hsExprNeedsParens (HsWrap _ _ e)      = hsExprNeedsParens e
 hsExprNeedsParens _ = True
 
 
@@ -1151,8 +1293,8 @@ isAtomicHsExpr (HsOverLit {})    = True
 isAtomicHsExpr (HsIPVar {})      = True
 isAtomicHsExpr (HsOverLabel {})  = True
 isAtomicHsExpr (HsUnboundVar {}) = True
-isAtomicHsExpr (HsWrap _ e)      = isAtomicHsExpr e
-isAtomicHsExpr (HsPar e)         = isAtomicHsExpr (unLoc e)
+isAtomicHsExpr (HsWrap _ _ e)    = isAtomicHsExpr e
+isAtomicHsExpr (HsPar _ e)       = isAtomicHsExpr (unLoc e)
 isAtomicHsExpr (HsRecFld{})      = True
 isAtomicHsExpr _                 = False
 
@@ -1177,10 +1319,10 @@ data HsCmd id
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   = HsCmdArrApp          -- Arrow tail, or arrow application (f -< arg)
+        (XCmdArrApp id)  -- type of the arrow expressions f,
+                         -- of the form a t t', where arg :: t
         (LHsExpr id)     -- arrow expression, f
         (LHsExpr id)     -- input expression, arg
-        (PostTc id Type) -- type of the arrow expressions f,
-                         -- of the form a t t', where arg :: t
         HsArrAppType     -- higher-order (-<<) or first-order (-<)
         Bool             -- True => right-to-left (f -< arg)
                          -- False => left-to-right (arg >- f)
@@ -1190,6 +1332,7 @@ data HsCmd id
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | HsCmdArrForm         -- Command formation,  (| e cmd1 .. cmdn |)
+        (XCmdArrForm id)
         (LHsExpr id)     -- The operator.
                          -- After type-checking, a type abstraction to be
                          -- applied to the type of the local environment tuple
@@ -1199,22 +1342,26 @@ data HsCmd id
                          -- were converted from OpApp's by the renamer
         [LHsCmdTop id]   -- argument commands
 
-  | HsCmdApp    (LHsCmd id)
+  | HsCmdApp    (XCmdApp id)
+                (LHsCmd id)
                 (LHsExpr id)
 
-  | HsCmdLam    (MatchGroup id (LHsCmd id))     -- kappa
+  | HsCmdLam    (XCmdLam id)
+                (MatchGroup id (LHsCmd id))     -- kappa
        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
        --       'ApiAnnotation.AnnRarrow',
 
        -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdPar    (LHsCmd id)                     -- parenthesised command
+  | HsCmdPar    (XCmdPar id)
+                (LHsCmd id)                     -- parenthesised command
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
     --             'ApiAnnotation.AnnClose' @')'@
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdCase   (LHsExpr id)
+  | HsCmdCase   (XCmdCase id)
+                (LHsExpr id)
                 (MatchGroup id (LHsCmd id))     -- bodies are HsCmd's
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',
     --       'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@,
@@ -1222,7 +1369,8 @@ data HsCmd id
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdIf     (Maybe (SyntaxExpr id))         -- cond function
+  | HsCmdIf     (XCmdIf id)
+                (Maybe (SyntaxExpr id))         -- cond function
                 (LHsExpr id)                    -- predicate
                 (LHsCmd id)                     -- then part
                 (LHsCmd id)                     -- else part
@@ -1233,7 +1381,8 @@ data HsCmd id
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdLet    (LHsLocalBinds id)      -- let(rec)
+  | HsCmdLet    (XCmdLet id)
+                (LHsLocalBinds id)      -- let(rec)
                 (LHsCmd  id)
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet',
     --       'ApiAnnotation.AnnOpen' @'{'@,
@@ -1241,8 +1390,8 @@ data HsCmd id
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdDo     (Located [CmdLStmt id])
-                (PostTc id Type)                -- Type of the whole expression
+  | HsCmdDo     (XCmdDo id)                     -- Type of the whole expression
+                (Located [CmdLStmt id])
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',
     --             'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi',
     --             'ApiAnnotation.AnnVbar',
@@ -1250,11 +1399,32 @@ data HsCmd id
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdWrap   HsWrapper
+  | HsCmdWrap   (XCmdWrap id)
+                HsWrapper
                 (HsCmd id)     -- If   cmd :: arg1 --> res
                                --      wrap :: arg1 "->" arg2
                                -- Then (HsCmdWrap wrap cmd) :: arg2 --> res
-deriving instance (DataId id) => Data (HsCmd id)
+  | 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
+type instance XCmdArrApp  GhcTc = Type
+
+type instance XCmdArrForm (GhcPass _) = PlaceHolder
+type instance XCmdApp     (GhcPass _) = PlaceHolder
+type instance XCmdLam     (GhcPass _) = PlaceHolder
+type instance XCmdPar     (GhcPass _) = PlaceHolder
+type instance XCmdCase    (GhcPass _) = PlaceHolder
+type instance XCmdIf      (GhcPass _) = PlaceHolder
+type instance XCmdLet     (GhcPass _) = PlaceHolder
+
+type instance XCmdDo      GhcPs = PlaceHolder
+type instance XCmdDo      GhcRn = PlaceHolder
+type instance XCmdDo      GhcTc = Type
+
+type instance XCmdWrap    (GhcPass _) = PlaceHolder
+type instance XXCmd       (GhcPass _) = PlaceHolder
 
 -- | Haskell Array Application Type
 data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
@@ -1271,11 +1441,22 @@ type LHsCmdTop p = Located (HsCmdTop p)
 
 -- | Haskell Top-level Command
 data HsCmdTop p
-  = HsCmdTop (LHsCmd p)
-             (PostTc p Type)    -- Nested tuple of inputs on the command's stack
-             (PostTc p Type)    -- return type of the command
-             (CmdSyntaxTable p) -- See Note [CmdSyntaxTable]
-deriving instance (DataId p) => 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]
+type instance XCmdTop  GhcTc = CmdTopTc
+
+type instance XXCmdTop (GhcPass _) = PlaceHolder
 
 instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p) where
     ppr cmd = pprCmd cmd
@@ -1294,9 +1475,9 @@ isQuietHsCmd :: HsCmd id -> Bool
 -- Parentheses do display something, but it gives little info and
 -- if we go deeper when we go inside them then we get ugly things
 -- like (...)
-isQuietHsCmd (HsCmdPar _) = True
+isQuietHsCmd (HsCmdPar {}) = True
 -- applications don't display anything themselves
-isQuietHsCmd (HsCmdApp _ _) = True
+isQuietHsCmd (HsCmdApp {}) = True
 isQuietHsCmd _ = False
 
 -----------------------
@@ -1304,69 +1485,71 @@ ppr_lcmd :: (OutputableBndrId (GhcPass p)) => LHsCmd (GhcPass p) -> SDoc
 ppr_lcmd c = ppr_cmd (unLoc c)
 
 ppr_cmd :: forall p. (OutputableBndrId (GhcPass p)) => HsCmd (GhcPass p) -> SDoc
-ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c)
+ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c)
 
-ppr_cmd (HsCmdApp c e)
+ppr_cmd (HsCmdApp c e)
   = let (fun, args) = collect_args c [e] in
     hang (ppr_lcmd fun) 2 (sep (map ppr args))
   where
-    collect_args (L _ (HsCmdApp fun arg)) args = collect_args fun (arg:args)
+    collect_args (L _ (HsCmdApp fun arg)) args = collect_args fun (arg:args)
     collect_args fun args = (fun, args)
 
-ppr_cmd (HsCmdLam matches)
+ppr_cmd (HsCmdLam matches)
   = pprMatches matches
 
-ppr_cmd (HsCmdCase expr matches)
+ppr_cmd (HsCmdCase expr matches)
   = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],
           nest 2 (pprMatches matches) ]
 
-ppr_cmd (HsCmdIf _ e ct ce)
+ppr_cmd (HsCmdIf _ e ct ce)
   = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")],
          nest 4 (ppr ct),
          text "else",
          nest 4 (ppr ce)]
 
 -- special case: let ... in let ...
-ppr_cmd (HsCmdLet (L _ binds) cmd@(L _ (HsCmdLet _ _)))
+ppr_cmd (HsCmdLet _ (L _ binds) cmd@(L _ (HsCmdLet {})))
   = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),
          ppr_lcmd cmd]
 
-ppr_cmd (HsCmdLet (L _ binds) cmd)
+ppr_cmd (HsCmdLet (L _ binds) cmd)
   = sep [hang (text "let") 2 (pprBinds binds),
          hang (text "in")  2 (ppr cmd)]
 
-ppr_cmd (HsCmdDo (L _ stmts) _)  = pprDo ArrowExpr stmts
+ppr_cmd (HsCmdDo _ (L _ stmts))  = pprDo ArrowExpr stmts
 
-ppr_cmd (HsCmdWrap w cmd)
+ppr_cmd (HsCmdWrap w cmd)
   = pprHsWrapper w (\_ -> parens (ppr_cmd cmd))
-ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True)
+ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True)
   = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
-ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp False)
+ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False)
   = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]
-ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True)
+ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True)
   = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]
-ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False)
+ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False)
   = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
 
-ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) _ (Just _) [arg1, arg2])
+ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2])
   = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v
                                          , pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) Infix _    [arg1, arg2])
+ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) Infix _    [arg1, arg2])
   = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v
                                          , pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) _ (Just _) [arg1, arg2])
+ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2])
   = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)
                                          , pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) Infix _    [arg1, arg2])
+ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _    [arg1, arg2])
   = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)
                                          , pprCmdArg (unLoc arg2)])
-ppr_cmd (HsCmdArrForm op _ _ args)
+ppr_cmd (HsCmdArrForm op _ _ args)
   = hang (text "(|" <> ppr_lexpr op)
          4 (sep (map (pprCmdArg.unLoc) args) <> text "|)")
+ppr_cmd (XCmd x) = ppr x
 
 pprCmdArg :: (OutputableBndrId (GhcPass p)) => HsCmdTop (GhcPass p) -> SDoc
-pprCmdArg (HsCmdTop cmd _ _ _)
+pprCmdArg (HsCmdTop _ cmd)
   = ppr_lcmd cmd
+pprCmdArg (XCmdTop x) = ppr x
 
 instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmdTop p) where
     ppr = pprCmdArg
@@ -1404,6 +1587,7 @@ a function defined by pattern matching must have the same number of
 patterns in each equation.
 -}
 
+-- AZ:TODO complete TTG on this, once DataId etc is resolved
 data MatchGroup p body
   = MG { mg_alts    :: Located [LMatch p body]  -- The alternatives
        , mg_arg_tys :: [PostTc p Type]  -- Types of the arguments, t1..tn
@@ -1412,13 +1596,14 @@ 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,DataId p) => Data (MatchGroup p body)
+deriving instance (Data body,DataIdLR p p) => Data (MatchGroup p body)
 
 -- | Located Match
 type LMatch id body = Located (Match id body)
 -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a
 --   list
 
+-- AZ:TODO complete TTG on this, once DataId etc is resolved
 -- For details on above see note [Api annotations] in ApiAnnotation
 data Match p body
   = Match {
@@ -1427,7 +1612,7 @@ data Match p body
         m_pats :: [LPat p], -- The patterns
         m_grhss :: (GRHSs p body)
   }
-deriving instance (Data body,DataId p) => Data (Match 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
@@ -1506,21 +1691,23 @@ hsLMatchPats (L _ (Match { m_pats = pats })) = pats
 --        'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
 --        'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnSemi'
 
+-- AZ:TODO complete TTG on this, once DataId etc is resolved
 -- For details on above see note [Api annotations] in ApiAnnotation
 data GRHSs p body
   = GRHSs {
       grhssGRHSs :: [LGRHS p body],      -- ^ Guarded RHSs
       grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause
     }
-deriving instance (Data body,DataId p) => Data (GRHSs p body)
+deriving instance (Data body,DataIdLR p p) => Data (GRHSs p body)
 
 -- | Located Guarded Right-Hand Side
 type LGRHS id body = Located (GRHS id body)
 
+-- AZ:TODO complete TTG on this, once DataId etc is resolved
 -- | Guarded Right Hand Side.
 data GRHS id body = GRHS [GuardLStmt id] -- Guards
                          body            -- Right hand side
-deriving instance (Data body,DataId id) => Data (GRHS id body)
+deriving instance (Data body,DataIdLR id id) => Data (GRHS id body)
 
 -- We know the list must have at least one @Match@ in it.
 
@@ -1773,7 +1960,7 @@ 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, DataId idL, DataId idR)
+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
@@ -1784,10 +1971,15 @@ data TransForm   -- The 'f' below is the 'using' function, 'e' is the by functio
 -- | Parenthesised Statement Block
 data ParStmtBlock idL idR
   = ParStmtBlock
+        (XParStmtBlock idL idR)
         [ExprLStmt idL]
         [IdP idR]          -- The variables to be returned
         (SyntaxExpr idR)   -- The return operator
-deriving instance (DataId idL, DataId idR) => Data (ParStmtBlock idL idR)
+  | 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
 
 -- | Applicative Argument
 data ApplicativeArg idL
@@ -1803,7 +1995,8 @@ data ApplicativeArg idL
       (HsExpr idL)         -- return (v1,..,vn), or just (v1,..,vn)
       (LPat idL)           -- (v1,...,vn)
 
-deriving instance (DataId idL) => Data (ApplicativeArg idL)
+-- AZ: May need to bring back idR?
+deriving instance (DataIdLR idL idL) => Data (ApplicativeArg idL)
 
 {-
 Note [The type of bind in Stmts]
@@ -1970,9 +2163,11 @@ Bool flag that is True when the original statement was a BodyStmt, so
 that we can pretty-print it correctly.
 -}
 
-instance (Outputable (StmtLR idL idL (LHsExpr idL)))
+instance (Outputable (StmtLR idL idL (LHsExpr idL)),
+          Outputable (XXParStmtBlock idL idR))
         => Outputable (ParStmtBlock idL idR) where
-  ppr (ParStmtBlock stmts _ _) = interpp'SP stmts
+  ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts
+  ppr (XParStmtBlock x)          = ppr x
 
 instance (idL ~ GhcPass pl,idR ~ GhcPass pr,
           OutputableBndrId idL, OutputableBndrId idR,
@@ -2041,6 +2236,7 @@ pprStmt (ApplicativeStmt args mb_join _)
           then ap_expr
           else text "join" <+> parens ap_expr
 
+   pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc
    pp_arg (_, ApplicativeArgOne pat expr isBody)
      | isBody =  -- See Note [Applicative BodyStmt]
      ppr (BodyStmt expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
@@ -2051,9 +2247,8 @@ pprStmt (ApplicativeStmt args mb_join _)
    pp_arg (_, ApplicativeArgMany stmts return pat) =
      ppr pat <+>
      text "<-" <+>
-     ppr (HsDo DoExpr (noLoc
-                (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)]))
-           (error "pprStmt"))
+     ppr (HsDo (panic "pprStmt") DoExpr (noLoc
+               (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)])))
 
 pprTransformStmt :: (OutputableBndrId (GhcPass p))
                  => [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
@@ -2121,29 +2316,41 @@ pprQuals quals = interpp'SP quals
 -- | Haskell Splice
 data HsSplice id
    = HsTypedSplice       --  $$z  or $$(f 4)
+        (XTypedSplice id)
         SpliceDecoration -- Whether $$( ) variant found, for pretty printing
         (IdP id)         -- A unique name to identify this splice point
         (LHsExpr id)     -- See Note [Pending Splices]
 
    | HsUntypedSplice     --  $z  or $(f 4)
+        (XUntypedSplice id)
         SpliceDecoration -- Whether $( ) variant found, for pretty printing
         (IdP id)         -- A unique name to identify this splice point
         (LHsExpr id)     -- See Note [Pending Splices]
 
    | HsQuasiQuote        -- See Note [Quasi-quote overview] in TcSplice
+        (XQuasiQuote id)
         (IdP id)         -- Splice point
         (IdP id)         -- Quoter
         SrcSpan          -- The span of the enclosed string
         FastString       -- The enclosed string
 
+   -- AZ:TODO: use XSplice instead of HsSpliced
    | HsSpliced  -- See Note [Delaying modFinalizers in untyped splices] in
                 -- RnSplice.
                 -- This is the result of splicing a splice. It is produced by
                 -- the renamer and consumed by the typechecker. It lives only
                 -- between the two.
+        (XSpliced id)
         ThModFinalizers     -- TH finalizers produced by the splice.
         (HsSplicedThing id) -- The result of splicing
-deriving instance (DataId id) => Data (HsSplice id)
+   | 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
+type instance XQuasiQuote    (GhcPass _) = PlaceHolder
+type instance XSpliced       (GhcPass _) = PlaceHolder
+type instance XXSplice       (GhcPass _) = PlaceHolder
 
 -- | A splice can appear with various decorations wrapped around it. This data
 -- type captures explicitly how it was originally written, for use in the pretty
@@ -2184,7 +2391,7 @@ data HsSplicedThing id
     | HsSplicedTy   (HsType id) -- ^ Haskell Spliced Type
     | HsSplicedPat  (Pat id)    -- ^ Haskell Spliced Pattern
 
-deriving instance (DataId id) => Data (HsSplicedThing id)
+deriving instance (DataIdLR id id) => Data (HsSplicedThing id)
 
 -- See Note [Pending Splices]
 type SplicePointName = Name
@@ -2208,7 +2415,6 @@ data PendingTcSplice
   = PendingTcSplice SplicePointName (LHsExpr GhcTc)
   deriving Data
 
-
 {-
 Note [Pending Splices]
 ~~~~~~~~~~~~~~~~~~~~~~
@@ -2294,24 +2500,25 @@ pprSpliceDecl e ImplicitSplice   = ppr_splice_decl e
 
 ppr_splice_decl :: (OutputableBndrId (GhcPass p))
                 => HsSplice (GhcPass p) -> SDoc
-ppr_splice_decl (HsUntypedSplice _ n e) = ppr_splice empty n e empty
+ppr_splice_decl (HsUntypedSplice _ n e) = ppr_splice empty n e empty
 ppr_splice_decl e = pprSplice e
 
 pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc
-pprSplice (HsTypedSplice HasParens  n e)
+pprSplice (HsTypedSplice HasParens  n e)
   = ppr_splice (text "$$(") n e (text ")")
-pprSplice (HsTypedSplice HasDollar n e)
+pprSplice (HsTypedSplice HasDollar n e)
   = ppr_splice (text "$$") n e empty
-pprSplice (HsTypedSplice NoParens n e)
+pprSplice (HsTypedSplice NoParens n e)
   = ppr_splice empty n e empty
-pprSplice (HsUntypedSplice HasParens  n e)
+pprSplice (HsUntypedSplice HasParens  n e)
   = ppr_splice (text "$(") n e (text ")")
-pprSplice (HsUntypedSplice HasDollar n e)
+pprSplice (HsUntypedSplice HasDollar n e)
   = ppr_splice (text "$")  n e empty
-pprSplice (HsUntypedSplice NoParens n e)
+pprSplice (HsUntypedSplice NoParens n e)
   = ppr_splice empty  n e empty
-pprSplice (HsQuasiQuote n q _ s)      = ppr_quasi n q s
-pprSplice (HsSpliced _ thing)         = ppr thing
+pprSplice (HsQuasiQuote _ n q _ s)      = ppr_quasi n q s
+pprSplice (HsSpliced _ _ thing)         = ppr thing
+pprSplice (XSplice x)                   = ppr x
 
 ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc
 ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <>
@@ -2324,15 +2531,26 @@ ppr_splice herald n e trail
     = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail
 
 -- | Haskell Bracket
-data HsBracket p = ExpBr (LHsExpr p)    -- [|  expr  |]
-                  | PatBr (LPat p)      -- [p| pat   |]
-                  | DecBrL [LHsDecl p]  -- [d| decls |]; result of parser
-                  | DecBrG (HsGroup p)  -- [d| decls |]; result of renamer
-                  | TypBr (LHsType p)   -- [t| type  |]
-                  | VarBr Bool (IdP p)  -- True: 'x, False: ''T
-                                 -- (The Bool flag is used only in pprHsBracket)
-                  | TExpBr (LHsExpr p)  -- [||  expr  ||]
-deriving instance (DataId p) => Data (HsBracket p)
+data HsBracket p
+  = ExpBr  (XExpBr p)   (LHsExpr p)    -- [|  expr  |]
+  | PatBr  (XPatBr p)   (LPat p)      -- [p| pat   |]
+  | DecBrL (XDecBrL p)  [LHsDecl p]   -- [d| decls |]; result of parser
+  | DecBrG (XDecBrG p)  (HsGroup p)   -- [d| decls |]; result of renamer
+  | TypBr  (XTypBr p)   (LHsType p)   -- [t| type  |]
+  | VarBr  (XVarBr p)   Bool (IdP p)  -- True: 'x, False: ''T
+                                -- (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
+type instance XDecBrL     (GhcPass _) = PlaceHolder
+type instance XDecBrG     (GhcPass _) = PlaceHolder
+type instance XTypBr      (GhcPass _) = PlaceHolder
+type instance XVarBr      (GhcPass _) = PlaceHolder
+type instance XTExpBr     (GhcPass _) = PlaceHolder
+type instance XXBracket   (GhcPass _) = PlaceHolder
 
 isTypedBracket :: HsBracket id -> Bool
 isTypedBracket (TExpBr {}) = True
@@ -2344,16 +2562,17 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
 
 
 pprHsBracket :: (OutputableBndrId (GhcPass p)) => HsBracket (GhcPass p) -> SDoc
-pprHsBracket (ExpBr e)   = thBrackets empty (ppr e)
-pprHsBracket (PatBr p)   = thBrackets (char 'p') (ppr p)
-pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp)
-pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds))
-pprHsBracket (TypBr t)   = thBrackets (char 't') (ppr t)
-pprHsBracket (VarBr True n)
+pprHsBracket (ExpBr e)   = thBrackets empty (ppr e)
+pprHsBracket (PatBr p)   = thBrackets (char 'p') (ppr p)
+pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp)
+pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds))
+pprHsBracket (TypBr t)   = thBrackets (char 't') (ppr t)
+pprHsBracket (VarBr True n)
   = char '\'' <> pprPrefixOcc n
-pprHsBracket (VarBr False n)
+pprHsBracket (VarBr False n)
   = text "''" <> pprPrefixOcc n
-pprHsBracket (TExpBr e)  = thTyBrackets (ppr e)
+pprHsBracket (TExpBr _ e)  = thTyBrackets (ppr e)
+pprHsBracket (XBracket e)  = ppr e
 
 thBrackets :: SDoc -> SDoc -> SDoc
 thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>
@@ -2386,7 +2605,8 @@ data ArithSeqInfo id
   | FromThenTo      (LHsExpr id)
                     (LHsExpr id)
                     (LHsExpr id)
-deriving instance (DataId id) => Data (ArithSeqInfo id)
+deriving instance (DataIdLR id id) => Data (ArithSeqInfo id)
+-- AZ: Sould ArithSeqInfo have a TTG extension?
 
 instance (p ~ GhcPass pass, OutputableBndrId p)
          => Outputable (ArithSeqInfo p) where
index 0229039..e8fa7a4 100644 (file)
@@ -13,7 +13,7 @@ import SrcLoc     ( Located )
 import Outputable ( SDoc, Outputable )
 import {-# SOURCE #-} HsPat  ( LPat )
 import BasicTypes ( SpliceExplicitFlag(..))
-import HsExtension ( OutputableBndrId, DataId, GhcPass )
+import HsExtension ( OutputableBndrId, DataIdLR, GhcPass )
 import Data.Data hiding ( Fixity )
 
 type role HsExpr nominal
@@ -29,12 +29,12 @@ data MatchGroup (a :: *) (body :: *)
 data GRHSs (a :: *) (body :: *)
 data SyntaxExpr (i :: *)
 
-instance (DataId p) => Data (HsSplice p)
-instance (DataId p) => Data (HsExpr p)
-instance (DataId p) => Data (HsCmd p)
-instance (Data body,DataId p) => Data (MatchGroup p body)
-instance (Data body,DataId p) => Data (GRHSs p body)
-instance (DataId p) => Data (SyntaxExpr p)
+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 8efd005..779ecc5 100644 (file)
@@ -7,6 +7,9 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+                                      -- in module PlaceHolder
 
 module HsExtension where
 
@@ -55,6 +58,10 @@ haskell-src-exts ASTs as well.
 
 -}
 
+-- | Used when constructing a term with an unused extension point.
+noExt :: PlaceHolder
+noExt = PlaceHolder
+
 -- | Used as a data type index for the hsSyn AST
 data GhcPass (c :: Pass)
 deriving instance Eq (GhcPass c)
@@ -76,6 +83,8 @@ 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
@@ -88,6 +97,61 @@ type instance IdP GhcPs = RdrName
 type instance IdP GhcRn = Name
 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 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)
+       )
+-- ---------------------------------------------------------------------
+-- ValBindsLR type families
+
+type family XValBinds    x x'
+type family XXValBindsLR x x'
+
+type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =
+       ( c (XValBinds    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.
@@ -104,57 +168,341 @@ 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 ForallX (c :: * -> Constraint) (x :: *) =
-  ( c (XHsChar x)
-  , c (XHsCharPrim x)
-  , c (XHsString x)
+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 (XHsInt x)
-  , c (XHsIntPrim x)
-  , c (XHsWordPrim x)
-  , c (XHsInt64Prim x)
   , c (XHsWord64Prim x)
-  , c (XHsInteger x)
-  , c (XHsRat x)
-  , c (XHsFloatPrim x)
-  , c (XHsDoublePrim 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 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
 
-type instance XHsChar       (GhcPass _) = SourceText
-type instance XHsCharPrim   (GhcPass _) = SourceText
-type instance XHsString     (GhcPass _) = SourceText
-type instance XHsStringPrim (GhcPass _) = SourceText
-type instance XHsInt        (GhcPass _) = ()
-type instance XHsIntPrim    (GhcPass _) = SourceText
-type instance XHsWordPrim   (GhcPass _) = SourceText
-type instance XHsInt64Prim  (GhcPass _) = SourceText
-type instance XHsWord64Prim (GhcPass _) = SourceText
-type instance XHsInteger    (GhcPass _) = SourceText
-type instance XHsRat        (GhcPass _) = ()
-type instance XHsFloatPrim  (GhcPass _) = ()
-type instance XHsDoublePrim (GhcPass _) = ()
-
-
+-- | 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)
+       )
+
+-- ---------------------------------------------------------------------
+-- Type families for the HsExpr type families
+
+type family XVar            x
+type family XUnboundVar     x
+type family XConLikeOut     x
+type family XRecFld         x
+type family XOverLabel      x
+type family XIPVar          x
+type family XOverLitE       x
+type family XLitE           x
+type family XLam            x
+type family XLamCase        x
+type family XApp            x
+type family XAppTypeE       x
+type family XOpApp          x
+type family XNegApp         x
+type family XPar            x
+type family XSectionL       x
+type family XSectionR       x
+type family XExplicitTuple  x
+type family XExplicitSum    x
+type family XCase           x
+type family XIf             x
+type family XMultiIf        x
+type family XLet            x
+type family XDo             x
+type family XExplicitList   x
+type family XExplicitPArr   x
+type family XRecordCon      x
+type family XRecordUpd      x
+type family XExprWithTySig  x
+type family XArithSeq       x
+type family XPArrSeq        x
+type family XSCC            x
+type family XCoreAnn        x
+type family XBracket        x
+type family XRnBracketOut   x
+type family XTcBracketOut   x
+type family XSpliceE        x
+type family XProc           x
+type family XStatic         x
+type family XArrApp         x
+type family XArrForm        x
+type family XTick           x
+type family XBinTick        x
+type family XTickPragma     x
+type family XEWildPat       x
+type family XEAsPat         x
+type family XEViewPat       x
+type family XELazyPat       x
+type family XWrap           x
+type family XXExpr          x
+
+type ForallXExpr (c :: * -> Constraint) (x :: *) =
+       ( c (XVar            x)
+       , c (XUnboundVar     x)
+       , c (XConLikeOut     x)
+       , c (XRecFld         x)
+       , c (XOverLabel      x)
+       , c (XIPVar          x)
+       , c (XOverLitE       x)
+       , c (XLitE           x)
+       , c (XLam            x)
+       , c (XLamCase        x)
+       , c (XApp            x)
+       , c (XAppTypeE       x)
+       , c (XOpApp          x)
+       , c (XNegApp         x)
+       , c (XPar            x)
+       , c (XSectionL       x)
+       , c (XSectionR       x)
+       , c (XExplicitTuple  x)
+       , c (XExplicitSum    x)
+       , c (XCase           x)
+       , c (XIf             x)
+       , c (XMultiIf        x)
+       , c (XLet            x)
+       , c (XDo             x)
+       , c (XExplicitList   x)
+       , c (XExplicitPArr   x)
+       , c (XRecordCon      x)
+       , c (XRecordUpd      x)
+       , c (XExprWithTySig  x)
+       , c (XArithSeq       x)
+       , c (XPArrSeq        x)
+       , c (XSCC            x)
+       , c (XCoreAnn        x)
+       , c (XBracket        x)
+       , c (XRnBracketOut   x)
+       , c (XTcBracketOut   x)
+       , c (XSpliceE        x)
+       , c (XProc           x)
+       , c (XStatic         x)
+       , c (XArrApp         x)
+       , c (XArrForm        x)
+       , c (XTick           x)
+       , c (XBinTick        x)
+       , c (XTickPragma     x)
+       , c (XEWildPat       x)
+       , c (XEAsPat         x)
+       , c (XEViewPat       x)
+       , c (XELazyPat       x)
+       , c (XWrap           x)
+       , c (XXExpr          x)
+       )
+-- ---------------------------------------------------------------------
+
+type family XUnambiguous        x
+type family XAmbiguous          x
+type family XXAmbiguousFieldOcc x
+
+type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) =
+       ( c (XUnambiguous        x)
+       , c (XAmbiguous          x)
+       , c (XXAmbiguousFieldOcc x)
+       )
 
 -- ----------------------------------------------------------------------
--- | Defaults for each annotation, used to simplify creation in arbitrary
--- contexts
-class HasDefault a where
-  def :: a
-
-instance HasDefault () where
-  def = ()
 
-instance HasDefault SourceText where
-  def = NoSourceText
-
--- | Provide a single constraint that captures the requirement for a default
--- across all the extension points.
-type HasDefaultX x = ForallX HasDefault x
+type family XPresent  x
+type family XMissing  x
+type family XXTupArg  x
+
+type ForallXTupArg (c :: * -> Constraint) (x :: *) =
+       ( c (XPresent x)
+       , c (XMissing x)
+       , c (XXTupArg x)
+       )
+
+-- ---------------------------------------------------------------------
+
+type family XTypedSplice   x
+type family XUntypedSplice x
+type family XQuasiQuote    x
+type family XSpliced       x
+type family XXSplice       x
+
+type ForallXSplice (c :: * -> Constraint) (x :: *) =
+       ( c (XTypedSplice   x)
+       , c (XUntypedSplice x)
+       , c (XQuasiQuote    x)
+       , c (XSpliced       x)
+       , c (XXSplice       x)
+       )
+
+-- ---------------------------------------------------------------------
+
+type family XExpBr      x
+type family XPatBr      x
+type family XDecBrL     x
+type family XDecBrG     x
+type family XTypBr      x
+type family XVarBr      x
+type family XTExpBr     x
+type family XXBracket   x
+
+type ForallXBracket (c :: * -> Constraint) (x :: *) =
+       ( c (XExpBr      x)
+       , c (XPatBr      x)
+       , c (XDecBrL     x)
+       , c (XDecBrG     x)
+       , c (XTypBr      x)
+       , c (XVarBr      x)
+       , c (XTExpBr     x)
+       , c (XXBracket   x)
+       )
+
+-- ---------------------------------------------------------------------
+
+type family XCmdTop  x
+type family XXCmdTop x
+
+type ForallXCmdTop (c :: * -> Constraint) (x :: *) =
+       ( c (XCmdTop  x)
+       , c (XXCmdTop x)
+       )
+
+-- ---------------------------------------------------------------------
+
+type family XCmdArrApp  x
+type family XCmdArrForm x
+type family XCmdApp     x
+type family XCmdLam     x
+type family XCmdPar     x
+type family XCmdCase    x
+type family XCmdIf      x
+type family XCmdLet     x
+type family XCmdDo      x
+type family XCmdWrap    x
+type family XXCmd       x
+
+type ForallXCmd (c :: * -> Constraint) (x :: *) =
+       ( c (XCmdArrApp  x)
+       , c (XCmdArrForm x)
+       , c (XCmdApp     x)
+       , c (XCmdLam     x)
+       , c (XCmdPar     x)
+       , c (XCmdCase    x)
+       , c (XCmdIf      x)
+       , c (XCmdLet     x)
+       , c (XCmdDo      x)
+       , c (XCmdWrap    x)
+       , c (XXCmd       x)
+       )
+
+-- ---------------------------------------------------------------------
+
+type family XParStmtBlock  x x'
+type family XXParStmtBlock x x'
+
+type ForallXParStmtBlock (c :: * -> Constraint) (x :: *) (x' :: *) =
+       ( c (XParStmtBlock  x x')
+       , c (XXParStmtBlock x x')
+       )
 
 -- ----------------------------------------------------------------------
 -- | Conversion of annotations from one type index to another. This is required
@@ -183,15 +531,69 @@ type ConvertIdX a b =
    XHsStringPrim a ~ XHsStringPrim b,
    XHsString a ~ XHsString b,
    XHsCharPrim a ~ XHsCharPrim b,
-   XHsChar a ~ XHsChar b)
+   XHsChar a ~ XHsChar b,
+   XXLit a ~ XXLit b)
+
+-- ----------------------------------------------------------------------
 
+-- | Provide a summary constraint that gives all am Outputable constraint to
+-- extension points needing one
+type OutputableX p =
+  ( Outputable (XXPat p)
+  , Outputable (XXPat GhcRn)
+
+  , Outputable (XSigPat p)
+  , Outputable (XSigPat GhcRn)
+
+  , Outputable (XXLit p)
+
+  , Outputable (XXOverLit p)
+
+  , Outputable (XXType p)
+
+  , Outputable (XExprWithTySig p)
+  , Outputable (XExprWithTySig GhcRn)
+
+  , Outputable (XAppTypeE p)
+  , Outputable (XAppTypeE GhcRn)
+
+  -- , Outputable (XXParStmtBlock (GhcPass idL) idR)
+  )
+-- TODO: Should OutputableX be included in OutputableBndrId?
 
 -- ----------------------------------------------------------------------
 
 --
 type DataId p =
   ( Data p
-  , ForallX Data p
+
+  , ForallXHsLit Data p
+  , ForallXPat   Data p
+
+  -- Th following GhcRn constraints should go away once TTG is fully implemented
+  , ForallXPat     Data GhcRn
+  , ForallXType    Data GhcRn
+  , ForallXExpr    Data GhcRn
+  , ForallXTupArg  Data GhcRn
+  , ForallXSplice  Data GhcRn
+  , ForallXBracket Data GhcRn
+  , ForallXCmdTop  Data GhcRn
+  , ForallXCmd     Data GhcRn
+
+  , ForallXOverLit           Data p
+  , ForallXType              Data p
+  , ForallXTyVarBndr         Data p
+  , ForallXAppType           Data 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
+
   , Data (NameOrRdrName (IdP p))
 
   , Data (IdP p)
@@ -211,10 +613,23 @@ type DataId p =
   , Data (PostTc p [Type])
   )
 
+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
+  , ForallXParStmtBlock Data GhcRn GhcRn
+  )
 
 -- |Constraint type to bundle up the requirement for 'OutputableBndr' on both
 -- the @id@ and the 'NameOrRdrName' type for it
 type OutputableBndrId id =
   ( OutputableBndr (NameOrRdrName (IdP id))
   , OutputableBndr (IdP id)
+  , OutputableX id
   )
index 271a415..182d00a 100644 (file)
@@ -27,6 +27,7 @@ import Type       ( Type )
 import Outputable
 import FastString
 import HsExtension
+import PlaceHolder
 
 import Data.ByteString (ByteString)
 import Data.Data hiding ( Fixity )
@@ -76,8 +77,24 @@ data HsLit x
   | HsDoublePrim (XHsDoublePrim x) FractionalLit
       -- ^ Unboxed Double
 
+  | 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
+type instance XHsStringPrim (GhcPass _) = SourceText
+type instance XHsInt        (GhcPass _) = PlaceHolder
+type instance XHsIntPrim    (GhcPass _) = SourceText
+type instance XHsWordPrim   (GhcPass _) = SourceText
+type instance XHsInt64Prim  (GhcPass _) = SourceText
+type instance XHsWord64Prim (GhcPass _) = SourceText
+type instance XHsInteger    (GhcPass _) = SourceText
+type instance XHsRat        (GhcPass _) = PlaceHolder
+type instance XHsFloatPrim  (GhcPass _) = PlaceHolder
+type instance XHsDoublePrim (GhcPass _) = PlaceHolder
+type instance XXLit         (GhcPass _) = PlaceHolder
 
 instance Eq (HsLit x) where
   (HsChar _ x1)       == (HsChar _ x2)       = x1==x2
@@ -98,11 +115,25 @@ instance Eq (HsLit x) where
 -- | Haskell Overloaded Literal
 data HsOverLit p
   = OverLit {
-        ol_val :: OverLitVal,
-        ol_rebindable :: PostRn p Bool, -- Note [ol_rebindable]
-        ol_witness :: HsExpr p,         -- Note [Overloaded literal witnesses]
-        ol_type :: PostTc p Type }
-deriving instance (DataId p) => Data (HsOverLit p)
+      ol_ext :: (XOverLit p),
+      ol_val :: OverLitVal,
+      ol_witness :: HsExpr p}         -- Note [Overloaded literal witnesses]
+
+  | XOverLit
+      (XXOverLit p)
+deriving instance (DataIdLR p p) => Data (HsOverLit p)
+
+data OverLitTc
+  = OverLitTc {
+        ol_rebindable :: Bool, -- Note [ol_rebindable]
+        ol_type :: Type }
+  deriving Data
+
+type instance XOverLit GhcPs = PlaceHolder
+type instance XOverLit GhcRn = Bool            -- Note [ol_rebindable]
+type instance XOverLit GhcTc = OverLitTc
+
+type instance XXOverLit (GhcPass _) = PlaceHolder
 
 -- Note [Literal source text] in BasicTypes for SourceText fields in
 -- the following
@@ -118,8 +149,9 @@ negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i)
 negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f)
 negateOverLitVal _ = panic "negateOverLitVal: argument is not a number"
 
-overLitType :: HsOverLit p -> PostTc p Type
-overLitType = ol_type
+overLitType :: HsOverLit GhcTc -> Type
+overLitType (OverLit (OverLitTc _ ty) _ _) = ty
+overLitType XOverLit{} = panic "overLitType"
 
 -- | Convert a literal from one index type to another, updating the annotations
 -- according to the relevant 'Convertable' instance
@@ -137,6 +169,7 @@ convertLit (HsInteger a x b)  = (HsInteger (convert a) x b)
 convertLit (HsRat a x b)      = (HsRat (convert a) x b)
 convertLit (HsFloatPrim a x)  = (HsFloatPrim (convert a) x)
 convertLit (HsDoublePrim a x) = (HsDoublePrim (convert a) x)
+convertLit (XLit a)           = (XLit (convert a))
 
 {-
 Note [ol_rebindable]
@@ -170,8 +203,10 @@ found to have.
 
 -- Comparison operations are needed when grouping literals
 -- for compiling pattern-matching (module MatchLit)
-instance Eq (HsOverLit p) where
-  (OverLit {ol_val = val1}) == (OverLit {ol_val=val2}) = val1 == val2
+instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where
+  (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2
+  (XOverLit  val1)   == (XOverLit  val2)   = val1 == val2
+  _ == _ = panic "Eq HsOverLit"
 
 instance Eq OverLitVal where
   (HsIntegral   i1)   == (HsIntegral   i2)   = i1 == i2
@@ -179,8 +214,10 @@ instance Eq OverLitVal where
   (HsIsString _ s1)   == (HsIsString _ s2)   = s1 == s2
   _                   == _                   = False
 
-instance Ord (HsOverLit p) where
-  compare (OverLit {ol_val=val1}) (OverLit {ol_val=val2}) = val1 `compare` val2
+instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where
+  compare (OverLit _ val1 _) (OverLit _ val2 _) = val1 `compare` val2
+  compare (XOverLit  val1)   (XOverLit  val2)   = val1 `compare` val2
+  compare _ _ = panic "Ord HsOverLit"
 
 instance Ord OverLitVal where
   compare (HsIntegral i1)     (HsIntegral i2)     = i1 `compare` i2
@@ -209,6 +246,7 @@ instance p ~ GhcPass pass => Outputable (HsLit p) where
     ppr (HsWordPrim st w)   = pprWithSourceText st (pprPrimWord w)
     ppr (HsInt64Prim st i)  = pp_st_suffix st primInt64Suffix  (pprPrimInt64 i)
     ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w)
+    ppr (XLit x) = ppr x
 
 pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc
 pp_st_suffix NoSourceText         _ doc = doc
@@ -219,6 +257,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
        => Outputable (HsOverLit p) where
   ppr (OverLit {ol_val=val, ol_witness=witness})
         = ppr val <+> (whenPprDebug (parens (pprExpr witness)))
+  ppr (XOverLit x) = ppr x
 
 instance Outputable OverLitVal where
   ppr (HsIntegral i)     = pprWithSourceText (il_text i) (integer (il_value i))
@@ -245,6 +284,7 @@ pmPprHsLit (HsInteger _ i _)  = integer i
 pmPprHsLit (HsRat _ f _)      = ppr f
 pmPprHsLit (HsFloatPrim _ f)  = ppr f
 pmPprHsLit (HsDoublePrim _ d) = ppr d
+pmPprHsLit (XLit x)           = ppr x
 
 -- | Returns 'True' for compound literals that will need parentheses.
 isCompoundHsLit :: HsLit x -> Bool
@@ -261,6 +301,7 @@ isCompoundHsLit (HsInteger _ x _)  = x < 0
 isCompoundHsLit (HsRat _ x _)      = fl_neg x
 isCompoundHsLit (HsFloatPrim _ x)  = fl_neg x
 isCompoundHsLit (HsDoublePrim _ x) = fl_neg x
+isCompoundHsLit (XLit _)           = False
 
 -- | Returns 'True' for compound overloaded literals that will need
 -- parentheses when used in an argument position.
@@ -271,3 +312,4 @@ isCompoundHsOverLit (OverLit { ol_val = olv }) = compound_ol_val olv
     compound_ol_val (HsIntegral x)   = il_neg x
     compound_ol_val (HsFractional x) = fl_neg x
     compound_ol_val (HsIsString {})  = False
+isCompoundHsOverLit (XOverLit { }) = False
index cfd923c..8ffde32 100644 (file)
@@ -50,6 +50,7 @@ import HsExtension
 import HsTypes
 import TcEvidence
 import BasicTypes
+import PlaceHolder
 -- others:
 import PprCore          ( {- instance OutputableBndr TyVar -} )
 import TysWiredIn
@@ -79,42 +80,49 @@ type LPat p = Located (Pat p)
 -- For details on above see note [Api annotations] in ApiAnnotation
 data Pat p
   =     ------------ Simple patterns ---------------
-    WildPat     (PostTc p Type)        -- ^ Wildcard Pattern
+    WildPat     (XWildPat p)        -- ^ Wildcard Pattern
         -- The sole reason for a type on a WildPat is to
         -- support hsPatType :: Pat Id -> Type
 
        -- AZ:TODO above comment needs to be updated
-  | VarPat      (Located (IdP p))  -- ^ Variable Pattern
+  | VarPat      (XVarPat p)
+                (Located (IdP p))  -- ^ Variable Pattern
 
                              -- See Note [Located RdrNames] in HsExpr
-  | LazyPat     (LPat p)                -- ^ Lazy Pattern
+  | LazyPat     (XLazyPat p)
+                (LPat p)                -- ^ Lazy Pattern
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | AsPat       (Located (IdP p)) (LPat p)    -- ^ As pattern
+  | AsPat       (XAsPat p)
+                (Located (IdP p)) (LPat p)    -- ^ As pattern
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | ParPat      (LPat p)                -- ^ Parenthesised pattern
+  | ParPat      (XParPat p)
+                (LPat p)                -- ^ Parenthesised pattern
                                         -- See Note [Parens in HsSyn] in HsExpr
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,
     --                                    'ApiAnnotation.AnnClose' @')'@
 
     -- For details on above see note [Api annotations] in ApiAnnotation
-  | BangPat     (LPat p)                -- ^ Bang pattern
+  | BangPat     (XBangPat p)
+                (LPat p)                -- ^ Bang pattern
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
         ------------ Lists, tuples, arrays ---------------
-  | ListPat     [LPat p]
+  | ListPat     (XListPat p)
+                [LPat p]
                 (PostTc p Type)                      -- The type of the elements
                 (Maybe (PostTc p Type, SyntaxExpr p)) -- For rebindable syntax
                    -- For OverloadedLists a Just (ty,fn) gives
                    -- overall type of the pattern, and the toList
-                   -- function to convert the scrutinee to a list value
+-- function to convert the scrutinee to a list value
+
     -- ^ Syntactic List
     --
     -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,
@@ -122,12 +130,13 @@ data Pat p
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | TuplePat    [LPat p]         -- Tuple sub-patterns
+  | TuplePat    (XTuplePat p)
+                  -- after typechecking, holds the types of the tuple components
+                [LPat p]         -- Tuple sub-patterns
                 Boxity           -- UnitPat is TuplePat []
-                [PostTc p Type]  -- [] before typechecker, filled in afterwards
-                                 -- with the types of the tuple components
-        -- You might think that the PostTc p Type was redundant, because we can
-        -- get the pattern type by getting the types of the sub-patterns.
+        -- You might think that the post typechecking Type was redundant,
+        -- because we can get the pattern type by getting the types of the
+        -- sub-patterns.
         -- But it's essential
         --      data T a where
         --        T1 :: Int -> T Int
@@ -147,12 +156,12 @@ data Pat p
     --            'ApiAnnotation.AnnOpen' @'('@ or @'(#'@,
     --            'ApiAnnotation.AnnClose' @')'@ or  @'#)'@
 
-  | SumPat      (LPat p)           -- Sum sub-pattern
-                ConTag             -- Alternative (one-based)
-                Arity              -- Arity (INVARIANT: ≥ 2)
-                (PostTc p [Type])  -- PlaceHolder before typechecker, filled in
+  | SumPat      (XSumPat p)        -- PlaceHolder before typechecker, filled in
                                    -- afterwards with the types of the
                                    -- alternative
+                (LPat p)           -- Sum sub-pattern
+                ConTag             -- Alternative (one-based)
+                Arity              -- Arity (INVARIANT: ≥ 2)
     -- ^ Anonymous sum pattern
     --
     -- - 'ApiAnnotation.AnnKeywordId' :
@@ -160,8 +169,8 @@ data Pat p
     --            'ApiAnnotation.AnnClose' @'#)'@
 
     -- For details on above see note [Api annotations] in ApiAnnotation
-  | PArrPat     [LPat p]                -- Syntactic parallel array
-                (PostTc p Type)         -- The type of the elements
+  | PArrPat     (XPArrPat p)   -- After typechecking,  the type of the elements
+                [LPat p]       -- Syntactic parallel array
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@,
     --                                    'ApiAnnotation.AnnClose' @':]'@
 
@@ -196,11 +205,11 @@ data Pat p
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | ViewPat       (LHsExpr p)
+  | ViewPat       (XViewPat p)     -- The overall type of the pattern
+                                   -- (= the argument type of the view function)
+                                   -- for hsPatType.
+                  (LHsExpr p)
                   (LPat p)
-                  (PostTc p Type)   -- The overall type of the pattern
-                                    -- (= the argument type of the view function)
-                                    -- for hsPatType.
     -- ^ View Pattern
 
         ------------ Pattern splices ---------------
@@ -208,31 +217,34 @@ data Pat p
   --        'ApiAnnotation.AnnClose' @')'@
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | SplicePat       (HsSplice p)    -- ^ Splice Pattern (Includes quasi-quotes)
+  | SplicePat       (XSplicePat p)
+                    (HsSplice p)    -- ^ Splice Pattern (Includes quasi-quotes)
 
         ------------ Literal and n+k patterns ---------------
-  | LitPat          (HsLit p)           -- ^ Literal Pattern
+  | LitPat          (XLitPat p)
+                    (HsLit p)           -- ^ Literal Pattern
                                         -- Used for *non-overloaded* literal patterns:
                                         -- Int#, Char#, Int, Char, String, etc.
 
   | NPat                -- Natural Pattern
                         -- Used for all overloaded literals,
                         -- including overloaded strings with -XOverloadedStrings
+                    (XNPat p)            -- Overall type of pattern. Might be
+                                         -- different than the literal's type
+                                         -- if (==) or negate changes the type
                     (Located (HsOverLit p))     -- ALWAYS positive
                     (Maybe (SyntaxExpr p)) -- Just (Name of 'negate') for
                                            -- negative patterns, Nothing
                                            -- otherwise
                     (SyntaxExpr p)       -- Equality checker, of type t->t->Bool
-                    (PostTc p Type)      -- Overall type of pattern. Might be
-                                         -- different than the literal's type
-                                         -- if (==) or negate changes the type
 
   -- ^ Natural Pattern
   --
   -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | NPlusKPat       (Located (IdP p))        -- n+k pattern
+  | NPlusKPat       (XNPlusKPat p)           -- Type of overall pattern
+                    (Located (IdP p))        -- n+k pattern
                     (Located (HsOverLit p))  -- It'll always be an HsIntegral
                     (HsOverLit p)       -- See Note [NPlusK patterns] in TcPat
                      -- NB: This could be (PostTc ...), but that induced a
@@ -240,24 +252,22 @@ data Pat p
 
                     (SyntaxExpr p)   -- (>=) function, of type t1->t2->Bool
                     (SyntaxExpr p)   -- Name of '-' (see RnEnv.lookupSyntaxName)
-                    (PostTc p Type)  -- Type of overall pattern
   -- ^ n+k pattern
 
         ------------ Pattern type signatures ---------------
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | SigPatIn        (LPat p)                  -- Pattern with a type signature
-                    (LHsSigWcType p)          -- Signature can bind both
-                                              -- kind and type vars
-    -- ^ Pattern with a type signature
-
-  | SigPatOut       (LPat p)
-                    Type
+  | SigPat          (XSigPat p)          -- Before typechecker
+                                         --  Signature can bind both
+                                         --  kind and type vars
+                                         -- After typechecker: Type
+                    (LPat p)                -- Pattern with a type signature
     -- ^ Pattern with a type signature
 
         ------------ Pattern coercions (translation only) ---------------
-  | CoPat       HsWrapper           -- Coercion Pattern
+  | CoPat       (XCoPat p)
+                HsWrapper           -- Coercion Pattern
                                     -- If co :: t1 ~ t2, p :: t2,
                                     -- then (CoPat co p) :: t1
                 (Pat p)             -- Why not LPat?  Ans: existing locn will do
@@ -265,7 +275,65 @@ data Pat p
         -- During desugaring a (CoPat co pat) turns into a cast with 'co' on
         -- the scrutinee, followed by a match on 'pat'
     -- ^ Coercion Pattern
-deriving instance (DataId p) => Data (Pat p)
+
+  -- | Trees that Grow extension point for new constructors
+  | XPat
+      (XXPat p)
+deriving instance (DataIdLR p p) => Data (Pat p)
+
+-- ---------------------------------------------------------------------
+
+type instance XWildPat GhcPs = PlaceHolder
+type instance XWildPat GhcRn = PlaceHolder
+type instance XWildPat GhcTc = Type
+
+type instance XVarPat  (GhcPass _) = PlaceHolder
+type instance XLazyPat (GhcPass _) = PlaceHolder
+type instance XAsPat   (GhcPass _) = PlaceHolder
+type instance XParPat  (GhcPass _) = PlaceHolder
+type instance XBangPat (GhcPass _) = PlaceHolder
+
+-- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap
+-- compiler, as it triggers https://ghc.haskell.org/trac/ghc/ticket/14396 for
+-- `SyntaxExpr`
+type instance XListPat (GhcPass _) = PlaceHolder
+
+type instance XTuplePat GhcPs = PlaceHolder
+type instance XTuplePat GhcRn = PlaceHolder
+type instance XTuplePat GhcTc = [Type]
+
+type instance XSumPat GhcPs = PlaceHolder
+type instance XSumPat GhcRn = PlaceHolder
+type instance XSumPat GhcTc = [Type]
+
+type instance XPArrPat GhcPs = PlaceHolder
+type instance XPArrPat GhcRn = PlaceHolder
+type instance XPArrPat GhcTc = Type
+
+type instance XViewPat GhcPs = PlaceHolder
+type instance XViewPat GhcRn = PlaceHolder
+type instance XViewPat GhcTc = Type
+
+type instance XSplicePat (GhcPass _) = PlaceHolder
+type instance XLitPat    (GhcPass _) = PlaceHolder
+
+type instance XNPat GhcPs = PlaceHolder
+type instance XNPat GhcRn = PlaceHolder
+type instance XNPat GhcTc = Type
+
+type instance XNPlusKPat GhcPs = PlaceHolder
+type instance XNPlusKPat GhcRn = PlaceHolder
+type instance XNPlusKPat GhcTc = Type
+
+type instance XSigPat GhcPs = (LHsSigWcType GhcPs)
+type instance XSigPat GhcRn = (LHsSigWcType GhcRn)
+type instance XSigPat GhcTc = Type
+
+type instance XCoPat  (GhcPass _) = PlaceHolder
+type instance XXPat   (GhcPass _) = PlaceHolder
+
+-- ---------------------------------------------------------------------
+
 
 -- | Haskell Constructor Pattern Details
 type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p))
@@ -383,24 +451,24 @@ data HsRecField' id arg = HsRecField {
 --
 -- See also Note [Disambiguating record fields] in TcExpr.
 
-hsRecFields :: HsRecFields p arg -> [PostRn p (IdP p)]
+hsRecFields :: HsRecFields p arg -> [XFieldOcc p]
 hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds)
 
 -- Probably won't typecheck at once, things have changed :/
 hsRecFieldsArgs :: HsRecFields p arg -> [arg]
 hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds)
 
-hsRecFieldSel :: HsRecField pass arg -> Located (PostRn pass (IdP pass))
-hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl
+hsRecFieldSel :: HsRecField pass arg -> Located (XFieldOcc pass)
+hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl
 
 hsRecFieldId :: HsRecField GhcTc arg -> Located Id
 hsRecFieldId = hsRecFieldSel
 
-hsRecUpdFieldRdr :: HsRecUpdField p -> Located RdrName
+hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName
 hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl
 
 hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id
-hsRecUpdFieldId = fmap selectorFieldOcc . hsRecUpdFieldOcc
+hsRecUpdFieldId = fmap extFieldOcc . hsRecUpdFieldOcc
 
 hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc
 hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl
@@ -444,28 +512,30 @@ pprParendPat p = sdocWithDynFlags $ \ dflags ->
       -- is the pattern inside that matters.  Sigh.
 
 pprPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc
-pprPat (VarPat (L _ var))     = pprPatBndr var
-pprPat (WildPat _)            = char '_'
-pprPat (LazyPat pat)          = char '~' <> pprParendLPat pat
-pprPat (BangPat pat)          = char '!' <> pprParendLPat pat
-pprPat (AsPat name pat)       = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat]
-pprPat (ViewPat expr pat _)   = hcat [pprLExpr expr, text " -> ", ppr pat]
-pprPat (ParPat pat)           = parens (ppr pat)
-pprPat (LitPat s)             = ppr s
-pprPat (NPat l Nothing  _ _)  = ppr l
-pprPat (NPat l (Just _) _ _)  = char '-' <> ppr l
-pprPat (NPlusKPat n k _ _ _ _)= hcat [ppr n, char '+', ppr k]
-pprPat (SplicePat splice)     = pprSplice splice
-pprPat (CoPat co pat _)       = pprHsWrapper co (\parens -> if parens
-                                                            then pprParendPat pat
-                                                            else pprPat pat)
-pprPat (SigPatIn pat ty)      = ppr pat <+> dcolon <+> ppr ty
-pprPat (SigPatOut pat ty)     = ppr pat <+> dcolon <+> ppr ty
-pprPat (ListPat pats _ _)     = brackets (interpp'SP pats)
-pprPat (PArrPat pats _)       = paBrackets (interpp'SP pats)
-pprPat (TuplePat pats bx _)   = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)
-pprPat (SumPat pat alt arity _) = sumParens (pprAlternative ppr pat alt arity)
-pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
+pprPat (VarPat _ (L _ var))     = pprPatBndr var
+pprPat (WildPat _)              = char '_'
+pprPat (LazyPat _ pat)          = char '~' <> pprParendLPat pat
+pprPat (BangPat _ pat)          = char '!' <> pprParendLPat pat
+pprPat (AsPat _ name pat)       = hcat [pprPrefixOcc (unLoc name), char '@',
+                                        pprParendLPat pat]
+pprPat (ViewPat _ expr pat)     = hcat [pprLExpr expr, text " -> ", ppr pat]
+pprPat (ParPat _ pat)           = parens (ppr pat)
+pprPat (LitPat _ s)             = ppr s
+pprPat (NPat _ l Nothing  _)    = ppr l
+pprPat (NPat _ l (Just _) _)    = char '-' <> ppr l
+pprPat (NPlusKPat _ n k _ _ _)  = hcat [ppr n, char '+', ppr k]
+pprPat (SplicePat _ splice)     = pprSplice splice
+pprPat (CoPat _ co pat _)       = pprHsWrapper co (\parens
+                                                   -> if parens
+                                                        then pprParendPat pat
+                                                        else pprPat pat)
+pprPat (SigPat ty pat)          = ppr pat <+> dcolon <+> ppr ty
+pprPat (ListPat _ pats _ _)     = brackets (interpp'SP pats)
+pprPat (PArrPat _ pats)         = paBrackets (interpp'SP pats)
+pprPat (TuplePat _ pats bx)     = tupleParens (boxityTupleSort bx)
+                                              (pprWithCommas ppr pats)
+pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity)
+pprPat (ConPatIn con details)   = pprUserCon (unLoc con) details
 pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
                     pat_binds = binds, pat_args = details })
   = sdocWithDynFlags $ \dflags ->
@@ -478,6 +548,7 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
                          , ppr binds])
           <+> pprConArgs details
     else pprUserCon (unLoc con) details
+pprPat (XPat x)               = ppr x
 
 
 pprUserCon :: (OutputableBndr con, OutputableBndrId (GhcPass p))
@@ -527,7 +598,7 @@ mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
 
 mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p)
 mkCharLitPat src c = mkPrefixConPat charDataCon
-                          [noLoc $ LitPat (HsCharPrim src c)] []
+                          [noLoc $ LitPat PlaceHolder (HsCharPrim src c)] []
 
 {-
 ************************************************************************
@@ -562,7 +633,7 @@ The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
 -}
 
 isBangedLPat :: LPat p -> Bool
-isBangedLPat (L _ (ParPat p))   = isBangedLPat p
+isBangedLPat (L _ (ParPat _ p)) = isBangedLPat p
 isBangedLPat (L _ (BangPat {})) = True
 isBangedLPat _                  = False
 
@@ -580,8 +651,8 @@ looksLazyPatBind _
   = False
 
 looksLazyLPat :: LPat p -> Bool
-looksLazyLPat (L _ (ParPat p))             = looksLazyLPat p
-looksLazyLPat (L _ (AsPat _ p))            = looksLazyLPat p
+looksLazyLPat (L _ (ParPat _ p))           = looksLazyLPat p
+looksLazyLPat (L _ (AsPat _ _ p))          = looksLazyLPat p
 looksLazyLPat (L _ (BangPat {}))           = False
 looksLazyLPat (L _ (VarPat {}))            = False
 looksLazyLPat (L _ (WildPat {}))           = False
@@ -608,15 +679,14 @@ isIrrefutableHsPat pat
     go1 (WildPat {})        = True
     go1 (VarPat {})         = True
     go1 (LazyPat {})        = True
-    go1 (BangPat pat)       = go pat
-    go1 (CoPat _ pat _)     = go1 pat
-    go1 (ParPat pat)        = go pat
-    go1 (AsPat _ pat)       = go pat
-    go1 (ViewPat _ pat _)   = go pat
-    go1 (SigPatIn pat _)    = go pat
-    go1 (SigPatOut pat _)   = go pat
-    go1 (TuplePat pats _ _) = all go pats
-    go1 (SumPat _ _ _ _)    = False
+    go1 (BangPat _ pat)     = go pat
+    go1 (CoPat _ _ pat _)   = go1 pat
+    go1 (ParPat _ pat)      = go pat
+    go1 (AsPat _ _ pat)     = go pat
+    go1 (ViewPat _ _ pat)   = go pat
+    go1 (SigPat _ pat)      = go pat
+    go1 (TuplePat _ pats _) = all go pats
+    go1 (SumPat {})         = False
                     -- See Note [Unboxed sum patterns aren't irrefutable]
     go1 (ListPat {})        = False
     go1 (PArrPat {})        = False     -- ?
@@ -638,6 +708,8 @@ isIrrefutableHsPat pat
     -- since we cannot know until the splice is evaluated.
     go1 (SplicePat {})      = False
 
+    go1 (XPat {})           = False
+
 {- Note [Unboxed sum patterns aren't irrefutable]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as
@@ -667,10 +739,9 @@ hsPatNeedsParens (NPlusKPat {})      = True
 hsPatNeedsParens (SplicePat {})      = False
 hsPatNeedsParens (ConPatIn _ ds)     = conPatNeedsParens ds
 hsPatNeedsParens p@(ConPatOut {})    = conPatNeedsParens (pat_args p)
-hsPatNeedsParens (SigPatIn {})       = True
-hsPatNeedsParens (SigPatOut {})      = True
+hsPatNeedsParens (SigPat {})         = True
 hsPatNeedsParens (ViewPat {})        = True
-hsPatNeedsParens (CoPat _ p _)       = hsPatNeedsParens p
+hsPatNeedsParens (CoPat _ _ p _)     = hsPatNeedsParens p
 hsPatNeedsParens (WildPat {})        = False
 hsPatNeedsParens (VarPat {})         = False
 hsPatNeedsParens (LazyPat {})        = False
@@ -683,6 +754,7 @@ hsPatNeedsParens (ListPat {})        = False
 hsPatNeedsParens (PArrPat {})        = False
 hsPatNeedsParens (LitPat {})         = False
 hsPatNeedsParens (NPat {})           = False
+hsPatNeedsParens (XPat {})           = True -- conservative default
 
 -- | Returns 'True' if a constructor pattern must be parenthesized in order
 -- to parse.
@@ -704,10 +776,9 @@ isCompoundPat (NPlusKPat {})       = True
 isCompoundPat (SplicePat {})       = False
 isCompoundPat (ConPatIn _ ds)      = isCompoundConPat ds
 isCompoundPat p@(ConPatOut {})     = isCompoundConPat (pat_args p)
-isCompoundPat (SigPatIn {})        = True
-isCompoundPat (SigPatOut {})       = True
+isCompoundPat (SigPat {})          = True
 isCompoundPat (ViewPat {})         = True
-isCompoundPat (CoPat _ p _)        = isCompoundPat p
+isCompoundPat (CoPat _ _ p _)      = isCompoundPat p
 isCompoundPat (WildPat {})         = False
 isCompoundPat (VarPat {})          = False
 isCompoundPat (LazyPat {})         = False
@@ -718,8 +789,9 @@ isCompoundPat (TuplePat {})        = False
 isCompoundPat (SumPat {})          = False
 isCompoundPat (ListPat {})         = False
 isCompoundPat (PArrPat {})         = False
-isCompoundPat (LitPat p)           = isCompoundHsLit p
-isCompoundPat (NPat (L _ p) _ _ _) = isCompoundHsOverLit p
+isCompoundPat (LitPat _ p)         = isCompoundHsLit p
+isCompoundPat (NPat _ (L _ p) _ _) = isCompoundHsOverLit p
+isCompoundPat (XPat {})            = False -- Assumption
 
 -- | Returns 'True' for compound constructor patterns that need parentheses
 -- when used in an argument position.
@@ -736,9 +808,9 @@ isCompoundConPat (RecCon {})      = False
 
 -- | @'parenthesizeCompoundPat' p@ checks if @'isCompoundPat' p@ is true, and
 -- if so, surrounds @p@ with a 'ParPat'. Otherwise, it simply returns @p@.
-parenthesizeCompoundPat :: LPat p -> LPat p
+parenthesizeCompoundPat :: LPat (GhcPass p) -> LPat (GhcPass p)
 parenthesizeCompoundPat lp@(L loc p)
-  | isCompoundPat p = L loc (ParPat lp)
+  | isCompoundPat p = L loc (ParPat PlaceHolder lp)
   | otherwise       = lp
 
 {-
@@ -746,30 +818,29 @@ parenthesizeCompoundPat lp@(L loc p)
 -}
 
 -- May need to add more cases
-collectEvVarsPats :: [Pat p] -> Bag EvVar
+collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar
 collectEvVarsPats = unionManyBags . map collectEvVarsPat
 
-collectEvVarsLPat :: LPat p -> Bag EvVar
+collectEvVarsLPat :: LPat GhcTc -> Bag EvVar
 collectEvVarsLPat (L _ pat) = collectEvVarsPat pat
 
-collectEvVarsPat :: Pat p -> Bag EvVar
+collectEvVarsPat :: Pat GhcTc -> Bag EvVar
 collectEvVarsPat pat =
   case pat of
-    LazyPat  p        -> collectEvVarsLPat p
-    AsPat _  p        -> collectEvVarsLPat p
-    ParPat   p        -> collectEvVarsLPat p
-    BangPat  p        -> collectEvVarsLPat p
-    ListPat  ps _ _   -> unionManyBags $ map collectEvVarsLPat ps
-    TuplePat ps _ _   -> unionManyBags $ map collectEvVarsLPat ps
-    SumPat p _ _ _    -> collectEvVarsLPat p
-    PArrPat  ps _     -> unionManyBags $ map collectEvVarsLPat ps
+    LazyPat _ p      -> collectEvVarsLPat p
+    AsPat _ _ p      -> collectEvVarsLPat p
+    ParPat  _ p      -> collectEvVarsLPat p
+    BangPat _ p      -> collectEvVarsLPat p
+    ListPat _ ps _ _ -> unionManyBags $ map collectEvVarsLPat ps
+    TuplePat _ ps _  -> unionManyBags $ map collectEvVarsLPat ps
+    SumPat _ p _ _   -> collectEvVarsLPat p
+    PArrPat _ ps     -> unionManyBags $ map collectEvVarsLPat ps
     ConPatOut {pat_dicts = dicts, pat_args  = args}
-                      -> unionBags (listToBag dicts)
+                     -> unionBags (listToBag dicts)
                                    $ unionManyBags
                                    $ map collectEvVarsLPat
                                    $ hsConPatArgs args
-    SigPatOut p _     -> collectEvVarsLPat p
-    CoPat _ p _       -> collectEvVarsPat  p
-    ConPatIn _  _     -> panic "foldMapPatBag: ConPatIn"
-    SigPatIn _ _      -> panic "foldMapPatBag: SigPatIn"
-    _other_pat        -> emptyBag
+    SigPat  _ p      -> collectEvVarsLPat p
+    CoPat _ _ p _    -> collectEvVarsPat  p
+    ConPatIn _  _    -> panic "foldMapPatBag: ConPatIn"
+    _other_pat       -> emptyBag
index 55c63fe..d9a4d79 100644 (file)
@@ -11,11 +11,11 @@ import SrcLoc( Located )
 
 import Data.Data hiding (Fixity)
 import Outputable
-import HsExtension      ( DataId, OutputableBndrId, GhcPass )
+import HsExtension      ( DataIdLR, OutputableBndrId, GhcPass )
 
 type role Pat nominal
 data Pat (i :: *)
 type LPat i = Located (Pat i)
 
-instance (DataId p) => Data (Pat p)
+instance (DataIdLR p p) => Data (Pat p)
 instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p)
index 7631c95..1534491 100644 (file)
@@ -111,7 +111,7 @@ data HsModule name
      --    hsmodImports,hsmodDecls if this style is used.
 
      -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId name) => Data (HsModule name)
+deriving instance (DataIdLR name name) => Data (HsModule name)
 
 instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsModule p) where
 
index a2c863e..5be6ddb 100644 (file)
@@ -17,7 +17,7 @@ HsTypes: Abstract syntax: user-defined types
 {-# LANGUAGE TypeFamilies #-}
 
 module HsTypes (
-        HsType(..), LHsType, HsKind, LHsKind,
+        HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind,
         HsTyVarBndr(..), LHsTyVarBndr,
         LHsQTyVars(..),
         HsImplicitBndrs(..),
@@ -44,7 +44,7 @@ module HsTypes (
         rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc,
         unambiguousFieldOcc, ambiguousFieldOcc,
 
-        HsWildCardInfo(..), mkAnonWildCardTy,
+        HsWildCardInfo(..), mkAnonWildCardTy, pprAnonWildCard,
         wildCardName, sameWildCard,
 
         mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,
@@ -73,8 +73,9 @@ import GhcPrelude
 
 import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
 
-import PlaceHolder ( PlaceHolder(..) )
+import PlaceHolder ( PlaceHolder(..), placeHolder )
 import HsExtension
+import HsLit () -- for instances
 
 import Id ( Id )
 import Name( Name )
@@ -109,11 +110,11 @@ type LBangType pass = Located (BangType pass)
 type BangType pass  = HsType pass       -- Bangs are in the HsType data type
 
 getBangType :: LHsType a -> LHsType a
-getBangType (L _ (HsBangTy _ ty)) = ty
-getBangType ty                    = ty
+getBangType (L _ (HsBangTy _ ty)) = ty
+getBangType ty                      = ty
 
 getBangStrictness :: LHsType a -> HsSrcBang
-getBangStrictness (L _ (HsBangTy s _)) = s
+getBangStrictness (L _ (HsBangTy s _)) = s
 getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)
 
 {-
@@ -269,11 +270,11 @@ data LHsQTyVars pass   -- See Note [HsType binders]
                -- See Note [Dependent LHsQTyVars] in TcHsType
     }
 
-deriving instance (DataId pass) => Data (LHsQTyVars pass)
+deriving instance (DataIdLR pass pass) => Data (LHsQTyVars pass)
 
 mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs
-mkHsQTvs tvs = HsQTvs { hsq_implicit = PlaceHolder, hsq_explicit = tvs
-                      , hsq_dependent = PlaceHolder }
+mkHsQTvs tvs = HsQTvs { hsq_implicit = placeHolder, hsq_explicit = tvs
+                      , hsq_dependent = placeHolder }
 
 hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr pass]
 hsQTvExplicit = hsq_explicit
@@ -363,12 +364,12 @@ the explicitly forall'd tyvar 'a' is bound by the HsForAllTy
 
 mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing
 mkHsImplicitBndrs x = HsIB { hsib_body   = x
-                           , hsib_vars   = PlaceHolder
-                           , hsib_closed = PlaceHolder }
+                           , hsib_vars   = placeHolder
+                           , hsib_closed = placeHolder }
 
 mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing
 mkHsWildCardBndrs x = HsWC { hswc_body = x
-                           , hswc_wcs  = PlaceHolder }
+                           , hswc_wcs  = placeHolder }
 
 -- Add empty binders.  This is a bit suspicious; what if
 -- the wrapped thing had free type variables?
@@ -404,9 +405,11 @@ instance OutputableBndr HsIPName where
 -- | Haskell Type Variable Binder
 data HsTyVarBndr pass
   = UserTyVar        -- no explicit kinding
+         (XUserTyVar pass)
          (Located (IdP pass))
         -- See Note [Located RdrNames] in HsExpr
   | KindedTyVar
+         (XKindedTyVar pass)
          (Located (IdP pass))
          (LHsKind pass)  -- The user-supplied kind signature
         -- ^
@@ -414,12 +417,20 @@ data HsTyVarBndr pass
         --          'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose'
 
         -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (HsTyVarBndr pass)
+
+  | XTyVarBndr
+      (XXTyVarBndr pass)
+deriving instance (DataIdLR pass pass) => Data (HsTyVarBndr pass)
+
+type instance XUserTyVar    (GhcPass _) = PlaceHolder
+type instance XKindedTyVar  (GhcPass _) = PlaceHolder
+type instance XXTyVarBndr   (GhcPass _) = PlaceHolder
 
 -- | Does this 'HsTyVarBndr' come with an explicit kind annotation?
 isHsKindedTyVar :: HsTyVarBndr pass -> Bool
 isHsKindedTyVar (UserTyVar {})   = False
 isHsKindedTyVar (KindedTyVar {}) = True
+isHsKindedTyVar (XTyVarBndr{})   = panic "isHsKindedTyVar"
 
 -- | Do all type variables in this 'LHsQTyVars' come with kind annotations?
 hsTvbAllKinded :: LHsQTyVars pass -> Bool
@@ -428,19 +439,22 @@ hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit
 -- | Haskell Type
 data HsType pass
   = HsForAllTy   -- See Note [HsType binders]
-      { hst_bndrs :: [LHsTyVarBndr pass]
+      { hst_xforall :: XForAllTy pass,
+        hst_bndrs   :: [LHsTyVarBndr pass]
                                        -- Explicit, user-supplied 'forall a b c'
-      , hst_body  :: LHsType pass      -- body type
+      , hst_body    :: LHsType pass      -- body type
       }
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall',
       --         'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
       -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsQualTy   -- See Note [HsType binders]
-      { hst_ctxt :: LHsContext pass       -- Context C => blah
-      , hst_body :: LHsType pass }
+      { hst_xqual :: XQualTy pass
+      , hst_ctxt  :: LHsContext pass       -- Context C => blah
+      , hst_body  :: LHsType pass }
 
-  | HsTyVar             Promoted -- whether explicitly promoted, for the pretty
+  | HsTyVar             (XTyVar pass)
+                        Promoted -- whether explicitly promoted, for the pretty
                                  -- printer
                         (Located (IdP pass))
                   -- Type variable, type constructor, or data constructor
@@ -450,53 +464,62 @@ data HsType pass
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsAppsTy            [LHsAppType pass] -- Used only before renaming,
+  | HsAppsTy            (XAppsTy pass)
+                        [LHsAppType pass] -- Used only before renaming,
                                           -- Note [HsAppsTy]
       -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
-  | HsAppTy             (LHsType pass)
+  | HsAppTy             (XAppTy pass)
+       &n