Refactor the implementation.
authorJose Pedro Magalhaes <jpm@cs.uu.nl>
Tue, 4 Oct 2011 13:43:42 +0000 (14:43 +0100)
committerJose Pedro Magalhaes <jpm@cs.uu.nl>
Tue, 4 Oct 2011 13:44:26 +0000 (14:44 +0100)
compiler/typecheck/TcDeriv.lhs [changed mode: 0644->0755]
compiler/typecheck/TcGenDeriv.lhs [changed mode: 0644->0755]
compiler/types/Generics.lhs [changed mode: 0644->0755]

old mode 100644 (file)
new mode 100755 (executable)
index fab148d..afe82c0
@@ -314,16 +314,20 @@ tcDeriving tycl_decls inst_decls deriv_decls
 
        ; overlap_flag <- getOverlapFlag
        ; let (infer_specs, given_specs) = splitEithers early_specs
-       ; deriv1 <- flatMapBagM (genInst True overlap_flag) (listToBag given_specs)
-       ; let (insts,_) = partitionBagWith unDerivInst deriv1
+       ; insts1 <- mapM (genInst True overlap_flag) given_specs
+--     ; let (insts,_) = partitionBagWith unDerivInst deriv1
 
-       ; final_specs <- extendLocalInstEnv (map iSpec (bagToList insts)) $
-                        inferInstanceContexts overlap_flag infer_specs
+       ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
+                           inferInstanceContexts overlap_flag infer_specs
 
-       ; deriv2 <- flatMapBagM (genInst False overlap_flag) (listToBag final_specs)
+       ; insts2 <- mapM (genInst False overlap_flag) final_specs
 
-       ; (inst_info, rn_binds, rn_dus)
-                <- renameDeriv is_boot (deriv1 `unionBags` deriv2)
+        ; let (inst_infos, deriv_stuff) = unzip (insts1 ++ insts2)
+        ; loc <- getSrcSpanM
+        ; let (binds, newTyCons, famInsts, extraInstances) = 
+                genAuxBinds loc (rm_dups (unionManyBags deriv_stuff))
+        ; (inst_info, rn_binds, rn_dus) <-
+            renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds
 
        ; dflags <- getDOpts
        ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
@@ -332,7 +336,7 @@ tcDeriving tycl_decls inst_decls deriv_decls
         ; when (not (null inst_info)) $
           dumpDerivingInfo (ddump_deriving inst_info rn_binds)
 -}
-
+{-
   ; let unGenBinds (DerivGenMetaTyCons x) = Left (Right x)
         unGenBinds (DerivGenRepTyCon x)   = Left (Left x)
         unGenBinds x                      = Right x
@@ -341,14 +345,19 @@ tcDeriving tycl_decls inst_decls deriv_decls
         (repTyConsB, repMetaTysB) = partitionBagWith id genBinds
         (repTyCons, repMetaTys) = (bagToList repTyConsB, bagToList repMetaTysB)
         all_tycons = map ATyCon (repTyCons ++ concat (map metaTyCons2TyCons repMetaTys))
-
+-}
+  ; let all_tycons = map ATyCon (bagToList newTyCons)
   ; gbl_env <- tcExtendGlobalEnv all_tycons $
                tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $
-               tcExtendLocalFamInstEnv (map mkLocalFamInst repTyCons) $
+               tcExtendLocalFamInstEnv (map mkLocalFamInst (bagToList famInsts)) $
                tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
 
   ; return (addTcgDUs gbl_env rn_dus, inst_info, rn_binds) }
   where
+    -- Remove duplicate requests for auxilliary bindings
+    rm_dups = foldrBag dup_check emptyBag
+    dup_check a b = if anyBag (isDupAux a) b then b else consBag a b
+
     ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name 
                    -> [MetaTyCons] -- ^ Empty data constructors
                    -> [TyCon]      -- ^ Rep type family instances
@@ -372,14 +381,16 @@ tcDeriving tycl_decls inst_decls deriv_decls
 
 
 renameDeriv :: Bool
-           -> BagDerivStuff --[(InstInfo RdrName, DerivAuxBinds)]
+           -> [InstInfo RdrName]
+           -> Bag (LHsBind RdrName, LSig RdrName)
            -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses)
-renameDeriv is_boot insts
+renameDeriv is_boot inst_infos bagBinds
   | is_boot    -- If we are compiling a hs-boot file, don't generate any derived bindings
                -- The inst-info bindings will all be empty, but it's easier to
                -- just use rn_inst_info to change the type appropriately
-  = do { (rn_inst_infos, fvs) <- mapAndUnzipBagM rn_inst_info inst_infos
-       ; return (rn_inst_infos, emptyValBindsOut, usesOnly (plusFVs (bagToList fvs))) }
+  = do { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos
+       ; return ( listToBag rn_inst_infos
+                 , emptyValBindsOut, usesOnly (plusFVs fvs)) }
 
   | otherwise
   = discardWarnings $   -- Discard warnings about unused bindings etc
@@ -387,22 +398,21 @@ renameDeriv is_boot insts
                -- Generate and rename any extra not-one-inst-decl-specific binds, 
                -- notably "con2tag" and/or "tag2con" functions.  
                -- Bring those names into scope before renaming the instances themselves
-         loc <- getSrcSpanM    -- Generic loc for shared bindings
-       ; (aux_binds, aux_sigs) <- genAuxBinds loc (rm_dups other_binds)
+--       loc <- getSrcSpanM    -- Generic loc for shared bindings
+       ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds
        ; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs)
        ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
        ; bindLocalNames (collectHsValBinders rn_aux_lhs) $ 
     do { (rn_aux, dus_aux) <- rnTopBindsRHS rn_aux_lhs
-       ; (rn_inst_infos, fvs_insts) <- mapAndUnzipBagM rn_inst_info inst_infos
-       ; return (rn_inst_infos, rn_aux,
-                  dus_aux `plusDU` usesOnly (plusFVs (bagToList fvs_insts))) } }
+       ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
+       ; return (listToBag rn_inst_infos, rn_aux,
+                  dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
 
   where
-    (inst_infos, other_binds) = partitionBagWith unDerivInst insts
-
-       -- Remove duplicate requests for auxilliary bindings
-    rm_dups = foldrBag dup_check emptyBag
-    dup_check a b = if anyBag (isDupAux a) b then b else consBag a b
+{-
+    --(inst_infos, other_binds) = partitionBagWith unDerivInst insts
+    (inst_infos, other_binds) = unzip insts
+-}
 
     rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
     rn_inst_info info@(InstInfo { iBinds = NewTypeDerived coi tc })
@@ -421,10 +431,11 @@ renameDeriv is_boot insts
        where
          (tyvars,_, clas,_) = instanceHead inst
          clas_nm            = className clas
-
+{-
 unDerivInst :: DerivStuff -> Either (InstInfo RdrName) DerivStuff
 unDerivInst (DerivInst x) = Left x
 unDerivInst  x            = Right x
+-}
 \end{code}
 
 Note [Newtype deriving and unused constructors]
@@ -456,16 +467,6 @@ stored in NewTypeDerived.
 @makeDerivSpecs@ fishes around to find the info about needed derived instances.
 
 \begin{code}
--- Make the "extras" for the generic representation
-mkGenDerivExtras :: TyCon -> Module
-                 -> TcRn BagDerivStuff
-mkGenDerivExtras tc mod = do
-        { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc mod
-        ; metaInsts                <- genDtMeta (tc, metaTyCons)
-        ; return (            unitBag (DerivGenMetaTyCons metaTyCons)
-                  `unionBags` unitBag (DerivGenRepTyCon rep0TyInst)
-                  `unionBags` metaInsts) }
-
 makeDerivSpecs :: Bool 
               -> [LTyClDecl Name] 
               -> [LInstDecl Name]
@@ -1469,41 +1470,45 @@ the renamer.  What a great hack!
 --
 genInst :: Bool             -- True <=> standalone deriving
         -> OverlapFlag
-        -> DerivSpec -> TcM BagDerivStuff
+        -> DerivSpec -> TcM (InstInfo RdrName, BagDerivStuff)
 genInst standalone_deriv oflag
         spec@(DS { ds_tc = rep_tycon, ds_tc_args = rep_tc_args
                  , ds_theta = theta, ds_newtype = is_newtype
                  , ds_name = name, ds_cls = clas })
   | is_newtype
-  = return $ unitBag $ DerivInst $ 
-      InstInfo { iSpec   = inst_spec
-               , iBinds  = NewTypeDerived co rep_tycon }
+  = return (InstInfo { iSpec   = inst_spec
+                     , iBinds  = NewTypeDerived co rep_tycon }, emptyBag)
 
   | otherwise
   = do { fix_env <- getFixityEnv
-       ; let { loc = getSrcSpan name
-             ; deriv_stuff = genDerivStuff loc fix_env clas rep_tycon
+       ; (meth_binds, deriv_stuff) <- genDerivStuff (getSrcSpan name) 
+                                        fix_env clas name rep_tycon
+       ; let { 
+{-
              ; (meth_binds', aux_binds) = partitionBag isDerivHsBind deriv_stuff
              ; meth_binds = mapBag unDerivHsBind meth_binds'
+-}
                   -- In case of a family instance, we need to use the representation
                   -- tycon (after all, it has the data constructors)
 
              ; inst_info = InstInfo { iSpec   = inst_spec
                                     , iBinds  = VanillaInst meth_binds []
                                                   standalone_deriv } }
+{-
        -- Generate the extra representation types and instances needed for a
        -- `Generic` instance
        ; generics_extras <- if classKey clas == genClassKey
-                             then mkGenDerivExtras rep_tycon (nameModule name)
+                             then gen_Generic_binds rep_tycon (nameModule name)
                               else return emptyBag
-
-       ; return (unitBag (DerivInst inst_info)
-                   `unionBags` aux_binds `unionBags` generics_extras) }
+-}
+       ; return ( inst_info, deriv_stuff) }
   where
+{-
     isDerivHsBind (DerivHsBind _) = True
     isDerivHsBind  _              = False
     unDerivHsBind (DerivHsBind x) = x
     unDerivHsBind _               = panic "unDerivHsBind"
+-}
     inst_spec = mkInstance oflag theta spec
     co1 = case tyConFamilyCoercion_maybe rep_tycon of
               Just co_con -> mkAxInstCo co_con rep_tc_args
@@ -1521,18 +1526,21 @@ genInst standalone_deriv oflag
 --    co2 : R1:N (b,b) ~ Tree (b,b)
 --    co  : N [(b,b)] ~ Tree (b,b)
 
-genDerivStuff :: SrcSpan -> FixityEnv -> Class -> TyCon
-              -> BagDerivStuff -- (LHsBinds RdrName, DerivAuxBinds)
-genDerivStuff loc fix_env clas tycon
+genDerivStuff :: SrcSpan -> FixityEnv -> Class -> Name -> TyCon
+              -> TcM (LHsBinds RdrName, BagDerivStuff)
+genDerivStuff loc fix_env clas name tycon
   | className clas `elem` typeableClassNames
-  = gen_Typeable_binds loc tycon
+  = return (gen_Typeable_binds loc tycon, emptyBag)
+
+  | classKey clas == genClassKey
+  = gen_Generic_binds tycon (nameModule name)
 
   | otherwise
   = case assocMaybe gen_list (getUnique clas) of
-       Just gen_fn -> gen_fn loc tycon
+       Just gen_fn -> return (gen_fn loc tycon)
        Nothing     -> pprPanic "genDerivStuff: bad derived class" (ppr clas)
   where
-    gen_list :: [(Unique, SrcSpan -> TyCon -> BagDerivStuff)]
+    gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
     gen_list = [(eqClassKey,            gen_Eq_binds)
               ,(ordClassKey,           gen_Ord_binds)
               ,(enumClassKey,          gen_Enum_binds)
@@ -1544,7 +1552,6 @@ genDerivStuff loc fix_env clas tycon
               ,(functorClassKey,       gen_Functor_binds)
               ,(foldableClassKey,      gen_Foldable_binds)
               ,(traversableClassKey,   gen_Traversable_binds)
-              ,(genClassKey,           genGenericBinds)
               ]
 \end{code}
 
@@ -1566,9 +1573,19 @@ For the generic representation we need to generate:
 @genGenericAll@ does all of them
 
 \begin{code}
+gen_Generic_binds :: TyCon -> Module
+                 -> TcM (LHsBinds RdrName, BagDerivStuff)
+gen_Generic_binds tc mod = do
+        { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc mod
+        ; metaInsts                <- genDtMeta (tc, metaTyCons)
+        ; return ( mkBindsRep tc
+                 ,           (DerivFamInst rep0TyInst)
+                   `consBag` ((mapBag DerivTyCon (metaTyCons2TyCons metaTyCons))
+                   `unionBags` metaInsts)) }
+{-
 genGenericBinds :: SrcSpan -> TyCon -> BagDerivStuff
 genGenericBinds _ tc = mapBag DerivHsBind $ mkBindsRep tc
-
+-}
 genGenericRepExtras :: TyCon -> Module -> TcM (MetaTyCons, TyCon)
 genGenericRepExtras tc mod =
   do  uniqS <- newUniqueSupply
old mode 100644 (file)
new mode 100755 (executable)
index 4846d00..ca84d21
@@ -12,7 +12,7 @@ This is where we do all the grimy bindings' generation.
 
 \begin{code}
 module TcGenDeriv (
-       BagDerivStuff, DerivStuff(..),
+       BagDerivStuff, DerivStuff(..), isDupAux,
 
        gen_Bounded_binds,
        gen_Enum_binds,
@@ -28,8 +28,8 @@ module TcGenDeriv (
        deepSubtypesContaining, foldDataConArgs,
        gen_Foldable_binds,
        gen_Traversable_binds,
-       genAuxBinds, isDupAux,
-       ordOpTbl, boxConTbl
+       genAuxBind, genAuxBinds,
+        ordOpTbl, boxConTbl
     ) where
 
 #include "HsVersions.h"
@@ -62,44 +62,56 @@ import FastString
 import Bag
 import Fingerprint
 import Constants
-import Generics (MetaTyCons)
 import TcEnv (InstInfo)
 
 import Data.List        ( partition, intersperse )
 \end{code}
 
 \begin{code}
+{-
+type DerivAuxBinds = [DerivAuxBind]
+
+data DerivAuxBind              -- Please add these auxiliary top-level bindings
+  = DerivCon2Tag TyCon         -- The con2Tag for given TyCon
+  | DerivTag2Con TyCon         -- ...ditto tag2Con
+  | DerivMaxTag  TyCon         -- ...and maxTag
+       -- All these generate ZERO-BASED tag operations
+       -- I.e first constructor has tag 0
+
+       -- Scrap your boilerplate
+  | MkDataCon DataCon          -- For constructor C we get $cC :: Constr
+  | MkTyCon   TyCon            -- For tycon T we get       $tT :: DataType
+-}
 type BagDerivStuff = Bag DerivStuff
 
-data DerivStuff     -- Please add these auxiliary top-level bindings
+data DerivStuff     -- Please add these auxiliary stuff
   = DerivCon2Tag TyCon  -- The con2Tag for given TyCon
   | DerivTag2Con TyCon  -- ...ditto tag2Con
   | DerivMaxTag  TyCon  -- ...and maxTag
   -- All these generate ZERO-BASED tag operations
   -- I.e first constructor has tag 0
 
-
   -- Generics
-  | DerivGenMetaTyCons MetaTyCons   -- New data types
-  | DerivGenRepTyCon TyCon         -- New type family instances
+  | DerivTyCon TyCon      -- New data types
+  | DerivFamInst TyCon    -- New type family instances
 
-  | DerivHsBind (LHsBind RdrName)  -- Yes, but not for the method bindings
-                                  -- Rather for top-level auxiliary bindings
+  | DerivHsBind (LHsBind RdrName)  -- New top-level auxiliary bindings
+  | DerivInst (InstInfo RdrName)   -- New, auxiliary instances
 
   -- Scrap your boilerplate (replaced  by DerivHsBind)
 --  | DerivDataCon DataCon    -- For constructor C we get $cC :: Constr
 --  | DerivTyCon   TyCon      -- For tycon T we get       $tT :: DataType
 
+  
+  
 
 isDupAux :: DerivStuff -> DerivStuff -> Bool
-isDupAux (DerivCon2Tag tc1)       (DerivCon2Tag tc2)       = tc1 == tc2
-isDupAux (DerivTag2Con tc1)       (DerivTag2Con tc2)       = tc1 == tc2
-isDupAux (DerivMaxTag tc1)        (DerivMaxTag tc2)        = tc1 == tc2
-isDupAux (DerivDataCon dc1)       (DerivDataCon dc2)       = dc1 == dc2
-isDupAux (DerivTyCon tc1)         (DerivTyCon tc2)         = tc1 == tc2
--- We are certain we do not introduce duplicates for the other cases
-isDupAux  _                        _                       = False
-
+isDupAux (DerivCon2Tag tc1) (DerivCon2Tag tc2) = tc1 == tc2
+isDupAux (DerivTag2Con tc1) (DerivTag2Con tc2) = tc1 == tc2
+isDupAux (DerivMaxTag tc1)  (DerivMaxTag tc2)  = tc1 == tc2
+isDupAux (DerivTyCon tc1)   (DerivTyCon tc2)   = tc1 == tc2
+isDupAux (DerivFamInst tc1) (DerivFamInst tc2) = tc1 == tc2
+isDupAux _                   _                 = False
 \end{code}
 
 
@@ -178,9 +190,9 @@ instance ... Eq (Foo ...) where
 
 
 \begin{code}
-gen_Eq_binds :: SrcSpan -> TyCon -> BagDerivStuff
+gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 gen_Eq_binds loc tycon
-  = method_binds `unionBags` aux_binds
+  = (method_binds, aux_binds)
   where
     (nullary_cons, nonnullary_cons)
        | isNewTyCon tycon = ([], tyConDataCons tycon)
@@ -199,9 +211,9 @@ gen_Eq_binds loc tycon
                       (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
 
     aux_binds | no_nullary_cons = emptyBag
-             | otherwise       = unitBag (DerivCon2Tag tycon)
+             | otherwise       = unitBag $ DerivCon2Tag tycon
 
-    method_binds = listToBag (map DerivHsBind [eq_bind, ne_bind])
+    method_binds = listToBag [eq_bind, ne_bind]
     eq_bind = mk_FunBind loc eq_RDR (map pats_etc nonnullary_cons ++ rest)
     ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
                        nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
@@ -336,19 +348,15 @@ gtResult OrdGE      = true_Expr
 gtResult OrdGT      = true_Expr
 
 ------------
-gen_Ord_binds :: SrcSpan -> TyCon -> BagDerivStuff
+gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 gen_Ord_binds loc tycon
   | null tycon_data_cons       -- No data-cons => invoke bale-out case
-  = unitBag $ DerivHsBind $ mk_FunBind loc compare_RDR []
+  = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag)
   | otherwise
-  =   unitBag (mkOrdOp OrdCompare)
-    `unionBags`
-      other_ops
-    `unionBags`
-      aux_binds
+  = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
   where
     aux_binds | single_con_type = emptyBag
-              | otherwise       = unitBag (DerivCon2Tag tycon)
+              | otherwise       = unitBag $ DerivCon2Tag tycon
 
        -- Note [Do not rely on compare]
     other_ops | (last_tag - first_tag) <= 2    -- 1-3 constructors
@@ -371,11 +379,9 @@ gen_Ord_binds loc tycon
     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
     
 
-    mkOrdOp :: OrdOp -> DerivStuff --LHsBind RdrName
+    mkOrdOp :: OrdOp -> LHsBind RdrName
     -- Returns a binding   op a b = ... compares a and b according to op ....
-    mkOrdOp op = DerivHsBind $ 
-                   mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] 
-                     (mkOrdOpRhs op)
+    mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op)
 
     mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
     mkOrdOpRhs op      -- RHS for comparing 'a' and 'b' according to op
@@ -565,18 +571,18 @@ instance ... Enum (Foo ...) where
 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 
 \begin{code}
-gen_Enum_binds :: SrcSpan -> TyCon -> BagDerivStuff
+gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 gen_Enum_binds loc tycon
-  = method_binds `unionBags` aux_binds
+  = (method_binds, aux_binds)
   where
-    method_binds = listToBag (map DerivHsBind [
+    method_binds = listToBag [
                        succ_enum,
                        pred_enum,
                        to_enum,
                        enum_from,
                        enum_from_then,
                        from_enum
-                   ])
+                   ]
     aux_binds = listToBag [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
 
     occ_nm = getOccString tycon
@@ -644,13 +650,13 @@ gen_Enum_binds loc tycon
 %************************************************************************
 
 \begin{code}
-gen_Bounded_binds :: SrcSpan -> TyCon -> BagDerivStuff
+gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 gen_Bounded_binds loc tycon
   | isEnumerationTyCon tycon
-  = listToBag (map DerivHsBind [min_bound_enum, max_bound_enum])
+  = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
   | otherwise
   = ASSERT(isSingleton data_cons)
-    (listToBag (map DerivHsBind [min_bound_1con, max_bound_1con]))
+    (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
   where
     data_cons = tyConDataCons tycon
 
@@ -731,17 +737,16 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report
 (p.~147).
 
 \begin{code}
-gen_Ix_binds :: SrcSpan -> TyCon -> BagDerivStuff
+gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 
 gen_Ix_binds loc tycon
   | isEnumerationTyCon tycon
-  = enum_ixes `unionBags` 
-      listToBag [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
+  = (enum_ixes, listToBag [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
   | otherwise
-  = single_con_ixes `unionBags` unitBag (DerivCon2Tag tycon)
+  = (single_con_ixes, unitBag (DerivCon2Tag tycon))
   where
     --------------------------------------------------------------
-    enum_ixes = listToBag (map DerivHsBind [enum_range, enum_index, enum_inRange])
+    enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
 
     enum_range
       = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
@@ -780,8 +785,8 @@ gen_Ix_binds loc tycon
          ))))
 
     --------------------------------------------------------------
-    single_con_ixes = listToBag (map DerivHsBind 
-                        [single_con_range, single_con_index, single_con_inRange])
+    single_con_ixes 
+      = listToBag [single_con_range, single_con_index, single_con_inRange]
 
     data_con
       =        case tyConSingleDataCon_maybe tycon of -- just checking...
@@ -891,10 +896,10 @@ instance Read T where
 
 
 \begin{code}
-gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> BagDerivStuff
+gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 
 gen_Read_binds get_fixity loc tycon
-  = listToBag (map DerivHsBind [read_prec, default_readlist, default_readlistprec])
+  = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
   where
     -----------------------------------------------------------------------
     default_readlist 
@@ -1060,10 +1065,10 @@ Example
                    -- the most tightly-binding operator
 
 \begin{code}
-gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> BagDerivStuff
+gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 
 gen_Show_binds get_fixity loc tycon
-  = listToBag (map DerivHsBind [shows_prec, show_list])
+  = (listToBag [shows_prec, show_list], emptyBag)
   where
     -----------------------------------------------------------------------
     show_list = mkHsVarBind loc showList_RDR
@@ -1192,9 +1197,9 @@ we generate
 We are passed the Typeable2 class as well as T
 
 \begin{code}
-gen_Typeable_binds :: SrcSpan -> TyCon -> BagDerivStuff --LHsBinds RdrName
+gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName
 gen_Typeable_binds loc tycon
-  = unitBag $ DerivHsBind $
+  = unitBag $
        mk_easy_FunBind loc 
                (mk_typeOf_RDR tycon)   -- Name of appropriate type0f function
                [nlWildPat] 
@@ -1270,17 +1275,57 @@ we generate
 
     
 \begin{code}
-gen_Data_binds :: SrcSpan -> TyCon -> BagDerivStuff
+gen_Data_binds :: SrcSpan
+              -> TyCon 
+              -> (LHsBinds RdrName,    -- The method bindings
+                  BagDerivStuff)       -- Auxiliary bindings
 gen_Data_binds loc tycon
-  =   listToBag (map DerivHsBind [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind])
-    `unionBags` gcast_binds
-    -- Auxiliary definitions: the data type and constructors
-    `unionBags` (listToBag (DerivTyCon tycon : map DerivDataCon data_cons))
+  = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
+     `unionBags` gcast_binds,
+               -- Auxiliary definitions: the data type and constructors
+     listToBag ( DerivHsBind (fst genDataTyCon)
+               : map (DerivHsBind . fst . genDataDataCon) data_cons))
+                -- JPM: We are dropping the signatures. Is this a problem?
   where
     data_cons  = tyConDataCons tycon
     n_cons     = length data_cons
     one_constr = n_cons == 1
 
+    genDataTyCon :: (LHsBind RdrName, LSig RdrName)
+    genDataTyCon        --  $dT
+      = (mkHsVarBind loc rdr_name rhs,
+         L loc (TypeSig [L loc rdr_name] sig_ty))
+      where
+        rdr_name = mk_data_type_name tycon
+        sig_ty   = nlHsTyVar dataType_RDR
+        constrs  = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
+        rhs = nlHsVar mkDataType_RDR 
+              `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
+              `nlHsApp` nlList constrs
+
+    genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName)
+    genDataDataCon dc       --  $cT1 etc
+      = (mkHsVarBind loc rdr_name rhs,
+         L loc (TypeSig [L loc rdr_name] sig_ty))
+      where
+        rdr_name = mk_constr_name dc
+        sig_ty   = nlHsTyVar constr_RDR
+        rhs      = nlHsApps mkConstr_RDR constr_args
+    
+        constr_args 
+           = [ -- nlHsIntLit (toInteger (dataConTag dc)),        -- Tag
+          nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
+          nlHsLit (mkHsString (occNameString dc_occ)),   -- String name
+               nlList  labels,                           -- Field labels
+          nlHsVar fixity]                                -- Fixity
+    
+        labels   = map (nlHsLit . mkHsString . getOccString)
+                       (dataConFieldLabels dc)
+        dc_occ   = getOccName dc
+        is_infix = isDataSymOcc dc_occ
+        fixity | is_infix  = infix_RDR
+          | otherwise = prefix_RDR
+
        ------------ gfoldl
     gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
           
@@ -1333,7 +1378,7 @@ gen_Data_binds loc tycon
                | tycon_kind `eqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
                | otherwise           = emptyBag
     mk_gcast dataCast_RDR gcast_RDR 
-      = unitBag (DerivHsBind $ mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR] 
+      = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR] 
                                  (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
 
 
@@ -1432,12 +1477,12 @@ This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
   $(cofmap 'a '(b -> c))  x  =  \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
 
 \begin{code}
-gen_Functor_binds :: SrcSpan -> TyCon -> BagDerivStuff
+gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 gen_Functor_binds loc tycon
-  = unitBag fmap_bind
+  = (unitBag fmap_bind, emptyBag)
   where
     data_cons = tyConDataCons tycon
-    fmap_bind = DerivHsBind $ L loc $ mkRdrFunBind (L loc fmap_RDR) eqns
+    fmap_bind = L loc $ mkRdrFunBind (L loc fmap_RDR) eqns
                                   
     fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
       where 
@@ -1603,13 +1648,13 @@ Note that the arguments to the real foldr function are the wrong way around,
 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
 
 \begin{code}
-gen_Foldable_binds :: SrcSpan -> TyCon -> BagDerivStuff
+gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 gen_Foldable_binds loc tycon
-  = unitBag foldr_bind
+  = (unitBag foldr_bind, emptyBag)
   where
     data_cons = tyConDataCons tycon
 
-    foldr_bind = DerivHsBind $ L loc $ mkRdrFunBind (L loc foldable_foldr_RDR) eqns
+    foldr_bind = L loc $ mkRdrFunBind (L loc foldable_foldr_RDR) eqns
     eqns = map foldr_eqn data_cons
     foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
       where 
@@ -1655,13 +1700,13 @@ gives the function: traverse f (T x y) = T <$> pure x <*> f y
 instead of:         traverse f (T x y) = T x <$> f y
 
 \begin{code}
-gen_Traversable_binds :: SrcSpan -> TyCon -> BagDerivStuff
+gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 gen_Traversable_binds loc tycon
-  = unitBag traverse_bind
+  = (unitBag traverse_bind, emptyBag)
   where
     data_cons = tyConDataCons tycon
 
-    traverse_bind = DerivHsBind $ L loc $ mkRdrFunBind (L loc traverse_RDR) eqns
+    traverse_bind = L loc $ mkRdrFunBind (L loc traverse_RDR) eqns
     eqns = map traverse_eqn data_cons
     traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
       where 
@@ -1755,51 +1800,37 @@ genAuxBind loc (DerivMaxTag tycon)
     max_tag =  case (tyConDataCons tycon) of
                 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
 
-genAuxBind loc (DerivTyCon tycon)      --  $dT
-  = (mkHsVarBind loc rdr_name rhs,
-     L loc (TypeSig [L loc rdr_name] sig_ty))
-  where
-    rdr_name = mk_data_type_name tycon
-    sig_ty   = nlHsTyVar dataType_RDR
-    constrs  = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
-    rhs = nlHsVar mkDataType_RDR 
-          `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
-          `nlHsApp` nlList constrs
-
-genAuxBind loc (DerivDataCon dc)       --  $cT1 etc
-  = (mkHsVarBind loc rdr_name rhs,
-     L loc (TypeSig [L loc rdr_name] sig_ty))
-  where
-    rdr_name = mk_constr_name dc
-    sig_ty   = nlHsTyVar constr_RDR
-    rhs      = nlHsApps mkConstr_RDR constr_args
-
-    constr_args 
-       = [ -- nlHsIntLit (toInteger (dataConTag dc)),    -- Tag
-          nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
-          nlHsLit (mkHsString (occNameString dc_occ)),   -- String name
-           nlList  labels,                               -- Field labels
-          nlHsVar fixity]                                -- Fixity
-
-    labels   = map (nlHsLit . mkHsString . getOccString)
-                   (dataConFieldLabels dc)
-    dc_occ   = getOccName dc
-    is_infix = isDataSymOcc dc_occ
-    fixity | is_infix  = infix_RDR
-          | otherwise = prefix_RDR
-
--- We know we do not call genAuxBind with the generics stuff
-genAuxBind _ _ = panic "genAuxBind"
-
-genAuxBinds :: Monad m => SrcSpan -> BagDerivStuff -> m ( Bag (LHsBind RdrName)
-                                                        , Bag (LSig RdrName))
-genAuxBinds loc bs = mapAndUnzipBagM (return . genAuxBind loc) auxBinds where
-  partf x@(DerivGenMetaTyCons _) = Left x
-  partf x@(DerivGenRepTyCon _)   = Left x
-  partf x@(DerivInst _)          = Left x
-  partf x@(DerivHsBind _)        = Left x
-  partf x                        = Right x
-  (_, auxBinds) = partitionBagWith partf bs
+genAuxBind loc _ = panic "genAuxBind"
+
+genAuxBinds :: SrcSpan -> BagDerivStuff
+            -> ( Bag (LHsBind RdrName, LSig RdrName)
+               , Bag TyCon
+               , Bag TyCon
+               , Bag (InstInfo RdrName))
+{-
+genAuxBinds loc = mapBag (genAuxBind loc) . filterBag (not . isGen)
+  isGen (DerivCon2Tag _) = True
+  isGen (DerivTag2Con _) = True
+  isGen (DerivMaxTag _)  = True
+  isGen (DerivTyCon t) =             = False
+  isGen (DerivFamInst t) =             = False
+-}
+genAuxBinds loc s = foldrBag f (emptyBag, emptyBag, emptyBag, emptyBag) s where
+  f :: DerivStuff
+    -> (Bag (LHsBind RdrName, LSig RdrName), Bag TyCon, Bag TyCon, Bag (InstInfo RdrName))
+    -> (Bag (LHsBind RdrName, LSig RdrName), Bag TyCon, Bag TyCon, Bag (InstInfo RdrName))
+  f x@(DerivCon2Tag   _) = add1 (genAuxBind loc x)
+  f x@(DerivTag2Con   _) = add1 (genAuxBind loc x)
+  f x@(DerivMaxTag    _) = add1 (genAuxBind loc x)
+  f   (DerivTyCon   t) = add2 t
+  f   (DerivFamInst t) = add3 t
+  f   (DerivInst    i) = add4 i
+  f    _               = id
+
+  add1 x (a,b,c,d) = (x `consBag` a,b,c,d)
+  add2 x (a,b,c,d) = (a,x `consBag` b,c,d)
+  add3 x (a,b,c,d) = (a,b,x `consBag` c,d)
+  add4 x (a,b,c,d) = (a,b,c,x `consBag` d)
 
 mk_data_type_name :: TyCon -> RdrName  -- "$tT"
 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
old mode 100644 (file)
new mode 100755 (executable)
index a2ded63..d594b68
@@ -224,8 +224,8 @@ data MetaTyCons = MetaTyCons { -- One meta datatype per dataype
 instance Outputable MetaTyCons where
   ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s))
                                    
-metaTyCons2TyCons :: MetaTyCons -> [TyCon]
-metaTyCons2TyCons (MetaTyCons d c s) = d : c ++ concat s
+metaTyCons2TyCons :: MetaTyCons -> Bag TyCon
+metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s)
 
 
 -- Bindings for Datatype, Constructor, and Selector instances