Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Merge branch 'fix#5464'

  • Loading branch information...
commit 29a97fded4010bd01aa0a17945c84258e285d421 2 parents 3aa2ee2 + 6431f7c
José Pedro Magalhães authored October 07, 2011
2  compiler/ghc.cabal.in 100644 → 100755
@@ -394,6 +394,7 @@ Library
394 394
         TcExpr
395 395
         TcForeign
396 396
         TcGenDeriv
  397
+        TcGenGenerics
397 398
         TcHsSyn
398 399
         TcHsType
399 400
         TcInstDcls
@@ -418,7 +419,6 @@ Library
418 419
         Coercion
419 420
         FamInstEnv
420 421
         FunDeps
421  
-        Generics
422 422
         InstEnv
423 423
         TyCon
424 424
         Kind
389  compiler/typecheck/TcDeriv.lhs 100644 → 100755
@@ -13,20 +13,22 @@ module TcDeriv ( tcDeriving ) where
13 13
 import HsSyn
14 14
 import DynFlags
15 15
 
16  
-import Generics
17 16
 import TcRnMonad
18 17
 import FamInst
19 18
 import TcEnv
20 19
 import TcClassDcl( tcAddDeclCtxt )	-- Small helper
21 20
 import TcGenDeriv			-- Deriv stuff
  21
+import TcGenGenerics
22 22
 import InstEnv
23 23
 import Inst
  24
+import FamInstEnv
24 25
 import TcHsType
25 26
 import TcMType
26 27
 import TcSimplify
27 28
 
28 29
 import RnBinds
29 30
 import RnEnv
  31
+import RnSource   ( addTcgDUs )
30 32
 import HscTypes
31 33
 
32 34
 import Class
@@ -41,13 +43,10 @@ import Name
41 43
 import NameSet
42 44
 import TyCon
43 45
 import TcType
44  
-import BuildTyCl
45  
-import BasicTypes
46 46
 import Var
47 47
 import VarSet
48 48
 import PrelNames
49 49
 import SrcLoc
50  
-import UniqSupply
51 50
 import Util
52 51
 import ListSetOps
53 52
 import Outputable
@@ -299,109 +298,97 @@ both of them.  So we gather defs/uses from deriving just like anything else.
299 298
 tcDeriving  :: [LTyClDecl Name]  -- All type constructors
300 299
             -> [LInstDecl Name]  -- All instance declarations
301 300
             -> [LDerivDecl Name] -- All stand-alone deriving declarations
302  
-            -> TcM ([InstInfo Name] -- The generated "instance decls"
303  
-                   ,HsValBinds Name -- Extra generated top-level bindings
304  
-                   ,DefUses
305  
-                   ,[TyCon]         -- Extra generated top-level types
306  
-                   ,[TyCon])        -- Extra generated type family instances
307  
-
  301
+            -> TcM (TcGblEnv, Bag (InstInfo Name), HsValBinds Name)
308 302
 tcDeriving tycl_decls inst_decls deriv_decls
309  
-  = recoverM (return ([], emptyValBindsOut, emptyDUs, [], [])) $
  303
+  = recoverM (do { g <- getGblEnv
  304
+                 ; return (g, emptyBag, emptyValBindsOut)}) $
310 305
     do	{   	-- Fish the "deriving"-related information out of the TcEnv
311 306
 		-- And make the necessary "equations".
312 307
 	  is_boot <- tcIsHsBoot
313 308
 	; traceTc "tcDeriving" (ppr is_boot)
314  
-	; (early_specs, genericsExtras) 
315  
-                <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
316  
-        ; let (repMetaTys, repTyCons, metaInsts) = unzip3 genericsExtras
  309
+	; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
317 310
 
318 311
 	; overlap_flag <- getOverlapFlag
319 312
 	; let (infer_specs, given_specs) = splitEithers early_specs
320 313
 	; insts1 <- mapM (genInst True overlap_flag) given_specs
321 314
 
322 315
 	; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
323  
-			 inferInstanceContexts overlap_flag infer_specs
  316
+                           inferInstanceContexts overlap_flag infer_specs
324 317
 
325 318
 	; insts2 <- mapM (genInst False overlap_flag) final_specs
326 319
 
327  
-	-- We no longer generate the old generic to/from functions
328  
-        -- from each type declaration, so this is emptyBag
329  
-	; gen_binds <- return emptyBag -- mkGenericBinds is_boot tycl_decls
330  
-	
331  
-	; (inst_info, rn_binds, rn_dus)
332  
-                <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ concat metaInsts)
  320
+        ; let (inst_infos, deriv_stuff) = unzip (insts1 ++ insts2)
  321
+        ; loc <- getSrcSpanM
  322
+        ; let (binds, newTyCons, famInsts, extraInstances) = 
  323
+                genAuxBinds loc (unionManyBags deriv_stuff)
  324
+        ; (inst_info, rn_binds, rn_dus) <-
  325
+            renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds
333 326
 
334 327
 	; dflags <- getDOpts
335 328
 	; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
336  
-	         (ddump_deriving inst_info rn_binds repMetaTys repTyCons metaInsts))
  329
+	         (ddump_deriving inst_info rn_binds newTyCons famInsts extraInstances))
337 330
 {-
338 331
         ; when (not (null inst_info)) $
339 332
           dumpDerivingInfo (ddump_deriving inst_info rn_binds)
340 333
 -}
341  
-	; return ( inst_info, rn_binds, rn_dus
342  
-                 , concat (map metaTyCons2TyCons repMetaTys), repTyCons) }
  334
+
  335
+  ; let all_tycons = map ATyCon (bagToList newTyCons)
  336
+  ; gbl_env <- tcExtendGlobalEnv all_tycons $
  337
+               tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $
  338
+               tcExtendLocalFamInstEnv (map mkLocalFamInst (bagToList famInsts)) $
  339
+               tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
  340
+
  341
+  ; return (addTcgDUs gbl_env rn_dus, inst_info, rn_binds) }
343 342
   where
344  
-    ddump_deriving :: [InstInfo Name] -> HsValBinds Name 
345  
-                   -> [MetaTyCons] -- ^ Empty data constructors
346  
-                   -> [TyCon]      -- ^ Rep type family instances
347  
-                   -> [[(InstInfo RdrName, DerivAuxBinds)]] 
  343
+    ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name 
  344
+                   -> Bag TyCon  -- ^ Empty data constructors
  345
+                   -> Bag TyCon  -- ^ Rep type family instances
  346
+                   -> Bag (InstInfo RdrName)
348 347
                       -- ^ Instances for the repMetaTys
349 348
                    -> SDoc
350 349
     ddump_deriving inst_infos extra_binds repMetaTys repTyCons metaInsts
351  
-      =    hang (ptext (sLit "Derived instances"))
352  
-              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)
  350
+      =    hang (ptext (sLit "Derived instances:"))
  351
+              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
353 352
                  $$ ppr extra_binds)
354  
-        $$ hangP "Generic representation" (
355  
-              hangP "Generated datatypes for meta-information"
356  
-               (vcat (map ppr repMetaTys))
  353
+        $$ hangP "Generic representation:" (
  354
+              hangP "Generated datatypes for meta-information:"
  355
+               (vcat (map ppr (bagToList repMetaTys)))
357 356
            -- The Outputable instance for TyCon unfortunately only prints the name...
358  
-           $$ hangP "Representation types" 
359  
-                (vcat (map ppr  repTyCons))
360  
-           $$ hangP "Meta-information instances"
361  
-                (vcat (map (pprInstInfoDetails . fst) (concat metaInsts))))
  357
+           $$ hangP "Representation types:"
  358
+                (vcat (map ppr (bagToList repTyCons)))
  359
+           $$ hangP "Meta-information instances:"
  360
+                (vcat (map pprInstInfoDetails (bagToList metaInsts))))
362 361
     
363 362
     hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
364 363
 
365 364
 
366  
-renameDeriv :: Bool -> LHsBinds RdrName
367  
-	    -> [(InstInfo RdrName, DerivAuxBinds)]
368  
- 	    -> TcM ([InstInfo Name], HsValBinds Name, DefUses)
369  
-renameDeriv is_boot gen_binds insts
  365
+renameDeriv :: Bool
  366
+	    -> [InstInfo RdrName]
  367
+	    -> Bag (LHsBind RdrName, LSig RdrName)
  368
+ 	    -> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses)
  369
+renameDeriv is_boot inst_infos bagBinds
370 370
   | is_boot	-- If we are compiling a hs-boot file, don't generate any derived bindings
371 371
 		-- The inst-info bindings will all be empty, but it's easier to
372 372
 		-- just use rn_inst_info to change the type appropriately
373  
-  = do	{ (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos	
374  
-	; return (rn_inst_infos, emptyValBindsOut, usesOnly (plusFVs fvs)) }
  373
+  = do	{ (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos
  374
+	; return ( listToBag rn_inst_infos
  375
+                 , emptyValBindsOut, usesOnly (plusFVs fvs)) }
375 376
 
376 377
   | otherwise
377 378
   = discardWarnings $ 	 -- Discard warnings about unused bindings etc
378  
-    do	{ (rn_gen, dus_gen) <- setXOptM Opt_ScopedTypeVariables $  -- Type signatures in patterns 
379  
-								  -- are used in the generic binds
380  
-			       rnTopBinds (ValBindsIn gen_binds [])
381  
-	; keepAliveSetTc (duDefs dus_gen)	-- Mark these guys to be kept alive
382  
-
383  
-		-- Generate and rename any extra not-one-inst-decl-specific binds, 
384  
-		-- notably "con2tag" and/or "tag2con" functions.  
385  
-		-- Bring those names into scope before renaming the instances themselves
386  
-	; loc <- getSrcSpanM	-- Generic loc for shared bindings
387  
-	; let (aux_binds, aux_sigs) = unzip $ map (genAuxBind loc) $ 
388  
-	                              rm_dups [] $ concat deriv_aux_binds
389  
-              aux_val_binds = ValBindsIn (listToBag aux_binds) aux_sigs
  379
+    do	{
  380
+        -- Bring the extra deriving stuff into scope
  381
+        -- before renaming the instances themselves
  382
+	; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds
  383
+	; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs)
390 384
 	; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
391 385
 	; bindLocalNames (collectHsValBinders rn_aux_lhs) $ 
392 386
     do	{ (rn_aux, dus_aux) <- rnTopBindsRHS rn_aux_lhs
393 387
 	; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
394  
-	; return (rn_inst_infos, rn_aux `plusHsValBinds` rn_gen,
395  
-                  dus_gen `plusDU` dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
  388
+	; return (listToBag rn_inst_infos, rn_aux,
  389
+                  dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
396 390
 
397 391
   where
398  
-    (inst_infos, deriv_aux_binds) = unzip insts
399  
-    
400  
-	-- Remove duplicate requests for auxilliary bindings
401  
-    rm_dups acc [] = acc
402  
-    rm_dups acc (b:bs) | any (isDupAux b) acc = rm_dups acc bs
403  
-    		       | otherwise	      = rm_dups (b:acc) bs
404  
-
405 392
 
406 393
     rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
407 394
     rn_inst_info info@(InstInfo { iBinds = NewTypeDerived coi tc })
@@ -451,75 +438,20 @@ stored in NewTypeDerived.
451 438
 @makeDerivSpecs@ fishes around to find the info about needed derived instances.
452 439
 
453 440
 \begin{code}
454  
--- Make the "extras" for the generic representation
455  
-mkGenDerivExtras :: TyCon 
456  
-                 -> TcRn (MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])
457  
-mkGenDerivExtras tc = do
458  
-        { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc
459  
-        ; metaInsts                <- genDtMeta (tc, metaTyCons)
460  
-        ; return (metaTyCons, rep0TyInst, metaInsts) }
461  
-
462 441
 makeDerivSpecs :: Bool 
463 442
 	       -> [LTyClDecl Name] 
464 443
 	       -> [LInstDecl Name]
465 444
 	       -> [LDerivDecl Name] 
466  
-	       -> TcM ( [EarlyDerivSpec]
467  
-                      , [(MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])])
  445
+	       -> TcM [EarlyDerivSpec]
468 446
 makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
469 447
   | is_boot     -- No 'deriving' at all in hs-boot files
470 448
   = do  { mapM_ add_deriv_err deriv_locs 
471  
-        ; return ([],[]) }
  449
+        ; return [] }
472 450
   | otherwise
473 451
   = do  { eqns1 <- mapAndRecoverM deriveTyData all_tydata
474 452
         ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
475  
-
476  
-        -- Generic representation stuff: we might need to add some "extras"
477  
-        -- to the instances
478  
-        ; xDerRep <- getDOpts >>= return . xopt Opt_DeriveGeneric
479  
-        ; generic_extras_deriv <- if not xDerRep
480  
-                                   -- No extras if the flag is off
481  
-                                   then (return [])
482  
-                                    else do {
483  
-          let allTyNames = [ tcdName d | L _ d <- tycl_decls, isDataDecl d ]
484  
-        -- Select only those types that derive Generic
485  
-        ; let sel_tydata = [ tcdName t | (L _ c, L _ t) <- all_tydata
486  
-                                       , isGenClassName c ]
487  
-        ; let sel_deriv_decls = catMaybes [ getTypeName t
488  
-                                  | L _ (DerivDecl (L _ t)) <- deriv_decls ] 
489  
-        ; derTyDecls <- mapM tcLookupTyCon $ 
490  
-                         filter (needsExtras xDerRep
491  
-                                  (sel_tydata ++ sel_deriv_decls)) allTyNames
492  
-        -- We need to generate the extras to add to what has
493  
-        -- already been derived
494  
-        ; {- pprTrace "sel_tydata" (ppr sel_tydata) $
495  
-          pprTrace "sel_deriv_decls" (ppr sel_deriv_decls) $
496  
-          pprTrace "derTyDecls" (ppr derTyDecls) $
497  
-          pprTrace "deriv_decls" (ppr deriv_decls) $ -}
498  
-          mapM mkGenDerivExtras derTyDecls }
499  
-
500  
-        -- Merge and return
501  
-        ; return ( eqns1 ++ eqns2, generic_extras_deriv) }
  453
+        ; return (eqns1 ++ eqns2) }
502 454
   where
503  
-      -- We need extras if the flag DeriveGeneric is on and this type is 
504  
-      -- deriving Generic
505  
-    needsExtras xDerRep tydata tc_name = xDerRep && tc_name `elem` tydata
506  
-
507  
-    -- Extracts the name of the class in the deriving and makes sure it is ours
508  
-    isGenClassName :: HsType Name -> Bool
509  
-    isGenClassName ty = case splitHsInstDeclTy_maybe ty of
510  
-        Just (_, _, cls_name, _) -> cls_name == genClassName
511  
-        _                        -> False
512  
-
513  
-    -- Extracts the name of the type in the deriving
514  
-    -- This function (and also getClassName above) is not really nice, and I
515  
-    -- might not have covered all possible cases. I wonder if there is no easier
516  
-    -- way to extract class and type name from a LDerivDecl...
517  
-    getTypeName :: HsType Name -> Maybe Name
518  
-    getTypeName ty = do
519  
-        (_, _, cls_name, [ty]) <- splitHsInstDeclTy_maybe ty
520  
-        guard (cls_name == genClassName)
521  
-        fmap fst $ splitHsClassTy_maybe (unLoc ty)
522  
-
523 455
     extractTyDataPreds decls
524 456
       = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
525 457
 
@@ -699,8 +631,9 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta
699 631
       	   -- For standalone deriving (mtheta /= Nothing), 
700 632
       	   -- check that all the data constructors are in scope.
701 633
       	   ; rdr_env <- getGlobalRdrEnv
702  
-      	   ; let hidden_data_cons = isAbstractTyCon rep_tc || 
703  
-                                    any not_in_scope (tyConDataCons rep_tc)
  634
+      	   ; let hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
  635
+                                    (isAbstractTyCon rep_tc || 
  636
+                                     any not_in_scope (tyConDataCons rep_tc))
704 637
       	         not_in_scope dc  = null (lookupGRE_Name rdr_env (dataConName dc))
705 638
       	   ; unless (isNothing mtheta || not hidden_data_cons)
706 639
       	   	    (bale_out (derivingHiddenErr tycon))
@@ -1508,31 +1441,30 @@ the renamer.  What a great hack!
1508 1441
 --
1509 1442
 genInst :: Bool             -- True <=> standalone deriving
1510 1443
         -> OverlapFlag
1511  
-        -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds)
  1444
+        -> DerivSpec -> TcM (InstInfo RdrName, BagDerivStuff)
1512 1445
 genInst standalone_deriv oflag
1513 1446
         spec@(DS { ds_tc = rep_tycon, ds_tc_args = rep_tc_args
1514 1447
                  , ds_theta = theta, ds_newtype = is_newtype
1515 1448
                  , ds_name = name, ds_cls = clas })
1516 1449
   | is_newtype
1517 1450
   = return (InstInfo { iSpec   = inst_spec
1518  
-                     , iBinds  = NewTypeDerived co rep_tycon }, [])
  1451
+                     , iBinds  = NewTypeDerived co rep_tycon }, emptyBag)
1519 1452
 
1520 1453
   | otherwise
1521  
-  = do  { fix_env <- getFixityEnv
1522  
-        ; let loc   = getSrcSpan name
1523  
-              (meth_binds, aux_binds) = genDerivBinds loc fix_env clas rep_tycon
1524  
-                   -- In case of a family instance, we need to use the representation
1525  
-                   -- tycon (after all, it has the data constructors)
1526  
-
1527  
-        ; return (InstInfo { iSpec   = inst_spec
1528  
-                           , iBinds  = VanillaInst meth_binds [] standalone_deriv }
1529  
-                 , aux_binds) }
  1454
+  = do { fix_env <- getFixityEnv
  1455
+       ; (meth_binds, deriv_stuff) <- genDerivStuff (getSrcSpan name) 
  1456
+                                        fix_env clas name rep_tycon
  1457
+       ; let inst_info = InstInfo { iSpec   = inst_spec
  1458
+                                  , iBinds  = VanillaInst meth_binds []
  1459
+                                                standalone_deriv }
  1460
+       ; return ( inst_info, deriv_stuff) }
1530 1461
   where
  1462
+
1531 1463
     inst_spec = mkInstance oflag theta spec
1532 1464
     co1 = case tyConFamilyCoercion_maybe rep_tycon of
1533 1465
               Just co_con -> mkAxInstCo co_con rep_tc_args
1534  
-    	      Nothing     -> id_co
1535  
-	      -- Not a family => rep_tycon = main tycon
  1466
+              Nothing     -> id_co
  1467
+              -- Not a family => rep_tycon = main tycon
1536 1468
     co2 = mkAxInstCo (newTyConCo rep_tycon) rep_tc_args
1537 1469
     co  = co1 `mkTransCo` co2
1538 1470
     id_co = mkReflCo (mkTyConApp rep_tycon rep_tc_args)
@@ -1545,174 +1477,35 @@ genInst standalone_deriv oflag
1545 1477
 --    co2 : R1:N (b,b) ~ Tree (b,b)
1546 1478
 --    co  : N [(b,b)] ~ Tree (b,b)
1547 1479
 
1548  
-genDerivBinds :: SrcSpan -> FixityEnv -> Class -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1549  
-genDerivBinds loc fix_env clas tycon
  1480
+genDerivStuff :: SrcSpan -> FixityEnv -> Class -> Name -> TyCon
  1481
+              -> TcM (LHsBinds RdrName, BagDerivStuff)
  1482
+genDerivStuff loc fix_env clas name tycon
1550 1483
   | className clas `elem` typeableClassNames
1551  
-  = (gen_Typeable_binds loc tycon, [])
  1484
+  = return (gen_Typeable_binds loc tycon, emptyBag)
1552 1485
 
1553  
-  | otherwise
  1486
+  | classKey clas == genClassKey   -- Special case because monadic
  1487
+  = gen_Generic_binds tycon (nameModule name)
  1488
+
  1489
+  | otherwise	                   -- Non-monadic generators
1554 1490
   = case assocMaybe gen_list (getUnique clas) of
1555  
-	Just gen_fn -> gen_fn loc tycon
1556  
-	Nothing	    -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
  1491
+        Just gen_fn -> return (gen_fn loc tycon)
  1492
+        Nothing	    -> pprPanic "genDerivStuff: bad derived class" (ppr clas)
1557 1493
   where
1558  
-    gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds))]
  1494
+    gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
1559 1495
     gen_list = [(eqClassKey,            gen_Eq_binds)
1560  
- 	       ,(ordClassKey,           gen_Ord_binds)
1561  
- 	       ,(enumClassKey,          gen_Enum_binds)
1562  
- 	       ,(boundedClassKey,       gen_Bounded_binds)
1563  
- 	       ,(ixClassKey,            gen_Ix_binds)
1564  
- 	       ,(showClassKey,          gen_Show_binds fix_env)
1565  
- 	       ,(readClassKey,          gen_Read_binds fix_env)
1566  
-	       ,(dataClassKey,          gen_Data_binds)
1567  
-	       ,(functorClassKey,       gen_Functor_binds)
1568  
-	       ,(foldableClassKey,      gen_Foldable_binds)
1569  
-	       ,(traversableClassKey,   gen_Traversable_binds)
1570  
-	       ,(genClassKey,           genGenericBinds)
1571  
- 	       ]
1572  
-\end{code}
1573  
-
1574  
-%************************************************************************
1575  
-%*									*
1576  
-\subsection[TcDeriv-generic-binds]{Bindings for the new generic deriving mechanism}
1577  
-%*									*
1578  
-%************************************************************************
1579  
-
1580  
-For the generic representation we need to generate:
1581  
-\begin{itemize}
1582  
-\item A Generic instance
1583  
-\item A Rep type instance 
1584  
-\item Many auxiliary datatypes and instances for them (for the meta-information)
1585  
-\end{itemize}
1586  
-
1587  
-@genGenericBinds@ does (1)
1588  
-@genGenericRepExtras@ does (2) and (3)
1589  
-@genGenericAll@ does all of them
1590  
-
1591  
-\begin{code}
1592  
-genGenericBinds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1593  
-genGenericBinds _ tc = (mkBindsRep tc, [ {- No DerivAuxBinds -} ])
1594  
-
1595  
-genGenericRepExtras :: TyCon -> TcM (MetaTyCons, TyCon)
1596  
-genGenericRepExtras tc =
1597  
-  do  uniqS <- newUniqueSupply
1598  
-      let
1599  
-        -- Uniques for everyone
1600  
-        (uniqD:uniqs) = uniqsFromSupply uniqS
1601  
-        (uniqsC,us) = splitAt (length tc_cons) uniqs
1602  
-        uniqsS :: [[Unique]] -- Unique supply for the S datatypes
1603  
-        uniqsS = mkUniqsS tc_arits us
1604  
-        mkUniqsS []    _  = []
1605  
-        mkUniqsS (n:t) us = case splitAt n us of
1606  
-                              (us1,us2) -> us1 : mkUniqsS t us2
1607  
-
1608  
-        tc_name   = tyConName tc
1609  
-        tc_cons   = tyConDataCons tc
1610  
-        tc_arits  = map dataConSourceArity tc_cons
1611  
-        
1612  
-        tc_occ    = nameOccName tc_name
1613  
-        d_occ     = mkGenD tc_occ
1614  
-        c_occ m   = mkGenC tc_occ m
1615  
-        s_occ m n = mkGenS tc_occ m n
1616  
-        mod_name  = nameModule (tyConName tc)
1617  
-        d_name    = mkExternalName uniqD mod_name d_occ wiredInSrcSpan
1618  
-        c_names   = [ mkExternalName u mod_name (c_occ m) wiredInSrcSpan
1619  
-                      | (u,m) <- zip uniqsC [0..] ]
1620  
-        s_names   = [ [ mkExternalName u mod_name (s_occ m n) wiredInSrcSpan 
1621  
-                        | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ]
1622  
-        
1623  
-        mkTyCon name = ASSERT( isExternalName name )
1624  
-                       buildAlgTyCon name [] [] distinctAbstractTyConRhs
1625  
-                           NonRecursive False NoParentTyCon Nothing
1626  
-
1627  
-      metaDTyCon  <- mkTyCon d_name
1628  
-      metaCTyCons <- sequence [ mkTyCon c_name | c_name <- c_names ]
1629  
-      metaSTyCons <- mapM sequence 
1630  
-                       [ [ mkTyCon s_name 
1631  
-                         | s_name <- s_namesC ] | s_namesC <- s_names ]
1632  
-
1633  
-      let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
1634  
-  
1635  
-      rep0_tycon <- tc_mkRepTyCon tc metaDts
1636  
-      
1637  
-      -- pprTrace "rep0" (ppr rep0_tycon) $
1638  
-      return (metaDts, rep0_tycon)
1639  
-{-
1640  
-genGenericAll :: TyCon
1641  
-                  -> TcM ((InstInfo RdrName, DerivAuxBinds), MetaTyCons, TyCon)
1642  
-genGenericAll tc =
1643  
-  do  (metaDts, rep0_tycon)     <- genGenericRepExtras tc
1644  
-      clas                      <- tcLookupClass genClassName
1645  
-      dfun_name                 <- new_dfun_name clas tc
1646  
-      let
1647  
-        mkInstRep = (InstInfo { iSpec = inst, iBinds = binds }
1648  
-                               , [ {- No DerivAuxBinds -} ])
1649  
-        inst  = mkLocalInstance dfun NoOverlap
1650  
-        binds = VanillaInst (mkBindsRep tc) [] False
1651  
-
1652  
-        tvs   = tyConTyVars tc
1653  
-        tc_ty = mkTyConApp tc (mkTyVarTys tvs)
1654  
-        
1655  
-        dfun  = mkDictFunId dfun_name (tyConTyVars tc) [] clas [tc_ty]
1656  
-      return (mkInstRep, metaDts, rep0_tycon)
1657  
--}
1658  
-genDtMeta :: (TyCon, MetaTyCons) -> TcM [(InstInfo RdrName, DerivAuxBinds)]
1659  
-genDtMeta (tc,metaDts) =
1660  
-  do  dflags <- getDOpts
1661  
-      dClas <- tcLookupClass datatypeClassName
1662  
-      d_dfun_name <- new_dfun_name dClas tc
1663  
-      cClas <- tcLookupClass constructorClassName
1664  
-      c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ]
1665  
-      sClas <- tcLookupClass selectorClassName
1666  
-      s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc 
1667  
-                                               | _ <- x ] 
1668  
-                                             | x <- metaS metaDts ])
1669  
-      fix_env <- getFixityEnv
1670  
-
1671  
-      let
1672  
-        safeOverlap = safeLanguageOn dflags
1673  
-        (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
1674  
-        
1675  
-        -- Datatype
1676  
-        d_metaTycon = metaD metaDts
1677  
-        d_inst = mkLocalInstance d_dfun $ NoOverlap safeOverlap
1678  
-        d_binds = VanillaInst dBinds [] False
1679  
-        d_dfun  = mkDictFunId d_dfun_name (tyConTyVars tc) [] dClas 
1680  
-                    [ mkTyConTy d_metaTycon ]
1681  
-        d_mkInst = (InstInfo { iSpec = d_inst, iBinds = d_binds }, [])
1682  
-        
1683  
-        -- Constructor
1684  
-        c_metaTycons = metaC metaDts
1685  
-        c_insts = [ mkLocalInstance (c_dfun c ds) $ NoOverlap safeOverlap
1686  
-                  | (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
1687  
-        c_binds = [ VanillaInst c [] False | c <- cBinds ]
1688  
-        c_dfun c dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] cClas 
1689  
-                               [ mkTyConTy c ]
1690  
-        c_mkInst = [ (InstInfo { iSpec = is, iBinds = bs }, []) 
1691  
-                   | (is,bs) <- myZip1 c_insts c_binds ]
1692  
-        
1693  
-        -- Selector
1694  
-        s_metaTycons = metaS metaDts
1695  
-        s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) $
1696  
-                                                  NoOverlap safeOverlap))
1697  
-                    (myZip2 s_metaTycons s_dfun_names)
1698  
-        s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ]
1699  
-        s_dfun s dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] sClas
1700  
-                               [ mkTyConTy s ]
1701  
-        s_mkInst = map (map (\(is,bs) -> (InstInfo {iSpec=is, iBinds=bs}, [])))
1702  
-                     (myZip2 s_insts s_binds)
1703  
-       
1704  
-        myZip1 :: [a] -> [b] -> [(a,b)]
1705  
-        myZip1 l1 l2 = ASSERT (length l1 == length l2) zip l1 l2
1706  
-        
1707  
-        myZip2 :: [[a]] -> [[b]] -> [[(a,b)]]
1708  
-        myZip2 l1 l2 =
1709  
-          ASSERT (and (zipWith (>=) (map length l1) (map length l2)))
1710  
-            [ zip x1 x2 | (x1,x2) <- zip l1 l2 ]
1711  
-        
1712  
-      return (d_mkInst : c_mkInst ++ concat s_mkInst)
  1496
+               ,(ordClassKey,           gen_Ord_binds)
  1497
+               ,(enumClassKey,          gen_Enum_binds)
  1498
+               ,(boundedClassKey,       gen_Bounded_binds)
  1499
+               ,(ixClassKey,            gen_Ix_binds)
  1500
+               ,(showClassKey,          gen_Show_binds fix_env)
  1501
+               ,(readClassKey,          gen_Read_binds fix_env)
  1502
+               ,(dataClassKey,          gen_Data_binds)
  1503
+               ,(functorClassKey,       gen_Functor_binds)
  1504
+               ,(foldableClassKey,      gen_Foldable_binds)
  1505
+               ,(traversableClassKey,   gen_Traversable_binds)
  1506
+               ]
1713 1507
 \end{code}
1714 1508
 
1715  
-
1716 1509
 %************************************************************************
1717 1510
 %*									*
1718 1511
 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
209  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  
-	DerivAuxBinds, isDupAux,
  15
+	BagDerivStuff, DerivStuff(..),
16 16
 
17 17
 	gen_Bounded_binds,
18 18
 	gen_Enum_binds,
@@ -28,7 +28,7 @@ module TcGenDeriv (
28 28
 	deepSubtypesContaining, foldDataConArgs,
29 29
 	gen_Foldable_binds,
30 30
 	gen_Traversable_binds,
31  
-	genAuxBind,
  31
+	genAuxBinds,
32 32
         ordOpTbl, boxConTbl
33 33
     ) where
34 34
 
@@ -62,32 +62,32 @@ import FastString
62 62
 import Bag
63 63
 import Fingerprint
64 64
 import Constants
  65
+import TcEnv (InstInfo)
65 66
 
66 67
 import Data.List        ( partition, intersperse )
67 68
 \end{code}
68 69
 
69 70
 \begin{code}
70  
-type DerivAuxBinds = [DerivAuxBind]
71  
-
72  
-data DerivAuxBind		-- Please add these auxiliary top-level bindings
73  
-  = GenCon2Tag TyCon		-- The con2Tag for given TyCon
74  
-  | GenTag2Con TyCon		-- ...ditto tag2Con
75  
-  | GenMaxTag  TyCon		-- ...and maxTag
76  
-	-- All these generate ZERO-BASED tag operations
77  
-	-- I.e first constructor has tag 0
78  
-
79  
-	-- Scrap your boilerplate
80  
-  | MkDataCon DataCon		-- For constructor C we get $cC :: Constr
81  
-  | MkTyCon   TyCon		-- For tycon T we get       $tT :: DataType
82  
-
83  
-
84  
-isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool
85  
-isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1 == tc2
86  
-isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1 == tc2
87  
-isDupAux (GenMaxTag tc1)  (GenMaxTag tc2)  = tc1 == tc2
88  
-isDupAux (MkDataCon dc1)  (MkDataCon dc2)  = dc1 == dc2
89  
-isDupAux (MkTyCon tc1)    (MkTyCon tc2)    = tc1 == tc2
90  
-isDupAux _                _                = False
  71
+type BagDerivStuff = Bag DerivStuff
  72
+
  73
+data AuxBindSpec
  74
+  = DerivCon2Tag TyCon  -- The con2Tag for given TyCon
  75
+  | DerivTag2Con TyCon  -- ...ditto tag2Con
  76
+  | DerivMaxTag  TyCon  -- ...and maxTag
  77
+  deriving( Eq )
  78
+  -- All these generate ZERO-BASED tag operations
  79
+  -- I.e first constructor has tag 0
  80
+
  81
+data DerivStuff     -- Please add this auxiliary stuff
  82
+  = DerivAuxBind AuxBindSpec
  83
+
  84
+  -- Generics
  85
+  | DerivTyCon TyCon      -- New data types
  86
+  | DerivFamInst TyCon    -- New type family instances
  87
+
  88
+  -- New top-level auxiliary bindings 
  89
+  | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
  90
+  | DerivInst (InstInfo RdrName)                -- New, auxiliary instances
91 91
 \end{code}
92 92
 
93 93
 
@@ -166,7 +166,7 @@ instance ... Eq (Foo ...) where
166 166
 
167 167
 
168 168
 \begin{code}
169  
-gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
  169
+gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
170 170
 gen_Eq_binds loc tycon
171 171
   = (method_binds, aux_binds)
172 172
   where
@@ -186,8 +186,8 @@ gen_Eq_binds loc tycon
186 186
     	    untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
187 187
     	               (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
188 188
 
189  
-    aux_binds | no_nullary_cons = []
190  
-	      | otherwise       = [GenCon2Tag tycon]
  189
+    aux_binds | no_nullary_cons = emptyBag
  190
+	      | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
191 191
 
192 192
     method_binds = listToBag [eq_bind, ne_bind]
193 193
     eq_bind = mk_FunBind loc eq_RDR (map pats_etc nonnullary_cons ++ rest)
@@ -324,15 +324,15 @@ gtResult OrdGE      = true_Expr
324 324
 gtResult OrdGT      = true_Expr
325 325
 
326 326
 ------------
327  
-gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
  327
+gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
328 328
 gen_Ord_binds loc tycon
329 329
   | null tycon_data_cons	-- No data-cons => invoke bale-out case
330  
-  = (unitBag $ mk_FunBind loc compare_RDR [], [])
  330
+  = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag)
331 331
   | otherwise
332 332
   = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
333 333
   where
334  
-    aux_binds | single_con_type = []
335  
-              | otherwise       = [GenCon2Tag tycon]
  334
+    aux_binds | single_con_type = emptyBag
  335
+              | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
336 336
 
337 337
 	-- Note [Do not rely on compare]
338 338
     other_ops | (last_tag - first_tag) <= 2 	-- 1-3 constructors
@@ -547,7 +547,7 @@ instance ... Enum (Foo ...) where
547 547
 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
548 548
 
549 549
 \begin{code}
550  
-gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
  550
+gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
551 551
 gen_Enum_binds loc tycon
552 552
   = (method_binds, aux_binds)
553 553
   where
@@ -559,7 +559,8 @@ gen_Enum_binds loc tycon
559 559
 			enum_from_then,
560 560
 			from_enum
561 561
 		    ]
562  
-    aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]
  562
+    aux_binds = listToBag $ map DerivAuxBind
  563
+                  [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
563 564
 
564 565
     occ_nm = getOccString tycon
565 566
 
@@ -626,13 +627,13 @@ gen_Enum_binds loc tycon
626 627
 %************************************************************************
627 628
 
628 629
 \begin{code}
629  
-gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
  630
+gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
630 631
 gen_Bounded_binds loc tycon
631 632
   | isEnumerationTyCon tycon
632  
-  = (listToBag [ min_bound_enum, max_bound_enum ], [])
  633
+  = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
633 634
   | otherwise
634 635
   = ASSERT(isSingleton data_cons)
635  
-    (listToBag [ min_bound_1con, max_bound_1con ], [])
  636
+    (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
636 637
   where
637 638
     data_cons = tyConDataCons tycon
638 639
 
@@ -713,13 +714,15 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report
713 714
 (p.~147).
714 715
 
715 716
 \begin{code}
716  
-gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
  717
+gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
717 718
 
718 719
 gen_Ix_binds loc tycon
719 720
   | isEnumerationTyCon tycon
720  
-  = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
  721
+  = ( enum_ixes
  722
+    , listToBag $ map DerivAuxBind
  723
+                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
721 724
   | otherwise
722  
-  = (single_con_ixes, [GenCon2Tag tycon])
  725
+  = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
723 726
   where
724 727
     --------------------------------------------------------------
725 728
     enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
@@ -872,10 +875,10 @@ instance Read T where
872 875
 
873 876
 
874 877
 \begin{code}
875  
-gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
  878
+gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
876 879
 
877 880
 gen_Read_binds get_fixity loc tycon
878  
-  = (listToBag [read_prec, default_readlist, default_readlistprec], [])
  881
+  = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
879 882
   where
880 883
     -----------------------------------------------------------------------
881 884
     default_readlist 
@@ -1041,10 +1044,10 @@ Example
1041 1044
 		    -- the most tightly-binding operator
1042 1045
 
1043 1046
 \begin{code}
1044  
-gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
  1047
+gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1045 1048
 
1046 1049
 gen_Show_binds get_fixity loc tycon
1047  
-  = (listToBag [shows_prec, show_list], [])
  1050
+  = (listToBag [shows_prec, show_list], emptyBag)
1048 1051
   where
1049 1052
     -----------------------------------------------------------------------
1050 1053
     show_list = mkHsVarBind loc showList_RDR
@@ -1254,17 +1257,53 @@ we generate
1254 1257
 gen_Data_binds :: SrcSpan
1255 1258
 	       -> TyCon 
1256 1259
 	       -> (LHsBinds RdrName,	-- The method bindings
1257  
-		   DerivAuxBinds)	-- Auxiliary bindings
  1260
+		   BagDerivStuff)	-- Auxiliary bindings
1258 1261
 gen_Data_binds loc tycon
1259 1262
   = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
1260 1263
      `unionBags` gcast_binds,
1261 1264
 		-- Auxiliary definitions: the data type and constructors
1262  
-     MkTyCon tycon : map MkDataCon data_cons)
  1265
+     listToBag ( DerivHsBind (genDataTyCon)
  1266
+               : map (DerivHsBind . genDataDataCon) data_cons))
1263 1267
   where
1264 1268
     data_cons  = tyConDataCons tycon
1265 1269
     n_cons     = length data_cons
1266 1270
     one_constr = n_cons == 1
1267 1271
 
  1272
+    genDataTyCon :: (LHsBind RdrName, LSig RdrName)
  1273
+    genDataTyCon        --  $dT
  1274
+      = (mkHsVarBind loc rdr_name rhs,
  1275
+         L loc (TypeSig [L loc rdr_name] sig_ty))
  1276
+      where
  1277
+        rdr_name = mk_data_type_name tycon
  1278
+        sig_ty   = nlHsTyVar dataType_RDR
  1279
+        constrs  = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
  1280
+        rhs = nlHsVar mkDataType_RDR 
  1281
+              `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
  1282
+              `nlHsApp` nlList constrs
  1283
+
  1284
+    genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName)
  1285
+    genDataDataCon dc       --  $cT1 etc
  1286
+      = (mkHsVarBind loc rdr_name rhs,
  1287
+         L loc (TypeSig [L loc rdr_name] sig_ty))
  1288
+      where
  1289
+        rdr_name = mk_constr_name dc
  1290
+        sig_ty   = nlHsTyVar constr_RDR
  1291
+        rhs      = nlHsApps mkConstr_RDR constr_args
  1292
+    
  1293
+        constr_args 
  1294
+           = [ -- nlHsIntLit (toInteger (dataConTag dc)),	  -- Tag
  1295
+    	   nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
  1296
+    	   nlHsLit (mkHsString (occNameString dc_occ)),	  -- String name
  1297
+               nlList  labels,				  -- Field labels
  1298
+    	   nlHsVar fixity]				  -- Fixity
  1299
+    
  1300
+        labels   = map (nlHsLit . mkHsString . getOccString)
  1301
+                       (dataConFieldLabels dc)
  1302
+        dc_occ   = getOccName dc
  1303
+        is_infix = isDataSymOcc dc_occ
  1304
+        fixity | is_infix  = infix_RDR
  1305
+    	   | otherwise = prefix_RDR
  1306
+
1268 1307
 	------------ gfoldl
1269 1308
     gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
1270 1309
           
@@ -1416,9 +1455,9 @@ This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1416 1455
   $(cofmap 'a '(b -> c))  x  =  \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1417 1456
 
1418 1457
 \begin{code}
1419  
-gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
  1458
+gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1420 1459
 gen_Functor_binds loc tycon
1421  
-  = (unitBag fmap_bind, [])
  1460
+  = (unitBag fmap_bind, emptyBag)
1422 1461
   where
1423 1462
     data_cons = tyConDataCons tycon
1424 1463
     fmap_bind = L loc $ mkRdrFunBind (L loc fmap_RDR) eqns
@@ -1587,9 +1626,9 @@ Note that the arguments to the real foldr function are the wrong way around,
1587 1626
 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1588 1627
 
1589 1628
 \begin{code}
1590  
-gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
  1629
+gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1591 1630
 gen_Foldable_binds loc tycon
1592  
-  = (unitBag foldr_bind, [])
  1631
+  = (unitBag foldr_bind, emptyBag)
1593 1632
   where
1594 1633
     data_cons = tyConDataCons tycon
1595 1634
 
@@ -1639,9 +1678,9 @@ gives the function: traverse f (T x y) = T <$> pure x <*> f y
1639 1678
 instead of:         traverse f (T x y) = T x <$> f y
1640 1679
 
1641 1680
 \begin{code}
1642  
-gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
  1681
+gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1643 1682
 gen_Traversable_binds loc tycon
1644  
-  = (unitBag traverse_bind, [])
  1683
+  = (unitBag traverse_bind, emptyBag)
1645 1684
   where
1646 1685
     data_cons = tyConDataCons tycon
1647 1686
 
@@ -1694,8 +1733,8 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1694 1733
 fiddling around.
1695 1734
 
1696 1735
 \begin{code}
1697  
-genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName)
1698  
-genAuxBind loc (GenCon2Tag tycon)
  1736
+genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName)
  1737
+genAuxBindSpec loc (DerivCon2Tag tycon)
1699 1738
   = (mk_FunBind loc rdr_name eqns, 
1700 1739
      L loc (TypeSig [L loc rdr_name] (L loc sig_ty)))
1701 1740
   where
@@ -1718,7 +1757,7 @@ genAuxBind loc (GenCon2Tag tycon)
1718 1757
     mk_eqn con = ([nlWildConPat con], 
1719 1758
 		  nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1720 1759
 
1721  
-genAuxBind loc (GenTag2Con tycon)
  1760
+genAuxBindSpec loc (DerivTag2Con tycon)
1722 1761
   = (mk_FunBind loc rdr_name 
1723 1762
 	[([nlConVarPat intDataCon_RDR [a_RDR]], 
1724 1763
 	   nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
@@ -1729,7 +1768,7 @@ genAuxBind loc (GenTag2Con tycon)
1729 1768
 
1730 1769
     rdr_name = tag2con_RDR tycon
1731 1770
 
1732  
-genAuxBind loc (GenMaxTag tycon)
  1771
+genAuxBindSpec loc (DerivMaxTag tycon)
1733 1772
   = (mkHsVarBind loc rdr_name rhs,
1734 1773
      L loc (TypeSig [L loc rdr_name] (L loc sig_ty)))
1735 1774
   where
@@ -1739,38 +1778,36 @@ genAuxBind loc (GenMaxTag tycon)
1739 1778
     max_tag =  case (tyConDataCons tycon) of
1740 1779
 		 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1741 1780
 
1742  
-genAuxBind loc (MkTyCon tycon)	--  $dT
1743  
-  = (mkHsVarBind loc rdr_name rhs,
1744  
-     L loc (TypeSig [L loc rdr_name] sig_ty))
1745  
-  where
1746  
-    rdr_name = mk_data_type_name tycon
1747  
-    sig_ty   = nlHsTyVar dataType_RDR
1748  
-    constrs  = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
1749  
-    rhs = nlHsVar mkDataType_RDR 
1750  
-          `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1751  
-          `nlHsApp` nlList constrs
1752  
-
1753  
-genAuxBind loc (MkDataCon dc)	--  $cT1 etc
1754  
-  = (mkHsVarBind loc rdr_name rhs,
1755  
-     L loc (TypeSig [L loc rdr_name] sig_ty))
1756  
-  where
1757  
-    rdr_name = mk_constr_name dc
1758  
-    sig_ty   = nlHsTyVar constr_RDR
1759  
-    rhs      = nlHsApps mkConstr_RDR constr_args
1760  
-
1761  
-    constr_args 
1762  
-       = [ -- nlHsIntLit (toInteger (dataConTag dc)),	  -- Tag
1763  
-	   nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1764  
-	   nlHsLit (mkHsString (occNameString dc_occ)),	  -- String name
1765  
-           nlList  labels,				  -- Field labels
1766  
-	   nlHsVar fixity]				  -- Fixity
1767  
-
1768  
-    labels   = map (nlHsLit . mkHsString . getOccString)
1769  
-                   (dataConFieldLabels dc)
1770  
-    dc_occ   = getOccName dc
1771  
-    is_infix = isDataSymOcc dc_occ
1772  
-    fixity | is_infix  = infix_RDR
1773  
-	   | otherwise = prefix_RDR
  1781
+type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings
  1782
+                              ( Bag (LHsBind RdrName, LSig RdrName)
  1783
+                                -- Extra bindings (used by Generic only)
  1784
+                              , Bag TyCon -- Extra top-level datatypes
  1785
+                              , Bag TyCon -- Extra family instances
  1786
+                              , Bag (InstInfo RdrName)) -- Extra instances
  1787
+
  1788
+genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
  1789
+genAuxBinds loc b = genAuxBinds' b2 where
  1790
+  (b1,b2) = partitionBagWith splitDerivAuxBind b
  1791
+  splitDerivAuxBind (DerivAuxBind x) = Left x
  1792
+  splitDerivAuxBind  x               = Right x
  1793
+
  1794
+  rm_dups = foldrBag dup_check emptyBag
  1795
+  dup_check a b = if anyBag (== a) b then b else consBag a b
  1796
+  
  1797
+  genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
  1798
+  genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1)
  1799
+                            , emptyBag, emptyBag, emptyBag)
  1800
+  f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
  1801
+  f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
  1802
+  f (DerivHsBind  b) = add1 b
  1803
+  f (DerivTyCon   t) = add2 t
  1804
+  f (DerivFamInst t) = add3 t
  1805
+  f (DerivInst    i) = add4 i
  1806
+
  1807
+  add1 x (a,b,c,d) = (x `consBag` a,b,c,d)
  1808
+  add2 x (a,b,c,d) = (a,x `consBag` b,c,d)
  1809
+  add3 x (a,b,c,d) = (a,b,x `consBag` c,d)
  1810
+  add4 x (a,b,c,d) = (a,b,c,x `consBag` d)
1774 1811
 
1775 1812
 mk_data_type_name :: TyCon -> RdrName 	-- "$tT"
1776 1813
 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
171  compiler/types/Generics.lhs → compiler/typecheck/TcGenGenerics.lhs 100644 → 100755
@@ -2,45 +2,175 @@
2 2
 % (c) The University of Glasgow 2011
3 3
 %
4 4
 
  5
+The deriving code for the Generic class
  6
+(equivalent to the code in TcGenDeriv, for other classes)
  7
+
5 8
 \begin{code}
6 9
 
7  
-module Generics ( canDoGenerics,
8  
-		  mkBindsRep, tc_mkRepTyCon, mkBindsMetaD,
9  
-		  MetaTyCons(..), metaTyCons2TyCons
10  
-    ) where
  10
+module TcGenGenerics (canDoGenerics, gen_Generic_binds) where
11 11
 
12 12
 
  13
+import DynFlags
13 14
 import HsSyn
14 15
 import Type
15 16
 import TcType
  17
+import TcGenDeriv
16 18
 import DataCon
17  
-
18 19
 import TyCon
19 20
 import Name hiding (varName)
20  
-import Module (moduleName, moduleNameString)
  21
+import Module (Module, moduleName, moduleNameString)
  22
+import IfaceEnv (newGlobalBinder)
21 23
 import RdrName
22 24
 import BasicTypes
23 25
 import TysWiredIn
24 26
 import PrelNames
25  
-
26  
--- For generation of representation types
27  
-import TcEnv (tcLookupTyCon)
  27
+import InstEnv
  28
+import TcEnv
  29
+import MkId
28 30
 import TcRnMonad
29 31
 import HscTypes
30 32
 import BuildTyCl
31  
-
32 33
 import SrcLoc
33 34
 import Bag
34 35
 import Outputable 
35 36
 import FastString
  37
+import UniqSupply
36 38
 
37 39
 #include "HsVersions.h"
38 40
 \end{code}
39 41
 
40 42
 %************************************************************************
41  
-%*									*
  43
+%*                                                                      *
  44
+\subsection{Bindings for the new generic deriving mechanism}
  45
+%*                                                                      *
  46
+%************************************************************************
  47
+
  48
+For the generic representation we need to generate:
  49
+\begin{itemize}
  50
+\item A Generic instance
  51
+\item A Rep type instance 
  52
+\item Many auxiliary datatypes and instances for them (for the meta-information)
  53
+\end{itemize}
  54
+
  55
+\begin{code}
  56
+gen_Generic_binds :: TyCon -> Module
  57
+                 -> TcM (LHsBinds RdrName, BagDerivStuff)
  58
+gen_Generic_binds tc mod = do
  59
+        { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc mod
  60
+        ; metaInsts                <- genDtMeta (tc, metaTyCons)
  61
+        ; return ( mkBindsRep tc
  62
+                 ,           (DerivFamInst rep0TyInst)
  63
+                   `consBag` ((mapBag DerivTyCon (metaTyCons2TyCons metaTyCons))
  64
+                   `unionBags` metaInsts)) }
  65
+
  66
+genGenericRepExtras :: TyCon -> Module -> TcM (MetaTyCons, TyCon)
  67
+genGenericRepExtras tc mod =
  68
+  do  uniqS <- newUniqueSupply
  69
+      let
  70
+        -- Uniques for everyone
  71
+        (uniqD:uniqs) = uniqsFromSupply uniqS
  72
+        (uniqsC,us) = splitAt (length tc_cons) uniqs
  73
+        uniqsS :: [[Unique]] -- Unique supply for the S datatypes
  74
+        uniqsS = mkUniqsS tc_arits us
  75
+        mkUniqsS []    _  = []
  76
+        mkUniqsS (n:t) us = case splitAt n us of
  77
+                              (us1,us2) -> us1 : mkUniqsS t us2
  78
+
  79
+        tc_name   = tyConName tc
  80
+        tc_cons   = tyConDataCons tc
  81
+        tc_arits  = map dataConSourceArity tc_cons
  82
+        
  83
+        tc_occ    = nameOccName tc_name
  84
+        d_occ     = mkGenD tc_occ
  85
+        c_occ m   = mkGenC tc_occ m
  86
+        s_occ m n = mkGenS tc_occ m n
  87
+        d_name    = mkExternalName uniqD mod d_occ wiredInSrcSpan
  88
+        c_names   = [ mkExternalName u mod (c_occ m) wiredInSrcSpan
  89
+                      | (u,m) <- zip uniqsC [0..] ]
  90
+        s_names   = [ [ mkExternalName u mod (s_occ m n) wiredInSrcSpan 
  91
+                        | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ]
  92
+        
  93
+        mkTyCon name = ASSERT( isExternalName name )
  94
+                       buildAlgTyCon name [] [] distinctAbstractTyConRhs
  95
+                           NonRecursive False NoParentTyCon Nothing
  96
+
  97
+      metaDTyCon  <- mkTyCon d_name
  98
+      metaCTyCons <- sequence [ mkTyCon c_name | c_name <- c_names ]
  99
+      metaSTyCons <- mapM sequence 
  100
+                       [ [ mkTyCon s_name 
  101
+                         | s_name <- s_namesC ] | s_namesC <- s_names ]
  102
+
  103
+      let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
  104
+  
  105
+      rep0_tycon <- tc_mkRepTyCon tc metaDts mod
  106
+      
  107
+      -- pprTrace "rep0" (ppr rep0_tycon) $
  108
+      return (metaDts, rep0_tycon)
  109
+
  110
+genDtMeta :: (TyCon, MetaTyCons) -> TcM BagDerivStuff
  111
+genDtMeta (tc,metaDts) =
  112
+  do  loc <- getSrcSpanM
  113
+      dflags <- getDOpts
  114
+      dClas <- tcLookupClass datatypeClassName
  115
+      let new_dfun_name clas tycon = newDFunName clas [mkTyConApp tycon []] loc
  116
+      d_dfun_name <- new_dfun_name dClas tc
  117
+      cClas <- tcLookupClass constructorClassName
  118
+      c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ]
  119
+      sClas <- tcLookupClass selectorClassName
  120
+      s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc 
  121
+                                               | _ <- x ] 
  122
+                                             | x <- metaS metaDts ])
  123
+      fix_env <- getFixityEnv
  124
+
  125
+      let
  126
+        safeOverlap = safeLanguageOn dflags
  127
+        (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
  128
+        
  129
+        -- Datatype
  130
+        d_metaTycon = metaD metaDts
  131
+        d_inst = mkLocalInstance d_dfun $ NoOverlap safeOverlap
  132
+        d_binds = VanillaInst dBinds [] False
  133
+        d_dfun  = mkDictFunId d_dfun_name (tyConTyVars tc) [] dClas 
  134
+                    [ mkTyConTy d_metaTycon ]
  135
+        d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds })
  136
+        
  137
+        -- Constructor
  138
+        c_metaTycons = metaC metaDts
  139
+        c_insts = [ mkLocalInstance (c_dfun c ds) $ NoOverlap safeOverlap
  140
+                  | (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
  141
+        c_binds = [ VanillaInst c [] False | c <- cBinds ]
  142
+        c_dfun c dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] cClas 
  143
+                               [ mkTyConTy c ]
  144
+        c_mkInst = [ DerivInst (InstInfo { iSpec = is, iBinds = bs })
  145
+                   | (is,bs) <- myZip1 c_insts c_binds ]
  146
+        
  147
+        -- Selector
  148
+        s_metaTycons = metaS metaDts
  149
+        s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) $
  150
+                                                  NoOverlap safeOverlap))
  151
+                    (myZip2 s_metaTycons s_dfun_names)
  152
+        s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ]
  153
+        s_dfun s dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] sClas
  154
+                               [ mkTyConTy s ]
  155
+        s_mkInst = map (map (\(is,bs) -> DerivInst (InstInfo { iSpec  = is
  156
+                                                             , iBinds = bs})))
  157
+                       (myZip2 s_insts s_binds)
  158
+       
  159
+        myZip1 :: [a] -> [b] -> [(a,b)]
  160
+        myZip1 l1 l2 = ASSERT (length l1 == length l2) zip l1 l2
  161
+        
  162
+        myZip2 :: [[a]] -> [[b]] -> [[(a,b)]]
  163
+        myZip2 l1 l2 =
  164
+          ASSERT (and (zipWith (>=) (map length l1) (map length l2)))
  165
+            [ zip x1 x2 | (x1,x2) <- zip l1 l2 ]
  166
+        
  167
+      return (listToBag (d_mkInst : c_mkInst ++ concat s_mkInst))
  168
+\end{code}
  169
+
  170
+%************************************************************************
  171
+%*                                                                      *
42 172
 \subsection{Generating representation types}
43  
-%*									*
  173
+%*                                                                      *
44 174
 %************************************************************************
45 175
 
46 176
 \begin{code}
@@ -73,9 +203,7 @@ canDoGenerics tycon
73 203
                           then (Just (ppr dc <+> text "must be a vanilla data constructor"))
74 204
                           else Nothing)
75 205
 
76  
-
77 206
 	-- Nor can we do the job if it's an existen