[commit: ghc] wip/14691: Implement the pure evTerm smart constructors (9bc184a)

[git at git.haskell.org]

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

On branch  : wip/14691
Link       : http://ghc.haskell.org/trac/ghc/changeset/9bc184af3a8b9e31591cde36d6cf64dac7710174/ghc

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

commit 9bc184af3a8b9e31591cde36d6cf64dac7710174
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Sat Jan 20 10:15:42 2018 -0500

    Implement the pure evTerm smart constructors
    
    and move some of them with heavier dependencies to TcEvTerm (otherwise
    we’d get module import cycles).


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

9bc184af3a8b9e31591cde36d6cf64dac7710174
 compiler/ghc.cabal.in             |  1 +
 compiler/typecheck/TcCanonical.hs |  1 +
 compiler/typecheck/TcErrors.hs    |  1 +
 compiler/typecheck/TcEvTerm.hs    | 43 ++++++++++++++++++++++++++
 compiler/typecheck/TcEvidence.hs  | 65 +++++++++++----------------------------
 compiler/typecheck/TcInteract.hs  |  1 +
 6 files changed, 65 insertions(+), 47 deletions(-)

diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 1e3447b..d4387cb 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -471,6 +471,7 @@ Library
         TcTypeable
         TcType
         TcEvidence
+        TcEvTerm
         TcUnify
         TcInteract
         TcCanonical
diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index 87d45f2..1a5a4fd 100644
--- a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ -19,6 +19,7 @@ import Type
 import TcFlatten
 import TcSMonad
 import TcEvidence
+import TcEvTerm
 import Class
 import TyCon
 import TyCoRep   -- cleverly decomposes types, good for completeness checking
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index 37db63f..2f8f4cf 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -31,6 +31,7 @@ import TyCon
 import Class
 import DataCon
 import TcEvidence
+import TcEvTerm
 import HsExpr  ( UnboundVar(..) )
 import HsBinds ( PatSynBind(..) )
 import Name
diff --git a/compiler/typecheck/TcEvTerm.hs b/compiler/typecheck/TcEvTerm.hs
new file mode 100644
index 0000000..c1eb117
--- /dev/null
+++ b/compiler/typecheck/TcEvTerm.hs
@@ -0,0 +1,43 @@
+-- | Smart constructors for EvTerm
+-- (those who have too heavy dependencies for TcEvidence)
+module TcEvTerm
+    ( evDelayedError, evLit, evCallStack, evTypeable)
+
+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 Literal ( Literal(..) )
+import TcEvidence
+
+-- Used with Opt_DeferTypeErrors
+-- See Note [Deferring coercion errors to runtime]
+-- in TcSimplify
+evDelayedError :: Type -> FastString -> EvTerm
+evDelayedError ty msg
+  = Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]
+  where
+    errorId = tYPE_ERROR_ID
+    litMsg  = Lit (MachStr (fastStringToByteString msg))
+
+-- Dictionary for KnownNat and KnownSymbol classes.
+-- Note [KnownNat & KnownSymbol and EvLit]
+evLit :: EvLit -> EvTerm
+evLit = undefined
+
+-- Dictionary for CallStack implicit parameters
+evCallStack :: EvCallStack -> EvTerm
+evCallStack = undefined
+
+-- Dictionary for (Typeable ty)
+evTypeable :: Type -> EvTypeable -> EvTerm
+evTypeable = undefined
diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index faf8650..02e1699 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -20,8 +20,7 @@ module TcEvidence (
 
   -- EvTerm (already a CoreExpr)
   EvTerm,
-  evId, evCoercion, evCast, evDFunApp, evDelayedError, evSuperClass,
-  evLit, evCallStack, evTypeable, evSelector,
+  evId, evCoercion, evCast, evDFunApp,  evSuperClass, evSelector,
   mkEvCast, evVarsOfTerm, mkEvScSelectors,
 
   EvLit(..), evTermCoercion,
@@ -64,8 +63,10 @@ import Name
 import Pair
 
 import CoreSyn
-import Id (isEvVar)
-import CoreFVs (exprSomeFreeVars)
+import CoreUtils
+import Class ( classSCSelId )
+import Id ( isEvVar )
+import CoreFVs ( exprSomeFreeVars )
 
 import Util
 import Bag
@@ -482,57 +483,43 @@ mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = tm }
 
 type EvTerm = CoreExpr
 
--- An EvTerm is (usually) constructed by any of these smart constructors:
+-- An EvTerm is (usually) constructed by any of the constructors here
+-- and those more complicates ones who were moved to module TcEvTerm
 
 -- | Any sort of evidence Id, including coercions
 evId ::  EvId -> EvTerm
-evId eid = undefined
+evId = Var
 
 -- coercion bindings
 -- See Note [Coercion evidence terms]
 evCoercion :: TcCoercion -> EvTerm
-evCoercion tc = undefined
-
+evCoercion = Coercion
 
 -- | d |> co
 evCast :: EvTerm -> TcCoercion -> EvTerm
-evCast et tc = undefined
+evCast et tc | isReflCo tc = et
+             | otherwise   = Cast et tc
 
 -- Dictionary instance application
 evDFunApp :: DFunId -> [Type] -> [EvTerm] -> EvTerm
-evDFunApp dfunid tys ets = undefined
-
--- Used with Opt_DeferTypeErrors
--- See Note [Deferring coercion errors to runtime]
--- in TcSimplify
-evDelayedError :: Type -> FastString -> EvTerm
-evDelayedError = undefined
+evDFunApp df tys ets = Var df `mkTyApps` tys `mkApps` ets
 
 -- n'th superclass. Used for both equalities and
 -- dictionaries, even though the former have no
 -- selector Id.  We count up from _0_
 evSuperClass :: EvTerm -> Int -> EvTerm
-evSuperClass = undefined
-
--- Dictionary for KnownNat and KnownSymbol classes.
--- Note [KnownNat & KnownSymbol and EvLit]
-evLit :: EvLit -> EvTerm
-evLit = undefined
-
--- Dictionary for CallStack implicit parameters
-evCallStack :: EvCallStack -> EvTerm
-evCallStack = undefined
-
--- Dictionary for (Typeable ty)
-evTypeable :: Type -> EvTypeable -> EvTerm
-evTypeable = undefined
+evSuperClass d n = Var sc_sel_id `mkTyApps` tys `App` d
+  where
+    (cls, tys) = getClassPredTys (exprType d)
+    sc_sel_id  = classSCSelId cls n -- Zero-indexed
 
 -- Selector id plus the types at which it
 -- should be instantiated, used for HasField
 -- dictionaries; see Note [HasField instances]
 -- in TcInterface
 evSelector :: Id -> [Type] -> [EvTerm] -> EvTerm
-evSelector = undefined
+evSelector sel_id tys tms = Var sel_id `mkTyApps` tys `mkApps` tms
+
 
 -- | Instructions on how to make a 'Typeable' dictionary.
 -- See Note [Typeable evidence terms]
@@ -830,9 +817,6 @@ evTermCoercion tm            = pprPanic "evTermCoercion" (ppr tm)
 evVarsOfTerm :: EvTerm -> VarSet
 evVarsOfTerm = exprSomeFreeVars isEvVar
 
-evVarsOfTerms :: [EvTerm] -> VarSet
-evVarsOfTerms = mapUnionVarSet evVarsOfTerm
-
 -- | Do SCC analysis on a bag of 'EvBind's.
 sccEvBinds :: Bag EvBind -> [SCC EvBind]
 sccEvBinds bs = stronglyConnCompFromEdgedVerticesUniq edges
@@ -848,19 +832,6 @@ sccEvBinds bs = stronglyConnCompFromEdgedVerticesUniq edges
       -- is still deterministic even if the edges are in nondeterministic order
       -- as explained in Note [Deterministic SCC] in Digraph.
 
-evVarsOfCallStack :: EvCallStack -> VarSet
-evVarsOfCallStack cs = case cs of
-  EvCsEmpty -> emptyVarSet
-  EvCsPushCall _ _ tm -> evVarsOfTerm tm
-
-evVarsOfTypeable :: EvTypeable -> VarSet
-evVarsOfTypeable ev =
-  case ev of
-    EvTypeableTyCon _ e   -> mapUnionVarSet evVarsOfTerm e
-    EvTypeableTyApp e1 e2 -> evVarsOfTerms [e1,e2]
-    EvTypeableTrFun e1 e2 -> evVarsOfTerms [e1,e2]
-    EvTypeableTyLit e     -> evVarsOfTerm e
-
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index 9dc2fff..7af3d04 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -47,6 +47,7 @@ import FamInstEnv
 import Unify ( tcUnifyTyWithTFs )
 
 import TcEvidence
+import TcEvTerm
 import Outputable
 
 import TcRnTypes