Refactor invariants for FamInsts.

This commit mirrors work done in the commit for ClsInsts, 5efe9b...

Specifically:
- All FamInsts have *fresh* type variables. So, no more freshness work
in addLocalFamInst

Also:
- Some pretty-printing code around FamInsts was cleaned up a bit
This caused location information to be added to CoAxioms and index
information to be added to FamInstBranches.

compiler/iface/TcIface.lhs

@@ -559,7 +559,8 @@ tc_iface_decl _ _ (IfaceAxiom {ifName = ax_occ, ifTyCon = tc, ifAxBranches = bra
           = bindIfaceTyVars tv_bndrs $ \ tvs -> do
             { tc_lhs <- mapM tcIfaceType lhs
             ; tc_rhs <- tcIfaceType rhs
-            ; let branch = CoAxBranch { cab_tvs = tvs
+            ; let branch = CoAxBranch { cab_loc = noSrcSpan
+                                      , cab_tvs = tvs
                                       , cab_lhs = tc_lhs
                                       , cab_rhs = tc_rhs }
             ; return branch }

compiler/typecheck/FamInst.lhs

@@ -11,7 +11,10 @@ The @FamInst@ type: family instance heads
 module FamInst ( 
         checkFamInstConsistency, tcExtendLocalFamInstEnv,
 	tcLookupFamInst, tcLookupDataFamInst,
-        tcGetFamInstEnvs
+        tcGetFamInstEnvs,
+
+        freshenFamInstEqn, freshenFamInstEqnLoc,
+        mkFreshenedSynInst, mkFreshenedSynInstLoc
     ) where
 
 import HscTypes
@@ -22,6 +25,7 @@ import TcRnMonad
 import TyCon
 import CoAxiom
 import DynFlags
+import SrcLoc
 import Module
 import Outputable
 import UniqFM
@@ -30,6 +34,7 @@ import Util
 import Maybes
 import TcMType
 import Type
+import Name
 import Control.Monad
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -264,32 +269,20 @@ addLocalFamInst (home_fie, my_fis) fam_inst
         -- my_fies is just the ones from this module
   = do { traceTc "addLocalFamInst" (ppr fam_inst)
 
-           -- We wish to extend the instance envt with completely
-           -- fresh template variables. Otherwise, there may be
-           -- problems when we try to unify the template variables
-           -- with type family applications.
-
-           -- See also addLocalInst in Inst.lhs
-       ; (axBranches', fiBranches')
-           <- zipWithAndUnzipM mk_skolem_tyvars (fromBranchList $ coAxiomBranches axiom)
-                                                (fromBranchList fiBranches)
-       ; let axiom' = axiom { co_ax_branches = toBranchList axBranches' }
-             fam_inst' = fam_inst { fi_axiom = axiom'
-                                  , fi_branches = toBranchList fiBranches' }
-
        ; isGHCi <- getIsGHCi
  
            -- In GHCi, we *override* any identical instances
            -- that are also defined in the interactive context
        ; let (home_fie', my_fis') 
-               | isGHCi    = ( deleteFromFamInstEnv home_fie fam_inst'
-                             , filterOut (identicalFamInst fam_inst') my_fis)
+               | isGHCi    = ( deleteFromFamInstEnv home_fie fam_inst
+                             , filterOut (identicalFamInst fam_inst) my_fis)
                | otherwise = (home_fie, my_fis)
 
            -- Load imported instances, so that we report
            -- overlaps correctly
        ; eps <- getEps
        ; let inst_envs  = (eps_fam_inst_env eps, home_fie')
+             fam_inst'  = toBranchedFamInst fam_inst
              home_fie'' = extendFamInstEnv home_fie fam_inst'
 
            -- Check for conflicting instance decls
@@ -299,44 +292,6 @@ addLocalFamInst (home_fie, my_fis) fam_inst
          else 
             return (home_fie,   my_fis) }
 
-  where
-    axiom = famInstAxiom fam_inst
-    fiBranches = famInstBranches fam_inst
-
-    zipWithAndUnzipM :: Monad m
-                     => (a -> b -> m (c, d))
-                     -> [a]
-                     -> [b]
-                     -> m ([c], [d])
-    zipWithAndUnzipM f as bs
-      = do { cds <- zipWithM f as bs
-           ; return $ unzip cds }
-
-    mk_skolem_tyvars :: CoAxBranch -> FamInstBranch
-                     -> TcM (CoAxBranch, FamInstBranch)
-    mk_skolem_tyvars axb fib
-      = do { (subst, skol_tvs) <- tcInstSkolTyVars (coAxBranchTyVars axb)
-           ; let axb' = coAxBranchSubst axb skol_tvs subst
-                 fib' = famInstBranchSubst fib skol_tvs subst
-           ; return (axb', fib') }
-
-    -- substitute the tyvars for a new set of tyvars
-    coAxBranchSubst :: CoAxBranch -> [TyVar] -> TvSubst -> CoAxBranch
-    coAxBranchSubst (CoAxBranch { cab_lhs = lhs
-                                , cab_rhs = rhs }) new_tvs subst
-      = CoAxBranch { cab_tvs = new_tvs
-                   , cab_lhs = substTys subst lhs
-                   , cab_rhs = substTy subst rhs }
-
-    -- substitute the current set of tyvars for another
-    famInstBranchSubst :: FamInstBranch -> [TyVar] -> TvSubst -> FamInstBranch
-    famInstBranchSubst fib@(FamInstBranch { fib_lhs = lhs
-                                          , fib_rhs = rhs }) new_tvs subst
-      = fib { fib_tvs = new_tvs
-            , fib_lhs = substTys subst lhs
-            , fib_rhs = substTy subst rhs }
-
-
 \end{code}
 
 %************************************************************************
@@ -368,7 +323,7 @@ conflictInstErr fam_inst branch conflictingMatch
                    [(fam_inst, branch),
                     (confInst, famInstNthBranch confInst confIndex)]
   | otherwise
-  = pprPanic "conflictInstErr" (pprFamInstBranch (famInstTyCon fam_inst) branch)
+  = pprPanic "conflictInstErr" (pprFamInstBranch (famInstAxiom fam_inst) branch)
 
 addFamInstsErr :: SDoc -> [(FamInst Branched, FamInstBranch)] -> TcRn ()
 addFamInstsErr herald insts
@@ -393,3 +348,53 @@ tcGetFamInstEnvs
   = do { eps <- getEps; env <- getGblEnv
        ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) }
 \end{code}
+
+%************************************************************************
+%*									*
+	Freshening type variables
+%*									*
+%************************************************************************
+
+\begin{code}
+
+-- All type variables in a FamInst/CoAxiom must be fresh. This function
+-- creates the fresh variables and applies the necessary substitution
+-- It is defined here to avoid a dependency from FamInstEnv on the monad
+-- code.
+freshenFamInstEqn :: [TyVar] -- original, possibly stale, tyvars
+                  -> [Type]  -- LHS patterns
+                  -> Type    -- RHS
+                  -> TcM ([TyVar], [Type], Type)
+freshenFamInstEqn tvs lhs rhs
+  = do { loc <- getSrcSpanM
+       ; freshenFamInstEqnLoc loc tvs lhs rhs }
+
+-- freshenFamInstEqn needs to be called outside the TcM monad:
+freshenFamInstEqnLoc :: SrcSpan
+                     -> [TyVar] -> [Type] -> Type
+                     -> TcRnIf gbl lcl ([TyVar], [Type], Type)
+freshenFamInstEqnLoc loc tvs lhs rhs
+  = do { (subst, tvs') <- tcInstSkolTyVarsLoc loc tvs
+       ; let lhs' = substTys subst lhs
+             rhs' = substTy  subst rhs
+       ; return (tvs', lhs', rhs') }
+
+-- Makes an unbranched synonym FamInst, with freshened tyvars
+mkFreshenedSynInst :: Name    -- Unique name for the coercion tycon
+                   -> [TyVar] -- possibly stale tyvars of the coercion
+                   -> TyCon   -- Family tycon
+                   -> [Type]  -- LHS patterns
+                   -> Type    -- RHS
+                   -> TcM (FamInst Unbranched)
+mkFreshenedSynInst name tvs fam_tc inst_tys rep_ty
+  = do { loc <- getSrcSpanM
+       ; mkFreshenedSynInstLoc loc name tvs fam_tc inst_tys rep_ty }
+
+mkFreshenedSynInstLoc :: SrcSpan
+                      -> Name -> [TyVar] -> TyCon -> [Type] -> Type
+                      -> TcRnIf gbl lcl (FamInst Unbranched)
+mkFreshenedSynInstLoc loc name tvs fam_tc inst_tys rep_ty
+  = do { (tvs', inst_tys', rep_ty') <- freshenFamInstEqnLoc loc tvs inst_tys rep_ty
+       ; return $ mkSingleSynFamInst name tvs' fam_tc inst_tys' rep_ty' }
+
+\end{code}
\ No newline at end of file

compiler/typecheck/TcGenGenerics.lhs

@@ -28,7 +28,8 @@ import TcGenDeriv
 import DataCon
 import TyCon
 import CoAxiom
-import FamInstEnv       ( FamInst, mkSingleSynFamInst )
+import FamInstEnv       ( FamInst )
+import FamInst
 import Module           ( Module, moduleName, moduleNameString )
 import IfaceEnv         ( newGlobalBinder )
 import Name      hiding ( varName )
@@ -448,7 +449,7 @@ tc_mkRepFamInsts gk tycon metaDts mod =
                    in newGlobalBinder mod (mkGen (nameOccName (tyConName tycon)))
                         (nameSrcSpan (tyConName tycon))
 
-     ; return $ mkSingleSynFamInst rep_name tyvars rep appT repTy
+     ; mkFreshenedSynInst rep_name tyvars rep appT repTy
      }
 
 --------------------------------------------------------------------------------

compiler/typecheck/TcInstDcls.lhs

@@ -472,14 +472,14 @@ tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl }))
   = setSrcSpan loc      $
     tcAddTyFamInstCtxt decl  $
     do { fam_tc <- tcFamInstDeclCombined TopLevel (tyFamInstDeclLName decl)
-       ; fam_inst <- tcTyFamInstDecl fam_tc (L loc decl)
+       ; fam_inst <- tcTyFamInstDecl Nothing fam_tc (L loc decl)
        ; return ([], [fam_inst]) }
 
 tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl }))
   = setSrcSpan loc      $
     tcAddDataFamInstCtxt decl  $
     do { fam_tc <- tcFamInstDeclCombined TopLevel (dfid_tycon decl)
-       ; fam_inst <- tcDataFamInstDecl fam_tc decl
+       ; fam_inst <- tcDataFamInstDecl Nothing fam_tc (L loc decl)
        ; return ([], [toBranchedFamInst fam_inst]) }
 
 tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))
@@ -504,12 +504,9 @@ tcClsInstDecl (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
         -- Next, process any associated types.
         ; traceTc "tcLocalInstDecl" (ppr poly_ty)
         ; tyfam_insts0 <- tcExtendTyVarEnv tyvars $
-                          mapAndRecoverM tcAssocTyDecl ats
+                          mapAndRecoverM (tcAssocTyDecl clas mini_env) ats
         ; datafam_insts <- tcExtendTyVarEnv tyvars $
-                           mapAndRecoverM tcAssocDataDecl adts
-
-        -- discard the [()]
-        ; _ <- mapAndRecoverM (tcAssocFamInst clas mini_env) (tyfam_insts0 ++ datafam_insts)
+                           mapAndRecoverM (tcAssocDataDecl clas mini_env) adts
 
         -- Check for missing associated types and build them
         -- from their defaults (if available)
@@ -540,7 +537,7 @@ tcClsInstDecl (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
                            tvs'     = varSetElems tv_set'
                      ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys'
                      ; ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) 
-                       return (mkSingleSynFamInst rep_tc_name tvs' fam_tc pat_tys' rhs') }
+                       mkFreshenedSynInst rep_tc_name tvs' fam_tc pat_tys' rhs' }
 
         ; tyfam_insts1 <- mapM mk_deflt_at_instances (classATItems clas)
         
@@ -571,6 +568,29 @@ class instance heads, but can contain data constructors and hence they share a
 lot of kinding and type checking code with ordinary algebraic data types (and
 GADTs).
 
+Note [Associated type consistency check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+According to the invariant stated in FamInstEnv, all FamInsts are created
+with *fresh* variables. This is all well and good for matching instances --
+when we don't want a spurious variable collision -- but bad for type checking
+the instance declarations. Consider this example:
+
+  class Cls a where
+    type Typ a
+
+  instance Cls (Maybe b) where
+    type Typ (Maybe b) = Int
+
+When we're checking the class instance, we build the mini_env [a |-> Maybe b].
+Then, we wish to check that the pattern used in the type instance matches.
+If we build the FamInst for the associated type instance before doing this
+check, the check always fails. This is because the FamInst will be built with
+a *fresh* b, which won't be the same as the old, stale b.
+
+Bottom line: we must perform this check before creating the FamInst, even
+though it's a little awkward to do so. (The FamInst packages everything
+nicely, and we have to push around all pieces independently.)
+
 \begin{code}
 tcFamInstDeclCombined :: TopLevelFlag -> Located Name -> TcM TyCon
 tcFamInstDeclCombined top_lvl fam_tc_lname
@@ -590,9 +610,10 @@ tcFamInstDeclCombined top_lvl fam_tc_lname
 
        ; return fam_tc }
 
-tcTyFamInstDecl :: TyCon -> LTyFamInstDecl Name -> TcM (FamInst Branched)
+tcTyFamInstDecl :: Maybe (Class, VarEnv Type) -- the class & mini_env if applicable
+                -> TyCon -> LTyFamInstDecl Name -> TcM (FamInst Branched)
   -- "type instance"
-tcTyFamInstDecl fam_tc (L loc decl@(TyFamInstDecl { tfid_group = group }))
+tcTyFamInstDecl mb_clsinfo fam_tc (L loc decl@(TyFamInstDecl { tfid_group = group }))
   = do { -- (0) Check it's an open type family
          checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
        ; checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc)
@@ -603,7 +624,7 @@ tcTyFamInstDecl fam_tc (L loc decl@(TyFamInstDecl { tfid_group = group }))
        ; quads <- tcSynFamInstDecl fam_tc decl
 
          -- (2) create the branches
-       ; fam_inst_branches <- mapM check_valid_mk_branch quads
+       ; co_ax_branches <- mapM check_valid_mk_branch quads
 
          -- (3) construct coercion tycon
        ; rep_tc_name <- newFamInstAxiomName loc
@@ -611,40 +632,49 @@ tcTyFamInstDecl fam_tc (L loc decl@(TyFamInstDecl { tfid_group = group }))
                                             (get_typats quads)
 
          -- (4) check to see if earlier equations dominate a later one
-       ; foldlM_ check_inaccessible_branches [] (map fst fam_inst_branches)
+       ; foldlM_ check_inaccessible_branches [] co_ax_branches
 
-         -- now, build the FamInstGroup
-       ; return $ mkSynFamInst rep_tc_name fam_tc group fam_inst_branches }
+         -- now, build the FamInst
+       ; return $ mkSynFamInst rep_tc_name fam_tc group co_ax_branches }
 
     where 
       check_valid_mk_branch :: ([TyVar], [Type], Type, SrcSpan)
-                            -> TcM (FamInstBranch, CoAxBranch)
+                            -> TcM CoAxBranch
       check_valid_mk_branch (t_tvs, t_typats, t_rhs, loc)
         = setSrcSpan loc $
           do { -- check the well-formedness of the instance
                checkValidTyFamInst fam_tc t_tvs t_typats t_rhs
 
-             ; return $ mkSynFamInstBranch loc t_tvs t_typats t_rhs }
+               -- check that type patterns match the class instance head
+             ; tcAssocFamInst mb_clsinfo loc (ptext (sLit "type")) fam_tc t_typats
+
+               -- make fresh tyvars for axiom
+             ; (t_tvs', t_typats', t_rhs')
+                 <- freshenFamInstEqn t_tvs t_typats t_rhs
+
+             ; return $ mkCoAxBranch loc t_tvs' t_typats' t_rhs' }
 
-      check_inaccessible_branches :: [FamInstBranch]     -- previous
-                                  -> FamInstBranch       -- current
-                                  -> TcM [FamInstBranch] -- current : previous
+      check_inaccessible_branches :: [CoAxBranch]     -- previous
+                                  -> CoAxBranch       -- current
+                                  -> TcM [CoAxBranch] -- current : previous
       check_inaccessible_branches prev_branches
-                                  cur_branch@(FamInstBranch { fib_lhs = tys })
-        = setSrcSpan (famInstBranchSpan cur_branch) $
+                                  cur_branch@(CoAxBranch { cab_lhs = tys })
+        = setSrcSpan (coAxBranchSpan cur_branch) $
           do { when (tys `isDominatedBy` prev_branches) $
-                    addErrTc $ inaccessibleFamInstBranch fam_tc cur_branch
+                    addErrTc $ inaccessibleCoAxBranch fam_tc cur_branch
              ; return $ cur_branch : prev_branches }
 
       get_typats = map (\(_, tys, _, _) -> tys)
 
-tcDataFamInstDecl :: TyCon -> DataFamInstDecl Name -> TcM (FamInst Unbranched)
+tcDataFamInstDecl :: Maybe (Class, VarEnv Type)
+                  -> TyCon -> LDataFamInstDecl Name -> TcM (FamInst Unbranched)
   -- "newtype instance" and "data instance"
-tcDataFamInstDecl fam_tc 
-    (DataFamInstDecl { dfid_pats = pats
-                     , dfid_tycon = fam_tc_name
-                     , dfid_defn = defn@HsDataDefn { dd_ND = new_or_data, dd_cType = cType
-                                                   , dd_ctxt = ctxt, dd_cons = cons } })
+tcDataFamInstDecl mb_clsinfo fam_tc 
+    (L loc (DataFamInstDecl
+             { dfid_pats = pats
+             , dfid_tycon = fam_tc_name
+             , dfid_defn = defn@HsDataDefn { dd_ND = new_or_data, dd_cType = cType
+                                           , dd_ctxt = ctxt, dd_cons = cons } }))
   = do { -- Check that the family declaration is for the right kind
          checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
        ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc)
@@ -663,6 +693,8 @@ tcDataFamInstDecl fam_tc
 
        ; stupid_theta <- tcHsContext ctxt
        ; h98_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons
+         -- Check that type patterns match class instance head, if any
+       ; tcAssocFamInst mb_clsinfo loc (ppr new_or_data) fam_tc pats'
 
          -- Construct representation tycon
        ; rep_tc_name <- newFamInstTyConName fam_tc_name pats'
@@ -676,9 +708,12 @@ tcDataFamInstDecl fam_tc
                      DataType -> return (mkDataTyConRhs data_cons)
                      NewType  -> ASSERT( not (null data_cons) )
                                  mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons)
-              ; let fam_inst = mkDataFamInst axiom_name tvs' fam_tc pats' rep_tc
-                    parent   = FamInstTyCon (famInstAxiom fam_inst) fam_tc pats'
-                    rep_tc   = buildAlgTyCon rep_tc_name tvs' cType stupid_theta tc_rhs 
+              -- freshen tyvars
+              ; (subst, tvs'') <- tcInstSkolTyVars tvs'
+              ; let pats''   = substTys subst pats'
+                    fam_inst = mkDataFamInst axiom_name tvs'' fam_tc pats'' rep_tc
+                    parent   = FamInstTyCon (famInstAxiom fam_inst) fam_tc pats''
+                    rep_tc   = buildAlgTyCon rep_tc_name tvs'' cType stupid_theta tc_rhs 
                                              Recursive h98_syntax parent
                  -- We always assume that indexed types are recursive.  Why?
                  -- (1) Due to their open nature, we can never be sure that a
@@ -693,19 +728,22 @@ tcDataFamInstDecl fam_tc
 
 
 ----------------
-tcAssocFamInst :: Class              -- ^ Class of associated type
-               -> VarEnv Type        -- ^ Instantiation of class TyVars
-               -> FamInst Unbranched -- ^ RHS
+-- See Note [Associated type consistency check]
+tcAssocFamInst :: Maybe (Class
+               ,  VarEnv Type)       -- ^ Class of associated type
+                                     -- and instantiation of class TyVars
+               -> SrcSpan            -- ^ Of the family instance
+               -> SDoc               -- ^ "flavor" of the instance
+               -> TyCon              -- ^ Family tycon
+               -> [Type]             -- ^ Type patterns from instance
                -> TcM ()
-tcAssocFamInst clas mini_env fam_inst
-  = setSrcSpan (getSrcSpan fam_inst) $
-    tcAddFamInstCtxt (pprFamFlavor (fi_flavor fam_inst)) (fi_fam fam_inst) $
-    do { let branch = famInstSingleBranch fam_inst
-             fam_tc = famInstTyCon fam_inst
-             at_tys = famInstBranchLHS branch
-
+tcAssocFamInst Nothing _ _ _ _ = return ()
+tcAssocFamInst (Just (clas, mini_env)) loc flav fam_tc at_tys
+  = setSrcSpan loc $
+    tcAddFamInstCtxt flav (tyConName fam_tc) $
+    do {
        -- Check that the associated type comes from this class
-       ; checkTc (Just clas == tyConAssoc_maybe fam_tc)
+         checkTc (Just clas == tyConAssoc_maybe fam_tc)
                  (badATErr (className clas) (tyConName fam_tc))
 
        -- See Note [Checking consistent instantiation] in TcTyClsDecls
@@ -721,22 +759,26 @@ tcAssocFamInst clas mini_env fam_inst
       = return ()   -- Allow non-type-variable instantiation
                     -- See Note [Associated type instances]
 
-tcAssocTyDecl :: LTyFamInstDecl Name
+tcAssocTyDecl :: Class                   -- Class of associated type
+              -> VarEnv Type             -- Instantiation of class TyVars
+              -> LTyFamInstDecl Name     
               -> TcM (FamInst Unbranched)
-tcAssocTyDecl ldecl@(L loc decl)
+tcAssocTyDecl clas mini_env ldecl@(L loc decl)
   = setSrcSpan loc $
     tcAddTyFamInstCtxt decl $
     do { fam_tc <- tcFamInstDeclCombined NotTopLevel (tyFamInstDeclLName decl)
-       ; fam_inst <- tcTyFamInstDecl fam_tc ldecl
+       ; fam_inst <- tcTyFamInstDecl (Just (clas, mini_env)) fam_tc ldecl
        ; return $ toUnbranchedFamInst fam_inst }
 
-tcAssocDataDecl :: LDataFamInstDecl Name -- ^ RHS
+tcAssocDataDecl :: Class                 -- ^ Class of associated type
+                -> VarEnv Type           -- ^ Instantiation of class TyVars
+                -> LDataFamInstDecl Name -- ^ RHS
                 -> TcM (FamInst Unbranched)
-tcAssocDataDecl (L loc decl)
+tcAssocDataDecl clas mini_env ldecl@(L loc decl)
   = setSrcSpan loc $
     tcAddDataFamInstCtxt decl $
     do { fam_tc <- tcFamInstDeclCombined NotTopLevel (dfid_tycon decl)
-       ; tcDataFamInstDecl fam_tc decl }
+       ; tcDataFamInstDecl (Just (clas, mini_env)) fam_tc ldecl }
 \end{code}
 
 
@@ -1524,10 +1566,10 @@ badFamInstDecl tc_name
            quotes (ppr tc_name)
          , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ]
 
-inaccessibleFamInstBranch :: TyCon -> FamInstBranch -> SDoc
-inaccessibleFamInstBranch tc fi
+inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc
+inaccessibleCoAxBranch tc fi
   = ptext (sLit "Inaccessible family instance equation:") $$
-      (pprFamInstBranch tc fi)
+      (pprCoAxBranch tc fi)
 
 notOpenFamily :: TyCon -> SDoc
 notOpenFamily tc

compiler/typecheck/TcMType.lhs

@@ -43,7 +43,7 @@ module TcMType (
   -- Instantiation
   tcInstTyVars, tcInstSigTyVars, newSigTyVar,
   tcInstType, 
-  tcInstSkolTyVars, tcInstSuperSkolTyVars,
+  tcInstSkolTyVars, tcInstSkolTyVarsLoc, tcInstSuperSkolTyVars,
   tcInstSkolTyVarsX, tcInstSuperSkolTyVarsX,
   tcInstSkolTyVar, tcInstSkolType,
   tcSkolDFunType, tcSuperSkolTyVars,
@@ -221,15 +221,15 @@ tcSuperSkolTyVar subst tv
     kind   = substTy subst (tyVarKind tv)
     new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv
 
-tcInstSkolTyVar :: Bool -> TvSubst -> TyVar -> TcM (TvSubst, TcTyVar)
+tcInstSkolTyVar :: SrcSpan -> Bool -> TvSubst -> TyVar
+                -> TcRnIf gbl lcl (TvSubst, TcTyVar)
 -- Instantiate the tyvar, using 
 --      * the occ-name and kind of the supplied tyvar, 
 --      * the unique from the monad,
 --      * the location either from the tyvar (skol_info = SigSkol)
 --                     or from the monad (otherwise)
-tcInstSkolTyVar overlappable subst tyvar
+tcInstSkolTyVar loc overlappable subst tyvar
   = do  { uniq <- newUnique
-        ; loc  <- getSrcSpanM
         ; let new_name = mkInternalName uniq occ loc
               new_tv   = mkTcTyVar new_name kind (SkolemTv overlappable)
         ; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) }
@@ -239,6 +239,10 @@ tcInstSkolTyVar overlappable subst tyvar
     kind     = substTy subst (tyVarKind tyvar)
 
 -- Wrappers
+-- we need to be able to do this from outside the TcM monad:
+tcInstSkolTyVarsLoc :: SrcSpan -> [TyVar] -> TcRnIf gbl lcl (TvSubst, [TcTyVar])
+tcInstSkolTyVarsLoc loc = mapAccumLM (tcInstSkolTyVar loc False) (mkTopTvSubst [])
+
 tcInstSkolTyVars :: [TyVar] -> TcM (TvSubst, [TcTyVar])
 tcInstSkolTyVars = tcInstSkolTyVarsX (mkTopTvSubst [])
 
@@ -253,7 +257,9 @@ tcInstSuperSkolTyVarsX subst = tcInstSkolTyVars' True  subst
 tcInstSkolTyVars' :: Bool -> TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar])
 -- Precondition: tyvars should be ordered (kind vars first)
 -- see Note [Kind substitution when instantiating]
-tcInstSkolTyVars' isSuperSkol = mapAccumLM (tcInstSkolTyVar isSuperSkol)
+tcInstSkolTyVars' isSuperSkol subst tvs
+  = do { loc <- getSrcSpanM
+       ; mapAccumLM (tcInstSkolTyVar loc isSuperSkol) subst tvs }
 
 tcInstSkolType :: TcType -> TcM ([TcTyVar], TcThetaType, TcType)
 -- Instantiate a type with fresh skolem constants

compiler/types/CoAxiom.lhs

@@ -16,14 +16,14 @@ module CoAxiom (
        brListLength, brListNth, brListMap, brListFoldr,
        brListZipWith,
 
-       CoAxiom(..), CoAxBranch(..),
+       CoAxiom(..), CoAxBranch(..), mkCoAxBranch,
 
        toBranchedAxiom, toUnbranchedAxiom,
        coAxiomName, coAxiomArity, coAxiomBranches,
        coAxiomTyCon, isImplicitCoAxiom,
        coAxiomNthBranch, coAxiomSingleBranch_maybe,
        coAxiomSingleBranch, coAxBranchTyVars, coAxBranchLHS,
-       coAxBranchRHS
+       coAxBranchRHS, coAxBranchSpan
        ) where 
 
 import {-# SOURCE #-} TypeRep ( Type )
@@ -35,18 +35,13 @@ import Var
 import Util
 import BasicTypes
 import Data.Typeable ( Typeable )
+import SrcLoc
 import qualified Data.Data as Data
 
 #include "HsVersions.h"
 
 \end{code}
 
-%************************************************************************
-%*                                                                      *
-                    Coercion axioms
-%*                                                                      *
-%************************************************************************
-
 Note [Coercion axiom branches]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In order to allow type family instance groups, an axiom needs to contain an
@@ -115,6 +110,13 @@ remain compilable with GHC 7.2.1. If you are revising this code and GHC no
 longer needs to remain compatible with GHC 7.2.x, then please update this
 code to use promoted types.
 
+
+%************************************************************************
+%*                                                                      *
+                    Branch lists
+%*                                                                      *
+%************************************************************************
+
 \begin{code}
 
 -- the phantom type labels
@@ -177,7 +179,15 @@ brListZipWith f (NextBranch a ta) (NextBranch b tb) = f a b : brListZipWith f ta
 
 instance Outputable a => Outputable (BranchList a br) where
   ppr = ppr . fromBranchList
+\end{code}
+
+%************************************************************************
+%*                                                                      *
+                    Coercion axioms
+%*                                                                      *
+%************************************************************************
 
+\begin{code}
 -- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom.
 
 -- If you edit this type, you may need to update the GHC formalism
@@ -197,7 +207,8 @@ data CoAxiom br
 
 data CoAxBranch
   = CoAxBranch
-    { cab_tvs      :: [TyVar]      -- bound type variables
+    { cab_loc      :: SrcSpan      -- location of the defining equation
+    , cab_tvs      :: [TyVar]      -- bound type variables
     , cab_lhs      :: [Type]       -- type patterns to match against
     , cab_rhs      :: Type         -- right-hand side of the equality
     }
@@ -248,8 +259,16 @@ coAxBranchLHS = cab_lhs
 coAxBranchRHS :: CoAxBranch -> Type
 coAxBranchRHS = cab_rhs
 
+coAxBranchSpan :: CoAxBranch -> SrcSpan
+coAxBranchSpan = cab_loc
+
 isImplicitCoAxiom :: CoAxiom br -> Bool
 isImplicitCoAxiom = co_ax_implicit
+
+-- The tyvars must be *fresh*. This CoAxBranch will be put into a
+-- FamInst. See Note [Template tyvars are fresh] in InstEnv
+mkCoAxBranch :: SrcSpan -> [TyVar] -> [Type] -> Type -> CoAxBranch
+mkCoAxBranch = CoAxBranch
 \end{code}
 
 Note [Implicit axioms]
@@ -289,4 +308,5 @@ instance Typeable br => Data.Data (CoAxiom br) where
     toConstr _   = abstractConstr "CoAxiom"
     gunfold _ _  = error "gunfold"
     dataTypeOf _ = mkNoRepType "CoAxiom"
-\end{code}
\ No newline at end of file
+\end{code}
+

compiler/types/Coercion.lhs

@@ -87,7 +87,7 @@ import Var
 import VarEnv
 import VarSet
 import Maybes   ( orElse )
-import Name	( Name, NamedThing(..), nameUnique )
+import Name	( Name, NamedThing(..), nameUnique, getSrcSpan )
 import OccName 	( parenSymOcc )
 import Util
 import BasicTypes
@@ -705,7 +705,8 @@ mkNewTypeCo name tycon tvs rhs_ty
             , co_ax_implicit = True  -- See Note [Implicit axioms] in TyCon
             , co_ax_tc       = tycon
             , co_ax_branches = FirstBranch branch }
-  where branch = CoAxBranch { cab_tvs = tvs
+  where branch = CoAxBranch { cab_loc = getSrcSpan name
+                            , cab_tvs = tvs
                             , cab_lhs = mkTyVarTys tvs
                             , cab_rhs = rhs_ty }
 

compiler/types/FamInstEnv.lhs

@@ -14,9 +14,9 @@ module FamInstEnv (
         famInstBranchLHS, famInstBranches, famInstBranchSpan,
         toBranchedFamInst, toUnbranchedFamInst,
         famInstTyCon, famInstRepTyCon_maybe, dataFamInstRepTyCon, 
-        pprFamInst, pprFamInsts, pprFamInstBranch, pprFamInstBranches,
-        pprFamFlavor, pprFamInstBranchHdr,
-        mkSynFamInst, mkSynFamInstBranch, mkSingleSynFamInst,
+        pprFamInst, pprFamInsts, pprFamInstBranch,
+        pprFamFlavor, pprFamInstBranchHdr, pprCoAxBranch,
+        mkSynFamInst, mkSingleSynFamInst,
         mkDataFamInst, mkImportedFamInst, 
 
         FamInstEnv, FamInstEnvs,
@@ -107,8 +107,35 @@ assumes that it is part of a consistent axiom set.
 
 A "group" with fi_group=True can have just one element, however.
 
+Note [Why we need fib_rhs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+It may at first seem unnecessary to store the right-hand side of an equation
+in a FamInstBranch. After all, FamInstBranches are used only for matching a
+family application; the underlying CoAxiom is used to perform the actual
+simplification.
+
+However, we do need to know the rhs field during conflict checking to support
+confluent overlap. When two unbranched instances have overlapping left-hand
+sides, we check if the right-hand sides are coincident in the region of overlap.
+This check requires fib_rhs. See lookupFamInstEnvConflicts.
+
+Note [Why we need fib_index]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A FamInstBranch is always stored in a list of branches within a FamInst. So,
+why would we ever need it to store its own index? Because of printing,
+unfortunately.
+
+At various places, we need to print either a FamInstBranch or a CoAxBranch.
+These data structures store the same information, essentially, so they should
+print the same. We don't wish to duplicate code between them. Because a
+CoAxBranch is more fundamental, we choose to write the printing code for that.
+However, a FamInstBranch by itself has no reference to its attending CoAxBranch.
+The solution is for the FamInstBranch to carry its own index. Whenever we
+need to print a FamInstBranch, we happen to have its attending *CoAxiom*
+available. Knowing the index, we can then get the CoAxBranch and print. Hurrah.
+
 \begin{code}
-data FamInst br -- See Note [FamInsts and CoAxioms], Note [Branched axioms] in CoAxiom.lhs
+data FamInst br -- See Note [FamInsts and CoAxioms], Note [Branched axioms] in CoAxiom
   = FamInst { fi_axiom    :: CoAxiom br      -- The new coercion axiom introduced
                                              -- by this family instance
             , fi_flavor   :: FamFlavor
@@ -131,10 +158,16 @@ data FamInstBranch
                                  -- See Note [FamInst locations]
 
     , fib_tvs    :: [TyVar]      -- bound type variables
+                                 -- like ClsInsts, these variables are always
+                                 -- fresh. See Note [Template tyvars are fresh]
+                                 -- in InstEnv
     , fib_lhs    :: [Type]       -- type patterns
     , fib_rhs    :: Type         -- RHS of family instance
+                                 -- See Note [Why we need fib_rhs]
     , fib_tcs    :: [Maybe Name] -- used for "rough matching" during typechecking
                                  -- see Note [Rough-match field] in InstEnv
+    , fib_index  :: Int          -- the index of this branch (counting from 0)
+                                 -- See Note [Why we need fib_index]
     }
 
 data FamFlavor 
@@ -154,7 +187,9 @@ famInstTyCon = co_ax_tc . fi_axiom
 famInstNthBranch :: FamInst br -> Int -> FamInstBranch
 famInstNthBranch (FamInst { fi_branches = branches }) index
   = ASSERT( 0 <= index && index < (length $ fromBranchList branches) )
-    brListNth branches index
+    let branch = brListNth branches index in
+    ASSERT( fib_index branch == index )
+    branch
 
 famInstSingleBranch :: FamInst Unbranched -> FamInstBranch
 famInstSingleBranch (FamInst { fi_branches = FirstBranch branch }) = branch
@@ -197,6 +232,12 @@ dataFamInstRepTyCon fi
        SynFamilyInst        -> pprPanic "dataFamInstRepTyCon" (ppr fi)
 \end{code}
 
+%************************************************************************
+%*                                                                      *
+        Pretty printing
+%*                                                                      *
+%************************************************************************
+
 \begin{code}
 instance NamedThing (FamInst br) where
    getName = coAxiomName . fi_axiom
@@ -235,49 +276,61 @@ pprFamFlavor flavor
         | otherwise             -> ptext (sLit "WEIRD") <+> ppr tycon
 
 pprFamInstBranchHdr :: CoAxiom br -> FamInstBranch -> SDoc
-pprFamInstBranchHdr ax (FamInstBranch { fib_lhs = tys, fib_loc = loc })
+pprFamInstBranchHdr ax (FamInstBranch { fib_index = index })
+  = pprCoAxBranchHdr ax (coAxiomNthBranch ax index)
+
+pprFamInstBranch :: CoAxiom br -> FamInstBranch -> SDoc
+pprFamInstBranch ax (FamInstBranch { fib_index = index })
+  = pprCoAxBranch (coAxiomTyCon ax) (coAxiomNthBranch ax index)
+
+-- defined here to avoid bad dependencies
+pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc
+pprCoAxBranch fam_tc (CoAxBranch { cab_lhs = lhs
+                                 , cab_rhs = rhs })
+  = pprTypeApp fam_tc lhs <+> equals <+> (ppr rhs)
+
+pprCoAxBranchHdr :: CoAxiom br -> CoAxBranch -> SDoc
+pprCoAxBranchHdr (CoAxiom { co_ax_tc = fam_tc, co_ax_name = name })
+                 (CoAxBranch { cab_lhs = tys, cab_loc = loc })
   = hang (pprTypeApp fam_tc tys)
        2 (ptext (sLit "-- Defined") <+> ppr_loc)
     where
-        fam_tc = coAxiomTyCon ax
         ppr_loc
           | isGoodSrcSpan loc
           = ptext (sLit "at") <+> ppr (srcSpanStart loc)
     
           | otherwise
           = ptext (sLit "in") <+>
-              quotes (ppr (nameModule (coAxiomName ax)))
+              quotes (ppr (nameModule name))
 
-pprFamInstBranch :: TyCon -> FamInstBranch -> SDoc
-pprFamInstBranch fam_tc (FamInstBranch { fib_lhs = lhs
-                                       , fib_rhs = rhs })
-  = pprTypeApp fam_tc lhs <+> equals <+> (ppr rhs)
 
 pprFamInsts :: [FamInst br] -> SDoc
 pprFamInsts finsts = vcat (map pprFamInst finsts)
 
-pprFamInstBranches :: TyCon -> [FamInstBranch] -> SDoc
-pprFamInstBranches tc branches = vcat (map (pprFamInstBranch tc) branches)
-
--- | Create a branch of a @type@ family instance.
--- This branch must be incorporated into a full @FamInst@ with
--- @mkSynFamInst@ to be useful.
-mkSynFamInstBranch :: SrcSpan -- ^ where the branch equation appears
-                   -> [TyVar] -- ^ bound variables
-                   -> [Type]  -- ^ LHS type patterns
-                   -> Type    -- ^ RHS type
-                   -> (FamInstBranch, CoAxBranch)
-mkSynFamInstBranch loc tvs lhs_tys rhs_ty
-  = ( FamInstBranch { fib_loc    = loc
-                    , fib_tvs    = tvs
-                    , fib_lhs    = lhs_tys
-                    , fib_rhs    = rhs_ty
-                    , fib_tcs    = mb_tcs }
-    , CoAxBranch { cab_tvs = tvs
-                 , cab_lhs = lhs_tys
-                 , cab_rhs = rhs_ty })
-  where
-    mb_tcs = roughMatchTcs lhs_tys
+mk_fam_inst_branch :: Int -> CoAxBranch -> FamInstBranch
+mk_fam_inst_branch index
+                   (CoAxBranch { cab_loc = loc
+                               , cab_tvs = tvs
+                               , cab_lhs = lhs
+                               , cab_rhs = rhs })
+  = FamInstBranch { fib_loc   = loc
+                  , fib_tvs   = tvs
+                  , fib_lhs   = lhs
+                  , fib_rhs   = rhs
+                  , fib_tcs   = roughMatchTcs lhs
+                  , fib_index = index }
+
+map_with_index :: (Int -> a -> b) -> [a] -> [b]
+map_with_index f elts
+  = go 0 elts
+  where go _ []     = []
+        go n (x:xs) = f n x : go (n+1) xs
+
+zipWith_index :: (Int -> a -> b -> c) -> [a] -> [b] -> [c]
+zipWith_index f as bs
+  = go 0 as bs
+  where go n (a:as) (b:bs) = f n a b : go (n+1) as bs
+        go _ _      _      = []
 
 -- | Create a coercion identifying a @type@ family instance.
 -- It has the form @Co tvs :: F ts ~ R@, where @Co@ is
@@ -286,13 +339,13 @@ mkSynFamInstBranch loc tvs lhs_tys rhs_ty
 mkSynFamInst :: Name            -- ^ Unique name for the coercion tycon
              -> TyCon           -- ^ Family tycon (@F@)
              -> Bool            -- ^ Was this declared as a branched group?
-             -> [(FamInstBranch, CoAxBranch)] -- ^ the branches of this FamInst
+             -> [CoAxBranch]    -- ^ the branches of the CoAxiom
              -> FamInst Branched
 mkSynFamInst name fam_tc group branches
   = ASSERT( length branches >= 1 )
     FamInst { fi_fam      = tyConName fam_tc
             , fi_flavor   = SynFamilyInst
-            , fi_branches = toBranchList $ fst $ unzip branches
+            , fi_branches = toBranchList (map_with_index mk_fam_inst_branch branches)
             , fi_group    = group
             , fi_axiom    = axiom }
   where
@@ -300,12 +353,13 @@ mkSynFamInst name fam_tc group branches
                     , co_ax_name     = name
                     , co_ax_tc       = fam_tc
                     , co_ax_implicit = False
-                    , co_ax_branches = toBranchList (snd $ unzip branches) }
+                    , co_ax_branches = toBranchList branches }
+
 
 -- | Create a coercion identifying a @type@ family instance, but with only
 -- one equation (branch).
 mkSingleSynFamInst :: Name        -- ^ Unique name for the coercion tycon
-                   -> [TyVar]     -- ^ Type parameters of the coercion (@tvs@)
+                   -> [TyVar]     -- ^ *Fresh* tyvars of the coercion (@tvs@)
                    -> TyCon       -- ^ Family tycon (@F@)
                    -> [Type]      -- ^ Type instance (@ts@)
                    -> Type        -- ^ right-hand side
@@ -319,17 +373,14 @@ mkSingleSynFamInst name tvs fam_tc inst_tys rep_ty
             , fi_axiom    = axiom }
   where
     -- See note [FamInst Locations]
-    branch = FamInstBranch { fib_loc    = getSrcSpan name
-                           , fib_tvs    = tvs
-                           , fib_lhs    = inst_tys
-                           , fib_rhs    = rep_ty
-                           , fib_tcs    = roughMatchTcs inst_tys }
+    branch = mk_fam_inst_branch 0 axBranch
     axiom = CoAxiom { co_ax_unique   = nameUnique name
                     , co_ax_name     = name
                     , co_ax_tc       = fam_tc
                     , co_ax_implicit = False
                     , co_ax_branches = FirstBranch axBranch }
-    axBranch = CoAxBranch { cab_tvs = tvs
+    axBranch = CoAxBranch { cab_loc = getSrcSpan name
+                          , cab_tvs = tvs
                           , cab_lhs = inst_tys
                           , cab_rhs = rep_ty }
     
@@ -338,7 +389,7 @@ mkSingleSynFamInst name tvs fam_tc inst_tys rep_ty
 -- where @Co@ is the coercion constructor built here, @F@ the family tycon
 -- and @R@ the (derived) representation tycon.
 mkDataFamInst :: Name         -- ^ Unique name for the coercion tycon
-              -> [TyVar]      -- ^ Type parameters of the coercion (@tvs@)
+              -> [TyVar]      -- ^ *Fresh* parameters of the coercion (@tvs@)
               -> TyCon        -- ^ Family tycon (@F@)
               -> [Type]       -- ^ Type instance (@ts@)
               -> TyCon        -- ^ Representation tycon (@R@)
@@ -352,20 +403,16 @@ mkDataFamInst name tvs fam_tc inst_tys rep_tc
   where
     rhs = mkTyConApp rep_tc (mkTyVarTys tvs)
 
-    branch = FamInstBranch { fib_loc    = getSrcSpan name
                                -- See Note [FamInst locations]
-                           , fib_tvs    = tvs
-                           , fib_lhs    = inst_tys
-                           , fib_rhs    = rhs
-                           , fib_tcs    = roughMatchTcs inst_tys }
-
+    branch = mk_fam_inst_branch 0 axBranch
     axiom = CoAxiom { co_ax_unique   = nameUnique name
                     , co_ax_name     = name
                     , co_ax_tc       = fam_tc
                     , co_ax_branches = FirstBranch axBranch
                     , co_ax_implicit = False }
 
-    axBranch = CoAxBranch { cab_tvs = tvs
+    axBranch = CoAxBranch { cab_loc = getSrcSpan name
+                          , cab_tvs = tvs
                           , cab_lhs = inst_tys
                           , cab_rhs = rhs }
 
@@ -409,16 +456,18 @@ mkImportedFamInst fam group roughs axiom
        = ASSERT( fam == tyConName (coAxiomTyCon axiom) )
          axiom
 
-     branches = toBranchList (zipWith mk_fam_inst_branch (fromBranchList axBranches) roughs)
+     branches = toBranchList (zipWith_index mk_imp_fam_inst_branch (fromBranchList axBranches) roughs)
 
-     mk_fam_inst_branch (CoAxBranch { cab_tvs = tvs
-                                    , cab_lhs = lhs
-                                    , cab_rhs = rhs }) mb_tcs
+     mk_imp_fam_inst_branch index
+                            (CoAxBranch { cab_tvs = tvs
+                                        , cab_lhs = lhs
+                                        , cab_rhs = rhs }) mb_tcs
        = FamInstBranch { fib_loc    = noSrcSpan
                        , fib_tvs    = tvs
                        , fib_lhs    = lhs
                        , fib_rhs    = rhs
-                       , fib_tcs    = mb_tcs }
+                       , fib_tcs    = mb_tcs
+                       , fib_index  = index }
 
          -- Derive the flavor for an imported FamInst rather disgustingly
          -- Maybe we should store it in the IfaceFamInst?
@@ -702,15 +751,13 @@ lookupFamInstEnvConflicts
 -- Precondition: the tycon is saturated (or over-saturated)
 
 lookupFamInstEnvConflicts envs grp tc
-                          branch@(FamInstBranch { fib_lhs = tys, fib_rhs = rhs })
+                          (FamInstBranch { fib_lhs = tys, fib_rhs = rhs })
   = lookup_fam_inst_env my_unify False envs tc tys
   where
     my_unify :: MatchFun
     my_unify _ (FamInstBranch { fib_tvs = tpl_tvs, fib_lhs = tpl_tys
                               , fib_rhs = tpl_rhs }) old_grp match_tys
-       = ASSERT2( tyVarsOfTypes tys `disjointVarSet` mkVarSet tpl_tvs,
-                  (pprFamInstBranch tc branch <+> ppr tys) $$
-                  (ppr tpl_tvs <+> ppr tpl_tys) )
+       = ASSERT( tyVarsOfTypes tys `disjointVarSet` mkVarSet tpl_tvs )
                 -- Unification will break badly if the variables overlap
                 -- They shouldn't because we allocate separate uniques for them
          case tcUnifyTys instanceBindFun tpl_tys match_tys of
@@ -823,7 +870,7 @@ lookup_fam_inst_env' match_fun _one_sided ie fam tys
 find :: MatchFun -> [Type] -> [FamInst Branched] -> [FamInstMatch]
 find _         _         [] = []
 find match_fun match_tys (inst@(FamInst { fi_branches = branches, fi_group = is_group }) : rest)
-  = case findBranch [] (fromBranchList branches) 0 of
+  = case findBranch [] (fromBranchList branches) of
       (Just match, StopSearching) -> [match]
       (Just match, KeepSearching) -> match : find match_fun match_tys rest
       (Nothing,    StopSearching) -> []
@@ -832,15 +879,14 @@ find match_fun match_tys (inst@(FamInst { fi_branches = branches, fi_group = is_
     rough_tcs = roughMatchTcs match_tys
     findBranch :: [FamInstBranch]  -- the branches that have already been checked
                -> [FamInstBranch]  -- still looking through these
-               -> Int              -- the index of the next branch
                -> (Maybe FamInstMatch, ContSearch)
-    findBranch _ [] _ = (Nothing, KeepSearching)
-    findBranch seen (branch@(FamInstBranch { fib_tvs = tvs, fib_tcs = mb_tcs }) : rest) ind
+    findBranch _ [] = (Nothing, KeepSearching)
+    findBranch seen (branch@(FamInstBranch { fib_tvs = tvs, fib_tcs = mb_tcs, fib_index = ind }) : rest)
       | instanceCantMatch rough_tcs mb_tcs
-      = findBranch seen rest (ind+1) -- branch won't unify later; ignore
+      = findBranch seen rest -- branch won't unify later; ignore
       | otherwise
       = case match_fun seen branch is_group match_tys of
-          (Nothing, KeepSearching) -> findBranch (branch : seen) rest (ind+1)
+          (Nothing, KeepSearching) -> findBranch (branch : seen) rest
           (Nothing, StopSearching) -> (Nothing, StopSearching)
           (Just subst, cont)       -> (Just match, cont)
               where 
@@ -848,7 +894,6 @@ find match_fun match_tys (inst@(FamInst { fi_branches = branches, fi_group = is_
                                      , fim_index    = ind
                                      , fim_tys      = substTyVars subst tvs }
 
-
 lookup_fam_inst_env           -- The worker, local to this module
     :: MatchFun
     -> OneSidedMatch
@@ -887,11 +932,12 @@ The "extra" type argument [Char] just stays on the end.
 --   False -> no information
 -- It is currently (Oct 2012) used only for generating errors for
 -- inaccessible branches. If these errors go unreported, no harm done.
-isDominatedBy :: [Type] -> [FamInstBranch] -> Bool
+-- This is defined here to avoid a dependency from CoAxiom to Unify
+isDominatedBy :: [Type] -> [CoAxBranch] -> Bool
 isDominatedBy lhs branches
   = or $ map match branches
     where
-      match (FamInstBranch { fib_tvs = tvs, fib_lhs = tys })
+      match (CoAxBranch { cab_tvs = tvs, cab_lhs = tys })
         = isJust $ tcMatchTys (mkVarSet tvs) tys lhs
 \end{code}
 

compiler/vectorise/Vectorise/Generic/PAMethods.hs

@@ -23,6 +23,8 @@ import Type
 import OccName
 import Coercion
 import MkId
+import Name
+import FamInst
 
 import DynFlags
 import FastString
@@ -36,7 +38,7 @@ buildPReprTyCon orig_tc vect_tc repr
  = do name      <- mkLocalisedName mkPReprTyConOcc (tyConName orig_tc)
       rhs_ty    <- sumReprType repr
       prepr_tc  <- builtin preprTyCon
-      return $ mkSingleSynFamInst name tyvars prepr_tc instTys rhs_ty
+      liftDs $ mkFreshenedSynInstLoc (getSrcSpan name) name tyvars prepr_tc instTys rhs_ty
   where
     tyvars = tyConTyVars vect_tc
     instTys = [mkTyConApp vect_tc . mkTyVarTys $ tyConTyVars vect_tc]

compiler/vectorise/Vectorise/Generic/PData.hs

@@ -20,6 +20,7 @@ import DataCon
 import TyCon
 import Type
 import FamInstEnv
+import TcMType
 import Name
 import Util
 import MonadUtils
@@ -43,11 +44,12 @@ buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM (FamInst Unbranc
 buildDataFamInst name' fam_tc vect_tc rhs
  = do { axiom_name <- mkDerivedName mkInstTyCoOcc name'
 
-      ; let fam_inst = mkDataFamInst axiom_name tyvars fam_tc pat_tys rep_tc
+      ; (_, tyvars') <- liftDs $ tcInstSkolTyVarsLoc (getSrcSpan name') tyvars
+      ; let fam_inst = mkDataFamInst axiom_name tyvars' fam_tc pat_tys rep_tc
             ax       = famInstAxiom fam_inst
-            pat_tys  = [mkTyConApp vect_tc (mkTyVarTys tyvars)]
+            pat_tys  = [mkTyConApp vect_tc (mkTyVarTys tyvars')]
             rep_tc   = buildAlgTyCon name'
-                           tyvars
+                           tyvars'
                            Nothing
                            []          -- no stupid theta
                            rhs