X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FGenerics.lhs;h=68a41f84a2a839f02aab533bfc6a30532bcbac42;hb=c7cb47fc0e98e660621bfe7368464c4c93c9dbf1;hp=50b6b96a03fe7621e246a51e464fc10c70d6b498;hpb=ada48bbc7f6a43b2c042df629327902d82cea681;p=ghc-hetmet.git

diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs
index 50b6b96..68a41f8 100644
--- a/compiler/types/Generics.lhs
+++ b/compiler/types/Generics.lhs
@@ -5,7 +5,7 @@
 \begin{code}
 
 module Generics ( canDoGenerics,
-		  mkBindsRep0, tc_mkRep0TyCon, mkBindsMetaD,
+		  mkBindsRep, tc_mkRepTyCon, mkBindsMetaD,
 		  MetaTyCons(..), metaTyCons2TyCons
     ) where
 
@@ -42,29 +42,47 @@ import FastString
 %************************************************************************
 
 \begin{code}
-canDoGenerics :: TyCon -> Bool
+canDoGenerics :: TyCon -> Maybe SDoc
 -- Called on source-code data types, to see if we should generate
 -- generic functions for them.
+-- Nothing == yes
+-- Just s  == no, because of `s`
 
 canDoGenerics tycon
-  =  let result = not (any bad_con (tyConDataCons tycon)) 	-- See comment below
-                  -- We do not support datatypes with context (for now)
-                  && null (tyConStupidTheta tycon)
-                  -- We don't like type families
-                  && not (isFamilyTyCon tycon)
-
-     in {- pprTrace "canDoGenerics" (ppr (tycon,result)) -} result
+  =  mergeErrors (
+          -- We do not support datatypes with context
+              (if (not (null (tyConStupidTheta tycon)))
+                then (Just (ppr tycon <+> text "must not have a datatype context"))
+                else Nothing)
+          -- We don't like type families
+            : (if (isFamilyTyCon tycon)
+                then (Just (ppr tycon <+> text "must not be a family instance"))
+                else Nothing)
+          -- See comment below
+            : (map bad_con (tyConDataCons tycon)))
   where
-    bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
-  	-- If any of the constructor has an unboxed type as argument,
-	-- then we can't build the embedding-projection pair, because
-	-- it relies on instantiating *polymorphic* sum and product types
-	-- at the argument types of the constructors
+        -- If any of the constructor has an unboxed type as argument,
+        -- then we can't build the embedding-projection pair, because
+        -- it relies on instantiating *polymorphic* sum and product types
+        -- at the argument types of the constructors
+    bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))
+                  then (Just (ppr dc <+> text "must not have unlifted or polymorphic arguments"))
+                  else (if (not (isVanillaDataCon dc))
+                          then (Just (ppr dc <+> text "must be a vanilla data constructor"))
+                          else Nothing)
+
 
 	-- Nor can we do the job if it's an existential data constructor,
 
 	-- Nor if the args are polymorphic types (I don't think)
     bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
+    
+    mergeErrors :: [Maybe SDoc] -> Maybe SDoc
+    mergeErrors []           = Nothing
+    mergeErrors ((Just s):t) = case mergeErrors t of
+                                 Nothing -> Just s
+                                 Just s' -> Just (s <> text ", and" $$ s')
+    mergeErrors (Nothing :t) = mergeErrors t
 \end{code}
 
 %************************************************************************
@@ -77,33 +95,33 @@ canDoGenerics tycon
 type US = Int	-- Local unique supply, just a plain Int
 type Alt = (LPat RdrName, LHsExpr RdrName)
 
--- Bindings for the Representable0 instance
-mkBindsRep0 :: TyCon -> LHsBinds RdrName
-mkBindsRep0 tycon = 
-    unitBag (L loc (mkFunBind (L loc from0_RDR) from0_matches))
+-- Bindings for the Generic instance
+mkBindsRep :: TyCon -> LHsBinds RdrName
+mkBindsRep tycon = 
+    unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
   `unionBags`
-    unitBag (L loc (mkFunBind (L loc to0_RDR) to0_matches))
+    unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
       where
-        from0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from0_alts]
-        to0_matches   = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to0_alts  ]
+        from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
+        to_matches   = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts  ]
         loc           = srcLocSpan (getSrcLoc tycon)
         datacons      = tyConDataCons tycon
 
         -- Recurse over the sum first
-        from0_alts, to0_alts :: [Alt]
-        (from0_alts, to0_alts) = mkSum (1 :: US) tycon datacons
+        from_alts, to_alts :: [Alt]
+        (from_alts, to_alts) = mkSum (1 :: US) tycon datacons
         
 --------------------------------------------------------------------------------
 -- Type representation
 --------------------------------------------------------------------------------
 
-tc_mkRep0Ty :: -- The type to generate representation for
+tc_mkRepTy :: -- The type to generate representation for
                TyCon 
                -- Metadata datatypes to refer to
             -> MetaTyCons 
                -- Generated representation0 type
             -> TcM Type
-tc_mkRep0Ty tycon metaDts = 
+tc_mkRepTy tycon metaDts = 
   do
     d1    <- tcLookupTyCon d1TyConName
     c1    <- tcLookupTyCon c1TyConName
@@ -155,18 +173,18 @@ tc_mkRep0Ty tycon metaDts =
         
     return (mkD tycon)
 
-tc_mkRep0TyCon :: TyCon           -- The type to generate representation for
+tc_mkRepTyCon :: TyCon           -- The type to generate representation for
                -> MetaTyCons      -- Metadata datatypes to refer to
                -> TcM TyCon       -- Generated representation0 type
-tc_mkRep0TyCon tycon metaDts = 
+tc_mkRepTyCon tycon metaDts = 
 -- Consider the example input tycon `D`, where data D a b = D_ a
   do
     uniq1   <- newUnique
     uniq2   <- newUnique
     -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
-    rep0Ty  <- tc_mkRep0Ty tycon metaDts
-    -- `rep0` = GHC.Generics.Rep0 (type family)
-    rep0    <- tcLookupTyCon rep0TyConName
+    rep0Ty  <- tc_mkRepTy tycon metaDts
+    -- `rep0` = GHC.Generics.Rep (type family)
+    rep0    <- tcLookupTyCon repTyConName
     
     let modl    = nameModule  (tyConName tycon)
         loc     = nameSrcSpan (tyConName tycon)
@@ -185,7 +203,7 @@ tc_mkRep0TyCon tycon metaDts =
                  tyvars (SynonymTyCon rep0Ty)
                  (FamInstTyCon rep0 appT
                    (mkCoercionTyCon coName (tyConArity tycon)
-                     -- co : forall a b. Rep0 (D a b) ~ `rep0Ty` a b
+                     -- co : forall a b. Rep (D a b) ~ `rep0Ty` a b
                      (CoAxiom tyvars (mkTyConApp rep0 appT) rep0Ty)))
 
     return res