Turn EvTerm (almost) into CoreExpr (#14691)
[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 -> EvExpr
27 evDelayedError ty msg
28 = Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]
29 where
30 errorId = tYPE_ERROR_ID
31 litMsg = Lit (MachStr (fastStringToByteString msg))
32
33 -- Dictionary for CallStack implicit parameters
34 evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>
35 EvCallStack -> m EvExpr
36 -- See Note [Overview of implicit CallStacks] in TcEvidence.hs
37 evCallStack cs = do
38 df <- getDynFlags
39 m <- getModule
40 srcLocDataCon <- lookupDataCon srcLocDataConName
41 let mkSrcLoc l = mkCoreConApps srcLocDataCon <$>
42 sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)
43 , mkStringExprFS (moduleNameFS $ moduleName m)
44 , mkStringExprFS (srcSpanFile l)
45 , return $ mkIntExprInt df (srcSpanStartLine l)
46 , return $ mkIntExprInt df (srcSpanStartCol l)
47 , return $ mkIntExprInt df (srcSpanEndLine l)
48 , return $ mkIntExprInt df (srcSpanEndCol l)
49 ]
50
51 emptyCS <- Var <$> lookupId emptyCallStackName
52
53 pushCSVar <- lookupId pushCallStackName
54 let pushCS name loc rest =
55 mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest]
56
57 let mkPush name loc tm = do
58 nameExpr <- mkStringExprFS name
59 locExpr <- mkSrcLoc loc
60 -- at this point tm :: IP sym CallStack
61 -- but we need the actual CallStack to pass to pushCS,
62 -- so we use unwrapIP to strip the dictionary wrapper
63 -- See Note [Overview of implicit CallStacks]
64 let ip_co = unwrapIP (exprType tm)
65 return (pushCS nameExpr locExpr (Cast tm ip_co))
66
67 case cs of
68 EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
69 EvCsEmpty -> return emptyCS