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