[commit: ghc] wip/hasfield: OverloadedRecordFields magic constraint solving for HasField (835c52e)

[git at git.haskell.org]

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

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

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

commit 835c52e2d7c0089bc0f7e89fa0d328f8d65a80f5
Author: Adam Gundry <adam at well-typed.com>
Date:   Tue Dec 22 17:44:04 2015 +0000

    OverloadedRecordFields magic constraint solving for HasField
    
    Summary:
    This makes a start at implementing part 3 of the OverloadedRecordFields
    trilogy (see https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/MagicClasses).
    Only HasField has been done so far; updates need a bit more thought about
    the design. Moreover, I've gone for the functional dependency version
    as it seems simplest.
    
    Rather than adding another special-purpose constructor to EvTerm, I made
    it possible to embed arbitrary HsExprs in evidence. This should be useful
    for typechecker plugins. But I can specialise it if needed.
    
    Test Plan: some new tests added, more needed
    
    Reviewers: bgamari, austin, simonpj, hvr
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D1687


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

835c52e2d7c0089bc0f7e89fa0d328f8d65a80f5
 compiler/typecheck/TcEvidence.hs |  2 +-
 compiler/typecheck/TcInteract.hs | 16 +++++++++++-----
 2 files changed, 12 insertions(+), 6 deletions(-)

diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index 2866383..e2ad4b8 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -362,7 +362,7 @@ data EvTerm
 
   | EvTypeable Type EvTypeable   -- Dictionary for (Typeable ty)
 
-  | EvExpr (HsExpr Id)           -- Dictionary for HasField (internally generated)
+  | EvExpr (HsExpr Id)           -- Dictionary for HasField (internal)
                                  -- or arbitrary class (generated by plugin)
 
   deriving( Data.Data, Data.Typeable )
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index 096af23..ffcb27c 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -2180,7 +2180,6 @@ matchHasField dflags clas tys@[x_ty, r_ty, a_ty] loc
   | Just x <- isStrLitTy x_ty
   , Just (tycon, r_args) <- tcSplitTyConApp_maybe r_ty
   , Just fl <- lookupFsEnv (tyConFieldLabelEnv tycon) x
-  , Just (_, ax) <- tcInstNewTyCon_maybe (classTyCon clas) tys
   = do { env <- getGlobalRdrEnvTcS
          -- Check that the field selector is in scope
        ; case lookupGRE_Field_Name env (flSelector fl) (flLabel fl) of
@@ -2203,7 +2202,8 @@ matchHasField dflags clas tys@[x_ty, r_ty, a_ty] loc
          -- type in the third parameter of the HasField constraint.
              tenv = mkTopTCvSubst (dataConUnivTyVars data_con `zip` r_args)
              inst_field_ty = substTy tenv field_ty
-             theta = mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind, inst_field_ty, a_ty ]
+             theta = mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind
+                                            , inst_field_ty, a_ty ]
 
          -- Give up if the selector is "naughty" (i.e. this is an
          -- existentially quantified type) or has a higher-rank type.
@@ -2215,11 +2215,17 @@ matchHasField dflags clas tys@[x_ty, r_ty, a_ty] loc
        ; addUsedGRE True gre
 
          -- Build evidence term as described in Note [HasField instances]
-       ; let mk_ev [ev] = EvCast (EvExpr (mkHsLamConst proxy_ty (mkFunTy r_ty a_ty) body)) (mkTcSymCo ax)
+       ; let mk_ev [ev] = EvExpr lam `EvCast` mkTcSymCo ax
                where
+                lam      = mkHsLamConst proxy_ty (mkFunTy r_ty a_ty) body
                 proxy_ty = mkProxyPrimTy typeSymbolKind x_ty
-                co = mkTcFunCo Nominal (mkTcReflCo Nominal r_ty) (evTermCoercion ev)
-                body = mkHsWrap (mkWpCastN co <.> mkWpTyApps r_args) (HsVar (noLoc sel_id))
+                co       = mkTcFunCo Nominal (mkTcReflCo Nominal r_ty)
+                                             (evTermCoercion ev)
+                body     = mkHsWrap (mkWpCastN co <.> mkWpTyApps r_args)
+                                    (HsVar (noLoc sel_id))
+                ax       = case tcInstNewTyCon_maybe (classTyCon clas) tys of
+                             Just x  -> snd x
+                             Nothing -> panic "HasField not a newtype"
              mk_ev _ = panic "matchHasField.mk_ev"
 
        ; return (GenInst { lir_new_theta = [ theta ]