[project @ 2004-10-11 16:16:20 by simonpj]

---------------------------------
	Add lists to valid derivable methods
	---------------------------------

	(It'd be nice to merge this into the stable
	branch. It is an increase in functionality, but
	it's quite separate from everything else.)

Lists are useful in derivable type classes.  E.g. methods like

	class Shrinkable a where
	  op :: a -> [a]

This commit adds them, to join functions and tuples.

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 1c9447d..9516686 100644 (file)
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -702,7 +702,7 @@ genericMultiParamErr clas
 badGenericMethodType op op_ty
   = hang (ptext SLIT("Generic method type is too complex"))
        4 (vcat [ppr op <+> dcolon <+> ppr op_ty,
 badGenericMethodType op op_ty
   = hang (ptext SLIT("Generic method type is too complex"))
        4 (vcat [ppr op <+> dcolon <+> ppr op_ty,

-               ptext SLIT("You can only use type variables, arrows, and tuples")])
+               ptext SLIT("You can only use type variables, arrows, lists, and tuples")])

 
 recSynErr syn_decls
   = setSrcSpan (getLoc (head sorted_decls)) $
 
 recSynErr syn_decls
   = setSrcSpan (getLoc (head sorted_decls)) $

diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs
index 0063140..61b1a0f 100644 (file)
--- a/ghc/compiler/types/Generics.lhs
+++ b/ghc/compiler/types/Generics.lhs
@@ -10,7 +10,8 @@ import Type             ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes,
                          isTyVarTy, getTyVar_maybe, funTyCon
                        )
 import TcHsSyn         ( mkSimpleHsAlt )
                          isTyVarTy, getTyVar_maybe, funTyCon
                        )
 import TcHsSyn         ( mkSimpleHsAlt )

-import TcType          ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy, isTauTy )
+import TcType          ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitPhiTy, applyTy, 
+                         isTauTy, mkTyVarTy )

 import DataCon          ( DataCon, dataConOrigArgTys, isVanillaDataCon,
                          dataConSourceArity )
 
 import DataCon          ( DataCon, dataConOrigArgTys, isVanillaDataCon,
                          dataConSourceArity )
 

@@ -24,10 +25,11 @@ import BasicTypes       ( EP(..), Boxity(..) )
 import Var              ( TyVar )
 import VarSet          ( varSetElems )
 import Id               ( Id, idType )
 import Var              ( TyVar )
 import VarSet          ( varSetElems )
 import Id               ( Id, idType )

+import TysWiredIn      ( listTyCon )

 import PrelNames
        
 import SrcLoc          ( srcLocSpan, noLoc, Located(..) )
 import PrelNames
        
 import SrcLoc          ( srcLocSpan, noLoc, Located(..) )

-import Util             ( takeList )
+import Util             ( takeList, isSingleton )

 import Bag
 import Outputable 
 import FastString
 import Bag
 import Outputable 
 import FastString

@@ -190,6 +192,7 @@ validGenericMethodType :: Type -> Bool
   --   * type variables
   --   * function arrow
   --   * boxed tuples
   --   * type variables
   --   * function arrow
   --   * boxed tuples

+  --    * lists

   --   * an arbitrary type not involving the class type variables
   --           e.g. this is ok:        forall b. Ord b => [b] -> a
   --                where a is the class variable
   --   * an arbitrary type not involving the class type variables
   --           e.g. this is ok:        forall b. Ord b => [b] -> a
   --                where a is the class variable

@@ -207,7 +210,7 @@ validGenericMethodType ty
       where
        no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
 
       where
        no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
 

-    valid_tycon tc = tc == funTyCon || isBoxedTupleTyCon tc 
+    valid_tycon tc = tc == funTyCon || tc == listTyCon || isBoxedTupleTyCon tc 

        -- Compare bimapApp, below
 \end{code}
 
        -- Compare bimapApp, below
 \end{code}
 

@@ -429,7 +432,9 @@ will be fed to the type checker.  So the 'op' on the RHS will be
 at the representation type for T, Trep.
 
 
 at the representation type for T, Trep.
 
 

-A note about polymorphism.  Suppose the class op is polymorphic:
+Note [Polymorphic methods]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose the class op is polymorphic:

 
        class Baz a where
          op :: forall b. Ord b => a -> b -> b
 
        class Baz a where
          op :: forall b. Ord b => a -> b -> b

@@ -451,18 +456,19 @@ By the time the type checker has done its stuff we'll get
 \begin{code}
 mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
 mkGenericRhs sel_id tyvar tycon
 \begin{code}
 mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
 mkGenericRhs sel_id tyvar tycon

-  = mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id))
+  = ASSERT( isSingleton ctxt )         -- Checks shape of selector-id context
+    pprTrace "mkGenericRhs" (vcat [ppr sel_id, ppr (idType sel_id), ppr tyvar, ppr tycon, ppr local_tvs, ppr final_ty]) $
+    mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id))

   where 
        -- Initialising the "Environment" with the from/to functions
        -- on the datatype (actually tycon) in question
        (from_RDR, to_RDR) = mkGenericNames tycon 
 
   where 
        -- Initialising the "Environment" with the from/to functions
        -- on the datatype (actually tycon) in question
        (from_RDR, to_RDR) = mkGenericNames tycon 
 

-        -- Takes out the ForAll and the Class restrictions 
-        -- in front of the type of the method.
-       (_,_,op_ty) = tcSplitSigmaTy (idType sel_id)
+        -- Instantiate the selector type, and strip off its class context
+       (ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar))

 
         -- Do it again!  This deals with the case where the method type 
 
         -- Do it again!  This deals with the case where the method type 

-       -- is polymorphic -- see notes above
+       -- is polymorphic -- see Note [Polymorphic methods] above

        (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
 
        -- Now we probably have a tycon in front
        (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
 
        -- Now we probably have a tycon in front

@@ -492,6 +498,7 @@ bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP (LHsExpr RdrName)
 bimapApp env Nothing               = panic "TcClassDecl: Type Application!"
 bimapApp env (Just (tycon, ty_args)) 
   | tycon == funTyCon       = bimapArrow arg_eps
 bimapApp env Nothing               = panic "TcClassDecl: Type Application!"
 bimapApp env (Just (tycon, ty_args)) 
   | 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
   | isBoxedTupleTyCon tycon = bimapTuple arg_eps
   | otherwise              =   -- Otherwise validGenericMethodType will 
                                -- have checked that the type is a constant type

@@ -511,6 +518,7 @@ bimapArrow [ep1, ep2]
     to_body   = toEP   ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR))
 
 -------------------
     to_body   = toEP   ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR))
 
 -------------------

+-- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)

 bimapTuple eps 
   = EP { fromEP = mkHsLam [noLoc tuple_pat] (noLoc from_body),
         toEP   = mkHsLam [noLoc tuple_pat] (noLoc to_body) }
 bimapTuple eps 
   = EP { fromEP = mkHsLam [noLoc tuple_pat] (noLoc from_body),
         toEP   = mkHsLam [noLoc tuple_pat] (noLoc to_body) }

@@ -522,6 +530,12 @@ bimapTuple eps
     from_body   = ExplicitTuple [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed
 
 -------------------
     from_body   = ExplicitTuple [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed
 
 -------------------

+-- bimapList :: EP a b -> EP [a] [b]
+bimapList [ep]
+  = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep),
+        toEP   = nlHsApp (nlHsVar map_RDR) (toEP ep) }
+
+-------------------

 a_RDR  = mkVarUnqual FSLIT("a")
 b_RDR  = mkVarUnqual FSLIT("b")
 gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
 a_RDR  = mkVarUnqual FSLIT("a")
 b_RDR  = mkVarUnqual FSLIT("b")
 gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]