Revert "Checkpoint. The sources compile, but the libraries don't yet."

This reverts commit 0d0c71e.

compiler/hsSyn/HsDecls.lhs

@@ -27,7 +27,7 @@ module HsDecls (
   InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..),
   TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
   DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour,
-  TyFamInstEqn(..), LTyFamInstEqn, TyFamInstSpace(..), LTyFamInstSpace,
+  TyFamInstEqn(..), LTyFamInstEqn,
   LClsInstDecl, ClsInstDecl(..),
 
   -- ** Standalone deriving declarations
@@ -861,7 +861,6 @@ data TyFamInstSpace name
       { tfis_tycon :: Located name
       , tfis_pats  :: HsWithBndrs [LHsType name]
       }
-  deriving( Typeable, Data )
 
 type LTyFamInstDecl name = Located (TyFamInstDecl name)
 data TyFamInstDecl name 
@@ -872,8 +871,7 @@ data TyFamInstDecl name
   | TyFamInstBranched
        { tfid_eqns  :: [LTyFamInstEqn name]    -- ^ list of (possibly-overlapping) eqns 
                                                -- Always non-empty
-       , tfid_space :: Maybe (LTyFamInstSpace name)
-                                              -- ^ The (optional) region of the type
+       , tfid_space :: Maybe LTyFamInstSpace  -- ^ The (optional) region of the type
                                               -- space this group sits in.
        , tfid_fvs   :: NameSet }            -- The group is type-checked as one,
                                             --   so one NameSet will do
@@ -968,11 +966,6 @@ ppr_instance_keyword :: TopLevelFlag -> SDoc
 ppr_instance_keyword TopLevel    = ptext (sLit "instance")
 ppr_instance_keyword NotTopLevel = empty
 
-instance (OutputableBndr name) => Outputable (TyFamInstSpace name) where
-  ppr (TyFamInstSpace { tfis_tycon = tycon
-                      , tfis_pats  = pats })
-    = pp_fam_inst_lhs tycon pats []
-
 instance (OutputableBndr name) => Outputable (TyFamInstEqn name) where
   ppr (TyFamInstEqn { tfie_tycon = tycon
                     , tfie_pats  = pats

compiler/iface/BinIface.hs

@@ -26,7 +26,6 @@ import PrelInfo   (wiredInThings, basicKnownKeyNames)
 import Id         (idName, isDataConWorkId_maybe)
 import CoreSyn    (DFunArg(..))
 import Coercion   (LeftOrRight(..))
-import CoAxiom    (BranchFlag(..))
 import TysWiredIn
 import IfaceEnv
 import HscTypes
@@ -1367,17 +1366,7 @@ instance Binary IfaceFamInst where
         tys      <- get bh
         name     <- get bh
         orph     <- get bh
-        return (IfaceFamInst fam group space tys name orph)
-
-instance Binary BranchFlag where
-    put_ bh Branched   = putByte bh 0
-    put_ bh Unbranched = putByte bh 1
-    get bh = do
-        b <- getByte bh
-        case b of
-            0 -> return Branched
-            1 -> return Unbranched
-            _ -> panic ("get BranchFlag " ++ show b)
+        return (IfaceFamInst fam group tys name orph)
 
 instance Binary IfaceFamInstSpace where
     put_ bh IfaceNoFamInstSpace = putByte bh 0

compiler/iface/IfaceSyn.lhs

@@ -20,7 +20,7 @@ module IfaceSyn (
         IfaceBinding(..), IfaceConAlt(..),
         IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
         IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
-        IfaceClsInst(..), IfaceFamInst(..), IfaceFamInstSpace(..), IfaceTickish(..), 
+        IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), 
         IfaceBang(..), IfaceAxBranch(..),
 
         -- Misc
@@ -43,7 +43,6 @@ import PprCore()            -- Printing DFunArgs
 import Demand
 import Annotations
 import Class
-import CoAxiom ( BranchFlag(..) )
 import NameSet
 import Name
 import CostCentre
@@ -634,11 +633,11 @@ instance Outputable IfaceClsInst where
 
 instance Outputable IfaceFamInst where
   ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcss,
-                     ifFamInstAxiom = tycon_ax, ifFamInstSpace = space})
+                     ifFamInstAxiom = tycon_ax})
     = hang (ptext (sLit "family instance") <+>
             ppr fam <+> pprWithCommas (brackets . pprWithCommas ppr_rough) mb_tcss)
          2 ((equals <+> ppr tycon_ax) $$
-           ppr_space space)
+           ppr_space)
 
 ppr_rough :: Maybe IfaceTyCon -> SDoc
 ppr_rough Nothing   = dot

compiler/iface/MkIface.lhs

@@ -1673,15 +1673,16 @@ famInstToIfaceFamInst (FamInst { fi_axiom    = axiom,
          = Nothing
 
     iface_space
-      = case space of
-          NoFamInstSpace -> IfaceNoFamInstSpace
-          FamInstSpace { fis_tvs = tvs
-                       , fis_tys = tys
-                       , fis_tcs = tcs } ->
-            let (env, tv_bndrs) = tidyTyVarBndrs emptyTidyEnv tvs in
-            IfaceFamInstSpace { ifFamInstSpaceTvs = toIfaceTvBndrs tv_bndrs
-                              , ifFamInstSpaceTys = map (tidyToIfaceType env) tys
-                              , ifFamInstSpaceRoughMatch = map do_rough tcs }
+      | NoFamInstSpace <- space
+      = IfaceNoFamInstSpace
+
+      | FamInstSpace { fis_tvs = tvs
+                     , fis_tys = tys
+                     , fis_tcs = tcs } <- space
+      = let (env, tv_bndrs) = tidyTyVarBndrs emptyTidyEnv tvs in
+        IfaceFamInstSpace { ifFamInstSpaceTvs = toIfaceTvBndrs tv_bndrs
+                          , ifFamInstSpaceTys = map (tidyToIfaceType env) tys
+                          , ifFamInstSpaceRoughMatch = map do_rough fis_tcs }
 
 --------------------------
 toIfaceLetBndr :: Id -> IfaceLetBndr

compiler/iface/TcIface.lhs

@@ -663,7 +663,7 @@ tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcss
                              , ifFamInstSpace = space } )
     = do { axiom' <- forkM (ptext (sLit "Axiom") <+> ppr axiom_name) $
                      tcIfaceCoAxiom axiom_name
-         ; space' <- tcIfaceFamInstSpace space
+         ; space' <- tccIfaceFamInstSpace space
          ; let mb_tcss' = map (map (fmap ifaceTyConName)) mb_tcss
          ; return (mkImportedFamInst fam branched space' mb_tcss' axiom') }
 
@@ -674,7 +674,7 @@ tcIfaceFamInstSpace (IfaceFamInstSpace { ifFamInstSpaceTvs = tvs
                                        , ifFamInstSpaceRoughMatch = tcs })
   = bindIfaceTyVars tvs $ \tvs' -> do
     { tys' <- mapM tcIfaceType tys
-    ; return $ mkImportedFamInstSpace tvs' tys' (map (fmap ifaceTyConName) tcs) }
+    ; return $ mkImportedFamInstSpace tvs' tys' (map (fmap ifaceTyConName) tcs)
 \end{code}
 
 

compiler/parser/RdrHsSyn.lhs

@@ -192,13 +192,13 @@ mkTyFamInst :: SrcSpan
             -> LTyFamInstEqn RdrName
             -> P (LTyFamInstDecl RdrName)
 mkTyFamInst loc eqn
-  = return (L loc (TyFamInstSingle { tfid_eqn   = eqn
+  = return (L loc (TyFamInstSingle { tfid_eqn  = [eqn]
                                    , tfid_fvs   = placeHolderNames }))
 
 mkTyFamInstGroup :: SrcSpan
                  -> Maybe (LHsType RdrName)
                  -> [LTyFamInstEqn RdrName]
-                 -> P (LTyFamInstDecl RdrName)
+                 -> P TyFamInstDecl RdrName
 mkTyFamInstGroup loc mspace eqns
   = do { mspace' <- mkTyFamInstSpace mspace
        ; return $ L loc (TyFamInstBranched { tfid_eqns  = eqns
@@ -208,11 +208,10 @@ mkTyFamInstGroup loc mspace eqns
 mkTyFamInstSpace :: Maybe (LHsType RdrName)
                  -> P (Maybe (LTyFamInstSpace RdrName))
 mkTyFamInstSpace Nothing = return Nothing
-mkTyFamInstSpace (Just lty@(L loc _))
-  = do { (tycon, pats) <- checkTyClHdr lty
-       ; return (Just $ L loc
-                          (TyFamInstSpace { tfis_tycon = tycon
-                                          , tfis_pats  = mkHsWithBndrs pats }) ) }
+mkTyFamInstSpace (Just ty)
+  = do { (tycon, pats) <- checkTyClHdr ty
+       ; return (TyFamInstSpace { tfis_tycon = tycon
+                                , tfis_pats  = mkHsWithBndrs pats }) }
 
 mkFamDecl :: SrcSpan
           -> FamilyFlavour

compiler/rename/RnSource.lhs

@@ -520,7 +520,7 @@ rnFamInstLHS doc mb_cls tycon pats
 
        ; return ( tycon'
                 , HsWB { hswb_cts = pats', hswb_kvs = kv_names, hswb_tvs = tv_names }
-                , fvs `addOneFV` unLoc tycon' ) }
+                , fvs `addOneFV` unLoc tycon' )
 
 rnFamInstDecl :: HsDocContext
               -> Maybe (Name, [Name])
@@ -548,24 +548,23 @@ rnFamInstDecl doc mb_cls tycon pats payload rnPayload
 rnTyFamInstDecl :: Maybe (Name, [Name])
                 -> TyFamInstDecl RdrName
                 -> RnM (TyFamInstDecl Name, FreeVars)
-rnTyFamInstDecl mb_cls (TyFamInstSingle { tfid_eqn = L loc eqn })
-  = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn
-       ; return (TyFamInstSingle { tfid_eqn = L loc eqn'
-                                 , tfid_fvs = fvs }, fvs) }
+rnTyFamInstDecl mb_cls (TyFamInstSingle { tfid_eqn = eqn })
+  = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls) eqn
+       ; return (TyFamInstSingle { tfid_eqn = eqn'
+                                 , tfid_fvs = fvs }, fvs)
 rnTyFamInstDecl Nothing (TyFamInstBranched { tfid_eqns = eqns, tfid_space = mspace })
   = do { (eqns', fvs1) <- rnList (rnTyFamInstEqn Nothing) eqns
        ; (space', fvs2) <- rn_space mspace
-       ; let fvs = fvs1 `plusFV` fvs2
+       ; let fvs = fvs1 `plusFVs` fvs2
        ; return (TyFamInstBranched { tfid_eqns  = eqns'
                                    , tfid_space = space'
                                    , tfid_fvs   = fvs }, fvs) }
-  where rn_space Nothing = return (Nothing, emptyFVs)
-        rn_space (Just (L loc (TyFamInstSpace { tfis_tycon = tycon
-                                              , tfis_pats  = HsWB { hswb_cts = pats } })))
+  where rn_space Nothing = (Nothing, emptyFVs)
+        rn_space (Just (TyFamInstSpace { tfis_tycon = tycon
+                                       , tfis_pats  = pats }))
           = do { (tycon', pats', fvs) <- rnFamInstLHS (TySynCtx tycon) Nothing tycon pats
-               ; return (Just $ L loc $ TyFamInstSpace { tfis_tycon = tycon'
-                                                       , tfis_pats  = pats' }, fvs) }
-rnTyFamInstDecl _ _ = panic "rnTyFamInstDecl" -- branched instance in a class
+               ; return (TyFamInstSpace { tfis_tycon = tycon'
+                                        , tfis_pats  = pats' }, fvs) }
 
 rnTyFamInstEqn :: Maybe (Name, [Name])
                -> TyFamInstEqn RdrName

compiler/typecheck/FamInst.lhs

@@ -13,18 +13,18 @@ module FamInst (
         checkFamInstConsistency, tcExtendLocalFamInstEnv,
 	tcLookupFamInst, tcLookupDataFamInst,
         tcGetFamInstEnvs,
-        newFamInst, mkFamInstSpace
+        newFamInst
     ) where
 
 import HscTypes
 import FamInstEnv
 import InstEnv( roughMatchTcs )
+import Coercion( pprCoAxBranchHdr )
 import LoadIface
 import TypeRep
 import TcRnMonad
 import TyCon
 import CoAxiom
-import Type
 import DynFlags
 import Module
 import Outputable
@@ -33,7 +33,7 @@ import FastString
 import Util
 import Maybes
 import TcMType
-import SrcLoc
+import TcType
 import Name
 import Control.Monad
 import Data.Map (Map)
@@ -75,7 +75,7 @@ newFamInst flavor is_branched space axiom@(CoAxiom { co_ax_tc       = fam_tc
                              ; return (FirstBranch br') }
     go (NextBranch br brs) = do { br' <- go_branch br
                                 ; brs' <- go brs
-                                ; return (NextBranch br' brs') }
+                                ;return (NextBranch br' brs') }
     go_branch :: CoAxBranch -> TcRnIf gbl lcl FamInstBranch 
     go_branch (CoAxBranch { cab_tvs = tvs1
                           , cab_lhs = lhs
@@ -89,12 +89,10 @@ newFamInst flavor is_branched space axiom@(CoAxiom { co_ax_tc       = fam_tc
 
     mk_space :: BranchList FamInstBranch br -> FamInstSpace
     mk_space fam_branches
-      | Unbranched <- is_branched
+      | False <- is_branched
       , FirstBranch (FamInstBranch { fib_tvs = tvs, fib_lhs = lhs, fib_tcs = tcs })
           <- fam_branches
-      , FirstBranch co_ax_branch <- ax_branches
-      = FamInstSpace { fis_tvs = tvs, fis_tys = lhs, fis_tcs = tcs
-                     , fis_loc = coAxBranchSpan co_ax_branch  }
+      = FamInstSpace { fis_tvs = tvs, fis_tys = lhs, fis_tcs = tcs }
 
       | otherwise
       = space
@@ -372,24 +370,27 @@ environments (one for the EPS and one for the HPT).
 
 \begin{code}
 checkForConflicts :: FamInstEnvs -> FamInst Branched -> TcM Bool
-checkForConflicts inst_envs fam_inst
+checkForConflicts inst_envs fam_inst@(FamInst { fi_branches = branches })
   = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst
-             no_conflicts = null conflicts
+             no_conflicts = all null conflicts
        ; traceTc "checkForConflicts" (ppr conflicts $$ ppr fam_inst $$ ppr inst_envs)
        ; unless no_conflicts $ conflictInstErr fam_inst conflicts
        ; return no_conflicts }
+    where fam_tc = famInstTyCon fam_inst
 
 conflictInstErr :: FamInst Branched -> [FamInst Branched] -> TcRn ()
 conflictInstErr fam_inst confInsts
   = addFamInstsErr (ptext (sLit "Conflicting family instance declarations:"))
                    (fam_inst : confInsts)
+  | otherwise -- no conflict on this branch; see Trac #7560
+  = return ()
 
 addFamInstsErr :: SDoc -> [FamInst Branched] -> TcRn ()
 addFamInstsErr herald insts
   = ASSERT( not (null insts) )
     setSrcSpan srcSpan $ addErr $
     hang herald
-       2 (vcat [ pprFamInst fi 
+       2 (vcat [ pprCoAxBranchHdr (famInstAxiom fi) index 
                | fi <- sorted ])
  where
    getSpan   = getSrcLoc . famInstAxiom

compiler/typecheck/TcGenGenerics.lhs

@@ -29,7 +29,7 @@ import DataCon
 import TyCon
 import CoAxiom
 import Coercion         ( mkSingleCoAxiom )
-import FamInstEnv
+import FamInstEnv       ( FamInst, FamFlavor(..) )
 import FamInst
 import Module           ( Module, moduleName, moduleNameString )
 import IfaceEnv         ( newGlobalBinder )

compiler/typecheck/TcInstDcls.lhs

@@ -638,7 +638,7 @@ tcTyFamInstDecl mb_clsinfo (L loc decl)
        ; (space, co_ax_branches) <- tcSynFamInstDecl fam_tc decl
 
          -- (2) check for validity and inaccessibility
-       ; checkValidTypeSpace fam_tc space
+       ; checkValidTypeSpace space
        ; foldlM_ (check_valid_branch fam_tc space) [] co_ax_branches
 
          -- (3) construct coercion axiom
@@ -648,13 +648,15 @@ tcTyFamInstDecl mb_clsinfo (L loc decl)
        ; let axiom = mkBranchedCoAxiom rep_tc_name fam_tc co_ax_branches
        ; newFamInst SynFamilyInst branched space axiom }
     where
-      (eqn1, branched)
-        = case decl of
-            TyFamInstSingle { tfid_eqn = eqn }        -> (eqn, Unbranched)
-            TyFamInstBranched { tfid_eqns = (eqn:_) } -> (eqn, Branched)
-            _                                         -> panic "tcTyfamInstDecl"
+      eqn1
+        | TyFamInstSingle { tfid_eqn = eqn } <- decl        = eqn
+        | TyFamInstBranched { tfid_eqns = (eqn:_) } <- decl = eqn
       fam_lname = tfie_tycon (unLoc eqn1)
 
+      branched
+        | TyFamInstSingle {} <- decl   = Unbranched
+        | TyFamInstBranched {} <- decl = Branched
+
       check_valid_branch :: TyCon
                          -> FamInstSpace
                          -> [CoAxBranch]     -- previous