Commit 1aa1d405 authored by Alan Zimmerman's avatar Alan Zimmerman
Browse files

Restore Trees That Grow reverted commits

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].

 438dd1cb Phab:D4147
 e3ec2e7a Phab:D4177
 47ad6578 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
parent 48f55e76
......@@ -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 p -> 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 p -> 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 x 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 x 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
......
......@@ -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 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)
......@@ -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 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
......@@ -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 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)
......@@ -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 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)
addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e
; return (L l (Present e')) }
addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e
; return (L l (Present x 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 x 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 x matchgroup) =
liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup)
addTickHsCmd (HsCmdApp x 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 x e mgs) =
liftM2 (HsCmdCase x)
(addTickLHsExpr e)
(addTickCmdMatchGroup mgs)
addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
liftM3 (HsCmdIf cnd)
addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =
liftM3 (HsCmdIf x cnd)
(addBinTickLHsExpr (BinBox CondBinBox) e1)
(addTickLHsCmd c2)
(addTickLHsCmd c3)
addTickHsCmd (HsCmdLet (L l binds) c) =
addTickHsCmd (HsCmdLet x (L l binds) c) =
bindLocals (collectLocalBinders binds) $
liftM2 (HsCmdLet . L l)
liftM2 (HsCmdLet x . 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 x 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)
......
......@@ -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