1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
-- (those who have too heavy dependencies for TcEvidence)
module TcEvTerm
( evDelayedError, evCallStack )
where
import GhcPrelude
import FastString
import GHC.Core.Type
import GHC.Core
import GHC.Core.Make
import Literal ( Literal(..) )
import TcEvidence
import GHC.Driver.Types
import GHC.Driver.Session
import Name
import Module
import GHC.Core.Utils
import PrelNames
import SrcLoc
-- Used with Opt_DeferTypeErrors
-- See Note [Deferring coercion errors to runtime]
-- in TcSimplify
evDelayedError :: Type -> FastString -> EvTerm
evDelayedError ty msg
= EvExpr $
Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]
where
errorId = tYPE_ERROR_ID
litMsg = Lit (LitString (bytesFS msg))
-- Dictionary for CallStack implicit parameters
evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>
EvCallStack -> m EvExpr
-- See Note [Overview of implicit CallStacks] in TcEvidence.hs
evCallStack cs = do
df <- getDynFlags
let platform = targetPlatform df
m <- getModule
srcLocDataCon <- lookupDataCon srcLocDataConName
let mkSrcLoc l = mkCoreConApps srcLocDataCon <$>
sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)
, mkStringExprFS (moduleNameFS $ moduleName m)
, mkStringExprFS (srcSpanFile l)
, return $ mkIntExprInt platform (srcSpanStartLine l)
, return $ mkIntExprInt platform (srcSpanStartCol l)
, return $ mkIntExprInt platform (srcSpanEndLine l)
, return $ mkIntExprInt platform (srcSpanEndCol l)
]
emptyCS <- Var <$> lookupId emptyCallStackName
pushCSVar <- lookupId pushCallStackName
let pushCS name loc rest =
mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest]
let mkPush name loc tm = do
nameExpr <- mkStringExprFS name
locExpr <- mkSrcLoc loc
-- at this point tm :: IP sym CallStack
-- but we need the actual CallStack to pass to pushCS,
-- so we use unwrapIP to strip the dictionary wrapper
-- See Note [Overview of implicit CallStacks]
let ip_co = unwrapIP (exprType tm)
return (pushCS nameExpr locExpr (Cast tm ip_co))
case cs of
EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
EvCsEmpty -> return emptyCS
|
