projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Fix the 64k insns overflow check in ghci, and add more checks
[ghc-hetmet.git]
/
compiler
/
deSugar
/
Coverage.lhs
diff --git
a/compiler/deSugar/Coverage.lhs
b/compiler/deSugar/Coverage.lhs
index
4d85e90
..
dce7962
100644
(file)
--- a/
compiler/deSugar/Coverage.lhs
+++ b/
compiler/deSugar/Coverage.lhs
@@
-11,7
+11,7
@@
import HsSyn
import Module
import Outputable
import DynFlags
import Module
import Outputable
import DynFlags
-import Monad
+import Control.Monad
import SrcLoc
import ErrUtils
import Name
import SrcLoc
import ErrUtils
import Name
@@
-24,10
+24,9
@@
import HscTypes
import StaticFlags
import TyCon
import FiniteMap
import StaticFlags
import TyCon
import FiniteMap
+import Maybes
import Data.Array
import Data.Array
-import Data.Maybe
-import System.IO (FilePath)
import System.Directory ( createDirectoryIfMissing )
import Trace.Hpc.Mix
import System.Directory ( createDirectoryIfMissing )
import Trace.Hpc.Mix
@@
-279,6
+278,10
@@
addTickHsExpr (SectionR e1 e2) =
liftM2 SectionR
(addTickLHsExpr e1)
(addTickLHsExpr e2)
liftM2 SectionR
(addTickLHsExpr e1)
(addTickLHsExpr e2)
+addTickHsExpr (ExplicitTuple es boxity) =
+ liftM2 ExplicitTuple
+ (mapM addTickTupArg es)
+ (return boxity)
addTickHsExpr (HsCase e mgs) =
liftM2 HsCase
(addTickLHsExpr e)
addTickHsExpr (HsCase e mgs) =
liftM2 HsCase
(addTickLHsExpr e)
@@
-302,17
+305,13
@@
addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do
ListComp -> Just $ BinBox QualBinBox
_ -> Nothing
addTickHsExpr (ExplicitList ty es) =
ListComp -> Just $ BinBox QualBinBox
_ -> Nothing
addTickHsExpr (ExplicitList ty es) =
- liftM2 ExplicitList
+ liftM2 ExplicitList
(return ty)
(mapM (addTickLHsExpr) es)
addTickHsExpr (ExplicitPArr ty es) =
liftM2 ExplicitPArr
(return ty)
(mapM (addTickLHsExpr) es)
(return ty)
(mapM (addTickLHsExpr) es)
addTickHsExpr (ExplicitPArr ty es) =
liftM2 ExplicitPArr
(return ty)
(mapM (addTickLHsExpr) es)
-addTickHsExpr (ExplicitTuple es box) =
- liftM2 ExplicitTuple
- (mapM (addTickLHsExpr) es)
- (return box)
addTickHsExpr (RecordCon id ty rec_binds) =
liftM3 RecordCon
(return id)
addTickHsExpr (RecordCon id ty rec_binds) =
liftM3 RecordCon
(return id)
@@
-378,6
+377,10
@@
addTickHsExpr e@(HsType _) = return e
-- Others dhould never happen in expression content.
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
-- Others dhould never happen in expression content.
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
+addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id)
+addTickTupArg (Present e) = do { e' <- addTickLHsExpr e; return (Present e') }
+addTickTupArg (Missing ty) = return (Missing ty)
+
addTickMatchGroup :: MatchGroup Id -> TM (MatchGroup Id)
addTickMatchGroup (MatchGroup matches ty) = do
let isOneOfMany = matchesOneOfMany matches
addTickMatchGroup :: MatchGroup Id -> TM (MatchGroup Id)
addTickMatchGroup (MatchGroup matches ty) = do
let isOneOfMany = matchesOneOfMany matches