Make assignTemp_ less pessimistic
[ghc-hetmet.git] / compiler / types / Generics.lhs
index b608128..323da41 100644 (file)
@@ -5,7 +5,7 @@
 \begin{code}
 
 module Generics ( canDoGenerics,
-                 mkBindsRep0, tc_mkRep0TyCon, mkBindsMetaD,
+                 mkBindsRep, tc_mkRepTyCon, mkBindsMetaD,
                  MetaTyCons(..), metaTyCons2TyCons
     ) where
 
@@ -22,10 +22,12 @@ import RdrName
 import BasicTypes
 import TysWiredIn
 import PrelNames
+
 -- For generation of representation types
 import TcEnv (tcLookupTyCon)
-import TcRnMonad (TcM, newUnique)
+import TcRnMonad
 import HscTypes
+import BuildTyCl
 
 import SrcLoc
 import Bag
@@ -42,35 +44,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)
-{-
-                  -- Primitives are (probably) not representable either
-                  && not (isPrimTyCon tycon)
-                  -- Foreigns are (probably) not representable either
-                  && not (isForeignTyCon 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}
 
 %************************************************************************
@@ -83,33 +97,64 @@ 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
         
 --------------------------------------------------------------------------------
+-- The type instance synonym and synonym
+--       type instance Rep (D a b) = Rep_D a b
+--       type Rep_D a b = ...representation type for D ...
+--------------------------------------------------------------------------------
+
+tc_mkRepTyCon :: TyCon           -- The type to generate representation for
+               -> MetaTyCons      -- Metadata datatypes to refer to
+               -> TcM TyCon       -- Generated representation0 type
+tc_mkRepTyCon tycon metaDts = 
+-- Consider the example input tycon `D`, where data D a b = D_ a
+  do { -- `rep0` = GHC.Generics.Rep (type family)
+       rep0 <- tcLookupTyCon repTyConName
+
+       -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
+     ; rep0Ty <- tc_mkRepTy tycon metaDts
+    
+       -- `rep_name` is a name we generate for the synonym
+     ; rep_name <- newImplicitBinder (tyConName tycon) mkGenR
+     ; let -- `tyvars` = [a,b]
+           tyvars  = tyConTyVars tycon
+
+           -- rep0Ty has kind * -> *
+           rep_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
+
+           -- `appT` = D a b
+           appT = [mkTyConApp tycon (mkTyVarTys tyvars)]
+
+     ; buildSynTyCon rep_name tyvars (SynonymTyCon rep0Ty) rep_kind
+                     NoParentTyCon (Just (rep0, appT)) }
+
+--------------------------------------------------------------------------------
 -- 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
@@ -161,41 +206,6 @@ tc_mkRep0Ty tycon metaDts =
         
     return (mkD tycon)
 
-tc_mkRep0TyCon :: TyCon           -- The type to generate representation for
-               -> MetaTyCons      -- Metadata datatypes to refer to
-               -> TcM TyCon       -- Generated representation0 type
-tc_mkRep0TyCon 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
-    
-    let modl    = nameModule  (tyConName tycon)
-        loc     = nameSrcSpan (tyConName tycon)
-        -- `repName` is a name we generate for the synonym
-        repName = mkExternalName uniq1 modl (mkGenR0 (nameOccName (tyConName tycon))) loc
-        -- `coName` is a name for the coercion
-        coName  = mkExternalName uniq2 modl (mkGenR0 (nameOccName (tyConName tycon))) loc
-        -- `tyvars` = [a,b]
-        tyvars  = tyConTyVars tycon
-        -- `appT` = D a b
-        appT    = [mkTyConApp tycon (mkTyVarTys tyvars)]
-        -- Result
-        res = mkSynTyCon repName
-                 -- rep0Ty has kind `kind of D` -> *
-                 (tyConKind tycon `mkArrowKind` liftedTypeKind)
-                 tyvars (SynonymTyCon rep0Ty)
-                 (FamInstTyCon rep0 appT
-                   (mkCoercionTyCon coName (tyConArity tycon)
-                     -- co : forall a b. Rep0 (D a b) ~ `rep0Ty` a b
-                     (CoAxiom tyvars (mkTyConApp rep0 appT) rep0Ty)))
-
-    return res
-
 --------------------------------------------------------------------------------
 -- Meta-information
 --------------------------------------------------------------------------------
@@ -208,7 +218,7 @@ data MetaTyCons = MetaTyCons { -- One meta datatype per dataype
                              , metaS :: [[TyCon]] }
                              
 instance Outputable MetaTyCons where
-  ppr (MetaTyCons d c s) = ppr d <+> ppr c <+> ppr s
+  ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s))
                                    
 metaTyCons2TyCons :: MetaTyCons -> [TyCon]
 metaTyCons2TyCons (MetaTyCons d c s) = d : c ++ concat s