fix haddock submodule pointer

[ghc-hetmet.git] / compiler / typecheck / TcDeriv.lhs

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index adf72cf..fab7c61 100644 (file)
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -332,7 +332,7 @@ tcDeriving tycl_decls inst_decls deriv_decls
 
        ; dflags <- getDOpts
        ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
-                (ddump_deriving inst_info rn_binds))
+                (ddump_deriving inst_info rn_binds repMetaTys repTyCons metaInsts))
 {-
         ; when (not (null inst_info)) $
           dumpDerivingInfo (ddump_deriving inst_info rn_binds)
@@ -340,11 +340,26 @@ tcDeriving tycl_decls inst_decls deriv_decls
        ; return ( inst_info, rn_binds, rn_dus
                  , concat (map metaTyCons2TyCons repMetaTys), repTyCons) }
   where
-    ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc
-    ddump_deriving inst_infos extra_binds
-      = hang (ptext (sLit "Derived instances"))
-           2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)
-              $$ ppr extra_binds)
+    ddump_deriving :: [InstInfo Name] -> HsValBinds Name 
+                   -> [MetaTyCons] -- ^ Empty data constructors
+                   -> [TyCon]      -- ^ Rep type family instances
+                   -> [[(InstInfo RdrName, DerivAuxBinds)]] 
+                      -- ^ Instances for the repMetaTys
+                   -> SDoc
+    ddump_deriving inst_infos extra_binds repMetaTys repTyCons metaInsts
+      =    hang (ptext (sLit "Derived instances"))
+              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)
+                 $$ ppr extra_binds)
+        $$ hangP "Generic representation" (
+              hangP "Generated datatypes for meta-information"
+               (vcat (map ppr repMetaTys))
+           -- The Outputable instance for TyCon unfortunately only prints the name...
+           $$ hangP "Representation types" 
+                (vcat (map ppr  repTyCons))
+           $$ hangP "Meta-information instances"
+                (vcat (map (pprInstInfoDetails . fst) (concat metaInsts))))
+    
+    hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
 
 
 renameDeriv :: Bool -> LHsBinds RdrName
@@ -476,7 +491,11 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
                                   (sel_tydata ++ sel_deriv_decls)) allTyNames
         -- We need to generate the extras to add to what has
         -- already been derived
-        ; mapM mkGenDerivExtras derTyDecls }
+        ; {- pprTrace "sel_tydata" (ppr sel_tydata) $
+          pprTrace "sel_deriv_decls" (ppr sel_deriv_decls) $
+          pprTrace "derTyDecls" (ppr derTyDecls) $
+          pprTrace "deriv_decls" (ppr deriv_decls) $ -}
+          mapM mkGenDerivExtras derTyDecls }
 
         -- Merge and return
         ; return ( eqns1 ++ eqns2, generic_extras_deriv) }
@@ -487,14 +506,22 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
 
     -- Extracts the name of the class in the deriving
     getClassName :: HsType Name -> Maybe Name
-    getClassName (HsPredTy (HsClassP n _)) = Just n
-    getClassName _                         = Nothing
+    getClassName (HsForAllTy _ _ _ (L _ n)) = getClassName n
+    getClassName (HsPredTy (HsClassP n _))  = Just n
+    getClassName _                          = Nothing
 
     -- Extracts the name of the type in the deriving
+    -- This function (and also getClassName above) is not really nice, and I
+    -- might not have covered all possible cases. I wonder if there is no easier
+    -- way to extract class and type name from a LDerivDecl...
     getTypeName :: HsType Name -> Maybe Name
+    getTypeName (HsForAllTy _ _ _ (L _ n))      = getTypeName n
     getTypeName (HsTyVar n)                     = Just n
     getTypeName (HsOpTy _ (L _ n) _)            = Just n
     getTypeName (HsPredTy (HsClassP _ [L _ n])) = getTypeName n
+    getTypeName (HsAppTy (L _ n) _)             = getTypeName n
+    getTypeName (HsParTy (L _ n))               = getTypeName n
+    getTypeName (HsKindSig (L _ n) _)           = getTypeName n
     getTypeName _                               = Nothing
 
     extractTyDataPreds decls
@@ -1356,7 +1383,7 @@ inferInstanceContexts oflag infer_specs
                  
           ; let tv_set = mkVarSet tyvars
                 weird_preds = [pred | pred <- deriv_rhs
-                                     , not (tyVarsOfPred pred `subVarSet` tv_set)]  
+                                     , not (tyVarsOfPred pred `subVarSet` tv_set)]
           ; mapM_ (addErrTc . badDerivedPred) weird_preds      
 
            ; theta <- simplifyDeriv orig the_pred tyvars deriv_rhs
@@ -1487,14 +1514,12 @@ genInst standalone_deriv oflag
   where
     inst_spec = mkInstance oflag theta spec
     co1 = case tyConFamilyCoercion_maybe rep_tycon of
-             Just co_con -> ACo (mkTyConApp co_con rep_tc_args)
+              Just co_con -> mkAxInstCo co_con rep_tc_args
              Nothing     -> id_co
              -- Not a family => rep_tycon = main tycon
-    co2 = case newTyConCo_maybe rep_tycon of
-             Just co_con -> ACo (mkTyConApp co_con rep_tc_args)
-              Nothing     -> id_co  -- The newtype is transparent; no need for a cast
-    co = co1 `mkTransCoI` co2
-    id_co = IdCo (mkTyConApp rep_tycon rep_tc_args)
+    co2 = mkAxInstCo (newTyConCo rep_tycon) rep_tc_args
+    co  = co1 `mkTransCo` co2
+    id_co = mkReflCo (mkTyConApp rep_tycon rep_tc_args)
 
 -- Example: newtype instance N [a] = N1 (Tree a) 
 --          deriving instance Eq b => Eq (N [(b,b)])
@@ -1592,7 +1617,8 @@ genGenericRepExtras tc =
       let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
   
       rep0_tycon <- tc_mkRepTyCon tc metaDts
-
+      
+      -- pprTrace "rep0" (ppr rep0_tycon) $
       return (metaDts, rep0_tycon)
 {-
 genGenericAll :: TyCon