Commit 509d5be6 authored by Shayan-Najd's avatar Shayan-Najd Committed by Alan Zimmerman
Browse files

[TTG: Handling Source Locations] Foundation and Pat

This patch removes the ping-pong style from HsPat (only, for now),
using the plan laid out at
https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/HandlingSourceLocations (solution
A).

- the class `HasSrcSpan`, and its functions (e.g., `cL` and `dL`), are introduced
- some instances of `HasSrcSpan` are introduced
- some constructors `L` are replaced with `cL`
- some patterns `L` are replaced with `dL->L` view pattern
- some type annotation are necessarily updated (e.g., `Pat p` --> `Pat (GhcPass p)`)

Phab diff: D5036
Trac Issues #15495

Updates haddock submodule
parent ad2d7612
......@@ -6,6 +6,9 @@
-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternSynonyms #-}
-- |
-- #name_types#
......@@ -202,6 +205,12 @@ nameOccName name = n_occ name
nameSrcLoc name = srcSpanStart (n_loc name)
nameSrcSpan name = n_loc name
type instance SrcSpanLess Name = Name
instance HasSrcSpan Name where
composeSrcSpan (L sp n) = n {n_loc = sp}
decomposeSrcSpan n = L (n_loc n) n
{-
************************************************************************
* *
......@@ -668,7 +677,7 @@ class NamedThing a where
getOccName n = nameOccName (getName n) -- Default method
instance NamedThing e => NamedThing (GenLocated l e) where
instance NamedThing e => NamedThing (Located e) where
getName = getName . unLoc
getSrcLoc :: NamedThing a => a -> SrcLoc
......
......@@ -7,6 +7,11 @@
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms #-}
-- | This module contains types that relate to the positions of things
-- in source files, and allow tagging of those things with locations
......@@ -70,11 +75,16 @@ module SrcLoc (
-- ** Deconstructing Located
getLoc, unLoc,
unRealSrcSpan, getRealSrcSpan,
-- ** Combining and comparing Located values
eqLocated, cmpLocated, combineLocs, addCLoc,
leftmost_smallest, leftmost_largest, rightmost,
spans, isSubspanOf, sortLocated
spans, isSubspanOf, sortLocated,
-- ** HasSrcSpan
HasSrcSpan(..), SrcSpanLess, dL, cL,
pattern LL, onHasSrcSpan, liftL
) where
import GhcPrelude
......@@ -169,7 +179,7 @@ advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1)
************************************************************************
-}
sortLocated :: [Located a] -> [Located a]
sortLocated :: HasSrcSpan a => [a] -> [a]
sortLocated things = sortBy (comparing getLoc) things
instance Outputable RealSrcLoc where
......@@ -517,35 +527,36 @@ data GenLocated l e = L l e
type Located = GenLocated SrcSpan
type RealLocated = GenLocated RealSrcSpan
unLoc :: GenLocated l e -> e
unLoc (L _ e) = e
unLoc :: HasSrcSpan a => a -> SrcSpanLess a
unLoc (dL->L _ e) = e
getLoc :: GenLocated l e -> l
getLoc (L l _) = l
getLoc :: HasSrcSpan a => a -> SrcSpan
getLoc (dL->L l _) = l
noLoc :: e -> Located e
noLoc e = L noSrcSpan e
noLoc :: HasSrcSpan a => SrcSpanLess a -> a
noLoc e = cL noSrcSpan e
mkGeneralLocated :: String -> e -> Located e
mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e
mkGeneralLocated :: HasSrcSpan e => String -> SrcSpanLess e -> e
mkGeneralLocated s e = cL (mkGeneralSrcSpan (fsLit s)) e
combineLocs :: Located a -> Located b -> SrcSpan
combineLocs :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan
combineLocs a b = combineSrcSpans (getLoc a) (getLoc b)
-- | Combine locations from two 'Located' things and add them to a third thing
addCLoc :: Located a -> Located b -> c -> Located c
addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c
addCLoc :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) =>
a -> b -> SrcSpanLess c -> c
addCLoc a b c = cL (combineSrcSpans (getLoc a) (getLoc b)) c
-- not clear whether to add a general Eq instance, but this is useful sometimes:
-- | Tests whether the two located things are equal
eqLocated :: Eq a => Located a -> Located a -> Bool
eqLocated :: (HasSrcSpan a , Eq (SrcSpanLess a)) => a -> a -> Bool
eqLocated a b = unLoc a == unLoc b
-- not clear whether to add a general Ord instance, but this is useful sometimes:
-- | Tests the ordering of the two located things
cmpLocated :: Ord a => Located a -> Located a -> Ordering
cmpLocated :: (HasSrcSpan a , Ord (SrcSpanLess a)) => a -> a -> Ordering
cmpLocated a b = unLoc a `compare` unLoc b
instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
......@@ -586,3 +597,94 @@ isSubspanOf src parent
| srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False
| otherwise = srcSpanStart parent <= srcSpanStart src &&
srcSpanEnd parent >= srcSpanEnd src
{-
************************************************************************
* *
\subsection{HasSrcSpan Typeclass to Set/Get Source Location Spans}
* *
************************************************************************
-}
{-
Note [HasSrcSpan Typeclass]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
To be able to uniformly set/get source location spans (of `SrcSpan`) in
syntactic entities (`HsSyn`), we use the typeclass `HasSrcSpan`.
More details can be found at the following wiki page
ImplementingTreesThatGrow/HandlingSourceLocations
For most syntactic entities, the source location spans are stored in
a syntactic entity by a wapper constuctor (introduced by TTG's
new constructor extension), e.g., by `NewPat (WrapperPat sp pat)`
for a source location span `sp` and a pattern `pat`.
-}
-- | Determines the type of undecorated syntactic entities
-- For most syntactic entities `E`, where source location spans are
-- introduced by a wrapper construtor of the same syntactic entity,
-- we have `SrcSpanLess E = E`.
-- However, some syntactic entities have a different type compared to
-- a syntactic entity `e :: E` may have the type `Located E` when
-- decorated by wrapping it with `L sp e` for a source span `sp`.
type family SrcSpanLess a
-- | A typeclass to set/get SrcSpans
class HasSrcSpan a where
-- | Composes a `SrcSpan` decoration with an undecorated syntactic
-- entity to form its decorated variant
composeSrcSpan :: Located (SrcSpanLess a) -> a
-- | Decomposes a decorated syntactic entity into its `SrcSpan`
-- decoration and its undecorated variant
decomposeSrcSpan :: a -> Located (SrcSpanLess a)
{- laws:
composeSrcSpan . decomposeSrcSpan = id
decomposeSrcSpan . composeSrcSpan = id
in other words, `HasSrcSpan` defines an iso relation between
a `SrcSpan`-decorated syntactic entity and its undecorated variant
(together with the `SrcSpan`).
-}
type instance SrcSpanLess (GenLocated l e) = e
instance HasSrcSpan (Located a) where
composeSrcSpan = id
decomposeSrcSpan = id
-- | An abbreviated form of decomposeSrcSpan,
-- mainly to be used in ViewPatterns
dL :: HasSrcSpan a => a -> Located (SrcSpanLess a)
dL = decomposeSrcSpan
-- | An abbreviated form of composeSrcSpan,
-- mainly to replace the hardcoded `L`
cL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL sp e = composeSrcSpan (L sp e)
-- | A Pattern Synonym to Set/Get SrcSpans
pattern LL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
pattern LL sp e <- (dL->L sp e)
where
LL sp e = cL sp e
-- | Lifts a function of undecorated entities to one of decorated ones
onHasSrcSpan :: (HasSrcSpan a , HasSrcSpan b) =>
(SrcSpanLess a -> SrcSpanLess b) -> a -> b
onHasSrcSpan f (dL->L l e) = cL l (f e)
liftL :: (HasSrcSpan a, HasSrcSpan b, Monad m) =>
(SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b
liftL f (dL->L loc a) = do
a' <- f a
return $ cL loc a'
getRealSrcSpan :: RealLocated a -> RealSrcSpan
getRealSrcSpan (L l _) = l
unRealSrcSpan :: RealLocated a -> a
unRealSrcSpan (L _ e) = e
......@@ -6,6 +6,7 @@ Pattern Matching Coverage Checking.
{-# LANGUAGE CPP, GADTs, DataKinds, KindSignatures #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Check (
-- Checking and printing
......@@ -342,7 +343,7 @@ checkSingle' locn var p = do
(Covered, _ ) -> PmResult prov [] us' [] -- useful
(NotCovered, NotDiverged) -> PmResult prov m us' [] -- redundant
(NotCovered, Diverged ) -> PmResult prov [] us' m -- inaccessible rhs
where m = [L locn [L locn p]]
where m = [cL locn [cL locn p]]
-- | Exhaustive for guard matches, is used for guards in pattern bindings and
-- in @MultiIf@ expressions.
......@@ -353,7 +354,7 @@ checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do
dflags <- getDynFlags
let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)
dsMatchContext = DsMatchContext hs_ctx combinedLoc
match = L combinedLoc $
match = cL combinedLoc $
Match { m_ext = noExt
, m_ctxt = hs_ctx
, m_pats = []
......@@ -419,8 +420,8 @@ checkMatches' vars matches
(NotCovered, Diverged ) -> (final_prov, rs, final_u, m:is)
hsLMatchToLPats :: LMatch id body -> Located [LPat id]
hsLMatchToLPats (L l (Match { m_pats = pats })) = L l pats
hsLMatchToLPats (L _ (XMatch _)) = panic "checMatches'"
hsLMatchToLPats (dL->L l (Match { m_pats = pats })) = cL l pats
hsLMatchToLPats _ = panic "checMatches'"
-- | Check an empty case expression. Since there are no clauses to process, we
-- only compute the uncovered set. See Note [Checking EmptyCase Expressions]
......@@ -986,7 +987,7 @@ translatePat fam_insts pat = case pat of
return [xp,g]
-- (n + k) ===> x (True <- x >= k) (n <- x-k)
NPlusKPat ty (L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty
NPlusKPat ty (dL->L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty
-- (fun -> pat) ===> x (pat <- fun x)
ViewPat arg_ty lexpr lpat -> do
......@@ -1031,7 +1032,7 @@ translatePat fam_insts pat = case pat of
-- pattern and do further translation as an optimization, for the reason,
-- see Note [Guards and Approximation].
ConPatOut { pat_con = L _ con
ConPatOut { pat_con = (dL->L _ con)
, pat_arg_tys = arg_tys
, pat_tvs = ex_tvs
, pat_dicts = dicts
......@@ -1048,7 +1049,7 @@ translatePat fam_insts pat = case pat of
, pm_con_args = args }]
-- See Note [Translate Overloaded Literal for Exhaustiveness Checking]
NPat _ (L _ olit) mb_neg _
NPat _ (dL->L _ olit) mb_neg _
| OverLit (OverLitTc False ty) (HsIsString src s) _ <- olit
, isStringTy ty ->
foldr (mkListPatVec charTy) [nilPattern charTy] <$>
......@@ -1216,7 +1217,7 @@ translateConPatVec fam_insts univ_tys ex_tvs c (RecCon (HsRecFields fs _))
-- Some label information
orig_lbls = map flSelector $ conLikeFieldLabels c
matched_pats = [ (getName (unLoc (hsRecFieldId x)), unLoc (hsRecFieldArg x))
| L _ x <- fs]
| (dL->L _ x) <- fs]
matched_lbls = [ name | (name, _pat) <- matched_pats ]
subsetOf :: Eq a => [a] -> [a] -> Bool
......@@ -1229,18 +1230,19 @@ translateConPatVec fam_insts univ_tys ex_tvs c (RecCon (HsRecFields fs _))
-- Translate a single match
translateMatch :: FamInstEnvs -> LMatch GhcTc (LHsExpr GhcTc)
-> DsM (PatVec,[PatVec])
translateMatch fam_insts (L _ (Match { m_pats = lpats, m_grhss = grhss })) = do
translateMatch fam_insts (dL->L _ (Match { m_pats = lpats, m_grhss = grhss })) =
do
pats' <- concat <$> translatePatVec fam_insts pats
guards' <- mapM (translateGuards fam_insts) guards
return (pats', guards')
where
extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc]
extractGuards (L _ (GRHS _ gs _)) = map unLoc gs
extractGuards (L _ (XGRHS _)) = panic "translateMatch"
extractGuards (dL->L _ (GRHS _ gs _)) = map unLoc gs
extractGuards _ = panic "translateMatch"
pats = map unLoc lpats
guards = map extractGuards (grhssGRHSs grhss)
translateMatch _ (L _ (XMatch _)) = panic "translateMatch"
translateMatch _ _ = panic "translateMatch"
-- -----------------------------------------------------------------------
-- * Transform source guards (GuardStmt Id) to PmPats (Pattern)
......@@ -1304,7 +1306,7 @@ translateLet _binds = return []
-- | Translate a pattern guard
translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM PatVec
translateBind fam_insts (L _ p) e = do
translateBind fam_insts (dL->L _ p) e = do
ps <- translatePat fam_insts p
return [mkGuard ps (unLoc e)]
......@@ -2457,10 +2459,10 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
TypeOfUncovered _ -> True
UncoveredPatterns u -> notNull u)
when exists_r $ forM_ redundant $ \(L l q) -> do
when exists_r $ forM_ redundant $ \(dL->L l q) -> do
putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
(pprEqn q "is redundant"))
when exists_i $ forM_ inaccessible $ \(L l q) -> do
when exists_i $ forM_ inaccessible $ \(dL->L l q) -> do
putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
(pprEqn q "has inaccessible right hand side"))
when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $
......@@ -2583,7 +2585,7 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun
(ppr_match, pref)
= case kind of
FunRhs { mc_fun = L _ fun }
FunRhs { mc_fun = (dL->L _ fun) }
-> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
_ -> (pprMatchContext kind, \ pp -> pp)
......
......@@ -4,6 +4,8 @@
-}
{-# LANGUAGE NondecreasingIndentation, RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
module Coverage (addTicksToBinds, hpcInitCode) where
......@@ -119,7 +121,7 @@ guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath
guessSourceFile binds orig_file =
-- Try look for a file generated from a .hsc file to a
-- .hs file, by peeking ahead.
let top_pos = catMaybes $ foldrBag (\ (L pos _) rest ->
let top_pos = catMaybes $ foldrBag (\ (dL->L pos _) rest ->
srcSpanFileName_maybe pos : rest) [] binds
in
case top_pos of
......@@ -253,12 +255,12 @@ addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc)
addTickLHsBinds = mapBagM addTickLHsBind
addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds,
addTickLHsBind (dL->L pos bind@(AbsBinds { abs_binds = binds,
abs_exports = abs_exports })) = do
withEnv add_exports $ do
withEnv add_inlines $ do
binds' <- addTickLHsBinds binds
return $ L pos $ bind { abs_binds = binds' }
return $ cL pos $ bind { abs_binds = binds' }
where
-- in AbsBinds, the Id on each binding is not the actual top-level
-- Id that we are defining, they are related by the abs_exports
......@@ -278,7 +280,7 @@ addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds,
| ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
, isInlinePragma (idInlinePragma pid) ] }
addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id) }))) = do
let name = getOccString id
decl_path <- getPathEntry
density <- getDensity
......@@ -290,7 +292,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
-- See Note [inline sccs]
tickish <- tickishType `liftM` getEnv
if inline && tickish == ProfNotes then return (L pos funBind) else do
if inline && tickish == ProfNotes then return (cL pos funBind) else do
(fvs, mg) <-
getFreeVars $
......@@ -319,8 +321,8 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
return Nothing
let mbCons = maybe Prelude.id (:)
return $ L pos $ funBind { fun_matches = mg
, fun_tick = tick `mbCons` fun_tick funBind }
return $ cL pos $ funBind { fun_matches = mg
, fun_tick = tick `mbCons` fun_tick funBind }
where
-- a binding is a simple pattern binding if it is a funbind with
......@@ -329,7 +331,8 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
-- TODO: Revisit this
addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do
addTickLHsBind (dL->L pos (pat@(PatBind { pat_lhs = lhs
, pat_rhs = rhs }))) = do
let name = "(...)"
(fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs
let pat' = pat { pat_rhs = rhs'}
......@@ -338,7 +341,9 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do
density <- getDensity
decl_path <- getPathEntry
let top_lev = null decl_path
if not (shouldTickPatBind density top_lev) then return (L pos pat') else do
if not (shouldTickPatBind density top_lev)
then return (cL pos pat')
else do
-- Allocate the ticks
rhs_tick <- bindTick density name pos fvs
......@@ -350,12 +355,14 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do
rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat')
patvar_tickss = zipWith mbCons patvar_ticks
(snd (pat_ticks pat') ++ repeat [])
return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }
return $ cL pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }
-- Only internal stuff, not from source, uses VarBind, so we ignore it.
addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind
addTickLHsBind var_bind@(dL->L _ (VarBind {})) = return var_bind
addTickLHsBind patsyn_bind@(dL->L _ (PatSynBind {})) = return patsyn_bind
addTickLHsBind bind@(dL->L _ (XHsBindsLR {})) = return bind
addTickLHsBind _ = panic "addTickLHsBind: Impossible Match" -- due to #15884
bindTick
......@@ -390,7 +397,7 @@ bindTick density name pos fvs = do
-- selectively add ticks to interesting expressions
addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr e@(L pos e0) = do
addTickLHsExpr e@(dL->L pos e0) = do
d <- getDensity
case d of
TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
......@@ -406,7 +413,7 @@ addTickLHsExpr e@(L pos e0) = do
-- (because the body will definitely have a tick somewhere). ToDo: perhaps
-- we should treat 'case' and 'if' the same way?
addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprRHS e@(L pos e0) = do
addTickLHsExprRHS e@(dL->L pos e0) = do
d <- getDensity
case d of
TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
......@@ -435,7 +442,7 @@ addTickLHsExprEvalInner e = do
-- break012. This gives the user the opportunity to inspect the
-- values of the let-bound variables.
addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprLetBody e@(L pos e0) = do
addTickLHsExprLetBody e@(dL->L pos e0) = do
d <- getDensity
case d of
TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
......@@ -449,9 +456,9 @@ addTickLHsExprLetBody e@(L pos e0) = do
-- because the scope of this tick is completely subsumed by
-- another.
addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever (L pos e0) = do
addTickLHsExprNever (dL->L pos e0) = do
e1 <- addTickHsExpr e0
return $ L pos e1
return $ cL pos e1
-- general heuristic: expressions which do not denote values are good
-- break points
......@@ -468,16 +475,16 @@ isCallSite OpApp{} = True
isCallSite _ = False
addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprOptAlt oneOfMany (L pos e0)
addTickLHsExprOptAlt oneOfMany (dL->L pos e0)
= ifDensity TickForCoverage
(allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
(addTickLHsExpr (L pos e0))
(addTickLHsExpr (cL pos e0))
addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addBinTickLHsExpr boxLabel (L pos e0)
addBinTickLHsExpr boxLabel (dL->L pos e0)
= ifDensity TickForCoverage
(allocBinTickBox boxLabel pos $ addTickHsExpr e0)
(addTickLHsExpr (L pos e0))
(addTickLHsExpr (cL pos e0))
-- -----------------------------------------------------------------------------
......@@ -486,7 +493,7 @@ 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 e@(HsVar _ (dL->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
......@@ -545,14 +552,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 x (L l binds) e) =
addTickHsExpr (HsLet x (dL->L l binds) e) =
bindLocals (collectLocalBinders binds) $
liftM2 (HsLet x . L l)
liftM2 (HsLet x . cL l)
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsExprLetBody e)
addTickHsExpr (HsDo srcloc cxt (L l stmts))
addTickHsExpr (HsDo srcloc cxt (dL->L l stmts))
= do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
; return (HsDo srcloc cxt (L l stmts')) }
; return (HsDo srcloc cxt (cL l stmts')) }
where
forQual = case cxt of
ListComp -> Just $ BinBox QualBinBox
......@@ -599,7 +606,7 @@ addTickHsExpr (HsTick x t e) =
addTickHsExpr (HsBinTick x t0 t1 e) =
liftM (HsBinTick x t0 t1) (addTickLHsExprNever e)
addTickHsExpr (HsTickPragma _ _ _ _ (L pos e0)) = do
addTickHsExpr (HsTickPragma _ _ _ _ (dL->L pos e0)) = do
e2 <- allocTickBox (ExpBox False) False False pos $
addTickHsExpr e0
return $ unLoc e2
......@@ -630,22 +637,25 @@ addTickHsExpr (HsWrap x w e) =
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
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"
addTickTupArg (dL->L l (Present x e)) = do { e' <- addTickLHsExpr e
; return (cL l (Present x e')) }
addTickTupArg (dL->L l (Missing ty)) = return (cL l (Missing ty))
addTickTupArg (dL->L _ (XTupArg _)) = panic "addTickTupArg"
addTickTupArg _ = panic "addTickTupArg: Impossible Match" -- due to #15884
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsExpr GhcTc))
addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
addTickMatchGroup is_lam mg@(MG { mg_alts = dL->L l matches }) = do
let isOneOfMany = matchesOneOfMany matches
matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
return $ mg { mg_alts = L l matches' }
return $ mg { mg_alts = cL l matches' }
addTickMatchGroup _ (XMatchGroup _) = panic "addTickMatchGroup"
addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
-> TM (Match GhcTc (LHsExpr GhcTc))
addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats, m_grhss = gRHSs }) =
addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats
, m_grhss = gRHSs }) =
bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
return $ match { m_grhss = gRHSs' }
......@@ -653,11 +663,11 @@ addTickMatch _ _ (XMatch _) = panic "addTickMatch"
addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do
addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (dL->L l local_binds)) = do
bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds
guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
return $ GRHSs x guarded' (L l local_binds')
return $ GRHSs x guarded' (cL l local_binds')
where
binders = collectLocalBinders local_binds
addTickGRHSs _ _ (XGRHSs _) = panic "addTickGRHSs"
......@@ -671,7 +681,7 @@ addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do
addTickGRHS _ _ (XGRHS _) = panic "addTickGRHS"
addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
addTickGRHSBody isOneOfMany isLambda expr@(dL->L pos e0) = do
d <- getDensity
case d of
TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr
......@@ -714,13 +724,13 @@ addTickStmt isGuard (BodyStmt x e bind' guard') = do
(addTick isGuard e)
(addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard')
addTickStmt _isGuard (LetStmt x (L l binds)) = do
liftM (LetStmt x . L l)
addTickStmt _isGuard (LetStmt x (dL->L l binds)) = do
liftM (LetStmt x . cL l)
(addTickHsLocalBinds binds)
addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do
liftM3 (ParStmt x)
(mapM (addTickStmtAndBinders isGuard) pairs)
(unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr))
(unLoc <$> addTickLHsExpr (cL hpcSrcSpan mzipExpr))
(addTickSyntaxExpr hpcSrcSpan bindExpr)