X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FGenerics.lhs;h=5494999b57ae7a3f52285d12361f4db3c6574826;hb=bf2f000a552e025ec156010d52aee282bdfcf7a4;hp=2c973649cfcf8c8836e9d8c8dd65b9cb0b700bd8;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs
index 2c97364..5494999 100644
--- a/compiler/types/Generics.lhs
+++ b/compiler/types/Generics.lhs
@@ -1,3 +1,7 @@
+%
+% (c) The University of Glasgow 2006
+%
+
 \begin{code}
 module Generics ( canDoGenerics, mkTyConGenericBinds,
 		  mkGenericRhs, 
@@ -6,30 +10,24 @@ module Generics ( canDoGenerics, mkTyConGenericBinds,
 
 
 import HsSyn
-import Type             ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes,
-			  isTyVarTy, getTyVar_maybe, funTyCon
-			)
-import TcHsSyn		( mkSimpleHsAlt )
-import TcType		( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitPhiTy, applyTy, 
-			  isTauTy, mkTyVarTy )
-import DataCon          ( DataCon, dataConOrigArgTys, isVanillaDataCon,
-			  dataConSourceArity )
-
-import TyCon            ( TyCon, tyConName, tyConDataCons, 
-			  isBoxedTupleTyCon
-			)
-import Name		( nameModule, nameOccName, getSrcLoc )
-import OccName		( mkGenOcc1, mkGenOcc2 )
-import RdrName		( RdrName, getRdrName, mkVarUnqual, mkOrig )
-import BasicTypes       ( EP(..), Boxity(..) )
-import Var              ( TyVar )
-import VarSet		( varSetElems )
-import Id               ( Id, idType )
-import TysWiredIn	( listTyCon )
+import Type
+import TcHsSyn
+import TcType
+import DataCon
+
+import TyCon
+import Name
+import OccName
+import RdrName
+import BasicTypes
+import Var
+import VarSet
+import Id
+import TysWiredIn
 import PrelNames
 	
-import SrcLoc		( srcLocSpan, noLoc, Located(..) )
-import Util             ( takeList, isSingleton )
+import SrcLoc
+import Util
 import Bag
 import Outputable 
 import FastString
@@ -202,9 +200,10 @@ validGenericMethodType ty
     (local_tvs, _, tau) = tcSplitSigmaTy ty
 
     valid ty
-      | isTyVarTy ty    = True
-      | no_tyvars_in_ty	= True
-      | otherwise	= case tcSplitTyConApp_maybe ty of
+      | not (isTauTy ty) = False 	-- Note [Higher ramk methods]
+      | isTyVarTy ty     = True
+      | no_tyvars_in_ty	 = True
+      | otherwise	 = case tcSplitTyConApp_maybe ty of
 				Just (tc,tys) -> valid_tycon tc && all valid tys
 				Nothing	      -> False
       where
@@ -452,6 +451,24 @@ By the time the type checker has done its stuff we'll get
 	instance Foo T where
 	   op = \b. \dict::Ord b. toOp b (op Trep b dict)
 
+Note [Higher rank methods]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Higher-rank method types don't work, because we'd generate a bimap that
+needs impredicative polymorphism.  In principle that should be possible
+(with boxy types and all) but it would take a bit of working out.   Here's
+an example:
+  class ChurchEncode k where 
+    match :: k -> z 
+       	  -> (forall a b z. a -> b -> z)  {- product -} 
+       	  -> (forall a   z. a -> z)       {- left -} 
+       	  -> (forall a   z. a -> z)       {- right -} 
+       	  -> z 
+  
+    match {| Unit    |} Unit      unit prod left right = unit 
+    match {| a :*: b |} (x :*: y) unit prod left right = prod x y 
+    match {| a :+: b |} (Inl l)   unit prod left right = left l 
+    match {| a :+: b |} (Inr r)   unit prod left right = right r 
+
 \begin{code}
 mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
 mkGenericRhs sel_id tyvar tycon
@@ -486,26 +503,25 @@ generate_bimap :: EPEnv
 	       -> EP (LHsExpr RdrName)
 -- Top level case - splitting the TyCon.
 generate_bimap env@(tv,ep,local_tvs) ty 
-  = case getTyVar_maybe ty of
-	Just tv1 |  tv == tv1 -> ep				-- The class tyvar
-		 |  otherwise -> ASSERT( tv1 `elem` local_tvs)	-- One of the polymorphic tyvars of the method
-				 idEP	
-	Nothing	 -> bimapApp env (tcSplitTyConApp_maybe ty)
+  | all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
+  = idEP	-- A constant type
+
+  | Just tv1 <- getTyVar_maybe ty
+  = ASSERT( tv == tv1 ) ep					-- The class tyvar
+
+  | Just (tycon, ty_args) <- tcSplitTyConApp_maybe ty
+  = bimapTyCon tycon (map (generate_bimap env) ty_args)
+
+  | otherwise
+  = pprPanic "generate_bimap" (ppr ty)
 
 -------------------
-bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP (LHsExpr RdrName)
-bimapApp env Nothing		    = panic "TcClassDecl: Type Application!"
-bimapApp env (Just (tycon, ty_args)) 
+bimapTyCon :: TyCon -> [EP  (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
+bimapTyCon tycon arg_eps 
   | tycon == funTyCon       = bimapArrow arg_eps
   | tycon == listTyCon      = bimapList arg_eps
   | isBoxedTupleTyCon tycon = bimapTuple arg_eps
-  | otherwise		    =	-- Otherwise validGenericMethodType will 
-				-- have checked that the type is a constant type
-			      ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
-			      idEP
-    where
-      arg_eps = map (generate_bimap env) ty_args
-      (_,_,local_tvs) = env
+  | otherwise		    = pprPanic "bimapTyCon" (ppr tycon)
 
 -------------------
 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')