Add ASSERTs to all calls of nameModule

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

diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs
index 2c97364..01632d3 100644 (file)
--- a/compiler/types/Generics.lhs
+++ b/compiler/types/Generics.lhs
@@ -1,4 +1,15 @@
+%
+% (c) The University of Glasgow 2006
+%
+

 \begin{code}
 \begin{code}

+{-# OPTIONS -fno-warn-incomplete-patterns #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+

 module Generics ( canDoGenerics, mkTyConGenericBinds,
                  mkGenericRhs, 
                  validGenericInstanceType, validGenericMethodType
 module Generics ( canDoGenerics, mkTyConGenericBinds,
                  mkGenericRhs, 
                  validGenericInstanceType, validGenericMethodType

@@ -6,30 +17,24 @@ module Generics ( canDoGenerics, mkTyConGenericBinds,
 
 
 import HsSyn
 
 
 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 PrelNames
        

-import SrcLoc          ( srcLocSpan, noLoc, Located(..) )
-import Util             ( takeList, isSingleton )
+import SrcLoc
+import Util

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

@@ -202,9 +207,10 @@ validGenericMethodType ty
     (local_tvs, _, tau) = tcSplitSigmaTy ty
 
     valid 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
                                Just (tc,tys) -> valid_tycon tc && all valid tys
                                Nothing       -> False
       where

@@ -386,12 +392,13 @@ splitInHalf list = (left, right)
 mkGenericLocal :: US -> RdrName
 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
 
 mkGenericLocal :: US -> RdrName
 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
 

+mkGenericNames :: TyCon -> (RdrName, RdrName)

 mkGenericNames tycon
   = (from_RDR, to_RDR)
   where
     tc_name  = tyConName tycon
     tc_occ   = nameOccName tc_name
 mkGenericNames tycon
   = (from_RDR, to_RDR)
   where
     tc_name  = tyConName tycon
     tc_occ   = nameOccName tc_name

-    tc_mod   = nameModule tc_name
+    tc_mod   = ASSERT( isExternalName tc_name ) nameModule tc_name

     from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
     to_RDR   = mkOrig tc_mod (mkGenOcc2 tc_occ)
 \end{code}
     from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
     to_RDR   = mkOrig tc_mod (mkGenOcc2 tc_occ)
 \end{code}

@@ -452,6 +459,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)
 
        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
 \begin{code}
 mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
 mkGenericRhs sel_id tyvar tycon

@@ -486,29 +511,29 @@ generate_bimap :: EPEnv
               -> EP (LHsExpr RdrName)
 -- Top level case - splitting the TyCon.
 generate_bimap env@(tv,ep,local_tvs) ty 
               -> 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
   | 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')
 
 -------------------
 -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')

+bimapArrow :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)

 bimapArrow [ep1, ep2]
   = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body, 
         toEP   = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body }
 bimapArrow [ep1, ep2]
   = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body, 
         toEP   = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body }

@@ -518,6 +543,7 @@ bimapArrow [ep1, ep2]
 
 -------------------
 -- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)
 
 -------------------
 -- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)

+bimapTuple :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)

 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) }

@@ -530,13 +556,17 @@ bimapTuple eps
 
 -------------------
 -- bimapList :: EP a b -> EP [a] [b]
 
 -------------------
 -- bimapList :: EP a b -> EP [a] [b]

+bimapList :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)

 bimapList [ep]
   = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep),
         toEP   = nlHsApp (nlHsVar map_RDR) (toEP ep) }
 
 -------------------
 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")
+a_RDR, b_RDR :: RdrName
+a_RDR  = mkVarUnqual (fsLit "a")
+b_RDR  = mkVarUnqual (fsLit "b")
+
+gs_RDR :: [RdrName]

 gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
 
 idEP :: EP (LHsExpr RdrName)
 gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
 
 idEP :: EP (LHsExpr RdrName)