[commit: ghc] wip/hasfield: Support virtual fields via manual HasField instances (9a390aa)

[git at git.haskell.org]

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

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

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

commit 9a390aa6277b6c21fe69b662d2dbd398c48523f2
Author: Adam Gundry <adam at well-typed.com>
Date:   Tue Dec 22 16:56:04 2015 +0000

    Support virtual fields via manual HasField instances


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

9a390aa6277b6c21fe69b662d2dbd398c48523f2
 compiler/typecheck/TcInteract.hs                             | 12 ++++++------
 .../tests/overloadedrecflds/should_run/hasfieldrun01.hs      | 12 ++++++++++--
 .../tests/overloadedrecflds/should_run/hasfieldrun01.stdout  |  1 +
 3 files changed, 17 insertions(+), 8 deletions(-)

diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index d246b15..66cacea 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -1801,7 +1801,7 @@ match_class_inst dflags clas tys loc
   | cls_name == typeableClassName     = matchTypeable        clas tys
   | clas `hasKey` heqTyConKey         = matchLiftedEquality       tys
   | clas `hasKey` coercibleTyConKey   = matchLiftedCoercible      tys
-  | cls_name == hasFieldClassName     = matchHasField        clas tys
+  | cls_name == hasFieldClassName     = matchHasField dflags clas tys loc
   | otherwise                         = matchInstEnv dflags clas tys loc
   where
     cls_name = className clas
@@ -2131,8 +2131,8 @@ matchLiftedCoercible args = pprPanic "matchLiftedCoercible" (ppr args)
 *                                                                     *
 ***********************************************************************-}
 
-matchHasField :: Class -> [Type] -> TcS LookupInstResult
-matchHasField clas tys@[x_ty, r_ty, a_ty]
+matchHasField :: DynFlags -> Class -> [Type] -> CtLoc -> TcS LookupInstResult
+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
@@ -2140,7 +2140,7 @@ matchHasField clas tys@[x_ty, r_ty, a_ty]
   = do { env <- getGlobalRdrEnvTcS
        ; let gres = lookupGRE_Field_Name env (flSelector fl) (flLabel fl)
        ; case gres of
-           []      -> return NoInstance
+           []      -> matchInstEnv dflags clas tys loc
            (gre:_) -> do {
        ; addUsedGRE True gre
        ; sel_id <- tcLookupId (flSelector fl)
@@ -2155,7 +2155,7 @@ matchHasField clas tys@[x_ty, r_ty, a_ty]
              theta = mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind, inst_field_ty, a_ty ]
 
        ; if isNaughtyRecordSelector sel_id || not (isTauTy inst_field_ty)
-         then return NoInstance
+         then matchInstEnv dflags clas tys loc
          else do {
 
        ; let mk_ev [ev] = EvCast (EvExpr (mkHsLamConst proxy_ty (mkFunTy r_ty a_ty) body)) (mkTcSymCo ax)
@@ -2171,7 +2171,7 @@ matchHasField clas tys@[x_ty, r_ty, a_ty]
                          , lir_safe_over = True
                          })
        } } }
-matchHasField _ _ = return NoInstance
+matchHasField dflags clas tys loc = matchInstEnv dflags clas tys loc
 
 mkHsLamConst :: Type -> Type -> HsExpr Id -> HsExpr Id
 mkHsLamConst arg_ty res_ty body = HsLam mg
diff --git a/testsuite/tests/overloadedrecflds/should_run/hasfieldrun01.hs b/testsuite/tests/overloadedrecflds/should_run/hasfieldrun01.hs
index 0f27c6b..eeda42e 100644
--- a/testsuite/tests/overloadedrecflds/should_run/hasfieldrun01.hs
+++ b/testsuite/tests/overloadedrecflds/should_run/hasfieldrun01.hs
@@ -1,7 +1,8 @@
-{-# LANGUAGE DataKinds, MagicHash, TypeFamilies #-}
+{-# LANGUAGE DataKinds, FlexibleInstances, MagicHash,
+             MultiParamTypeClasses, TypeFamilies #-}
 
 import GHC.Prim (Proxy#, proxy#)
-import GHC.Records (getField)
+import GHC.Records (HasField(..))
 
 type family B where B = Bool
 
@@ -10,8 +11,15 @@ data T = MkT { foo :: Int, bar :: B }
 data U a b = MkU { baf :: a }
 
 t = MkT 42 True
+
+u :: U Char Char
 u = MkU 'x'
 
+-- A virtual foo field for U
+instance HasField "foo" (U a b) [Char] where
+  getField _ _ = "virtual"
+
 main = do print (getField (proxy# :: Proxy# "foo") t)
           print (getField (proxy# :: Proxy# "bar") t)
           print (getField (proxy# :: Proxy# "baf") u)
+          print (getField (proxy# :: Proxy# "foo") u)
diff --git a/testsuite/tests/overloadedrecflds/should_run/hasfieldrun01.stdout b/testsuite/tests/overloadedrecflds/should_run/hasfieldrun01.stdout
index 1bfbe7a..4c188ae 100644
--- a/testsuite/tests/overloadedrecflds/should_run/hasfieldrun01.stdout
+++ b/testsuite/tests/overloadedrecflds/should_run/hasfieldrun01.stdout
@@ -1,3 +1,4 @@
 42
 True
 'x'
+"virtual"