Refactor HsDecls again, to put family instances in InstDecl
authorSimon Peyton Jones <simonpj@microsoft.com>
Mon, 6 Feb 2012 08:38:59 +0000 (08:38 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Mon, 6 Feb 2012 08:38:59 +0000 (08:38 +0000)
This continues the clean up of the front end.  Since they
were first invented, type and data family *instance* decls
have been in the TyClDecl data type, even though they always
treated separately.

This patch takes a step in the right direction
  * The InstDecl type now includes both class instances and
    type/data family instances

  * The hs_tyclds field of HsGroup now never has any family
    instance declarations in it

However a family instance is still a TyClDecl.  It should really
be a separate type, but that's the next step.

All this was provoked by fixing Trac #5792 in the HEAD.
(I did a less invasive fix on the branch.)

12 files changed:
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsDecls.lhs
compiler/hsSyn/HsUtils.lhs
compiler/main/HscStats.lhs
compiler/parser/Parser.y.pp
compiler/rename/RnNames.lhs
compiler/rename/RnSource.lhs
compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcTyClsDecls.lhs
utils/ghctags/Main.hs

index 103f70f..4105a9e 100644 (file)
@@ -129,10 +129,12 @@ repTopDs group
        decls <- addBinds ss (do {
                        val_ds  <- rep_val_binds (hs_valds group) ;
                        tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ;
-                       inst_ds <- mapM repInstD' (hs_instds group) ;
+                       inst_ds <- mapM repInstD (hs_instds group) ;
                        for_ds <- mapM repForD (hs_fords group) ;
                        -- more needed
-                       return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
+                       return (de_loc $ sort_by_loc $ 
+                                val_ds ++ catMaybes tycl_ds
+                                       ++ catMaybes inst_ds ++ for_ds) }) ;
 
        decl_ty <- lookupType decQTyConName ;
        let { core_list = coreList' decl_ty decls } ;
@@ -307,8 +309,12 @@ repLAssocFamInst = liftM de_loc . mapMaybeM repTyClD
 
 -- represent instance declarations
 --
-repInstD' :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
-repInstD' (L loc (InstDecl ty binds _ ats))    -- Ignore user pragmas for now
+repInstD :: LInstDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
+repInstD (L loc (FamInstDecl fi_decl))
+  = repTyClD (L loc fi_decl)
+
+
+repInstD (L loc (ClsInstDecl ty binds _ ats))  -- Ignore user pragmas for now
   = do { dec <- addTyVarBinds tvs $ \_ ->
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't 
@@ -327,7 +333,7 @@ repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now
                ; ats1 <- repLAssocFamInst ats
                ; decls <- coreList decQTyConName (ats1 ++ binds1)
                ; repInst cxt1 inst_ty1 decls }
-       ; return (loc, dec) }
+       ; return (Just (loc, dec)) }
  where
    Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty)
 
index 4292a11..5318c5b 100644 (file)
@@ -195,7 +195,7 @@ cvtDec (InstanceD ctxt ty decs)
        ; ctxt' <- cvtContext ctxt
        ; L loc ty' <- cvtType ty
        ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty'
-       ; returnL $ InstD (InstDecl inst_ty' binds' sigs' ats') }
+       ; returnL $ InstD (ClsInstDecl inst_ty' binds' sigs' ats') }
 
 cvtDec (ForeignD ford) 
   = do { ford' <- cvtForD ford
@@ -213,23 +213,25 @@ cvtDec (DataInstD ctxt tc tys constrs derivs)
   = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
        ; cons' <- mapM cvtConstr constrs
        ; derivs' <- cvtDerivs derivs
-       ; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
-                                  , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
-                                  , tcdCons = cons', tcdDerivs = derivs' }) }
+       ; returnL $ InstD $ FamInstDecl $
+                   TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
+                          , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
+                          , tcdCons = cons', tcdDerivs = derivs' } }
 
 cvtDec (NewtypeInstD ctxt tc tys constr derivs)
   = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
        ; con' <- cvtConstr constr
        ; derivs' <- cvtDerivs derivs
-       ; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
-                                  , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
-                                  , tcdCons = [con'], tcdDerivs = derivs' })
-       }
+       ; returnL $ InstD $ FamInstDecl $
+                   TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
+                          , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
+                          , tcdCons = [con'], tcdDerivs = derivs' } }
 
 cvtDec (TySynInstD tc tys rhs)
   = do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys
        ; rhs' <- cvtType rhs
-       ; returnL $ TyClD (TySynonym tc' tvs' tys' rhs') }
+       ; returnL $ InstD $ FamInstDecl $ 
+                    TySynonym tc' tvs' tys' rhs' }
 
 ----------------
 cvt_ci_decs :: MsgDoc -> [TH.Dec]
index f8e6bc0..e6d369c 100644 (file)
@@ -18,9 +18,11 @@ module HsDecls (
   isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl,
   isFamInstDecl, tcdName, tyClDeclTyVars,
   countTyClDecls,
+
   -- ** Instance declarations
   InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..),
-  instDeclATs,
+  FamInstDecl, LFamInstDecl, instDeclFamInsts,
+
   -- ** Standalone deriving declarations
   DerivDecl(..), LDerivDecl,
   -- ** @RULE@ declarations
@@ -128,12 +130,15 @@ data HsGroup id
   = HsGroup {
         hs_valds  :: HsValBinds id,
 
-        hs_tyclds :: [[LTyClDecl id]],  
+        hs_tyclds :: [[LTyClDecl id]],
                 -- A list of mutually-recursive groups
+                -- No family-instances here; they are in hs_instds
                 -- Parser generates a singleton list;
                 -- renamer does dependency analysis
 
-        hs_instds :: [LInstDecl id],
+        hs_instds  :: [LInstDecl id],
+                -- Both class and family instance declarations in here
+
         hs_derivds :: [LDerivDecl id],
 
         hs_fixds  :: [LFixitySig id],
@@ -154,7 +159,8 @@ emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
 emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
 emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }
 
-emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [],
+emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], 
+                       hs_derivds = [],
                        hs_fixds = [], hs_defds = [], hs_annds = [],
                        hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [],
                        hs_valds = error "emptyGroup hs_valds: Can't happen",
@@ -430,8 +436,9 @@ Interface file code:
 -- In both cases, 'tcdVars' collects all variables we need to quantify over.
 
 type LTyClDecl name = Located (TyClDecl name)
-type TyClGroup name = [LTyClDecl name]  -- this is used in TcTyClsDecls to represent
+type TyClGroup name = [LTyClDecl name]  -- This is used in TcTyClsDecls to represent
                                         -- strongly connected components of decls
+                                        -- No familiy instances in here
 
 -- | A type or class declaration.
 data TyClDecl name
@@ -504,7 +511,7 @@ data TyClDecl name
                 tcdMeths   :: LHsBinds name,            -- ^ Default methods
                 tcdATs     :: [LTyClDecl name],         -- ^ Associated types; ie
                                                         --   only 'TyFamily'
-                tcdATDefs  :: [LTyClDecl name],         -- ^ Associated type defaults; ie
+                tcdATDefs  :: [LFamInstDecl name],      -- ^ Associated type defaults; ie
                                                         --   only 'TySynonym'
                 tcdDocs    :: [LDocDecl]                -- ^ Haddock docs
     }
@@ -602,15 +609,14 @@ tyClDeclTyVars (ForeignType {})                = []
 \end{code}
 
 \begin{code}
-countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int, Int)
-        -- class, synonym decls, data, newtype, family decls, family instances
+countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int)
+        -- class, synonym decls, data, newtype, family decls
 countTyClDecls decls 
  = (count isClassDecl    decls,
     count isSynDecl      decls,  -- excluding...
     count isDataTy       decls,  -- ...family...
     count isNewTy        decls,  -- ...instances
-    count isFamilyDecl   decls,
-    count isFamInstDecl  decls)
+    count isFamilyDecl   decls)
  where
    isDataTy TyData{tcdND = DataType, tcdTyPats = Nothing} = True
    isDataTy _                                             = False
@@ -833,18 +839,25 @@ pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyG
 \begin{code}
 type LInstDecl name = Located (InstDecl name)
 
-data InstDecl name
-  = InstDecl    (LHsType name)  -- Context => Class Instance-type
-                                -- Using a polytype means that the renamer conveniently
-                                -- figures out the quantified type variables for us.
-                (LHsBinds name)
-                [LSig name]     -- User-supplied pragmatic info
-                [LTyClDecl name]-- Associated types (ie, 'TyData' and
-                                -- 'TySynonym' only)
+type LFamInstDecl name = Located (FamInstDecl name)
+type FamInstDecl  name = TyClDecl name  -- Type or data family instance
+
+data InstDecl name  -- Both class and family instances
+  = ClsInstDecl    
+      (LHsType name)    -- Context => Class Instance-type
+                        -- Using a polytype means that the renamer conveniently
+                        -- figures out the quantified type variables for us.
+      (LHsBinds name)
+      [LSig name]          -- User-supplied pragmatic info
+      [LFamInstDecl name]  -- Family instances for associated types
+
+  | FamInstDecl         -- type/data family instance
+      (FamInstDecl name)
+
   deriving (Data, Typeable)
 
 instance (OutputableBndr name) => Outputable (InstDecl name) where
-    ppr (InstDecl inst_ty binds sigs ats)
+    ppr (ClsInstDecl inst_ty binds sigs ats)
       | null sigs && null ats && isEmptyBag binds  -- No "where" part
       = top_matter
 
@@ -855,10 +868,16 @@ instance (OutputableBndr name) => Outputable (InstDecl name) where
       where
         top_matter = ptext (sLit "instance") <+> ppr inst_ty
 
+    ppr (FamInstDecl decl) = ppr decl
+
 -- Extract the declarations of associated types from an instance
---
-instDeclATs :: [LInstDecl name] -> [LTyClDecl name]
-instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats]
+
+instDeclFamInsts :: [LInstDecl name] -> [LTyClDecl name]
+instDeclFamInsts inst_decls 
+  = concatMap do_one inst_decls
+  where
+    do_one (L _ (ClsInstDecl _ _ _ fam_insts)) = fam_insts
+    do_one (L loc (FamInstDecl fam_inst))      = [L loc fam_inst]
 \end{code}
 
 %************************************************************************
index 3527d91..293f5b0 100644 (file)
@@ -68,7 +68,7 @@ module HsUtils(
   collectLStmtBinders, collectStmtBinders,
   collectSigTysFromPats, collectSigTysFromPat,
 
-  hsTyClDeclBinders, hsTyClDeclsBinders, 
+  hsLTyClDeclBinders, hsTyClDeclBinders, hsTyClDeclsBinders, 
   hsForeignDeclsBinders, hsGroupBinders,
   
   -- Collecting implicit binders
@@ -619,29 +619,33 @@ hsForeignDeclsBinders foreign_decls
   = [n | L _ (ForeignImport (L _ n) _ _ _) <- foreign_decls]
 
 hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name]
+-- We need to look at instance declarations too, 
+-- because their associated types may bind data constructors
 hsTyClDeclsBinders tycl_decls inst_decls
-  = [n | d <- instDeclATs inst_decls ++ concat tycl_decls
-       , L _ n <- hsTyClDeclBinders d]
+  = [n | d <- instDeclFamInsts inst_decls ++ concat tycl_decls
+       , L _ n <- hsLTyClDeclBinders d]
 
-hsTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
+hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
 -- ^ Returns all the /binding/ names of the decl, along with their SrcLocs.
 -- The first one is guaranteed to be the name of the decl. For record fields
 -- mentioned in multiple constructors, the SrcLoc will be from the first
 -- occurence.  We use the equality to filter out duplicate field names
+hsLTyClDeclBinders (L _ d) = hsTyClDeclBinders d
 
-hsTyClDeclBinders (L _ (TyFamily    {tcdLName = name})) = [name]
-hsTyClDeclBinders (L _ (ForeignType {tcdLName = name})) = [name]
+hsTyClDeclBinders :: Eq name => TyClDecl name -> [Located name]
+hsTyClDeclBinders (TyFamily    {tcdLName = name}) = [name]
+hsTyClDeclBinders (ForeignType {tcdLName = name}) = [name]
 
-hsTyClDeclBinders (L _ (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats}))
+hsTyClDeclBinders (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})
   = cls_name : 
-    concatMap hsTyClDeclBinders ats ++ [n | L _ (TypeSig ns _) <- sigs, n <- ns]
+    concatMap hsLTyClDeclBinders ats ++ [n | L _ (TypeSig ns _) <- sigs, n <- ns]
 
-hsTyClDeclBinders (L _ (TySynonym   {tcdLName = name, tcdTyPats = mb_pats })
+hsTyClDeclBinders (TySynonym   {tcdLName = name, tcdTyPats = mb_pats }
   | isJust mb_pats = []
   | otherwise      = [name]
   -- See Note [Binders in family instances]
 
-hsTyClDeclBinders (L _ (TyData {tcdLName = tc_name, tcdCons = cons, tcdTyPats = mb_pats }))
+hsTyClDeclBinders (TyData {tcdLName = tc_name, tcdCons = cons, tcdTyPats = mb_pats })
   | isJust mb_pats = hsConDeclsBinders cons
   | otherwise      = tc_name : hsConDeclsBinders cons
   -- See Note [Binders in family instances]
index f89903f..168e49a 100644 (file)
@@ -52,7 +52,6 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
                ("DataDecls        ", data_ds),
                ("NewTypeDecls     ", newt_ds),
                ("TypeFamilyDecls  ", type_fam_ds),
-               ("FamilyInstDecls  ", fam_inst_ds),
                ("DataConstrs      ", data_constrs),
                ("DataDerivings    ", data_derivs),
                ("ClassDecls       ", class_ds),
@@ -89,7 +88,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
                -- in class decls.  ToDo
 
     tycl_decls  = [d | TyClD d <- decls]
-    (class_ds, type_ds, data_ds, newt_ds, type_fam_ds, fam_inst_ds) = 
+    (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) = 
       countTyClDecls tycl_decls
 
     inst_decls  = [d | InstD d <- decls]
@@ -153,7 +152,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
               (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl)))))
     class_info _ = (0,0)
 
-    inst_info (InstDecl _ inst_meths inst_sigs ats)
+    inst_info (FamInstDecl d) = case countATDecl d of
+                                  (tyd, dtd) -> (0,0,0,tyd,dtd)
+    inst_info (ClsInstDecl _ inst_meths inst_sigs ats)
        = case count_sigs (map unLoc inst_sigs) of
            (_,_,ss,is,_) ->
              case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of
@@ -162,9 +163,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
                           (map (count_bind.unLoc) (bagToList inst_meths))), 
                    ss, is, tyDecl, dtDecl)
         where
-         countATDecl (TyData    {}) = (0, 1)
-         countATDecl (TySynonym {}) = (1, 0)
-         countATDecl d              = pprPanic "countATDecl: Unhandled decl"
+    countATDecl (TyData    {}) = (0, 1)
+    countATDecl (TySynonym {}) = (1, 0)
+    countATDecl d              = pprPanic "countATDecl: Unhandled decl"
                                             (ppr d)
 
     addpr :: (Int,Int) -> Int
index a4e61fc..c05f2e1 100644 (file)
@@ -567,10 +567,7 @@ topdecls :: { OrdList (LHsDecl RdrName) }
 topdecl :: { OrdList (LHsDecl RdrName) }
         : cl_decl                               { unitOL (L1 (TyClD (unLoc $1))) }
         | ty_decl                               { unitOL (L1 (TyClD (unLoc $1))) }
-        | 'instance' inst_type where_inst
-            { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
-              in 
-              unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))}
+        | inst_decl                             { unitOL (L1 (InstD (unLoc $1))) }
         | stand_alone_deriving                  { unitOL (LL (DerivD (unLoc $1))) }
         | 'default' '(' comma_types0 ')'        { unitOL (LL $ DefD (DefaultDecl $3)) }
         | 'foreign' fdecl                       { unitOL (LL (unLoc $2)) }
@@ -629,12 +626,6 @@ ty_decl :: { LTyClDecl RdrName }
                 -- infix type constructors to be declared
                 {% mkTyFamily (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4) }
 
-           -- type instance declarations
-        | 'type' 'instance' type '=' ctype
-                -- Note the use of type for the head; this allows
-                -- infix type constructors and type patterns
-                {% mkTySynonym (comb2 $1 $5) True $3 $5 }
-
           -- ordinary data type or newtype declaration
         | data_or_newtype tycl_hdr constrs deriving
                 {% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) False $2 
@@ -655,18 +646,32 @@ ty_decl :: { LTyClDecl RdrName }
         | 'data' 'family' type opt_kind_sig
                 {% mkTyFamily (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) }
 
+inst_decl :: { LInstDecl RdrName }
+        : 'instance' inst_type where_inst
+                 { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
+                   in L (comb3 $1 $2 $3) (ClsInstDecl $2 binds sigs ats) }
+
+           -- type instance declarations
+        | 'type' 'instance' type '=' ctype
+                -- Note the use of type for the head; this allows
+                -- infix type constructors and type patterns
+                {% do { L loc d <- mkTySynonym (comb2 $1 $5) True $3 $5
+                      ; return (L loc (FamInstDecl d)) } }
+
           -- data/newtype instance declaration
         | data_or_newtype 'instance' tycl_hdr constrs deriving
-                {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $3
-                            Nothing (reverse (unLoc $4)) (unLoc $5) }
+                {% do { L loc d <- mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $3
+                                      Nothing (reverse (unLoc $4)) (unLoc $5)
+                      ; return (L loc (FamInstDecl d)) } }
 
           -- GADT instance declaration
         | data_or_newtype 'instance' tycl_hdr opt_kind_sig 
                  gadt_constrlist
                  deriving
-                {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $3
-                            (unLoc $4) (unLoc $5) (unLoc $6) }
-
+                {% do { L loc d <- mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $3
+                                            (unLoc $4) (unLoc $5) (unLoc $6)
+                      ; return (L loc (FamInstDecl d)) } }
+        
 -- Associated type family declarations
 --
 -- * They have a different syntax than on the toplevel (no family special
index 68e6d02..b3a3f83 100644 (file)
@@ -486,12 +486,8 @@ getLocalNonValBinders fixity_env
                 hs_tyclds = tycl_decls,
                 hs_instds = inst_decls,
                 hs_fords  = foreign_decls })
-  = do  { -- Separate out the family instance declarations
-          let (tyinst_decls, tycl_decls_noinsts)
-                   = partition (isFamInstDecl . unLoc) (concat tycl_decls)
-
-          -- Process all type/class decls *except* family instances
-        ; tc_avails <- mapM new_tc tycl_decls_noinsts
+  = do  { -- Process all type/class decls *except* family instances
+        ; tc_avails <- mapM new_tc (concat tycl_decls)
         ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env
         ; setEnvs envs $ do {
             -- Bring these things into scope first
@@ -499,7 +495,6 @@ getLocalNonValBinders fixity_env
 
           -- Process all family instances
           -- to bring new data constructors into scope
-        ; ti_avails  <- mapM (new_ti Nothing) tyinst_decls
         ; nti_avails <- concatMapM new_assoc inst_decls
 
           -- Finish off with value binders:
@@ -510,7 +505,7 @@ getLocalNonValBinders fixity_env
                         | otherwise = for_hs_bndrs
         ; val_avails <- mapM new_simple val_bndrs
 
-        ; let avails    = ti_avails ++ nti_avails ++ val_avails
+        ; let avails    = nti_avails ++ val_avails
               new_bndrs = availsToNameSet avails `unionNameSets` 
                           availsToNameSet tc_avails
         ; envs <- extendGlobalRdrEnvRn avails fixity_env 
@@ -529,20 +524,25 @@ getLocalNonValBinders fixity_env
                             ; return (Avail nm) }
 
     new_tc tc_decl              -- NOT for type/data instances
-        = do { names@(main_name : _) <- mapM newTopSrcBinder (hsTyClDeclBinders tc_decl)
+        = do { let bndrs = hsTyClDeclBinders (unLoc tc_decl)
+             ; names@(main_name : _) <- mapM newTopSrcBinder bndrs
              ; return (AvailTC main_name names) }
 
-    new_ti :: Maybe Name -> LTyClDecl RdrName -> RnM AvailInfo
+    new_ti :: Maybe Name -> FamInstDecl RdrName -> RnM AvailInfo
     new_ti mb_cls ti_decl  -- ONLY for type/data instances
-        = do { main_name <- lookupTcdName mb_cls (unLoc ti_decl)
+        = ASSERT( isFamInstDecl ti_decl ) 
+          do { main_name <- lookupTcdName mb_cls ti_decl
              ; sub_names <- mapM newTopSrcBinder (hsTyClDeclBinders ti_decl)
              ; return (AvailTC (unLoc main_name) sub_names) }
                         -- main_name is not bound here!
 
     new_assoc :: LInstDecl RdrName -> RnM [AvailInfo]
-    new_assoc (L _ (InstDecl inst_ty _ _ ats))
+    new_assoc (L _ (FamInstDecl d)) 
+      = do { avail <- new_ti Nothing d
+           ; return [avail] }
+    new_assoc (L _ (ClsInstDecl inst_ty _ _ ats))
       = do { mb_cls_nm <- get_cls_parent inst_ty 
-           ; mapM (new_ti mb_cls_nm) ats }
+           ; mapM (new_ti mb_cls_nm . unLoc) ats }
       where
         get_cls_parent inst_ty
           | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty
@@ -551,7 +551,8 @@ getLocalNonValBinders fixity_env
           = return Nothing
 
 lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name)
--- Used for TyData and TySynonym only
+-- Used for TyData and TySynonym only, 
+-- both ordinary ones and family instances
 -- See Note [Family instance binders]
 lookupTcdName mb_cls tc_decl
   | not (isFamInstDecl tc_decl)   -- The normal case
index 175b9a7..54f9501 100644 (file)
@@ -424,7 +424,11 @@ patchCCallTarget packageId callTarget
 
 \begin{code}
 rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
-rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
+rnSrcInstDecl (FamInstDecl ty_decl)
+  = do { (ty_decl', fvs) <- rnTyClDecl Nothing ty_decl
+       ; return (FamInstDecl ty_decl', fvs) }
+
+rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats)
        -- Used for both source and interface file decls
   = do { inst_ty' <- rnLHsInstType (text "In an instance declaration") inst_ty
        ; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty'
@@ -460,7 +464,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
                             renameSigs (InstDeclCtxt cls) spec_inst_prags
 
        ; let uprags' = spec_inst_prags' ++ other_sigs'
-       ; return (InstDecl inst_ty' mbinds' uprags' ats',
+       ; return (ClsInstDecl inst_ty' mbinds' uprags' ats',
                 meth_fvs `plusFV` more_fvs
                           `plusFV` hsSigsFVs spec_inst_prags'
                          `plusFV` extractHsTyNames inst_ty') }
@@ -764,6 +768,7 @@ rnTyClDecls extra_deps tycl_ds
 
              all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs'
 
+       ; traceRn (text "rnTycl"  <+> (ppr ds_w_fvs $$ ppr sccs))
        ; return (map flattenSCC sccs, all_fvs) }
 
 
@@ -995,12 +1000,16 @@ depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)]
 depAnalTyClDecls ds_w_fvs
   = stronglyConnCompFromEdgedVertices edges
   where
-    edges = [ (d, tcdName (unLoc d), map get_assoc (nameSetToList fvs))
+    edges = [ (d, tcdName (unLoc d), map get_parent (nameSetToList fvs))
             | (d, fvs) <- ds_w_fvs ]
-    get_assoc n = lookupNameEnv assoc_env n `orElse` n
+
+    -- We also need to consider data constructor names since 
+    -- they may appear in types because of promotion.
+    get_parent n = lookupNameEnv assoc_env n `orElse` n
+
+    assoc_env :: NameEnv Name   -- Maps a data constructor back 
+                                -- to its parent type constructor
     assoc_env = mkNameEnv assoc_env_list
-    -- We also need to consider data constructor names since they may
-    -- appear in types because of promotion.
     assoc_env_list = do
       (L _ d, _) <- ds_w_fvs
       case d of
@@ -1210,7 +1219,7 @@ extendRecordFieldEnv tycl_decls inst_decls
     all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls
                         , L _ con <- cons ]
     all_tycl_decls = at_tycl_decls ++ concat tycl_decls
-    at_tycl_decls = instDeclATs inst_decls  -- Do not forget associated types!
+    at_tycl_decls = instDeclFamInsts inst_decls  -- Do not forget associated types!
 
     get_con (ConDecl { con_name = con, con_details = RecCon flds })
            (RecFields env fld_set)
index 4db96c6..7751ae4 100644 (file)
@@ -459,7 +459,7 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
 
     all_tydata :: [(LHsType Name, LTyClDecl Name)]
         -- Derived predicate paired with its data type declaration
-    all_tydata = extractTyDataPreds (instDeclATs inst_decls ++ tycl_decls)
+    all_tydata = extractTyDataPreds (instDeclFamInsts inst_decls ++ tycl_decls)
 
     deriv_locs = map (getLoc . snd) all_tydata
                  ++ map getLoc deriv_decls
index 8351b7b..89a034b 100644 (file)
@@ -371,17 +371,16 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
             -- round)
 
             -- (1) Do class and family instance declarations
-       ; fam_insts       <- mapAndRecoverM tcTopFamInstDecl $
-                            filter (isFamInstDecl . unLoc) tycl_decls
-       ; inst_decl_stuff <- mapAndRecoverM tcLocalInstDecl1  inst_decls
+       ; inst_decl_stuff <- mapAndRecoverM tcLocalInstDecl1 inst_decls
 
-       ; let { (local_info, at_fam_insts_s) = unzip inst_decl_stuff
-             ; all_fam_insts = concat at_fam_insts_s ++ fam_insts }
+       ; let { (local_infos_s, fam_insts_s) = unzip inst_decl_stuff
+             ; all_fam_insts = concat fam_insts_s
+             ; local_infos   = concat local_infos_s }
 
             -- (2) Next, construct the instance environment so far, consisting of
             --   (a) local instance decls
             --   (b) local family instance decls
-       ; addClsInsts local_info      $
+       ; addClsInsts local_infos     $
          addFamInsts all_fam_insts   $ do
 
             -- (3) Compute instances from "deriving" clauses;
@@ -403,13 +402,13 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
        ; when (safeLanguageOn dflags) $
              mapM_ (\x -> when (typInstCheck x)
                                (addErrAt (getSrcSpan $ iSpec x) typInstErr))
-                   local_info
+                   local_infos
        -- As above but for Safe Inference mode.
        ; when (safeInferOn dflags) $
-             mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_info
+             mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_infos
 
        ; return ( gbl_env
-                , (bagToList deriv_inst_info) ++ local_info
+                , bagToList deriv_inst_info ++ local_infos
                 , deriv_binds)
     }}
   where
@@ -437,12 +436,18 @@ addFamInsts fam_insts thing_inside
 
 \begin{code}
 tcLocalInstDecl1 :: LInstDecl Name
-                 -> TcM (InstInfo Name, [FamInst])
+                 -> TcM ([InstInfo Name], [FamInst])
         -- A source-file instance declaration
         -- Type-check all the stuff before the "where"
         --
         -- We check for respectable instance type, and context
-tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
+tcLocalInstDecl1 (L loc (FamInstDecl decl))
+  = setSrcSpan loc      $
+    tcAddDeclCtxt decl  $
+    do { fam_inst <- tcFamInstDecl TopLevel decl
+       ; return ([], [fam_inst]) }
+
+tcLocalInstDecl1 (L loc (ClsInstDecl poly_ty binds uprags ats))
   = setSrcSpan loc                      $
     addErrCtxt (instDeclCtxt1 poly_ty)  $
 
@@ -500,7 +505,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
               ispec    = mkLocalInstance dfun overlap_flag
               inst_info = InstInfo { iSpec  = ispec, iBinds = VanillaInst binds uprags False }
 
-        ; return ( inst_info, fam_insts0 ++ concat fam_insts1) }
+        ; return ( [inst_info], fam_insts0 ++ concat fam_insts1) }
 \end{code}
 
 %************************************************************************
@@ -515,12 +520,6 @@ lot of kinding and type checking code with ordinary algebraic data types (and
 GADTs).
 
 \begin{code}
-tcTopFamInstDecl :: LTyClDecl Name -> TcM FamInst
-tcTopFamInstDecl (L loc decl)
-  = setSrcSpan loc      $
-    tcAddDeclCtxt decl  $
-    tcFamInstDecl TopLevel decl
-
 tcFamInstDecl :: TopLevelFlag -> TyClDecl Name -> TcM FamInst
 tcFamInstDecl top_lvl decl
   = do { -- Type family instances require -XTypeFamilies
index 2c28655..95d7d23 100644 (file)
@@ -101,13 +101,10 @@ tcTyAndClassDecls :: ModDetails
                   -> TcM TcGblEnv       -- Input env extended by types and classes
                                         -- and their implicit Ids,DataCons
 -- Fails if there are any errors
-tcTyAndClassDecls boot_details decls_s
-  = checkNoErrs $ do    -- The code recovers internally, but if anything gave rise to
+tcTyAndClassDecls boot_details tyclds_s
+  = checkNoErrs $       -- The code recovers internally, but if anything gave rise to
                         -- an error we'd better stop now, to avoid a cascade
-  { let tyclds_s = map (filterOut (isFamInstDecl . unLoc)) decls_s
-                   -- Remove family instance decls altogether
-                   -- They are dealt with by TcInstDcls
-  ; fold_env tyclds_s }  -- type check each group in dependency order folding the global env
+    fold_env tyclds_s   -- type check each group in dependency order folding the global env
   where
     fold_env :: [TyClGroup Name] -> TcM TcGblEnv
     fold_env [] = getGblEnv
@@ -379,7 +376,7 @@ kcTyClDecl decl@(TyFamily {})
   = kcFamilyDecl [] decl      -- the empty list signals a toplevel decl
 
 kcTyClDecl decl@(TyData {})
-  = ASSERT( not . isFamInstDecl $ decl )   -- must not be a family instance
+  = ASSERT2( not . isFamInstDecl $ decl, ppr decl )   -- must not be a family instance
     kcTyClDeclBody decl        $ \_ -> kcDataDecl decl
 
 kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
index 95d4323..c0e5180 100644 (file)
@@ -253,7 +253,7 @@ boundValues mod group =
                        , bind <- bagToList binds
                        , x <- boundThings mod bind ]
                _other -> error "boundValues"
-      tys = [ n | ns <- map hsTyClDeclBinders (concat (hs_tyclds group))
+      tys = [ n | ns <- map hsLTyClDeclBinders (concat (hs_tyclds group))
                 , n <- map found ns ]
       fors = concat $ map forBound (hs_fords group)
              where forBound lford = case unLoc lford of