Implement evCallStack

4 files changed, 52 insertions, 51 deletions

diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 55765f39dd..b87d5adbee 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -1307,6 +1307,7 @@ tyConRep tc
        ; return (Var tc_rep_id) }
   | otherwise
   = pprPanic "tyConRep" (ppr tc)
+-}
 
 {- Note [Memoising typeOf]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1317,49 +1318,3 @@ the proxy argument.  This is what went wrong in #3245 and #9203. So we
 help GHC by manually keeping the 'rep' *outside* the lambda.
 -}
 
-
-{-**********************************************************************
-*                                                                      *
-           Desugaring EvCallStack evidence
-*                                                                      *
-**********************************************************************-}
-
-dsEvCallStack :: EvCallStack -> DsM CoreExpr
--- See Note [Overview of implicit CallStacks] in TcEvidence.hs
-dsEvCallStack cs = do
-  df            <- getDynFlags
-  m             <- getModule
-  srcLocDataCon <- dsLookupDataCon srcLocDataConName
-  let mkSrcLoc l =
-        liftM (mkCoreConApps srcLocDataCon)
-              (sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)
-                        , mkStringExprFS (moduleNameFS $ moduleName m)
-                        , mkStringExprFS (srcSpanFile l)
-                        , return $ mkIntExprInt df (srcSpanStartLine l)
-                        , return $ mkIntExprInt df (srcSpanStartCol l)
-                        , return $ mkIntExprInt df (srcSpanEndLine l)
-                        , return $ mkIntExprInt df (srcSpanEndCol l)
-                        ])
-
-  emptyCS <- Var <$> dsLookupGlobalId emptyCallStackName
-
-  pushCSVar <- dsLookupGlobalId 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
-        case tm of
-          EvCallStack EvCsEmpty -> return (pushCS nameExpr locExpr emptyCS)
-          _ -> do tmExpr  <- dsEvTerm tm
-                  -- at this point tmExpr :: 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 tmExpr)
-                  return (pushCS nameExpr locExpr (mkCastDs tmExpr ip_co))
-  case cs of
-    EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
-    EvCsEmpty -> return emptyCS
--}
diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index 1a5a4fdd2e..0b85567f7a 100644
--- a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ -172,7 +172,8 @@ solveCallStack ev ev_cs = do
   -- We're given ev_cs :: CallStack, but the evidence term should be a
   -- dictionary, so we have to coerce ev_cs to a dictionary for
   -- `IP ip CallStack`. See Note [Overview of implicit CallStacks]
-  let ev_tm = mkEvCast (evCallStack ev_cs) (wrapIP (ctEvPred ev))
+  cs_tm <- evCallStack ev_cs
+  let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev))
   setWantedEvBind (ctEvEvId ev) ev_tm
 
 canClass :: CtEvidence
diff --git a/compiler/typecheck/TcEvTerm.hs b/compiler/typecheck/TcEvTerm.hs
index f79b742039..7e148f6e03 100644
--- a/compiler/typecheck/TcEvTerm.hs
+++ b/compiler/typecheck/TcEvTerm.hs
@@ -1,4 +1,4 @@
--- | Smart constructors for EvTerm
+
 -- (those who have too heavy dependencies for TcEvidence)
 module TcEvTerm
     ( evDelayedError, evCallStack, evTypeable)
@@ -10,9 +10,16 @@ import GhcPrelude
 import FastString
 import Type
 import CoreSyn
-import MkCore ( tYPE_ERROR_ID )
+import MkCore
 import Literal ( Literal(..) )
 import TcEvidence
+import HscTypes
+import DynFlags
+import Name
+import Module
+import CoreUtils
+import PrelNames
+import SrcLoc
 
 -- Used with Opt_DeferTypeErrors
 -- See Note [Deferring coercion errors to runtime]
@@ -25,8 +32,42 @@ evDelayedError ty msg
     litMsg  = Lit (MachStr (fastStringToByteString msg))
 
 -- Dictionary for CallStack implicit parameters
-evCallStack :: EvCallStack -> EvTerm
-evCallStack = undefined
+evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>
+    EvCallStack -> m CoreExpr
+-- See Note [Overview of implicit CallStacks] in TcEvidence.hs
+evCallStack cs = do
+  df            <- getDynFlags
+  m             <- getModule
+  srcLocDataCon <- lookupDataCon srcLocDataConName
+  let mkSrcLoc l = mkCoreConApps srcLocDataCon <$>
+               sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)
+                        , mkStringExprFS (moduleNameFS $ moduleName m)
+                        , mkStringExprFS (srcSpanFile l)
+                        , return $ mkIntExprInt df (srcSpanStartLine l)
+                        , return $ mkIntExprInt df (srcSpanStartCol l)
+                        , return $ mkIntExprInt df (srcSpanEndLine l)
+                        , return $ mkIntExprInt df (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
 
 -- Dictionary for (Typeable ty)
 evTypeable :: Type -> EvTypeable -> EvTerm
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index 196ee27b4a..14e010d743 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -143,6 +143,7 @@ import TyCon
 import TcErrors   ( solverDepthErrorTcS )
 
 import Name
+import Module ( HasModule, getModule )
 import RdrName ( GlobalRdrEnv, GlobalRdrElt )
 import qualified RnEnv as TcM
 import Var
@@ -2385,6 +2386,9 @@ instance MonadFail.MonadFail TcS where
 instance MonadUnique TcS where
    getUniqueSupplyM = wrapTcS getUniqueSupplyM
 
+instance HasModule TcS where
+   getModule = wrapTcS getModule
+
 instance MonadThings TcS where
    lookupThing n = wrapTcS (lookupThing n)