remove empty dir

[ghc-hetmet.git] / ghc / compiler / types / Generics.lhs

diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs
index 0063140..2c97364 100644 (file)
--- a/ghc/compiler/types/Generics.lhs
+++ b/ghc/compiler/types/Generics.lhs
@@ -10,24 +10,26 @@ import Type             ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes,
                          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 TyCon            ( TyCon, tyConName, tyConDataCons, 
                          isBoxedTupleTyCon
                        )
-import Name            ( nameModuleName, nameOccName, getSrcLoc )
+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 PrelNames
        
 import SrcLoc          ( srcLocSpan, noLoc, Located(..) )
-import Util             ( takeList )
+import Util             ( takeList, isSingleton )
 import Bag
 import Outputable 
 import FastString
@@ -190,6 +192,7 @@ validGenericMethodType :: Type -> Bool
   --   * 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
@@ -207,7 +210,7 @@ validGenericMethodType 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}
 
@@ -252,13 +255,12 @@ type FromAlt = (LPat RdrName, LHsExpr RdrName)
 
 mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
 mkTyConGenericBinds tycon
-  = unitBag (L loc (FunBind (L loc from_RDR) False {- Not infix -}
-                           (mkMatchGroup [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts])))
-
+  = unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
        `unionBags`
-    unitBag (L loc (FunBind (L loc to_RDR) False 
-                           (mkMatchGroup [mkSimpleHsAlt to_pat to_body])))
+    unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
   where
+    from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
+    to_matches   = [mkSimpleHsAlt to_pat to_body]
     loc             = srcLocSpan (getSrcLoc tycon)
     datacons = tyConDataCons tycon
     (from_RDR, to_RDR) = mkGenericNames tycon
@@ -389,7 +391,7 @@ mkGenericNames tycon
   where
     tc_name  = tyConName tycon
     tc_occ   = nameOccName tc_name
-    tc_mod   = nameModuleName tc_name
+    tc_mod   = nameModule tc_name
     from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
     to_RDR   = mkOrig tc_mod (mkGenOcc2 tc_occ)
 \end{code}
@@ -429,7 +431,9 @@ will be fed to the type checker.  So the 'op' on the RHS will be
 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
@@ -451,18 +455,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
-  = 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 
 
-        -- 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 
-       -- 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
@@ -492,6 +497,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
+  | tycon == listTyCon      = bimapList arg_eps
   | isBoxedTupleTyCon tycon = bimapTuple arg_eps
   | otherwise              =   -- Otherwise validGenericMethodType will 
                                -- have checked that the type is a constant type
@@ -511,17 +517,24 @@ bimapArrow [ep1, ep2]
     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) }
   where
     names      = takeList eps gs_RDR
-    tuple_pat  = TuplePat (map nlVarPat names) Boxed
+    tuple_pat  = TuplePat (map nlVarPat names) Boxed placeHolderType
     eps_w_names = eps `zip` names
     to_body     = ExplicitTuple [toEP   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) .. ] ]