Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Refactor the implementation.

  • Loading branch information...
commit acc2451d5df3a5523a362e029b1b6d63e3fe3196 1 parent 3a9fddd
José Pedro Magalhães dreixel authored
123 compiler/typecheck/TcDeriv.lhs 100644 → 100755
@@ -314,16 +314,20 @@ tcDeriving tycl_decls inst_decls deriv_decls
314 314
315 315 ; overlap_flag <- getOverlapFlag
316 316 ; let (infer_specs, given_specs) = splitEithers early_specs
317   - ; deriv1 <- flatMapBagM (genInst True overlap_flag) (listToBag given_specs)
318   - ; let (insts,_) = partitionBagWith unDerivInst deriv1
  317 + ; insts1 <- mapM (genInst True overlap_flag) given_specs
  318 +-- ; let (insts,_) = partitionBagWith unDerivInst deriv1
319 319
320   - ; final_specs <- extendLocalInstEnv (map iSpec (bagToList insts)) $
321   - inferInstanceContexts overlap_flag infer_specs
  320 + ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
  321 + inferInstanceContexts overlap_flag infer_specs
322 322
323   - ; deriv2 <- flatMapBagM (genInst False overlap_flag) (listToBag final_specs)
  323 + ; insts2 <- mapM (genInst False overlap_flag) final_specs
324 324
325   - ; (inst_info, rn_binds, rn_dus)
326   - <- renameDeriv is_boot (deriv1 `unionBags` deriv2)
  325 + ; let (inst_infos, deriv_stuff) = unzip (insts1 ++ insts2)
  326 + ; loc <- getSrcSpanM
  327 + ; let (binds, newTyCons, famInsts, extraInstances) =
  328 + genAuxBinds loc (rm_dups (unionManyBags deriv_stuff))
  329 + ; (inst_info, rn_binds, rn_dus) <-
  330 + renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds
327 331
328 332 ; dflags <- getDOpts
329 333 ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
@@ -332,7 +336,7 @@ tcDeriving tycl_decls inst_decls deriv_decls
332 336 ; when (not (null inst_info)) $
333 337 dumpDerivingInfo (ddump_deriving inst_info rn_binds)
334 338 -}
335   -
  339 +{-
336 340 ; let unGenBinds (DerivGenMetaTyCons x) = Left (Right x)
337 341 unGenBinds (DerivGenRepTyCon x) = Left (Left x)
338 342 unGenBinds x = Right x
@@ -341,14 +345,19 @@ tcDeriving tycl_decls inst_decls deriv_decls
341 345 (repTyConsB, repMetaTysB) = partitionBagWith id genBinds
342 346 (repTyCons, repMetaTys) = (bagToList repTyConsB, bagToList repMetaTysB)
343 347 all_tycons = map ATyCon (repTyCons ++ concat (map metaTyCons2TyCons repMetaTys))
344   -
  348 +-}
  349 + ; let all_tycons = map ATyCon (bagToList newTyCons)
345 350 ; gbl_env <- tcExtendGlobalEnv all_tycons $
346 351 tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $
347   - tcExtendLocalFamInstEnv (map mkLocalFamInst repTyCons) $
  352 + tcExtendLocalFamInstEnv (map mkLocalFamInst (bagToList famInsts)) $
348 353 tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
349 354
350 355 ; return (addTcgDUs gbl_env rn_dus, inst_info, rn_binds) }
351 356 where
  357 + -- Remove duplicate requests for auxilliary bindings
  358 + rm_dups = foldrBag dup_check emptyBag
  359 + dup_check a b = if anyBag (isDupAux a) b then b else consBag a b
  360 +
352 361 ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
353 362 -> [MetaTyCons] -- ^ Empty data constructors
354 363 -> [TyCon] -- ^ Rep type family instances
@@ -372,14 +381,16 @@ tcDeriving tycl_decls inst_decls deriv_decls
372 381
373 382
374 383 renameDeriv :: Bool
375   - -> BagDerivStuff --[(InstInfo RdrName, DerivAuxBinds)]
  384 + -> [InstInfo RdrName]
  385 + -> Bag (LHsBind RdrName, LSig RdrName)
376 386 -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses)
377   -renameDeriv is_boot insts
  387 +renameDeriv is_boot inst_infos bagBinds
378 388 | is_boot -- If we are compiling a hs-boot file, don't generate any derived bindings
379 389 -- The inst-info bindings will all be empty, but it's easier to
380 390 -- just use rn_inst_info to change the type appropriately
381   - = do { (rn_inst_infos, fvs) <- mapAndUnzipBagM rn_inst_info inst_infos
382   - ; return (rn_inst_infos, emptyValBindsOut, usesOnly (plusFVs (bagToList fvs))) }
  391 + = do { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos
  392 + ; return ( listToBag rn_inst_infos
  393 + , emptyValBindsOut, usesOnly (plusFVs fvs)) }
383 394
384 395 | otherwise
385 396 = discardWarnings $ -- Discard warnings about unused bindings etc
@@ -387,22 +398,21 @@ renameDeriv is_boot insts
387 398 -- Generate and rename any extra not-one-inst-decl-specific binds,
388 399 -- notably "con2tag" and/or "tag2con" functions.
389 400 -- Bring those names into scope before renaming the instances themselves
390   - loc <- getSrcSpanM -- Generic loc for shared bindings
391   - ; (aux_binds, aux_sigs) <- genAuxBinds loc (rm_dups other_binds)
  401 +-- loc <- getSrcSpanM -- Generic loc for shared bindings
  402 + ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds
392 403 ; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs)
393 404 ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
394 405 ; bindLocalNames (collectHsValBinders rn_aux_lhs) $
395 406 do { (rn_aux, dus_aux) <- rnTopBindsRHS rn_aux_lhs
396   - ; (rn_inst_infos, fvs_insts) <- mapAndUnzipBagM rn_inst_info inst_infos
397   - ; return (rn_inst_infos, rn_aux,
398   - dus_aux `plusDU` usesOnly (plusFVs (bagToList fvs_insts))) } }
  407 + ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
  408 + ; return (listToBag rn_inst_infos, rn_aux,
  409 + dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
399 410
400 411 where
401   - (inst_infos, other_binds) = partitionBagWith unDerivInst insts
402   -
403   - -- Remove duplicate requests for auxilliary bindings
404   - rm_dups = foldrBag dup_check emptyBag
405   - dup_check a b = if anyBag (isDupAux a) b then b else consBag a b
  412 +{-
  413 + --(inst_infos, other_binds) = partitionBagWith unDerivInst insts
  414 + (inst_infos, other_binds) = unzip insts
  415 +-}
406 416
407 417 rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
408 418 rn_inst_info info@(InstInfo { iBinds = NewTypeDerived coi tc })
@@ -421,10 +431,11 @@ renameDeriv is_boot insts
421 431 where
422 432 (tyvars,_, clas,_) = instanceHead inst
423 433 clas_nm = className clas
424   -
  434 +{-
425 435 unDerivInst :: DerivStuff -> Either (InstInfo RdrName) DerivStuff
426 436 unDerivInst (DerivInst x) = Left x
427 437 unDerivInst x = Right x
  438 +-}
428 439 \end{code}
429 440
430 441 Note [Newtype deriving and unused constructors]
@@ -456,16 +467,6 @@ stored in NewTypeDerived.
456 467 @makeDerivSpecs@ fishes around to find the info about needed derived instances.
457 468
458 469 \begin{code}
459   --- Make the "extras" for the generic representation
460   -mkGenDerivExtras :: TyCon -> Module
461   - -> TcRn BagDerivStuff
462   -mkGenDerivExtras tc mod = do
463   - { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc mod
464   - ; metaInsts <- genDtMeta (tc, metaTyCons)
465   - ; return ( unitBag (DerivGenMetaTyCons metaTyCons)
466   - `unionBags` unitBag (DerivGenRepTyCon rep0TyInst)
467   - `unionBags` metaInsts) }
468   -
469 470 makeDerivSpecs :: Bool
470 471 -> [LTyClDecl Name]
471 472 -> [LInstDecl Name]
@@ -1469,41 +1470,45 @@ the renamer. What a great hack!
1469 1470 --
1470 1471 genInst :: Bool -- True <=> standalone deriving
1471 1472 -> OverlapFlag
1472   - -> DerivSpec -> TcM BagDerivStuff
  1473 + -> DerivSpec -> TcM (InstInfo RdrName, BagDerivStuff)
1473 1474 genInst standalone_deriv oflag
1474 1475 spec@(DS { ds_tc = rep_tycon, ds_tc_args = rep_tc_args
1475 1476 , ds_theta = theta, ds_newtype = is_newtype
1476 1477 , ds_name = name, ds_cls = clas })
1477 1478 | is_newtype
1478   - = return $ unitBag $ DerivInst $
1479   - InstInfo { iSpec = inst_spec
1480   - , iBinds = NewTypeDerived co rep_tycon }
  1479 + = return (InstInfo { iSpec = inst_spec
  1480 + , iBinds = NewTypeDerived co rep_tycon }, emptyBag)
1481 1481
1482 1482 | otherwise
1483 1483 = do { fix_env <- getFixityEnv
1484   - ; let { loc = getSrcSpan name
1485   - ; deriv_stuff = genDerivStuff loc fix_env clas rep_tycon
  1484 + ; (meth_binds, deriv_stuff) <- genDerivStuff (getSrcSpan name)
  1485 + fix_env clas name rep_tycon
  1486 + ; let {
  1487 +{-
1486 1488 ; (meth_binds', aux_binds) = partitionBag isDerivHsBind deriv_stuff
1487 1489 ; meth_binds = mapBag unDerivHsBind meth_binds'
  1490 +-}
1488 1491 -- In case of a family instance, we need to use the representation
1489 1492 -- tycon (after all, it has the data constructors)
1490 1493
1491 1494 ; inst_info = InstInfo { iSpec = inst_spec
1492 1495 , iBinds = VanillaInst meth_binds []
1493 1496 standalone_deriv } }
  1497 +{-
1494 1498 -- Generate the extra representation types and instances needed for a
1495 1499 -- `Generic` instance
1496 1500 ; generics_extras <- if classKey clas == genClassKey
1497   - then mkGenDerivExtras rep_tycon (nameModule name)
  1501 + then gen_Generic_binds rep_tycon (nameModule name)
1498 1502 else return emptyBag
1499   -
1500   - ; return (unitBag (DerivInst inst_info)
1501   - `unionBags` aux_binds `unionBags` generics_extras) }
  1503 +-}
  1504 + ; return ( inst_info, deriv_stuff) }
1502 1505 where
  1506 +{-
1503 1507 isDerivHsBind (DerivHsBind _) = True
1504 1508 isDerivHsBind _ = False
1505 1509 unDerivHsBind (DerivHsBind x) = x
1506 1510 unDerivHsBind _ = panic "unDerivHsBind"
  1511 +-}
1507 1512 inst_spec = mkInstance oflag theta spec
1508 1513 co1 = case tyConFamilyCoercion_maybe rep_tycon of
1509 1514 Just co_con -> mkAxInstCo co_con rep_tc_args
@@ -1521,18 +1526,21 @@ genInst standalone_deriv oflag
1521 1526 -- co2 : R1:N (b,b) ~ Tree (b,b)
1522 1527 -- co : N [(b,b)] ~ Tree (b,b)
1523 1528
1524   -genDerivStuff :: SrcSpan -> FixityEnv -> Class -> TyCon
1525   - -> BagDerivStuff -- (LHsBinds RdrName, DerivAuxBinds)
1526   -genDerivStuff loc fix_env clas tycon
  1529 +genDerivStuff :: SrcSpan -> FixityEnv -> Class -> Name -> TyCon
  1530 + -> TcM (LHsBinds RdrName, BagDerivStuff)
  1531 +genDerivStuff loc fix_env clas name tycon
1527 1532 | className clas `elem` typeableClassNames
1528   - = gen_Typeable_binds loc tycon
  1533 + = return (gen_Typeable_binds loc tycon, emptyBag)
  1534 +
  1535 + | classKey clas == genClassKey
  1536 + = gen_Generic_binds tycon (nameModule name)
1529 1537
1530 1538 | otherwise
1531 1539 = case assocMaybe gen_list (getUnique clas) of
1532   - Just gen_fn -> gen_fn loc tycon
  1540 + Just gen_fn -> return (gen_fn loc tycon)
1533 1541 Nothing -> pprPanic "genDerivStuff: bad derived class" (ppr clas)
1534 1542 where
1535   - gen_list :: [(Unique, SrcSpan -> TyCon -> BagDerivStuff)]
  1543 + gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
1536 1544 gen_list = [(eqClassKey, gen_Eq_binds)
1537 1545 ,(ordClassKey, gen_Ord_binds)
1538 1546 ,(enumClassKey, gen_Enum_binds)
@@ -1544,7 +1552,6 @@ genDerivStuff loc fix_env clas tycon
1544 1552 ,(functorClassKey, gen_Functor_binds)
1545 1553 ,(foldableClassKey, gen_Foldable_binds)
1546 1554 ,(traversableClassKey, gen_Traversable_binds)
1547   - ,(genClassKey, genGenericBinds)
1548 1555 ]
1549 1556 \end{code}
1550 1557
@@ -1566,9 +1573,19 @@ For the generic representation we need to generate:
1566 1573 @genGenericAll@ does all of them
1567 1574
1568 1575 \begin{code}
  1576 +gen_Generic_binds :: TyCon -> Module
  1577 + -> TcM (LHsBinds RdrName, BagDerivStuff)
  1578 +gen_Generic_binds tc mod = do
  1579 + { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc mod
  1580 + ; metaInsts <- genDtMeta (tc, metaTyCons)
  1581 + ; return ( mkBindsRep tc
  1582 + , (DerivFamInst rep0TyInst)
  1583 + `consBag` ((mapBag DerivTyCon (metaTyCons2TyCons metaTyCons))
  1584 + `unionBags` metaInsts)) }
  1585 +{-
1569 1586 genGenericBinds :: SrcSpan -> TyCon -> BagDerivStuff
1570 1587 genGenericBinds _ tc = mapBag DerivHsBind $ mkBindsRep tc
1571   -
  1588 +-}
1572 1589 genGenericRepExtras :: TyCon -> Module -> TcM (MetaTyCons, TyCon)
1573 1590 genGenericRepExtras tc mod =
1574 1591 do uniqS <- newUniqueSupply
259 compiler/typecheck/TcGenDeriv.lhs 100644 → 100755
@@ -12,7 +12,7 @@ This is where we do all the grimy bindings' generation.
12 12
13 13 \begin{code}
14 14 module TcGenDeriv (
15   - BagDerivStuff, DerivStuff(..),
  15 + BagDerivStuff, DerivStuff(..), isDupAux,
16 16
17 17 gen_Bounded_binds,
18 18 gen_Enum_binds,
@@ -28,8 +28,8 @@ module TcGenDeriv (
28 28 deepSubtypesContaining, foldDataConArgs,
29 29 gen_Foldable_binds,
30 30 gen_Traversable_binds,
31   - genAuxBinds, isDupAux,
32   - ordOpTbl, boxConTbl
  31 + genAuxBind, genAuxBinds,
  32 + ordOpTbl, boxConTbl
33 33 ) where
34 34
35 35 #include "HsVersions.h"
@@ -62,44 +62,56 @@ import FastString
62 62 import Bag
63 63 import Fingerprint
64 64 import Constants
65   -import Generics (MetaTyCons)
66 65 import TcEnv (InstInfo)
67 66
68 67 import Data.List ( partition, intersperse )
69 68 \end{code}
70 69
71 70 \begin{code}
  71 +{-
  72 +type DerivAuxBinds = [DerivAuxBind]
  73 +
  74 +data DerivAuxBind -- Please add these auxiliary top-level bindings
  75 + = DerivCon2Tag TyCon -- The con2Tag for given TyCon
  76 + | DerivTag2Con TyCon -- ...ditto tag2Con
  77 + | DerivMaxTag TyCon -- ...and maxTag
  78 + -- All these generate ZERO-BASED tag operations
  79 + -- I.e first constructor has tag 0
  80 +
  81 + -- Scrap your boilerplate
  82 + | MkDataCon DataCon -- For constructor C we get $cC :: Constr
  83 + | MkTyCon TyCon -- For tycon T we get $tT :: DataType
  84 +-}
72 85 type BagDerivStuff = Bag DerivStuff
73 86
74   -data DerivStuff -- Please add these auxiliary top-level bindings
  87 +data DerivStuff -- Please add these auxiliary stuff
75 88 = DerivCon2Tag TyCon -- The con2Tag for given TyCon
76 89 | DerivTag2Con TyCon -- ...ditto tag2Con
77 90 | DerivMaxTag TyCon -- ...and maxTag
78 91 -- All these generate ZERO-BASED tag operations
79 92 -- I.e first constructor has tag 0
80 93
81   -
82 94 -- Generics
83   - | DerivGenMetaTyCons MetaTyCons -- New data types
84   - | DerivGenRepTyCon TyCon -- New type family instances
  95 + | DerivTyCon TyCon -- New data types
  96 + | DerivFamInst TyCon -- New type family instances
85 97
86   - | DerivHsBind (LHsBind RdrName) -- Yes, but not for the method bindings
87   - -- Rather for top-level auxiliary bindings
  98 + | DerivHsBind (LHsBind RdrName) -- New top-level auxiliary bindings
  99 + | DerivInst (InstInfo RdrName) -- New, auxiliary instances
88 100
89 101 -- Scrap your boilerplate (replaced by DerivHsBind)
90 102 -- | DerivDataCon DataCon -- For constructor C we get $cC :: Constr
91 103 -- | DerivTyCon TyCon -- For tycon T we get $tT :: DataType
92 104
  105 +
  106 +
93 107
94 108 isDupAux :: DerivStuff -> DerivStuff -> Bool
95   -isDupAux (DerivCon2Tag tc1) (DerivCon2Tag tc2) = tc1 == tc2
96   -isDupAux (DerivTag2Con tc1) (DerivTag2Con tc2) = tc1 == tc2
97   -isDupAux (DerivMaxTag tc1) (DerivMaxTag tc2) = tc1 == tc2
98   -isDupAux (DerivDataCon dc1) (DerivDataCon dc2) = dc1 == dc2
99   -isDupAux (DerivTyCon tc1) (DerivTyCon tc2) = tc1 == tc2
100   --- We are certain we do not introduce duplicates for the other cases
101   -isDupAux _ _ = False
102   -
  109 +isDupAux (DerivCon2Tag tc1) (DerivCon2Tag tc2) = tc1 == tc2
  110 +isDupAux (DerivTag2Con tc1) (DerivTag2Con tc2) = tc1 == tc2
  111 +isDupAux (DerivMaxTag tc1) (DerivMaxTag tc2) = tc1 == tc2
  112 +isDupAux (DerivTyCon tc1) (DerivTyCon tc2) = tc1 == tc2
  113 +isDupAux (DerivFamInst tc1) (DerivFamInst tc2) = tc1 == tc2
  114 +isDupAux _ _ = False
103 115 \end{code}
104 116
105 117
@@ -178,9 +190,9 @@ instance ... Eq (Foo ...) where
178 190
179 191
180 192 \begin{code}
181   -gen_Eq_binds :: SrcSpan -> TyCon -> BagDerivStuff
  193 +gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
182 194 gen_Eq_binds loc tycon
183   - = method_binds `unionBags` aux_binds
  195 + = (method_binds, aux_binds)
184 196 where
185 197 (nullary_cons, nonnullary_cons)
186 198 | isNewTyCon tycon = ([], tyConDataCons tycon)
@@ -199,9 +211,9 @@ gen_Eq_binds loc tycon
199 211 (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
200 212
201 213 aux_binds | no_nullary_cons = emptyBag
202   - | otherwise = unitBag (DerivCon2Tag tycon)
  214 + | otherwise = unitBag $ DerivCon2Tag tycon
203 215
204   - method_binds = listToBag (map DerivHsBind [eq_bind, ne_bind])
  216 + method_binds = listToBag [eq_bind, ne_bind]
205 217 eq_bind = mk_FunBind loc eq_RDR (map pats_etc nonnullary_cons ++ rest)
206 218 ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
207 219 nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
@@ -336,19 +348,15 @@ gtResult OrdGE = true_Expr
336 348 gtResult OrdGT = true_Expr
337 349
338 350 ------------
339   -gen_Ord_binds :: SrcSpan -> TyCon -> BagDerivStuff
  351 +gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
340 352 gen_Ord_binds loc tycon
341 353 | null tycon_data_cons -- No data-cons => invoke bale-out case
342   - = unitBag $ DerivHsBind $ mk_FunBind loc compare_RDR []
  354 + = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag)
343 355 | otherwise
344   - = unitBag (mkOrdOp OrdCompare)
345   - `unionBags`
346   - other_ops
347   - `unionBags`
348   - aux_binds
  356 + = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
349 357 where
350 358 aux_binds | single_con_type = emptyBag
351   - | otherwise = unitBag (DerivCon2Tag tycon)
  359 + | otherwise = unitBag $ DerivCon2Tag tycon
352 360
353 361 -- Note [Do not rely on compare]
354 362 other_ops | (last_tag - first_tag) <= 2 -- 1-3 constructors
@@ -371,11 +379,9 @@ gen_Ord_binds loc tycon
371 379 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
372 380
373 381
374   - mkOrdOp :: OrdOp -> DerivStuff --LHsBind RdrName
  382 + mkOrdOp :: OrdOp -> LHsBind RdrName
375 383 -- Returns a binding op a b = ... compares a and b according to op ....
376   - mkOrdOp op = DerivHsBind $
377   - mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat]
378   - (mkOrdOpRhs op)
  384 + mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op)
379 385
380 386 mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
381 387 mkOrdOpRhs op -- RHS for comparing 'a' and 'b' according to op
@@ -565,18 +571,18 @@ instance ... Enum (Foo ...) where
565 571 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
566 572
567 573 \begin{code}
568   -gen_Enum_binds :: SrcSpan -> TyCon -> BagDerivStuff
  574 +gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
569 575 gen_Enum_binds loc tycon
570   - = method_binds `unionBags` aux_binds
  576 + = (method_binds, aux_binds)
571 577 where
572   - method_binds = listToBag (map DerivHsBind [
  578 + method_binds = listToBag [
573 579 succ_enum,
574 580 pred_enum,
575 581 to_enum,
576 582 enum_from,
577 583 enum_from_then,
578 584 from_enum
579   - ])
  585 + ]
580 586 aux_binds = listToBag [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
581 587
582 588 occ_nm = getOccString tycon
@@ -644,13 +650,13 @@ gen_Enum_binds loc tycon
644 650 %************************************************************************
645 651
646 652 \begin{code}
647   -gen_Bounded_binds :: SrcSpan -> TyCon -> BagDerivStuff
  653 +gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
648 654 gen_Bounded_binds loc tycon
649 655 | isEnumerationTyCon tycon
650   - = listToBag (map DerivHsBind [min_bound_enum, max_bound_enum])
  656 + = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
651 657 | otherwise
652 658 = ASSERT(isSingleton data_cons)
653   - (listToBag (map DerivHsBind [min_bound_1con, max_bound_1con]))
  659 + (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
654 660 where
655 661 data_cons = tyConDataCons tycon
656 662
@@ -731,17 +737,16 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report
731 737 (p.~147).
732 738
733 739 \begin{code}
734   -gen_Ix_binds :: SrcSpan -> TyCon -> BagDerivStuff
  740 +gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
735 741
736 742 gen_Ix_binds loc tycon
737 743 | isEnumerationTyCon tycon
738   - = enum_ixes `unionBags`
739   - listToBag [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
  744 + = (enum_ixes, listToBag [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
740 745 | otherwise
741   - = single_con_ixes `unionBags` unitBag (DerivCon2Tag tycon)
  746 + = (single_con_ixes, unitBag (DerivCon2Tag tycon))
742 747 where
743 748 --------------------------------------------------------------
744   - enum_ixes = listToBag (map DerivHsBind [enum_range, enum_index, enum_inRange])
  749 + enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
745 750
746 751 enum_range
747 752 = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
@@ -780,8 +785,8 @@ gen_Ix_binds loc tycon
780 785 ))))
781 786
782 787 --------------------------------------------------------------
783   - single_con_ixes = listToBag (map DerivHsBind
784   - [single_con_range, single_con_index, single_con_inRange])
  788 + single_con_ixes
  789 + = listToBag [single_con_range, single_con_index, single_con_inRange]
785 790
786 791 data_con
787 792 = case tyConSingleDataCon_maybe tycon of -- just checking...
@@ -891,10 +896,10 @@ instance Read T where
891 896
892 897
893 898 \begin{code}
894   -gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> BagDerivStuff
  899 +gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
895 900
896 901 gen_Read_binds get_fixity loc tycon
897   - = listToBag (map DerivHsBind [read_prec, default_readlist, default_readlistprec])
  902 + = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
898 903 where
899 904 -----------------------------------------------------------------------
900 905 default_readlist
@@ -1060,10 +1065,10 @@ Example
1060 1065 -- the most tightly-binding operator
1061 1066
1062 1067 \begin{code}
1063   -gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> BagDerivStuff
  1068 +gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1064 1069
1065 1070 gen_Show_binds get_fixity loc tycon
1066   - = listToBag (map DerivHsBind [shows_prec, show_list])
  1071 + = (listToBag [shows_prec, show_list], emptyBag)
1067 1072 where
1068 1073 -----------------------------------------------------------------------
1069 1074 show_list = mkHsVarBind loc showList_RDR
@@ -1192,9 +1197,9 @@ we generate
1192 1197 We are passed the Typeable2 class as well as T
1193 1198
1194 1199 \begin{code}
1195   -gen_Typeable_binds :: SrcSpan -> TyCon -> BagDerivStuff --LHsBinds RdrName
  1200 +gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName
1196 1201 gen_Typeable_binds loc tycon
1197   - = unitBag $ DerivHsBind $
  1202 + = unitBag $
1198 1203 mk_easy_FunBind loc
1199 1204 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1200 1205 [nlWildPat]
@@ -1270,17 +1275,57 @@ we generate
1270 1275
1271 1276
1272 1277 \begin{code}
1273   -gen_Data_binds :: SrcSpan -> TyCon -> BagDerivStuff
  1278 +gen_Data_binds :: SrcSpan
  1279 + -> TyCon
  1280 + -> (LHsBinds RdrName, -- The method bindings
  1281 + BagDerivStuff) -- Auxiliary bindings
1274 1282 gen_Data_binds loc tycon
1275   - = listToBag (map DerivHsBind [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind])
1276   - `unionBags` gcast_binds
1277   - -- Auxiliary definitions: the data type and constructors
1278   - `unionBags` (listToBag (DerivTyCon tycon : map DerivDataCon data_cons))
  1283 + = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
  1284 + `unionBags` gcast_binds,
  1285 + -- Auxiliary definitions: the data type and constructors
  1286 + listToBag ( DerivHsBind (fst genDataTyCon)
  1287 + : map (DerivHsBind . fst . genDataDataCon) data_cons))
  1288 + -- JPM: We are dropping the signatures. Is this a problem?
1279 1289 where
1280 1290 data_cons = tyConDataCons tycon
1281 1291 n_cons = length data_cons
1282 1292 one_constr = n_cons == 1
1283 1293
  1294 + genDataTyCon :: (LHsBind RdrName, LSig RdrName)
  1295 + genDataTyCon -- $dT
  1296 + = (mkHsVarBind loc rdr_name rhs,
  1297 + L loc (TypeSig [L loc rdr_name] sig_ty))
  1298 + where
  1299 + rdr_name = mk_data_type_name tycon
  1300 + sig_ty = nlHsTyVar dataType_RDR
  1301 + constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
  1302 + rhs = nlHsVar mkDataType_RDR
  1303 + `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
  1304 + `nlHsApp` nlList constrs
  1305 +
  1306 + genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName)
  1307 + genDataDataCon dc -- $cT1 etc
  1308 + = (mkHsVarBind loc rdr_name rhs,
  1309 + L loc (TypeSig [L loc rdr_name] sig_ty))
  1310 + where
  1311 + rdr_name = mk_constr_name dc
  1312 + sig_ty = nlHsTyVar constr_RDR
  1313 + rhs = nlHsApps mkConstr_RDR constr_args
  1314 +
  1315 + constr_args
  1316 + = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
  1317 + nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
  1318 + nlHsLit (mkHsString (occNameString dc_occ)), -- String name
  1319 + nlList labels, -- Field labels
  1320 + nlHsVar fixity] -- Fixity
  1321 +
  1322 + labels = map (nlHsLit . mkHsString . getOccString)
  1323 + (dataConFieldLabels dc)
  1324 + dc_occ = getOccName dc
  1325 + is_infix = isDataSymOcc dc_occ
  1326 + fixity | is_infix = infix_RDR
  1327 + | otherwise = prefix_RDR
  1328 +
1284 1329 ------------ gfoldl
1285 1330 gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
1286 1331
@@ -1333,7 +1378,7 @@ gen_Data_binds loc tycon
1333 1378 | tycon_kind `eqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1334 1379 | otherwise = emptyBag
1335 1380 mk_gcast dataCast_RDR gcast_RDR
1336   - = unitBag (DerivHsBind $ mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
  1381 + = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
1337 1382 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1338 1383
1339 1384
@@ -1432,12 +1477,12 @@ This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1432 1477 $(cofmap 'a '(b -> c)) x = \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1433 1478
1434 1479 \begin{code}
1435   -gen_Functor_binds :: SrcSpan -> TyCon -> BagDerivStuff
  1480 +gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1436 1481 gen_Functor_binds loc tycon
1437   - = unitBag fmap_bind
  1482 + = (unitBag fmap_bind, emptyBag)
1438 1483 where
1439 1484 data_cons = tyConDataCons tycon
1440   - fmap_bind = DerivHsBind $ L loc $ mkRdrFunBind (L loc fmap_RDR) eqns
  1485 + fmap_bind = L loc $ mkRdrFunBind (L loc fmap_RDR) eqns
1441 1486
1442 1487 fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1443 1488 where
@@ -1603,13 +1648,13 @@ Note that the arguments to the real foldr function are the wrong way around,
1603 1648 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1604 1649
1605 1650 \begin{code}
1606   -gen_Foldable_binds :: SrcSpan -> TyCon -> BagDerivStuff
  1651 +gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1607 1652 gen_Foldable_binds loc tycon
1608   - = unitBag foldr_bind
  1653 + = (unitBag foldr_bind, emptyBag)
1609 1654 where
1610 1655 data_cons = tyConDataCons tycon
1611 1656
1612   - foldr_bind = DerivHsBind $ L loc $ mkRdrFunBind (L loc foldable_foldr_RDR) eqns
  1657 + foldr_bind = L loc $ mkRdrFunBind (L loc foldable_foldr_RDR) eqns
1613 1658 eqns = map foldr_eqn data_cons
1614 1659 foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
1615 1660 where
@@ -1655,13 +1700,13 @@ gives the function: traverse f (T x y) = T <$> pure x <*> f y
1655 1700 instead of: traverse f (T x y) = T x <$> f y
1656 1701
1657 1702 \begin{code}
1658   -gen_Traversable_binds :: SrcSpan -> TyCon -> BagDerivStuff
  1703 +gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1659 1704 gen_Traversable_binds loc tycon
1660   - = unitBag traverse_bind
  1705 + = (unitBag traverse_bind, emptyBag)
1661 1706 where
1662 1707 data_cons = tyConDataCons tycon
1663 1708
1664   - traverse_bind = DerivHsBind $ L loc $ mkRdrFunBind (L loc traverse_RDR) eqns
  1709 + traverse_bind = L loc $ mkRdrFunBind (L loc traverse_RDR) eqns
1665 1710 eqns = map traverse_eqn data_cons
1666 1711 traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1667 1712 where
@@ -1755,51 +1800,37 @@ genAuxBind loc (DerivMaxTag tycon)
1755 1800 max_tag = case (tyConDataCons tycon) of
1756 1801 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1757 1802
1758   -genAuxBind loc (DerivTyCon tycon) -- $dT
1759   - = (mkHsVarBind loc rdr_name rhs,
1760   - L loc (TypeSig [L loc rdr_name] sig_ty))
1761   - where
1762   - rdr_name = mk_data_type_name tycon
1763   - sig_ty = nlHsTyVar dataType_RDR
1764   - constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
1765   - rhs = nlHsVar mkDataType_RDR
1766   - `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1767   - `nlHsApp` nlList constrs
1768   -
1769   -genAuxBind loc (DerivDataCon dc) -- $cT1 etc
1770   - = (mkHsVarBind loc rdr_name rhs,
1771   - L loc (TypeSig [L loc rdr_name] sig_ty))
1772   - where
1773   - rdr_name = mk_constr_name dc
1774   - sig_ty = nlHsTyVar constr_RDR
1775   - rhs = nlHsApps mkConstr_RDR constr_args
1776   -
1777   - constr_args
1778   - = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1779   - nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1780   - nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1781   - nlList labels, -- Field labels
1782   - nlHsVar fixity] -- Fixity
1783   -
1784   - labels = map (nlHsLit . mkHsString . getOccString)
1785   - (dataConFieldLabels dc)
1786   - dc_occ = getOccName dc
1787   - is_infix = isDataSymOcc dc_occ
1788   - fixity | is_infix = infix_RDR
1789   - | otherwise = prefix_RDR
1790   -
1791   --- We know we do not call genAuxBind with the generics stuff
1792   -genAuxBind _ _ = panic "genAuxBind"
1793   -
1794   -genAuxBinds :: Monad m => SrcSpan -> BagDerivStuff -> m ( Bag (LHsBind RdrName)
1795   - , Bag (LSig RdrName))
1796   -genAuxBinds loc bs = mapAndUnzipBagM (return . genAuxBind loc) auxBinds where
1797   - partf x@(DerivGenMetaTyCons _) = Left x
1798   - partf x@(DerivGenRepTyCon _) = Left x
1799   - partf x@(DerivInst _) = Left x
1800   - partf x@(DerivHsBind _) = Left x
1801   - partf x = Right x
1802   - (_, auxBinds) = partitionBagWith partf bs
  1803 +genAuxBind loc _ = panic "genAuxBind"
  1804 +
  1805 +genAuxBinds :: SrcSpan -> BagDerivStuff
  1806 + -> ( Bag (LHsBind RdrName, LSig RdrName)
  1807 + , Bag TyCon
  1808 + , Bag TyCon
  1809 + , Bag (InstInfo RdrName))
  1810 +{-
  1811 +genAuxBinds loc = mapBag (genAuxBind loc) . filterBag (not . isGen)
  1812 + isGen (DerivCon2Tag _) = True
  1813 + isGen (DerivTag2Con _) = True
  1814 + isGen (DerivMaxTag _) = True
  1815 + isGen (DerivTyCon t) = = False
  1816 + isGen (DerivFamInst t) = = False
  1817 +-}
  1818 +genAuxBinds loc s = foldrBag f (emptyBag, emptyBag, emptyBag, emptyBag) s where
  1819 + f :: DerivStuff
  1820 + -> (Bag (LHsBind RdrName, LSig RdrName), Bag TyCon, Bag TyCon, Bag (InstInfo RdrName))
  1821 + -> (Bag (LHsBind RdrName, LSig RdrName), Bag TyCon, Bag TyCon, Bag (InstInfo RdrName))
  1822 + f x@(DerivCon2Tag _) = add1 (genAuxBind loc x)
  1823 + f x@(DerivTag2Con _) = add1 (genAuxBind loc x)
  1824 + f x@(DerivMaxTag _) = add1 (genAuxBind loc x)
  1825 + f (DerivTyCon t) = add2 t
  1826 + f (DerivFamInst t) = add3 t
  1827 + f (DerivInst i) = add4 i
  1828 + f _ = id
  1829 +
  1830 + add1 x (a,b,c,d) = (x `consBag` a,b,c,d)
  1831 + add2 x (a,b,c,d) = (a,x `consBag` b,c,d)
  1832 + add3 x (a,b,c,d) = (a,b,x `consBag` c,d)
  1833 + add4 x (a,b,c,d) = (a,b,c,x `consBag` d)
1803 1834
1804 1835 mk_data_type_name :: TyCon -> RdrName -- "$tT"
1805 1836 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
4 compiler/types/Generics.lhs 100644 → 100755
@@ -224,8 +224,8 @@ data MetaTyCons = MetaTyCons { -- One meta datatype per dataype
224 224 instance Outputable MetaTyCons where
225 225 ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s))
226 226
227   -metaTyCons2TyCons :: MetaTyCons -> [TyCon]
228   -metaTyCons2TyCons (MetaTyCons d c s) = d : c ++ concat s
  227 +metaTyCons2TyCons :: MetaTyCons -> Bag TyCon
  228 +metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s)
229 229
230 230
231 231 -- Bindings for Datatype, Constructor, and Selector instances

0 comments on commit acc2451

Please sign in to comment.
Something went wrong with that request. Please try again.