Just file -> file
Nothing -> panic "can not find the original file during hpc trans"
- if "boot" `isSuffixOf` orig_file then return (binds, noHpcInfo, emptyModBreaks) else do
+ if "boot" `isSuffixOf` orig_file then return (binds, emptyHpcInfo False, emptyModBreaks) else do
let mod_name = moduleNameString (moduleName mod)
let (binds1,_,st)
= unTM (addTickLHsBinds binds)
(TTE
- { modName = mod_name
+ { fileName = mkFastString orig_file
, declPath = []
, inScope = emptyVarSet
, blackList = listToFM [ (getSrcSpan (tyConName tyCon),())
(addTickHsRecordBinds rec_binds)
(return cons) (return tys1) (return tys2)
-addTickHsExpr (ExprWithTySig {}) = error "addTickHsExpr: ExprWithTySig"
addTickHsExpr (ExprWithTySigOut e ty) =
liftM2 ExprWithTySigOut
(addTickLHsExprNever e) -- No need to tick the inner expression
addTickHsExpr e@(HsType ty) = return e
--- Should never happen in expression content.
-addTickHsExpr (EAsPat _ _) = error "addTickHsExpr: EAsPat _ _"
-addTickHsExpr (ELazyPat _) = error "addTickHsExpr: ELazyPat _"
-addTickHsExpr (EWildPat) = error "addTickHsExpr: EWildPat"
-addTickHsExpr (HsBinTick _ _ _) = error "addTickhsExpr: HsBinTick _ _ _"
-addTickHsExpr (HsTick _ _ _) = error "addTickhsExpr: HsTick _ _"
+-- Others dhould never happen in expression content.
+addTickHsExpr e@(ExprWithTySig {}) = pprPanic "addTickHsExpr" (ppr e)
+addTickHsExpr e@(EAsPat _ _) = pprPanic "addTickHsExpr" (ppr e)
+addTickHsExpr e@(ELazyPat _) = pprPanic "addTickHsExpr" (ppr e)
+addTickHsExpr e@(EWildPat) = pprPanic "addTickHsExpr" (ppr e)
+addTickHsExpr e@(HsBinTick _ _ _) = pprPanic "addTickHsExpr" (ppr e)
+addTickHsExpr e@(HsTick _ _ _) = pprPanic "addTickHsExpr" (ppr e)
addTickMatchGroup (MatchGroup matches ty) = do
let isOneOfMany = matchesOneOfMany matches
, mixEntries :: [MixEntry_]
}
-data TickTransEnv = TTE { modName :: String
+data TickTransEnv = TTE { fileName :: FastString
, declPath :: [String]
, inScope :: VarSet
, blackList :: FiniteMap SrcSpan ()
getPathEntry :: TM [String]
getPathEntry = declPath `liftM` getEnv
+getFileName :: TM FastString
+getFileName = fileName `liftM` getEnv
+
+sameFileName :: SrcSpan -> TM a -> TM a -> TM a
+sameFileName pos out_of_scope in_scope = do
+ file_name <- getFileName
+ case optSrcSpanFileName pos of
+ Just file_name2
+ | file_name == file_name2 -> in_scope
+ _ -> out_of_scope
+
bindLocals :: [Id] -> TM a -> TM a
bindLocals new_ids (TM m)
= TM $ \ env st ->
-- the tick application inherits the source position of its
-- expression argument to support nested box allocations
allocTickBox :: BoxLabel -> SrcSpan -> TM (HsExpr Id) -> TM (LHsExpr Id)
-allocTickBox boxLabel pos m | isGoodSrcSpan' pos = do
+allocTickBox boxLabel pos m | isGoodSrcSpan' pos =
+ sameFileName pos
+ (do e <- m; return (L pos e)) $ do
(fvs, e) <- getFreeVars m
TM $ \ env st ->
let c = tickBoxCount st
-- the tick application inherits the source position of its
-- expression argument to support nested box allocations
allocATickBox :: BoxLabel -> SrcSpan -> FreeVars -> TM (Maybe (Int,[Id]))
-allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos = TM $ \ env st ->
+allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos =
+ sameFileName pos
+ (return Nothing) $ TM $ \ env st ->
let me = (pos, map (nameOccName.idName) ids, boxLabel)
c = tickBoxCount st
mes = mixEntries st