[commit: ghc] wip/14691: Implement evLit (70cbf28)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/14691
Link       : http://ghc.haskell.org/trac/ghc/changeset/70cbf288e46f3b1a49257c1e48af2f24a5512b15/ghc

>---------------------------------------------------------------

commit 70cbf288e46f3b1a49257c1e48af2f24a5512b15
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Sat Jan 20 10:32:38 2018 -0500

    Implement evLit
    
    but really, the whole EvLit data type is now obsolete, as it just defers
    the construction of Core from matchKnownSymbol to makeLitDict.


>---------------------------------------------------------------

70cbf288e46f3b1a49257c1e48af2f24a5512b15
 compiler/typecheck/TcEvTerm.hs   | 13 +++++--------
 compiler/typecheck/TcInteract.hs |  6 ++++--
 compiler/typecheck/TcSMonad.hs   |  3 +++
 3 files changed, 12 insertions(+), 10 deletions(-)

diff --git a/compiler/typecheck/TcEvTerm.hs b/compiler/typecheck/TcEvTerm.hs
index c1eb117..ea1cab7 100644
--- a/compiler/typecheck/TcEvTerm.hs
+++ b/compiler/typecheck/TcEvTerm.hs
@@ -8,16 +8,12 @@ where
 import GhcPrelude
 
 import FastString
-import Var
 import Type
 import CoreSyn
-import CoreUtils
-import Class ( classSCSelId )
-import Id ( isEvVar )
-import CoreFVs ( exprSomeFreeVars )
-import MkCore ( tYPE_ERROR_ID )
+import MkCore ( tYPE_ERROR_ID, mkStringExprFS, mkNaturalExpr )
 import Literal ( Literal(..) )
 import TcEvidence
+import HscTypes
 
 -- Used with Opt_DeferTypeErrors
 -- See Note [Deferring coercion errors to runtime]
@@ -31,8 +27,9 @@ evDelayedError ty msg
 
 -- Dictionary for KnownNat and KnownSymbol classes.
 -- Note [KnownNat & KnownSymbol and EvLit]
-evLit :: EvLit -> EvTerm
-evLit = undefined
+evLit :: MonadThings m => EvLit -> m EvTerm
+evLit (EvNum n) = mkNaturalExpr n
+evLit (EvStr n) = mkStringExprFS n
 
 -- Dictionary for CallStack implicit parameters
 evCallStack :: EvCallStack -> EvTerm
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index 7af3d04..353851d 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -2588,8 +2588,10 @@ makeLitDict clas ty el
                       $ idType meth         -- forall n. KnownNat n => SNat n
     , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty]
           -- SNat n ~ Integer
-    , let ev_tm = mkEvCast (evLit el) (mkTcSymCo (mkTcTransCo co_dict co_rep))
-    = return $ GenInst { lir_new_theta = []
+    = do
+      litExpr <- evLit el
+      let ev_tm = mkEvCast (litExpr :: EvTerm) (mkTcSymCo (mkTcTransCo co_dict co_rep))
+      return $ GenInst { lir_new_theta = []
                        , lir_mk_ev     = \_ -> ev_tm
                        , lir_safe_over = True }
 
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index f7a2561..196ee27 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -2385,6 +2385,9 @@ instance MonadFail.MonadFail TcS where
 instance MonadUnique TcS where
    getUniqueSupplyM = wrapTcS getUniqueSupplyM
 
+instance MonadThings TcS where
+   lookupThing n = wrapTcS (lookupThing n)
+
 -- Basic functionality
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 wrapTcS :: TcM a -> TcS a