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) ...@@ -675,12 +675,12 @@ truePattern = nullaryConPattern (RealDataCon trueDataCon)
-- | A fake guard pattern (True <- _) used to represent cases we cannot handle -- | A fake guard pattern (True <- _) used to represent cases we cannot handle
fake_pat :: Pattern fake_pat :: Pattern
fake_pat = PmGrd { pm_grd_pv = [truePattern] fake_pat = PmGrd { pm_grd_pv = [truePattern]
, pm_grd_expr = PmExprOther EWildPat } , pm_grd_expr = PmExprOther (EWildPat noExt) }
{-# INLINE fake_pat #-} {-# INLINE fake_pat #-}
-- | Check whether a guard pattern is generated by the checker (unhandled) -- | Check whether a guard pattern is generated by the checker (unhandled)
isFakeGuard :: [Pattern] -> PmExpr -> Bool 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 | c == trueDataCon = True
| otherwise = False | otherwise = False
isFakeGuard _pats _e = False isFakeGuard _pats _e = False
...@@ -760,7 +760,7 @@ translatePat fam_insts pat = case pat of ...@@ -760,7 +760,7 @@ translatePat fam_insts pat = case pat of
case all cantFailPattern ps of case all cantFailPattern ps of
True -> do True -> do
(xp,xe) <- mkPmId2Forms arg_ty (xp,xe) <- mkPmId2Forms arg_ty
let g = mkGuard ps (HsApp lexpr xe) let g = mkGuard ps (HsApp noExt lexpr xe)
return [xp,g] return [xp,g]
False -> mkCanFailPmPat arg_ty False -> mkCanFailPmPat arg_ty
...@@ -1217,7 +1217,7 @@ mkPmId ty = getUniqueM >>= \unique -> ...@@ -1217,7 +1217,7 @@ mkPmId ty = getUniqueM >>= \unique ->
mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc) mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc)
mkPmId2Forms ty = do mkPmId2Forms ty = do
x <- mkPmId ty 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 -- * Converting between Value Abstractions, Patterns and PmExpr
......
...@@ -459,15 +459,15 @@ addTickLHsExprNever (L pos e0) = do ...@@ -459,15 +459,15 @@ addTickLHsExprNever (L pos e0) = do
-- general heuristic: expressions which do not denote values are good -- general heuristic: expressions which do not denote values are good
-- break points -- break points
isGoodBreakExpr :: HsExpr GhcTc -> Bool isGoodBreakExpr :: HsExpr GhcTc -> Bool
isGoodBreakExpr (HsApp {}) = True isGoodBreakExpr (HsApp {}) = True
isGoodBreakExpr (HsAppTypeOut {}) = True isGoodBreakExpr (HsAppType {}) = True
isGoodBreakExpr (OpApp {}) = True isGoodBreakExpr (OpApp {}) = True
isGoodBreakExpr _other = False isGoodBreakExpr _other = False
isCallSite :: HsExpr GhcTc -> Bool isCallSite :: HsExpr GhcTc -> Bool
isCallSite HsApp{} = True isCallSite HsApp{} = True
isCallSite HsAppTypeOut{} = True isCallSite HsAppType{} = True
isCallSite OpApp{} = True isCallSite OpApp{} = True
isCallSite _ = False isCallSite _ = False
addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
...@@ -489,55 +489,58 @@ addBinTickLHsExpr boxLabel (L pos e0) ...@@ -489,55 +489,58 @@ addBinTickLHsExpr boxLabel (L pos e0)
-- in the addTickLHsExpr family of functions.) -- in the addTickLHsExpr family of functions.)
addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e
addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"
addTickHsExpr e@(HsConLikeOut con) addTickHsExpr e@(HsConLikeOut _ con)
| Just id <- conLikeWrapId_maybe con = do freeVar id; return e | Just id <- conLikeWrapId_maybe con = do freeVar id; return e
addTickHsExpr e@(HsIPVar _) = return e addTickHsExpr e@(HsIPVar {}) = return e
addTickHsExpr e@(HsOverLit _) = return e addTickHsExpr e@(HsOverLit {}) = return e
addTickHsExpr e@(HsOverLabel{}) = return e addTickHsExpr e@(HsOverLabel{}) = return e
addTickHsExpr e@(HsLit _) = return e addTickHsExpr e@(HsLit {}) = return e
addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup) addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x)
addTickHsExpr (HsLamCase mgs) = liftM HsLamCase (addTickMatchGroup True mgs) (addTickMatchGroup True matchgroup)
addTickHsExpr (HsApp e1 e2) = liftM2 HsApp (addTickLHsExprNever e1) addTickHsExpr (HsLamCase x mgs) = liftM (HsLamCase x)
(addTickLHsExpr e2) (addTickMatchGroup True mgs)
addTickHsExpr (HsAppTypeOut e ty) = liftM2 HsAppTypeOut (addTickLHsExprNever e) addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1)
(return ty) (addTickLHsExpr e2)
addTickHsExpr (HsAppType ty e) = liftM2 HsAppType (return ty)
addTickHsExpr (OpApp e1 e2 fix e3) = (addTickLHsExprNever e)
addTickHsExpr (OpApp fix e1 e2 e3) =
liftM4 OpApp liftM4 OpApp
(return fix)
(addTickLHsExpr e1) (addTickLHsExpr e1)
(addTickLHsExprNever e2) (addTickLHsExprNever e2)
(return fix)
(addTickLHsExpr e3) (addTickLHsExpr e3)
addTickHsExpr (NegApp e neg) = addTickHsExpr (NegApp x e neg) =
liftM2 NegApp liftM2 (NegApp x)
(addTickLHsExpr e) (addTickLHsExpr e)
(addTickSyntaxExpr hpcSrcSpan neg) (addTickSyntaxExpr hpcSrcSpan neg)
addTickHsExpr (HsPar e) = addTickHsExpr (HsPar x e) =
liftM HsPar (addTickLHsExprEvalInner e) liftM (HsPar x) (addTickLHsExprEvalInner e)
addTickHsExpr (SectionL e1 e2) = addTickHsExpr (SectionL x e1 e2) =
liftM2 SectionL liftM2 (SectionL x)
(addTickLHsExpr e1) (addTickLHsExpr e1)
(addTickLHsExprNever e2) (addTickLHsExprNever e2)
addTickHsExpr (SectionR e1 e2) = addTickHsExpr (SectionR x e1 e2) =
liftM2 SectionR liftM2 (SectionR x)
(addTickLHsExprNever e1) (addTickLHsExprNever e1)
(addTickLHsExpr e2) (addTickLHsExpr e2)
addTickHsExpr (ExplicitTuple es boxity) = addTickHsExpr (ExplicitTuple x es boxity) =
liftM2 ExplicitTuple liftM2 (ExplicitTuple x)
(mapM addTickTupArg es) (mapM addTickTupArg es)
(return boxity) (return boxity)
addTickHsExpr (ExplicitSum tag arity e ty) = do addTickHsExpr (ExplicitSum ty tag arity e) = do
e' <- addTickLHsExpr e e' <- addTickLHsExpr e
return (ExplicitSum tag arity e' ty) return (ExplicitSum ty tag arity e')
addTickHsExpr (HsCase e mgs) = addTickHsExpr (HsCase x e mgs) =
liftM2 HsCase liftM2 (HsCase x)
(addTickLHsExpr e) -- not an EvalInner; e might not necessarily (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
-- be evaluated. -- be evaluated.
(addTickMatchGroup False mgs) (addTickMatchGroup False mgs)
addTickHsExpr (HsIf cnd e1 e2 e3) = addTickHsExpr (HsIf x cnd e1 e2 e3) =
liftM3 (HsIf cnd) liftM3 (HsIf x cnd)
(addBinTickLHsExpr (BinBox CondBinBox) e1) (addBinTickLHsExpr (BinBox CondBinBox) e1)
(addTickLHsExprOptAlt True e2) (addTickLHsExprOptAlt True e2)
(addTickLHsExprOptAlt True e3) (addTickLHsExprOptAlt True e3)
...@@ -545,14 +548,14 @@ addTickHsExpr (HsMultiIf ty alts) ...@@ -545,14 +548,14 @@ addTickHsExpr (HsMultiIf ty alts)
= do { let isOneOfMany = case alts of [_] -> False; _ -> True = do { let isOneOfMany = case alts of [_] -> False; _ -> True
; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
; return $ HsMultiIf ty alts' } ; return $ HsMultiIf ty alts' }
addTickHsExpr (HsLet (L l binds) e) = addTickHsExpr (HsLet x (L l binds) e) =
bindLocals (collectLocalBinders binds) $ bindLocals (collectLocalBinders binds) $
liftM2 (HsLet . L l) liftM2 (HsLet x . L l)
(addTickHsLocalBinds binds) -- to think about: !patterns. (addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsExprLetBody e) (addTickLHsExprLetBody e)
addTickHsExpr (HsDo cxt (L l stmts) srcloc) addTickHsExpr (HsDo srcloc cxt (L l stmts))
= do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
; return (HsDo cxt (L l stmts') srcloc) } ; return (HsDo srcloc cxt (L l stmts')) }
where where
forQual = case cxt of forQual = case cxt of
ListComp -> Just $ BinBox QualBinBox ListComp -> Just $ BinBox QualBinBox
...@@ -582,12 +585,12 @@ addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds }) ...@@ -582,12 +585,12 @@ addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
; flds' <- mapM addTickHsRecField flds ; flds' <- mapM addTickHsRecField flds
; return (expr { rupd_expr = e', rupd_flds = flds' }) } ; return (expr { rupd_expr = e', rupd_flds = flds' }) }
addTickHsExpr (ExprWithTySig e ty) = addTickHsExpr (ExprWithTySig ty e) =
liftM2 ExprWithTySig liftM2 ExprWithTySig
(addTickLHsExprNever e) -- No need to tick the inner expression
-- for expressions with signatures
(return ty) (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 liftM3 ArithSeq
(return ty) (return ty)
(addTickWit wit) (addTickWit wit)
...@@ -597,26 +600,26 @@ addTickHsExpr (ArithSeq ty wit arith_seq) = ...@@ -597,26 +600,26 @@ addTickHsExpr (ArithSeq ty wit arith_seq) =
return (Just fl') return (Just fl')
-- We might encounter existing ticks (multiple Coverage passes) -- We might encounter existing ticks (multiple Coverage passes)
addTickHsExpr (HsTick t e) = addTickHsExpr (HsTick x t e) =
liftM (HsTick t) (addTickLHsExprNever e) liftM (HsTick x t) (addTickLHsExprNever e)
addTickHsExpr (HsBinTick t0 t1 e) = addTickHsExpr (HsBinTick x t0 t1 e) =
liftM (HsBinTick t0 t1) (addTickLHsExprNever 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 $ e2 <- allocTickBox (ExpBox False) False False pos $
addTickHsExpr e0 addTickHsExpr e0
return $ unLoc e2 return $ unLoc e2
addTickHsExpr (PArrSeq ty arith_seq) = addTickHsExpr (PArrSeq ty arith_seq) =
liftM2 PArrSeq liftM2 PArrSeq
(return ty) (return ty)
(addTickArithSeqInfo arith_seq) (addTickArithSeqInfo arith_seq)
addTickHsExpr (HsSCC src nm e) = addTickHsExpr (HsSCC x src nm e) =
liftM3 HsSCC liftM3 (HsSCC x)
(return src) (return src)
(return nm) (return nm)
(addTickLHsExpr e) (addTickLHsExpr e)
addTickHsExpr (HsCoreAnn src nm e) = addTickHsExpr (HsCoreAnn x src nm e) =
liftM3 HsCoreAnn liftM3 (HsCoreAnn x)
(return src) (return src)
(return nm) (return nm)
(addTickLHsExpr e) (addTickLHsExpr e)
...@@ -624,20 +627,15 @@ addTickHsExpr e@(HsBracket {}) = return e ...@@ -624,20 +627,15 @@ addTickHsExpr e@(HsBracket {}) = return e
addTickHsExpr e@(HsTcBracketOut {}) = return e addTickHsExpr e@(HsTcBracketOut {}) = return e
addTickHsExpr e@(HsRnBracketOut {}) = return e addTickHsExpr e@(HsRnBracketOut {}) = return e
addTickHsExpr e@(HsSpliceE {}) = return e addTickHsExpr e@(HsSpliceE {}) = return e
addTickHsExpr (HsProc pat cmdtop) = addTickHsExpr (HsProc x pat cmdtop) =
liftM2 HsProc liftM2 (HsProc x)
(addTickLPat pat) (addTickLPat pat)
(liftL (addTickHsCmdTop) cmdtop) (liftL (addTickHsCmdTop) cmdtop)
addTickHsExpr (HsWrap w e) = addTickHsExpr (HsWrap x w e) =
liftM2 HsWrap liftM2 (HsWrap x)
(return w) (return w)
(addTickHsExpr e) -- Explicitly no tick on inside (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. -- Others should never happen in expression content.
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
...@@ -762,8 +760,8 @@ addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e ...@@ -762,8 +760,8 @@ addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
| otherwise = addTickLHsExprRHS e | otherwise = addTickLHsExprRHS e
addTickApplicativeArg addTickApplicativeArg
:: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc) :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc) -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
addTickApplicativeArg isGuard (op, arg) = addTickApplicativeArg isGuard (op, arg) =
liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
where where
...@@ -1169,7 +1167,7 @@ allocTickBox boxLabel countEntries topOnly pos m = ...@@ -1169,7 +1167,7 @@ allocTickBox boxLabel countEntries topOnly pos m =
(fvs, e) <- getFreeVars m (fvs, e) <- getFreeVars m
env <- getEnv env <- getEnv
tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) 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 ) (do
e <- m e <- m
return (L pos e) return (L pos e)
...@@ -1255,13 +1253,14 @@ mkBinTickBoxHpc boxLabel pos e = ...@@ -1255,13 +1253,14 @@ mkBinTickBoxHpc boxLabel pos e =
c = tickBoxCount st c = tickBoxCount st
mes = mixEntries st mes = mixEntries st
in in
( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) e ( L pos $ HsTick noExt (HpcTick (this_mod env) c)
-- notice that F and T are reversed, $ L pos $ HsBinTick noExt (c+1) (c+2) e
-- because we are building the list in -- notice that F and T are reversed,
-- reverse... -- because we are building the list in
, noFVs -- reverse...
, st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes} , noFVs
) , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
)
mkHpcPos :: SrcSpan -> HpcPos mkHpcPos :: SrcSpan -> HpcPos
mkHpcPos pos@(RealSrcSpan s) mkHpcPos pos@(RealSrcSpan s)
......
...@@ -575,10 +575,12 @@ dsCmd ids local_vars stack_ty res_ty ...@@ -575,10 +575,12 @@ dsCmd ids local_vars stack_ty res_ty
left_con <- dsLookupDataCon leftDataConName left_con <- dsLookupDataCon leftDataConName
right_con <- dsLookupDataCon rightDataConName right_con <- dsLookupDataCon rightDataConName
let let
left_id = HsConLikeOut (RealDataCon left_con) left_id = HsConLikeOut noExt (RealDataCon left_con)
right_id = HsConLikeOut (RealDataCon right_con) right_id = HsConLikeOut noExt (RealDataCon right_con)
left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e left_expr ty1 ty2 e = noLoc $ HsApp noExt
right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e (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, -- Prefix each tuple with a distinct series of Left's and Right's,
-- in a balanced way, keeping track of the types. -- in a balanced way, keeping track of the types.
...@@ -597,9 +599,10 @@ dsCmd ids local_vars stack_ty res_ty ...@@ -597,9 +599,10 @@ dsCmd ids local_vars stack_ty res_ty
(_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
in_ty = envStackType env_ids stack_ty in_ty = envStackType env_ids stack_ty
core_body <- dsExpr (HsCase exp (MG { mg_alts = L l matches' core_body <- dsExpr (HsCase noExt exp
, mg_arg_tys = arg_tys (MG { mg_alts = L l matches'
, mg_res_ty = sum_ty, mg_origin = origin })) , mg_arg_tys = arg_tys
, mg_res_ty = sum_ty, mg_origin = origin }))
-- Note that we replace the HsCase result type by sum_ty, -- Note that we replace the HsCase result type by sum_ty,
-- which is the type of matches' -- which is the type of matches'
......
...@@ -250,17 +250,18 @@ dsExpr = ds_expr False ...@@ -250,17 +250,18 @@ dsExpr = ds_expr False
ds_expr :: Bool -- are we directly inside an HsWrap? ds_expr :: Bool -- are we directly inside an HsWrap?
-- See Wrinkle in Note [Detecting forced eta expansion] -- See Wrinkle in Note [Detecting forced eta expansion]
-> HsExpr GhcTc -> DsM CoreExpr -> HsExpr GhcTc -> DsM CoreExpr
ds_expr _ (HsPar e) = dsLExpr e ds_expr _ (HsPar _ e) = dsLExpr e
ds_expr _ (ExprWithTySigOut e _) = dsLExpr e ds_expr _ (ExprWithTySig _ e) = dsLExpr e
ds_expr w (HsVar (L _ var)) = dsHsVar w var ds_expr w (HsVar _ (L _ var)) = dsHsVar w var
ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
ds_expr w (HsConLikeOut con) = dsConLike w con ds_expr w (HsConLikeOut _ con) = dsConLike w con
ds_expr _ (HsIPVar _) = panic "dsExpr: HsIPVar" ds_expr _ (HsIPVar {}) = panic "dsExpr: HsIPVar"
ds_expr _ (HsOverLabel{}) = panic "dsExpr: HsOverLabel" ds_expr _ (HsOverLabel{}) = panic "dsExpr: HsOverLabel"
ds_expr _ (HsLit lit) = dsLit (convertLit lit) ds_expr _ (HsLit _ lit) = dsLit (convertLit lit)
ds_expr _ (HsOverLit lit) = dsOverLit 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 = do { e' <- ds_expr True e
; wrap' <- dsHsWrapper co_fn ; wrap' <- dsHsWrapper co_fn
; dflags <- getDynFlags ; dflags <- getDynFlags
...@@ -270,7 +271,7 @@ ds_expr _ (HsWrap co_fn e) ...@@ -270,7 +271,7 @@ ds_expr _ (HsWrap co_fn e)
; warnAboutIdentities dflags e' wrapped_ty ; warnAboutIdentities dflags e' wrapped_ty
; return wrapped_e } ; 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) neg_expr)
= do { expr' <- putSrcSpanDs loc $ do = do { expr' <- putSrcSpanDs loc $ do
{ dflags <- getDynFlags { dflags <- getDynFlags
...@@ -279,23 +280,23 @@ ds_expr _ (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral i }))) ...@@ -279,23 +280,23 @@ ds_expr _ (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral i })))
; dsOverLit' dflags lit } ; dsOverLit' dflags lit }
; dsSyntaxExpr neg_expr [expr'] } ; dsSyntaxExpr neg_expr [expr'] }
ds_expr _ (NegApp expr neg_expr) ds_expr _ (NegApp _ expr neg_expr)
= do { expr' <- dsLExpr expr = do { expr' <- dsLExpr expr
; dsSyntaxExpr neg_expr [expr'] } ; dsSyntaxExpr neg_expr [expr'] }
ds_expr _ (HsLam a_Match) ds_expr _ (HsLam _ a_Match)
= uncurry mkLams <$> matchWrapper LambdaExpr Nothing 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 = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
; return $ Lam discrim_var matching_code } ; return $ Lam discrim_var matching_code }
ds_expr _ e@(HsApp fun arg) ds_expr _ e@(HsApp _ fun arg)
= do { fun' <- dsLExpr fun = do { fun' <- dsLExpr fun
; dsWhenNoErrs (dsLExprNoLP arg) ; dsWhenNoErrs (dsLExprNoLP arg)
(\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' 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 -- ignore type arguments here; they're in the wrappers instead at this point
= dsLExpr e = dsLExpr e
...@@ -339,19 +340,19 @@ If \tr{expr} is actually just a variable, say, then the simplifier ...@@ -339,19 +340,19 @@ If \tr{expr} is actually just a variable, say, then the simplifier
will sort it out. 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 = -- for the type of y, we need the type of op's 2nd argument
do { op' <- dsLExpr op do { op' <- dsLExpr op
; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2]) ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])
(\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') } (\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 = do { op' <- dsLExpr op
; dsWhenNoErrs (dsLExprNoLP expr) ; dsWhenNoErrs (dsLExprNoLP expr)
(\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') } (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }
-- dsLExpr (SectionR op expr) -- \ x -> op x 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 core_op <- dsLExpr op
-- for the type of x, we need the type of op's 2nd argument -- for the type of x, we need the type of op's 2nd argument
let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
...@@ -362,7 +363,7 @@ ds_expr _ e@(SectionR op expr) = do ...@@ -362,7 +363,7 @@ ds_expr _ e@(SectionR op expr) = do
Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e)
core_op [Var x_id, Var y_id])) 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)) = do { let go (lam_vars, args) (L _ (Missing ty))
-- For every missing expression, we need -- For every missing expression, we need
-- another lambda in the desugaring. -- another lambda in the desugaring.
...@@ -379,14 +380,14 @@ ds_expr _ (ExplicitTuple tup_args boxity) ...@@ -379,14 +380,14 @@ ds_expr _ (ExplicitTuple tup_args boxity)
(\(lam_vars, args) -> mkCoreLams lam_vars $ (\(lam_vars, args) -> mkCoreLams lam_vars $
mkCoreTupBoxity boxity args) } mkCoreTupBoxity boxity args) }
ds_expr _ (ExplicitSum alt arity expr types) ds_expr _ (ExplicitSum types alt arity expr)
= do { dsWhenNoErrs (dsLExprNoLP expr) = do { dsWhenNoErrs (dsLExprNoLP expr)
(\core_expr -> mkCoreConApps (sumDataCon alt arity) (\core_expr -> mkCoreConApps (sumDataCon alt arity)
(map (Type . getRuntimeRep) types ++ (map (Type . getRuntimeRep) types ++
map Type types ++ map Type types ++
[core_expr]) ) } [core_expr]) ) }
ds_expr _ (HsSCC _ cc expr@(L loc _)) = do ds_expr _ (HsSCC _ _ cc expr@(L loc _)) = do
dflags <- getDynFlags dflags <- getDynFlags
if gopt Opt_SccProfilingOn dflags if gopt Opt_SccProfilingOn dflags
then do then do
...@@ -397,31 +398,31 @@ ds_expr _ (HsSCC _ cc expr@(L loc _)) = do ...@@ -397,31 +398,31 @@ ds_expr _ (HsSCC _ cc expr@(L loc _)) = do
<$> dsLExpr expr <$> dsLExpr expr
else dsLExpr expr else dsLExpr expr
ds_expr _ (HsCoreAnn _ _ expr) ds_expr _ (HsCoreAnn _ _ _ expr)
= dsLExpr expr