[commit: ghc] wip/hasfield: Add EvExpr constructor to EvTerm (bca49cd)

[git at git.haskell.org]

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

On branch  : wip/hasfield
Link       : http://ghc.haskell.org/trac/ghc/changeset/bca49cd5c74b4b42b39151daceea7cac74096e56/ghc

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

commit bca49cd5c74b4b42b39151daceea7cac74096e56
Author: Adam Gundry <adam at well-typed.com>
Date:   Tue Dec 22 16:05:21 2015 +0000

    Add EvExpr constructor to EvTerm
    
    This makes it possible to embed arbitrary HsExprs as evidence terms,
    which will be useful for solving HasField constraints and for
    typechecker plugins.


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

bca49cd5c74b4b42b39151daceea7cac74096e56
 compiler/deSugar/DsBinds.hs      | 3 ++-
 compiler/typecheck/TcEvidence.hs | 6 ++++++
 compiler/typecheck/TcHsSyn.hs    | 3 +++
 3 files changed, 11 insertions(+), 1 deletion(-)

diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 1249806..ab27625 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -18,7 +18,7 @@ module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-}   DsExpr( dsLExpr )
+import {-# SOURCE #-}   DsExpr( dsExpr, dsLExpr )
 import {-# SOURCE #-}   Match( matchWrapper )
 
 import DsMonad
@@ -1007,6 +1007,7 @@ dsEvTerm (EvCallStack cs)   = dsEvCallStack cs
 dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev
 dsEvTerm (EvLit (EvNum n))  = mkIntegerExpr n
 dsEvTerm (EvLit (EvStr s))  = mkStringExprFS s
+dsEvTerm (EvExpr e)         = dsExpr e
 
 dsEvTerm (EvCast tm co)
   = do { tm' <- dsEvTerm tm
diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index 7890115..2866383 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -53,6 +53,7 @@ import VarEnv
 import VarSet
 import Name
 import Pair
+import HsExpr ( HsExpr )
 
 import Util
 import Bag
@@ -361,6 +362,9 @@ data EvTerm
 
   | EvTypeable Type EvTypeable   -- Dictionary for (Typeable ty)
 
+  | EvExpr (HsExpr Id)           -- Dictionary for HasField (internally generated)
+                                 -- or arbitrary class (generated by plugin)
+
   deriving( Data.Data, Data.Typeable )
 
 
@@ -657,6 +661,7 @@ evVarsOfTerm (EvDelayedError _ _) = emptyVarSet
 evVarsOfTerm (EvLit _)            = emptyVarSet
 evVarsOfTerm (EvCallStack cs)     = evVarsOfCallStack cs
 evVarsOfTerm (EvTypeable _ ev)    = evVarsOfTypeable ev
+evVarsOfTerm (EvExpr _)           = emptyVarSet
 
 evVarsOfTerms :: [EvTerm] -> VarSet
 evVarsOfTerms = mapUnionVarSet evVarsOfTerm
@@ -756,6 +761,7 @@ instance Outputable EvTerm where
   ppr (EvDelayedError ty msg) =     ptext (sLit "error")
                                 <+> sep [ char '@' <> ppr ty, ppr msg ]
   ppr (EvTypeable ty ev)      = ppr ev <+> dcolon <+> ptext (sLit "Typeable") <+> ppr ty
+  ppr (EvExpr e)              = ppr e
 
 instance Outputable EvLit where
   ppr (EvNum n) = integer n
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index ee7038d..0780325 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -1278,6 +1278,9 @@ zonkEvTerm env (EvDFunApp df tys tms)
 zonkEvTerm env (EvDelayedError ty msg)
   = do { ty' <- zonkTcTypeToType env ty
        ; return (EvDelayedError ty' msg) }
+zonkEvTerm env (EvExpr e)
+  = do { e' <- zonkExpr env e
+       ; return (EvExpr e') }
 
 zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
 zonkEvTypeable env (EvTypeableTyCon ts)