[commit: ghc] wip/hasfield: Replace EvExpr with more specific EvSelector in EvTerm (bbf6615)

[git at git.haskell.org]

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

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

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

commit bbf6615cf2a07181098cebcfc4f117b3b1b50f1c
Author: Adam Gundry <adam at well-typed.com>
Date:   Sun Oct 9 10:38:49 2016 +0100

    Replace EvExpr with more specific EvSelector in EvTerm


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

bbf6615cf2a07181098cebcfc4f117b3b1b50f1c
 compiler/deSugar/DsBinds.hs      |  4 +++-
 compiler/typecheck/TcEvidence.hs |  9 +++++----
 compiler/typecheck/TcHsSyn.hs    |  7 ++++---
 compiler/typecheck/TcInteract.hs | 23 +++++++++++++++--------
 4 files changed, 27 insertions(+), 16 deletions(-)

diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 72e003b..8dd1b51 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -1086,7 +1086,6 @@ 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
@@ -1103,6 +1102,9 @@ dsEvTerm (EvSuperClass d n)
              sc_sel_id  = classSCSelId cls n    -- Zero-indexed
        ; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
 
+dsEvTerm (EvSelector sel_id tys)
+  = return $ Var sel_id `mkTyApps` tys
+
 dsEvTerm (EvDelayedError ty msg) = return $ dsEvDelayedError ty msg
 
 dsEvDelayedError :: Type -> FastString -> CoreExpr
diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index 23bd6b1..0dd73ee 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -380,8 +380,9 @@ data EvTerm
 
   | EvTypeable Type EvTypeable   -- Dictionary for (Typeable ty)
 
-  | EvExpr (HsExpr Id)           -- Dictionary for HasField (internal)
-                                 -- or arbitrary class (generated by plugin)
+  | EvSelector Id [Type] -- Selector id plus the types at which it should be
+                         -- instantiated, used for HasField dictionaries;
+                         -- see Note [HasField instances] in TcInterface
 
   deriving Data.Data
 
@@ -685,7 +686,7 @@ evVarsOfTerm (EvDelayedError _ _) = emptyVarSet
 evVarsOfTerm (EvLit _)            = emptyVarSet
 evVarsOfTerm (EvCallStack cs)     = evVarsOfCallStack cs
 evVarsOfTerm (EvTypeable _ ev)    = evVarsOfTypeable ev
-evVarsOfTerm (EvExpr _)           = emptyVarSet
+evVarsOfTerm (EvSelector{})       = emptyVarSet
 
 evVarsOfTerms :: [EvTerm] -> VarSet
 evVarsOfTerms = mapUnionVarSet evVarsOfTerm
@@ -790,7 +791,7 @@ instance Outputable EvTerm where
   ppr (EvDelayedError ty msg) =     text "error"
                                 <+> sep [ char '@' <> ppr ty, ppr msg ]
   ppr (EvTypeable ty ev)      = ppr ev <+> dcolon <+> text "Typeable" <+> ppr ty
-  ppr (EvExpr e)              = ppr e
+  ppr (EvSelector sel tys)    = ppr sel <+> sep (map ppr tys)
 
 instance Outputable EvLit where
   ppr (EvNum n) = integer n
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index f21e9e4..a40b51a 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -1419,9 +1419,10 @@ 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') }
+zonkEvTerm env (EvSelector sel_id tys)
+  = do { sel_id' <- zonkIdBndr env sel_id
+       ; tys'    <- zonkTcTypeToTypes env tys
+       ; return (EvSelector sel_id' tys') }
 
 zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
 zonkEvTypeable env (EvTypeableTyCon ts)
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index 9df4585..bf12f57 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -2166,13 +2166,21 @@ Note that
 
 so the expression we construct is
 
-    \ foo @Int |> co
+    foo @Int |> co
 
 where
 
-    co :: (T Int -> [Int]) ~# (T Int -> b)
+    co :: (T Int -> [Int]) ~# HasField "foo" (T Int) b
 
-is built from the new wanted ([Int] ~# b).
+is built from
+
+    co1 :: (T Int -> [Int]) ~# (T Int -> b)
+
+derived from the new wanted ([Int] ~# b) and
+
+    co2 :: (T Int -> b) ~# HasField "foo" (T Int) b
+
+derived from the newtype coercion.
 
 If `foo` is not in scope, higher-rank or existentially quantified then
 the constraint is not solved automatically, but may be solved by a
@@ -2233,13 +2241,12 @@ matchHasField dflags clas tys@[_k_ty, x_ty, r_ty, a_ty] loc
        ; addUsedGRE True gre
 
          -- Build evidence term as described in Note [HasField instances]
-       ; let mk_ev [ev] = EvExpr body `EvCast` mkTcSymCo ax
+       ; let mk_ev [ev] = EvSelector sel_id (reverse rep_tc_args) `EvCast` co
                where
-                co       = mkTcFunCo Nominal (mkTcReflCo Nominal r_ty)
+                co       = mkTcSubCo co1 `mkTcTransCo` mkTcSymCo co2
+                co1      = mkTcFunCo Nominal (mkTcNomReflCo r_ty)
                                              (evTermCoercion ev)
-                body     = mkHsWrap (mkWpCastN co <.> mkWpTyApps (reverse rep_tc_args))
-                                    (HsVar (noLoc sel_id))
-                ax       = case tcInstNewTyCon_maybe (classTyCon clas) tys of
+                co2      = case tcInstNewTyCon_maybe (classTyCon clas) tys of
                              Just x  -> snd x
                              Nothing -> panic "HasField not a newtype"
              mk_ev _ = panic "matchHasField.mk_ev"