Commit 8e6ec0fa authored by Alan Zimmerman's avatar Alan Zimmerman

Udate hsSyn AST to use Trees that Grow

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

This commit prepares the ground for a full extensible AST, by replacing the type
parameter for the hsSyn data types with a set of indices into type families,

    data GhcPs -- ^ Index for GHC parser output
    data GhcRn -- ^ Index for GHC renamer output
    data GhcTc -- ^ Index for GHC typechecker output

These are now used instead of `RdrName`, `Name` and `Id`/`TcId`/`Var`

Where the original name type is required in a polymorphic context, this is
accessible via the IdP type family, defined as

    type family IdP p
    type instance IdP GhcPs = RdrName
    type instance IdP GhcRn = Name
    type instance IdP GhcTc = Id

These types are declared in the new 'hsSyn/HsExtension.hs' module.

To gain a better understanding of the extension mechanism, it has been applied
to `HsLit` only, also replacing the `SourceText` fields in them with extension
types.

To preserve extension generality, a type class is introduced to capture the
`SourceText` interface, which must be honoured by all of the extension points
which originally had a `SourceText`.  The class is defined as

    class HasSourceText a where
      -- Provide setters to mimic existing constructors
      noSourceText  :: a
      sourceText    :: String -> a

      setSourceText :: SourceText -> a
      getSourceText :: a -> SourceText

And the constraint is captured in `SourceTextX`, which is a constraint type
listing all the extension points that make use of the class.

Updating Haddock submodule to match.

Test Plan: ./validate

Reviewers: simonpj, shayan-najd, goldfire, austin, bgamari

Subscribers: rwbarton, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D3609
parent c9eb4385
......@@ -18,7 +18,6 @@ module BkpSyn (
) where
import HsSyn
import RdrName
import SrcLoc
import Outputable
import Module
......@@ -61,7 +60,7 @@ type LHsUnit n = Located (HsUnit n)
-- or an include.
data HsDeclType = ModuleD | SignatureD
data HsUnitDecl n
= DeclD HsDeclType (Located ModuleName) (Maybe (Located (HsModule RdrName)))
= DeclD HsDeclType (Located ModuleName) (Maybe (Located (HsModule GhcPs)))
| IncludeD (IncludeDecl n)
type LHsUnitDecl n = Located (HsUnitDecl n)
......
......@@ -709,7 +709,7 @@ summariseRequirement pn mod_name = do
summariseDecl :: PackageName
-> HscSource
-> Located ModuleName
-> Maybe (Located (HsModule RdrName))
-> Maybe (Located (HsModule GhcPs))
-> BkpM ModSummary
summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod
summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
......@@ -736,7 +736,7 @@ summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
hsModuleToModSummary :: PackageName
-> HscSource
-> ModuleName
-> Located (HsModule RdrName)
-> Located (HsModule GhcPs)
-> BkpM ModSummary
hsModuleToModSummary pn hsc_src modname
hsmod = do
......
......@@ -134,7 +134,7 @@ data PmPat :: PatTy -> * where
, pm_con_dicts :: [EvVar]
, pm_con_args :: [PmPat t] } -> PmPat t
-- For PmCon arguments' meaning see @ConPatOut@ in hsSyn/HsPat.hs
PmVar :: { pm_var_id :: Id } -> PmPat t
PmVar :: { pm_var_id :: Id } -> PmPat t
PmLit :: { pm_lit_lit :: PmLit } -> PmPat t -- See Note [Literals in PmPat]
PmNLit :: { pm_lit_id :: Id
, pm_lit_not :: [PmLit] } -> PmPat 'VA
......@@ -254,9 +254,9 @@ instance Monoid PartialResult where
data PmResult =
PmResult {
pmresultProvenance :: Provenance
, pmresultRedundant :: [Located [LPat Id]]
, pmresultRedundant :: [Located [LPat GhcTc]]
, pmresultUncovered :: UncoveredCandidates
, pmresultInaccessible :: [Located [LPat Id]] }
, pmresultInaccessible :: [Located [LPat GhcTc]] }
-- | Either a list of patterns that are not covered, or their type, in case we
-- have no patterns at hand. Not having patterns at hand can arise when
......@@ -289,7 +289,7 @@ uncoveredWithTy ty = PmResult FromBuiltin [] (TypeOfUncovered ty) []
-}
-- | Check a single pattern binding (let)
checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat Id -> DsM ()
checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat GhcTc -> DsM ()
checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do
tracePmD "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])
mb_pm_res <- tryM (getResult (checkSingle' locn var p))
......@@ -298,7 +298,7 @@ checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do
Right res -> dsPmWarn dflags ctxt res
-- | Check a single pattern binding (let)
checkSingle' :: SrcSpan -> Id -> Pat Id -> PmM PmResult
checkSingle' :: SrcSpan -> Id -> Pat GhcTc -> PmM PmResult
checkSingle' locn var p = do
liftD resetPmIterDs -- set the iter-no to zero
fam_insts <- liftD dsGetFamInstEnvs
......@@ -316,7 +316,7 @@ checkSingle' locn var p = do
-- | Check a matchgroup (case, functions, etc.)
checkMatches :: DynFlags -> DsMatchContext
-> [Id] -> [LMatch Id (LHsExpr Id)] -> DsM ()
-> [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM ()
checkMatches dflags ctxt vars matches = do
tracePmD "checkMatches" (hang (vcat [ppr ctxt
, ppr vars
......@@ -334,7 +334,7 @@ checkMatches dflags ctxt vars matches = do
-- | Check a matchgroup (case, functions, etc.). To be called on a non-empty
-- list of matches. For empty case expressions, use checkEmptyCase' instead.
checkMatches' :: [Id] -> [LMatch Id (LHsExpr Id)] -> PmM PmResult
checkMatches' :: [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> PmM PmResult
checkMatches' vars matches
| null matches = panic "checkMatches': EmptyCase"
| otherwise = do
......@@ -348,11 +348,11 @@ checkMatches' vars matches
, pmresultUncovered = UncoveredPatterns us
, pmresultInaccessible = map hsLMatchToLPats ds }
where
go :: [LMatch Id (LHsExpr Id)] -> Uncovered
go :: [LMatch GhcTc (LHsExpr GhcTc)] -> Uncovered
-> PmM (Provenance
, [LMatch Id (LHsExpr Id)]
, [LMatch GhcTc (LHsExpr GhcTc)]
, Uncovered
, [LMatch Id (LHsExpr Id)])
, [LMatch GhcTc (LHsExpr GhcTc)])
go [] missing = return (mempty, [], missing, [])
go (m:ms) missing = do
tracePm "checMatches': go" (ppr m $$ ppr missing)
......@@ -544,14 +544,14 @@ mkListPatVec ty xs ys = [PmCon { pm_con_con = RealDataCon consDataCon
{-# INLINE mkListPatVec #-}
-- | Create a (non-overloaded) literal pattern
mkLitPattern :: HsLit -> Pattern
mkLitPattern :: HsLit GhcTc -> Pattern
mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit }
{-# INLINE mkLitPattern #-}
-- -----------------------------------------------------------------------
-- * Transform (Pat Id) into of (PmPat Id)
translatePat :: FamInstEnvs -> Pat Id -> DsM PatVec
translatePat :: FamInstEnvs -> Pat GhcTc -> DsM PatVec
translatePat fam_insts pat = case pat of
WildPat ty -> mkPmVars [ty]
VarPat id -> return [PmVar (unLoc id)]
......@@ -661,15 +661,16 @@ translatePat fam_insts pat = case pat of
-- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs)
translateNPat :: FamInstEnvs
-> HsOverLit Id -> Maybe (SyntaxExpr Id) -> Type -> DsM PatVec
-> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> Type
-> DsM PatVec
translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty
| not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg
= translatePat fam_insts (LitPat (HsString src s))
| not type_change, isIntTy ty, HsIntegral i <- val
= translatePat fam_insts
(LitPat $ case mb_neg of
Nothing -> HsInt i
Just _ -> HsInt (negateIntegralLit i))
Nothing -> HsInt def i
Just _ -> HsInt def (negateIntegralLit i))
| not type_change, isWordTy ty, HsIntegral i <- val
= translatePat fam_insts
(LitPat $ case mb_neg of
......@@ -684,12 +685,12 @@ translateNPat _ ol mb_neg _
-- | Translate a list of patterns (Note: each pattern is translated
-- to a pattern vector but we do not concatenate the results).
translatePatVec :: FamInstEnvs -> [Pat Id] -> DsM [PatVec]
translatePatVec :: FamInstEnvs -> [Pat GhcTc] -> DsM [PatVec]
translatePatVec fam_insts pats = mapM (translatePat fam_insts) pats
-- | Translate a constructor pattern
translateConPatVec :: FamInstEnvs -> [Type] -> [TyVar]
-> ConLike -> HsConPatDetails Id -> DsM PatVec
-> ConLike -> HsConPatDetails GhcTc -> DsM PatVec
translateConPatVec fam_insts _univ_tys _ex_tvs _ (PrefixCon ps)
= concat <$> translatePatVec fam_insts (map unLoc ps)
translateConPatVec fam_insts _univ_tys _ex_tvs _ (InfixCon p1 p2)
......@@ -744,13 +745,14 @@ translateConPatVec fam_insts univ_tys ex_tvs c (RecCon (HsRecFields fs _))
| otherwise = subsetOf (x:xs) ys
-- Translate a single match
translateMatch :: FamInstEnvs -> LMatch Id (LHsExpr Id) -> DsM (PatVec,[PatVec])
translateMatch :: FamInstEnvs -> LMatch GhcTc (LHsExpr GhcTc)
-> DsM (PatVec,[PatVec])
translateMatch fam_insts (L _ (Match _ lpats _ grhss)) = do
pats' <- concat <$> translatePatVec fam_insts pats
guards' <- mapM (translateGuards fam_insts) guards
return (pats', guards')
where
extractGuards :: LGRHS Id (LHsExpr Id) -> [GuardStmt Id]
extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc]
extractGuards (L _ (GRHS gs _)) = map unLoc gs
pats = map unLoc lpats
......@@ -760,7 +762,7 @@ translateMatch fam_insts (L _ (Match _ lpats _ grhss)) = do
-- * Transform source guards (GuardStmt Id) to PmPats (Pattern)
-- | Translate a list of guard statements to a pattern vector
translateGuards :: FamInstEnvs -> [GuardStmt Id] -> DsM PatVec
translateGuards :: FamInstEnvs -> [GuardStmt GhcTc] -> DsM PatVec
translateGuards fam_insts guards = do
all_guards <- concat <$> mapM (translateGuard fam_insts) guards
return (replace_unhandled all_guards)
......@@ -800,7 +802,7 @@ cantFailPattern (PmGrd pv _e)
cantFailPattern _ = False
-- | Translate a guard statement to Pattern
translateGuard :: FamInstEnvs -> GuardStmt Id -> DsM PatVec
translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM PatVec
translateGuard fam_insts guard = case guard of
BodyStmt e _ _ _ -> translateBoolGuard e
LetStmt binds -> translateLet (unLoc binds)
......@@ -812,17 +814,17 @@ translateGuard fam_insts guard = case guard of
ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt"
-- | Translate let-bindings
translateLet :: HsLocalBinds Id -> DsM PatVec
translateLet :: HsLocalBinds GhcTc -> DsM PatVec
translateLet _binds = return []
-- | Translate a pattern guard
translateBind :: FamInstEnvs -> LPat Id -> LHsExpr Id -> DsM PatVec
translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM PatVec
translateBind fam_insts (L _ p) e = do
ps <- translatePat fam_insts p
return [mkGuard ps (unLoc e)]
-- | Translate a boolean guard
translateBoolGuard :: LHsExpr Id -> DsM PatVec
translateBoolGuard :: LHsExpr GhcTc -> DsM PatVec
translateBoolGuard e
| isJust (isTrueLHsExpr e) = return []
-- The formal thing to do would be to generate (True <- True)
......@@ -996,7 +998,7 @@ mkOneConFull x con = do
-- * More smart constructors and fresh variable generation
-- | Create a guard pattern
mkGuard :: PatVec -> HsExpr Id -> Pattern
mkGuard :: PatVec -> HsExpr GhcTc -> Pattern
mkGuard pv e
| all cantFailPattern pv = PmGrd pv expr
| PmExprOther {} <- expr = fake_pat
......@@ -1041,7 +1043,7 @@ mkPmId ty = getUniqueM >>= \unique ->
-- | Generate a fresh term variable of a given and return it in two forms:
-- * A variable pattern
-- * A variable expression
mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr Id)
mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc)
mkPmId2Forms ty = do
x <- mkPmId ty
return (PmVar x, noLoc (HsVar (noLoc x)))
......@@ -1508,9 +1510,9 @@ these constraints.
-- When we go deeper to check e.g. e1 we record two equalities:
-- (x ~ y), where y is the initial uncovered when checking (p1; .. ; pn)
-- and (x ~ p1).
genCaseTmCs2 :: Maybe (LHsExpr Id) -- Scrutinee
-> [Pat Id] -- LHS (should have length 1)
-> [Id] -- MatchVars (should have length 1)
genCaseTmCs2 :: Maybe (LHsExpr GhcTc) -- Scrutinee
-> [Pat GhcTc] -- LHS (should have length 1)
-> [Id] -- MatchVars (should have length 1)
-> DsM (Bag SimpleEq)
genCaseTmCs2 Nothing _ _ = return emptyBag
genCaseTmCs2 (Just scr) [p] [var] = do
......@@ -1524,7 +1526,7 @@ genCaseTmCs2 _ _ _ = panic "genCaseTmCs2: HsCase"
-- case x of { matches }
-- When checking matches we record that (x ~ y) where y is the initial
-- uncovered. All matches will have to satisfy this equality.
genCaseTmCs1 :: Maybe (LHsExpr Id) -> [Id] -> Bag SimpleEq
genCaseTmCs1 :: Maybe (LHsExpr GhcTc) -> [Id] -> Bag SimpleEq
genCaseTmCs1 Nothing _ = emptyBag
genCaseTmCs1 (Just scr) [var] = unitBag (var, lhsExprToPmExpr scr)
genCaseTmCs1 _ _ = panic "genCaseTmCs1: HsCase"
......@@ -1742,11 +1744,11 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun
\ pp -> ppr fun <+> pp)
_ -> (pprMatchContext kind, \ pp -> pp)
ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc
ppr_pats :: HsMatchContext Name -> [Pat GhcTc] -> SDoc
ppr_pats kind pats
= sep [sep (map ppr pats), matchSeparator kind, text "..."]
ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> [LPat Id] -> SDoc
ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> [LPat GhcTc] -> SDoc
ppr_eqn prefixF kind eqn = prefixF (ppr_pats kind (map unLoc eqn))
ppr_constraint :: (SDoc,[PmLit]) -> SDoc
......
......@@ -68,8 +68,8 @@ addTicksToBinds
-- isExportedId doesn't work yet (the desugarer
-- hasn't set it), so we have to work from this set.
-> [TyCon] -- Type constructor in this module
-> LHsBinds Id
-> IO (LHsBinds Id, HpcInfo, Maybe ModBreaks)
-> LHsBinds GhcTc
-> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)
addTicksToBinds hsc_env mod mod_loc exports tyCons binds
| let dflags = hsc_dflags hsc_env
......@@ -118,7 +118,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
| otherwise = return (binds, emptyHpcInfo False, Nothing)
guessSourceFile :: LHsBinds Id -> FilePath -> FilePath
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.
......@@ -252,10 +252,10 @@ shouldTickPatBind density top_lev
-- -----------------------------------------------------------------------------
-- Adding ticks to bindings
addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc)
addTickLHsBinds = mapBagM addTickLHsBind
addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds,
abs_exports = abs_exports })) = do
withEnv add_exports $ do
......@@ -419,7 +419,7 @@ bindTick density name pos fvs = do
-- Decorate an LHsExpr with ticks
-- selectively add ticks to interesting expressions
addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExpr e@(L pos e0) = do
d <- getDensity
case d of
......@@ -435,7 +435,7 @@ addTickLHsExpr e@(L pos e0) = do
-- We always consider these to be breakpoints, unless the expression is a 'let'
-- (because the body will definitely have a tick somewhere). ToDo: perhaps
-- we should treat 'case' and 'if' the same way?
addTickLHsExprRHS :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprRHS e@(L pos e0) = do
d <- getDensity
case d of
......@@ -452,7 +452,7 @@ addTickLHsExprRHS e@(L pos e0) = do
-- let binds in [], ( [] )
-- we never tick these if we're doing HPC, but otherwise
-- we treat it like an ordinary expression.
addTickLHsExprEvalInner :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprEvalInner e = do
d <- getDensity
case d of
......@@ -464,7 +464,7 @@ addTickLHsExprEvalInner e = do
-- want to tick the body, even if it is not a redex. See test
-- break012. This gives the user the opportunity to inspect the
-- values of the let-bound variables.
addTickLHsExprLetBody :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprLetBody e@(L pos e0) = do
d <- getDensity
case d of
......@@ -478,32 +478,32 @@ addTickLHsExprLetBody e@(L pos e0) = do
-- version of addTick that does not actually add a tick,
-- because the scope of this tick is completely subsumed by
-- another.
addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprNever (L pos e0) = do
e1 <- addTickHsExpr e0
return $ L pos e1
-- general heuristic: expressions which do not denote values are good
-- break points
isGoodBreakExpr :: HsExpr Id -> Bool
isGoodBreakExpr :: HsExpr GhcTc -> Bool
isGoodBreakExpr (HsApp {}) = True
isGoodBreakExpr (HsAppTypeOut {}) = True
isGoodBreakExpr (OpApp {}) = True
isGoodBreakExpr _other = False
isCallSite :: HsExpr Id -> Bool
isCallSite :: HsExpr GhcTc -> Bool
isCallSite HsApp{} = True
isCallSite HsAppTypeOut{} = True
isCallSite OpApp{} = True
isCallSite _ = False
addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickLHsExprOptAlt oneOfMany (L pos e0)
= ifDensity TickForCoverage
(allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
(addTickLHsExpr (L pos e0))
addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addBinTickLHsExpr boxLabel (L pos e0)
= ifDensity TickForCoverage
(allocBinTickBox boxLabel pos $ addTickHsExpr e0)
......@@ -515,7 +515,7 @@ addBinTickLHsExpr boxLabel (L pos e0)
-- (Whether to put a tick around the whole expression was already decided,
-- in the addTickLHsExpr family of functions.)
addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
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)
......@@ -668,24 +668,27 @@ addTickHsExpr (ExprWithTySigOut e ty) =
-- Others should never happen in expression content.
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
addTickTupArg :: LHsTupArg Id -> TM (LHsTupArg Id)
addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e
; return (L l (Present e')) }
addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id))
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsExpr GhcTc))
addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
let isOneOfMany = matchesOneOfMany matches
matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
return $ mg { mg_alts = L l matches' }
addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))
addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
-> TM (Match GhcTc (LHsExpr GhcTc))
addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) =
bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
return $ Match mf pats opSig gRHSs'
addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id))
addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do
bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds
......@@ -694,13 +697,14 @@ addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do
where
binders = collectLocalBinders local_binds
addTickGRHS :: Bool -> Bool -> GRHS Id (LHsExpr Id) -> TM (GRHS Id (LHsExpr Id))
addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
-> TM (GRHS GhcTc (LHsExpr GhcTc))
addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do
(stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
(addTickGRHSBody isOneOfMany isLambda expr)
return $ GRHS stmts' expr'
addTickGRHSBody :: Bool -> Bool -> LHsExpr Id -> TM (LHsExpr Id)
addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
d <- getDensity
case d of
......@@ -712,20 +716,22 @@ addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
_otherwise ->
addTickLHsExprRHS expr
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM [ExprLStmt Id]
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc]
-> TM [ExprLStmt GhcTc]
addTickLStmts isGuard stmts = do
(stmts, _) <- addTickLStmts' isGuard stmts (return ())
return stmts
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM a
-> TM ([ExprLStmt Id], a)
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a
-> TM ([ExprLStmt GhcTc], a)
addTickLStmts' isGuard lstmts res
= bindLocals (collectLStmtsBinders lstmts) $
do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
; a <- res
; return (lstmts', a) }
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id (LHsExpr Id) -> TM (Stmt Id (LHsExpr Id))
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc)
-> TM (Stmt GhcTc (LHsExpr GhcTc))
addTickStmt _isGuard (LastStmt e noret ret) = do
liftM3 LastStmt
(addTickLHsExpr e)
......@@ -778,13 +784,13 @@ addTickStmt isGuard stmt@(RecStmt {})
; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
, recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
| otherwise = addTickLHsExprRHS e
addTickApplicativeArg
:: Maybe (Bool -> BoxLabel) -> (SyntaxExpr Id, ApplicativeArg Id Id)
-> TM (SyntaxExpr Id, ApplicativeArg Id Id)
:: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc)
-> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc)
addTickApplicativeArg isGuard (op, arg) =
liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
where
......@@ -796,15 +802,15 @@ addTickApplicativeArg isGuard (op, arg) =
<*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret))
<*> addTickLPat pat
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id
-> TM (ParStmtBlock Id Id)
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
-> TM (ParStmtBlock GhcTc GhcTc)
addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
liftM3 ParStmtBlock
(addTickLStmts isGuard stmts)
(return ids)
(addTickSyntaxExpr hpcSrcSpan returnExpr)
addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds (HsValBinds binds) =
liftM HsValBinds
(addTickHsValBinds binds)
......@@ -813,7 +819,7 @@ addTickHsLocalBinds (HsIPBinds binds) =
(addTickHsIPBinds binds)
addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds
addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b)
addTickHsValBinds :: HsValBindsLR GhcTc a -> TM (HsValBindsLR GhcTc b)
addTickHsValBinds (ValBindsOut binds sigs) =
liftM2 ValBindsOut
(mapM (\ (rec,binds') ->
......@@ -824,28 +830,28 @@ addTickHsValBinds (ValBindsOut binds sigs) =
(return sigs)
addTickHsValBinds _ = panic "addTickHsValBinds"
addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)
addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
addTickHsIPBinds (IPBinds ipbinds dictbinds) =
liftM2 IPBinds
(mapM (liftL (addTickIPBind)) ipbinds)
(return dictbinds)
addTickIPBind :: IPBind Id -> TM (IPBind Id)
addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)
addTickIPBind (IPBind nm e) =
liftM2 IPBind
(return nm)
(addTickLHsExpr e)
-- There is no location here, so we might need to use a context location??
addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do
L _ x' <- addTickLHsExpr (L pos x)
return $ syn { syn_expr = x' }
-- we do not walk into patterns.
addTickLPat :: LPat Id -> TM (LPat Id)
addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
addTickLPat pat = return pat
addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
liftM4 HsCmdTop
(addTickLHsCmd cmd)
......@@ -853,12 +859,12 @@ addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
(return ty)
(return syntaxtable)
addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id)
addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd (L pos c0) = do
c1 <- addTickHsCmd c0
return $ L pos c1
addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)
addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
addTickHsCmd (HsCmdLam matchgroup) =
liftM HsCmdLam (addTickCmdMatchGroup matchgroup)
addTickHsCmd (HsCmdApp c e) =
......@@ -910,18 +916,19 @@ addTickHsCmd (HsCmdWrap w cmd)
-- Others should never happen in a command context.
--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id))
addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)
-> TM (MatchGroup GhcTc (LHsCmd GhcTc))
addTickCmdMatchGroup mg@(MG { mg_alts = L l matches }) = do
matches' <- mapM (liftL addTickCmdMatch) matches
return $ mg { mg_alts = L l matches' }
addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id))
addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
addTickCmdMatch (Match mf pats opSig gRHSs) =
bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickCmdGRHSs gRHSs
return $ Match mf pats opSig gRHSs'
addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id))
addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
addTickCmdGRHSs (GRHSs guarded (L l local_binds)) = do
bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds
......@@ -930,7 +937,7 @@ addTickCmdGRHSs (GRHSs guarded (L l local_binds)) = do
where
binders = collectLocalBinders local_binds
addTickCmdGRHS :: GRHS Id (LHsCmd Id) -> TM (GRHS Id (LHsCmd Id))
addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
-- The *guards* are *not* Cmds, although the body is
-- C.f. addTickGRHS for the BinBox stuff