1 files changed, 50 insertions, 5 deletions

diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs
index 016dc08a20..2d1fd5a3f1 100644
--- a/compiler/typecheck/FamInst.lhs
+++ b/compiler/typecheck/FamInst.lhs
@@ -8,6 +8,7 @@ module FamInst (
         checkFamInstConsistency, tcExtendLocalFamInstEnv,
         tcLookupFamInst,
         tcLookupDataFamInst, tcInstNewTyConTF_maybe, tcInstNewTyCon_maybe,
+        lookupRepTyCon,
         newFamInst
     ) where
 
@@ -17,9 +18,10 @@ import InstEnv( roughMatchTcs )
 import Coercion( pprCoAxBranchHdr )
 import TcEvidence
 import LoadIface
-import Type( applyTysX )
+import Type( applyTysX, isRecordsFam, isFldTyFam )
 import TypeRep
 import TcRnMonad
+import Unify
 import TyCon
 import CoAxiom
 import DynFlags
@@ -32,6 +34,9 @@ import Maybes
 import TcMType
 import TcType
 import Name
+import RnEnv
+import VarSet
+import PrelNames
 import Control.Monad
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -206,12 +211,16 @@ then we have a coercion (ie, type instance of family instance coercion)
 which implies that :R42T was declared as 'data instance T [a]'.
 
 \begin{code}
-tcLookupFamInst :: FamInstEnvs -> TyCon -> [Type] -> Maybe FamInstMatch
+tcLookupFamInst :: FamInstEnvs -> TyCon -> [Type] -> TcM (Maybe FamInstMatch)
+tcLookupFamInst _ fam tys
+  | isRecordsFam fam
+  = tcLookupRecordsFamInst fam tys
+
 tcLookupFamInst fam_envs tycon tys
   | not (isOpenFamilyTyCon tycon)
-  = Nothing
+  = return Nothing
   | otherwise
-  = case lookupFamInstEnv fam_envs tycon tys of
+  = return $ case lookupFamInstEnv fam_envs tycon tys of
       match : _ -> Just match
       []        -> Nothing
 
@@ -260,9 +269,46 @@ tcInstNewTyConTF_maybe fam_envs ty
   = Just (rep_tc, inner_ty, fam_co `mkTcTransCo` nt_co)
   | otherwise
   = Nothing
+
+
+-- See Note [Instance scoping for OverloadedRecordFields] in TcFldInsts
+-- and the section on "Looking up record field instances" in RnEnv
+tcLookupRecordsFamInst :: TyCon -> [Type] -> TcM (Maybe FamInstMatch)
+tcLookupRecordsFamInst fam tys
+  | Just (lbl, tc, args) <- tcSplitRecordsArgs tys
+  = do { rep_tc <- lookupRepTyCon tc args
+       ; mb_ax  <- lookupFldInstAxiom lbl tc rep_tc want_get
+       ; return $ do { ax <- mb_ax
+                     ; let fam_inst = fam_inst_for tc ax
+                     ; subst <- tcMatchTys (mkVarSet (fi_tvs fam_inst)) (fi_tys fam_inst) tys
+                     ; return $ FamInstMatch fam_inst (substTyVars subst (fi_tvs fam_inst)) } }
+  where
+    want_get = isFldTyFam fam
+
+    fam_inst_for tc axiom
+      | want_get  = mkImportedFamInst fldTyFamName
+                        [Nothing, Just (tyConName tc)] (toUnbranchedAxiom axiom)
+      | otherwise = mkImportedFamInst updTyFamName
+                        [Nothing, Just (tyConName tc), Nothing] (toUnbranchedAxiom axiom)
+
+tcLookupRecordsFamInst _ _ = return Nothing
+
+lookupRepTyCon :: TyCon -> [Type] -> TcM TyCon
+-- Lookup the representation tycon given a family tycon and its
+-- arguments; returns the original tycon if it is not a data family or
+-- it doesn't have a matching instance.
+lookupRepTyCon tc args
+  | isDataFamilyTyCon tc
+      = do { fam_envs <- tcGetFamInstEnvs
+           ; mb_fi <- tcLookupFamInst fam_envs tc args
+           ; return $ case mb_fi of
+                        Nothing  -> tc
+                        Just fim -> tcTyConAppTyCon (fi_rhs (fim_instance fim)) }
+  | otherwise = return tc
 \end{code}
 
 
+
 %************************************************************************
 %*                                                                      *
         Extending the family instance environment
@@ -371,4 +417,3 @@ tcGetFamInstEnvs
   = do { eps <- getEps; env <- getGblEnv
        ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) }
 \end{code}
-