WIP on combined Step 1 and 3 for Trees That Grow, HsExpr

See https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow

Trees that grow extension points are added for
- HsExpr

Updates haddock submodule

Test Plan: ./validate

Reviewers: bgamari, goldfire

Subscribers: rwbarton, thomie, shayan-najd, mpickering

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

compiler/deSugar/Check.hs

@@ -675,12 +675,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
@@ -760,7 +760,7 @@ translatePat fam_insts pat = case pat of
     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
 
@@ -1217,7 +1217,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

compiler/deSugar/Coverage.hs

@@ -459,15 +459,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)
@@ -489,55 +489,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 x 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 x e) =
+        liftM (HsPar x) (addTickLHsExprEvalInner e)
+addTickHsExpr (SectionL x e1 e2) =
+        liftM2 (SectionL x)
                 (addTickLHsExpr e1)
                 (addTickLHsExprNever e2)
-addTickHsExpr (SectionR e1 e2) =
-        liftM2 SectionR
+addTickHsExpr (SectionR x e1 e2) =
+        liftM2 (SectionR x)
                 (addTickLHsExprNever e1)
                 (addTickLHsExpr e2)
-addTickHsExpr (ExplicitTuple es boxity) =
-        liftM2 ExplicitTuple
+addTickHsExpr (ExplicitTuple x 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 x 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 x cnd e1 e2 e3) =
+        liftM3 (HsIf x cnd)
                 (addBinTickLHsExpr (BinBox CondBinBox) e1)
                 (addTickLHsExprOptAlt True e2)
                 (addTickLHsExprOptAlt True e3)
@@ -545,14 +548,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 x (L l binds) e) =
         bindLocals (collectLocalBinders binds) $
-          liftM2 (HsLet . L l)
+          liftM2 (HsLet x . 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
@@ -582,12 +585,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)
@@ -597,26 +600,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 x t e) =
+        liftM (HsTick x t) (addTickLHsExprNever e)
+addTickHsExpr (HsBinTick x t0 t1 e) =
+        liftM (HsBinTick x 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 x src nm e) =
+        liftM3 (HsSCC x)
                 (return src)
                 (return nm)
                 (addTickLHsExpr e)
-addTickHsExpr (HsCoreAnn src nm e) =
-        liftM3 HsCoreAnn
+addTickHsExpr (HsCoreAnn x src nm e) =
+        liftM3 (HsCoreAnn x)
                 (return src)
                 (return nm)
                 (addTickLHsExpr e)
@@ -624,20 +627,15 @@ 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 x pat cmdtop) =
+        liftM2 (HsProc x)
                 (addTickLPat pat)
                 (liftL (addTickHsCmdTop) cmdtop)
-addTickHsExpr (HsWrap w e) =
-        liftM2 HsWrap
+addTickHsExpr (HsWrap x 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)
 
@@ -762,8 +760,8 @@ addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
                   | otherwise          = addTickLHsExprRHS e
 
 addTickApplicativeArg
-  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc)
-  -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc)
+  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
+  -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
 addTickApplicativeArg isGuard (op, arg) =
   liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
  where
@@ -1169,7 +1167,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)
@@ -1255,13 +1253,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)

compiler/deSugar/DsArrows.hs

@@ -575,10 +575,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 +599,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'
 

compiler/deSugar/DsExpr.hs

@@ -250,17 +250,18 @@ 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 _ (XExpr {})             = panic "dsExpr: XExpr"
 
-ds_expr _ (HsWrap co_fn e)
+ds_expr _ (HsWrap _ co_fn e)
   = do { e' <- ds_expr True e
        ; wrap' <- dsHsWrapper co_fn
        ; dflags <- getDynFlags
@@ -270,7 +271,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
@@ -279,23 +280,23 @@ 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
 
@@ -339,19 +340,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)
@@ -362,7 +363,7 @@ 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.
@@ -379,14 +380,14 @@ ds_expr _ (ExplicitTuple tup_args boxity)
                       (\(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
@@ -397,31 +398,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
@@ -454,7 +455,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
@@ -536,8 +537,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')
@@ -596,9 +598,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
@@ -662,7 +666,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                                <.>
@@ -714,16 +718,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')
 
@@ -734,20 +738,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"
@@ -755,7 +758,6 @@ 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"
 
@@ -934,9 +936,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
@@ -968,15 +970,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 noExt $ mkBigLHsPatTupId rec_tup_pats
-        body         = noLoc $ HsDo
-                                DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty
+        body         = noLoc $ HsDo body_ty
+                                DoExpr (noLoc (rec_stmts ++ [ret_stmt]))