Commit e3ec2e7a authored by Alan Zimmerman's avatar Alan Zimmerman

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
parent 86c50a16
......@@ -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
......
......@@ -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)
......
......@@ -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'
......
......@@ -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]))
ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
ret_stmt = noLoc $ mkLastStmt ret_app
-- This LastStmt will be desugared with dsDo,
......@@ -1138,9 +1140,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