[project @ 2002-03-14 15:27:15 by simonpj]
[ghc-hetmet.git] / ghc / compiler / types / Generics.lhs
index 887c0d8..ca05c39 100644 (file)
@@ -4,40 +4,41 @@ module Generics ( mkTyConGenInfo, mkGenericRhs,
     ) where
 
 
-import CmdLineOpts     ( opt_GlasgowExts )
 import RnHsSyn         ( RenamedHsExpr )
-import HsSyn           ( HsExpr(..), InPat(..), mkSimpleMatch )
+import HsSyn           ( HsExpr(..), InPat(..), mkSimpleMatch, placeHolderType )
 
-import Type             ( Type, isUnLiftedType, applyTys, tyVarsOfType, tyVarsOfTypes,
-                         mkTyVarTys, mkForAllTys, mkTyConApp, splitFunTys,
-                         mkFunTy, funResultTy, isTyVarTy, splitForAllTys,
-                         splitSigmaTy, getTyVar, splitTyConApp_maybe, funTyCon
+import Type             ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes,
+                         mkTyVarTys, mkForAllTys, mkTyConApp, 
+                         mkFunTy, isTyVarTy, getTyVar_maybe,
+                         funTyCon
                        )
+import TcType          ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy )
+import DataCon          ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId, isExistentialDataCon )
 
-import DataCon          ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId )
-
-import TyCon            ( TyCon, tyConTyVars, tyConDataConsIfAvailable, 
+import TyCon            ( TyCon, tyConTyVars, tyConDataCons_maybe, 
                          tyConGenInfo, isNewTyCon, newTyConRep, isBoxedTupleTyCon
                        )
-import Name            ( Name, mkSysLocalName )
-import CoreSyn          ( mkLams, Expr(..), CoreExpr, AltCon(..), Note(..),
-                         mkConApp, Alt, Bind (..), mkTyApps, mkVarApps )
-import BasicTypes       ( RecFlag(..), EP(..), Boxity(..) )
+import Name            ( Name, mkSystemName )
+import CoreSyn          ( mkLams, Expr(..), CoreExpr, AltCon(..), 
+                         mkConApp, Alt, mkTyApps, mkVarApps )
+import CoreUtils       ( exprArity )
+import BasicTypes       ( EP(..), Boxity(..) )
 import Var              ( TyVar )
-import VarSet          ( isEmptyVarSet )
-import Id               ( Id, mkTemplateLocal, mkTemplateLocals, idType, idName, 
-                         mkTemplateLocalsNum, mkVanillaId, mkId
+import VarSet          ( varSetElems )
+import Id               ( Id, mkVanillaGlobal, idType, idName, 
+                         mkTemplateLocal, mkTemplateLocalsNum
                        ) 
 import TysWiredIn       ( genericTyCons,
                          genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
                          inlDataCon, crossTyCon, crossDataCon
                        )
-import IdInfo           ( vanillaIdInfo, setUnfoldingInfo )
+import IdInfo           ( noCafNoTyGenIdInfo, setUnfoldingInfo, setArityInfo )
 import CoreUnfold       ( mkTopUnfolding ) 
 
-import Unique          ( Uniquable(..), mkBuiltinUnique )
-import SrcLoc          ( mkBuiltinSrcLoc )
-import Maybes          ( maybeToBool, expectJust )
+import Maybe           ( isNothing )
+import SrcLoc          ( builtinSrcLoc )
+import Unique          ( mkBuiltinUnique )
+import Util             ( takeList )
 import Outputable 
 
 #include "HsVersions.h"
@@ -188,7 +189,7 @@ validGenericInstanceType :: Type -> Bool
   --   f {| a + Int |}
 
 validGenericInstanceType inst_ty
-  = case splitTyConApp_maybe inst_ty of
+  = case tcSplitTyConApp_maybe inst_ty of
        Just (tycon, tys) ->  all isTyVarTy tys && tycon `elem` genericTyCons
        Nothing           ->  False
 
@@ -198,17 +199,24 @@ validGenericMethodType :: Type -> Bool
   --   * function arrow
   --   * boxed tuples
   --   * an arbitrary type not involving the class type variables
-validGenericMethodType ty = valid ty
-
-valid ty
-  | isTyVarTy ty = True
-  | not (null arg_tys)  = all valid arg_tys && valid res_ty
-  | no_tyvars_in_ty    = True
-  | otherwise          = isBoxedTupleTyCon tc && all valid tys
+  --           e.g. this is ok:        forall b. Ord b => [b] -> a
+  --                where a is the class variable
+validGenericMethodType ty 
+  = valid tau
   where
-    (arg_tys, res_ty) = splitFunTys ty
-    no_tyvars_in_ty   = isEmptyVarSet (tyVarsOfType ty)
-    Just (tc,tys)     = splitTyConApp_maybe ty
+    (local_tvs, _, tau) = tcSplitSigmaTy ty
+
+    valid ty
+      | 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
+       no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
+
+    valid_tycon tc = tc == funTyCon || isBoxedTupleTyCon tc 
+       -- Compare bimapApp, below
 \end{code}
 
 
@@ -219,7 +227,7 @@ valid ty
 %************************************************************************
 
 \begin{code}
-mkTyConGenInfo :: TyCon -> Name -> Name -> Maybe (EP Id)
+mkTyConGenInfo :: TyCon -> [Name] -> Maybe (EP Id)
 -- mkTyConGenInfo is called twice
 --     once from TysWiredIn for Tuples
 --     once the typechecker TcTyDecls 
@@ -230,38 +238,44 @@ mkTyConGenInfo :: TyCon -> Name -> Name -> Maybe (EP Id)
 -- The two names are the names constructed by the renamer
 -- for the fromT and toT conversion functions.
 
-mkTyConGenInfo tycon from_name to_name
-  | True -- not opt_GlasgowExts
-  = Nothing
-
-  | null datacons      -- Abstractly imported types don't have
-  = Nothing            -- to/from operations, (and should not need them)
+mkTyConGenInfo tycon [from_name, to_name]
+  | isNothing maybe_datacons   -- Abstractly imported types don't have
+  = Nothing                    -- to/from operations, (and should not need them)
 
-       -- If any of the constructor has an unboxed type as argument
+       -- 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
-  | any (any isUnLiftedType . dataConOrigArgTys) datacons
+       -- Nor can we do the job if it's an existential data constructor,
+  | or [ any isUnLiftedType (dataConOrigArgTys dc) || isExistentialDataCon dc
+       | dc <- datacons ]
   = Nothing
 
   | otherwise
-  = Just (EP { fromEP = mkId from_name from_ty from_id_info,
-              toEP   = mkId to_name   to_ty   to_id_info })
+  = Just (EP { fromEP = mkVanillaGlobal from_name from_ty from_id_info,
+              toEP   = mkVanillaGlobal to_name   to_ty   to_id_info })
   where
-    tyvars      = tyConTyVars tycon                    -- [a, b, c]
-    datacons    = tyConDataConsIfAvailable tycon       -- [C, D]
-    tycon_ty    = mkTyConApp tycon tyvar_tys           -- T a b c
-    tyvar_tys    = mkTyVarTys tyvars
+    maybe_datacons = tyConDataCons_maybe tycon
+    Just datacons  = maybe_datacons            -- [C, D]
 
-    from_id_info = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
-    to_id_info   = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
+    tyvars        = tyConTyVars tycon          -- [a, b, c]
+    tycon_ty      = mkTyConApp tycon tyvar_tys -- T a b c
+    tyvar_tys      = mkTyVarTys tyvars
+
+    from_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
+                                     `setArityInfo`     exprArity from_fn
+    to_id_info   = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
+                                     `setArityInfo`     exprArity to_fn
+       -- It's important to set the arity info, so that
+       -- the calling convention (gotten from arity) 
+       -- matches reality.
 
     from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty)
     to_ty   = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty)
 
     (from_fn, to_fn, rep_ty) 
        | isNewTyCon tycon
-       = ( mkLams tyvars $ Lam x  $ Note (Coerce newrep_ty tycon_ty) (Var x),
+       = ( mkLams tyvars $ Lam x  $ Var x,
            Var (dataConWrapId the_datacon),
            newrep_ty )
 
@@ -276,7 +290,7 @@ mkTyConGenInfo tycon from_name to_name
            ----------------------
            --  Newtypes only
     [the_datacon]  = datacons
-    newrep_ty = applyTys (expectJust "mkGenTyConInfo" (newTyConRep tycon)) tyvar_tys
+    (_, newrep_ty) = newTyConRep tycon
        
            ----------------------
            --  Non-newtypes only
@@ -335,13 +349,6 @@ mk_sum_stuff i tyvars datacons
        where
          datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys
 
-
--- This constructs the c_of datatype from a DataCon and a Type
--- The identity function at the moment.
-cOfConstr :: DataCon -> Type -> Type
-cOfConstr y z = z
-
-
 ----------------------------------------------------
 --     Dealing with products
 ----------------------------------------------------
@@ -407,7 +414,51 @@ splitInHalf list = (left, right)
 
 Generating the Generic default method.  Uses the bimaps to generate the
 actual method. All of this is rather incomplete, but it would be nice
-to make even this work.
+to make even this work.  Example
+
+       class Foo a where
+         op :: Op a
+
+       instance Foo T
+
+Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
+
+       instance Foo T where
+          op = <mkGenericRhs op a T>
+
+To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
+
+       toOp   :: Op Trep -> Op T
+       fromOp :: Op T    -> Op Trep
+
+(the bimap) and then fill in the RHS with
+
+       instance Foo T where
+          op = toOp op
+
+Remember, we're generating a RenamedHsExpr, so the result of all this
+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:
+
+       class Baz a where
+         op :: forall b. Ord b => a -> b -> b
+
+Then we can still generate a bimap with
+
+       toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
+
+and fill in the instance decl thus
+
+       instance Foo T where
+          op = toOp op
+
+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)
 
 \begin{code}
 mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr
@@ -419,37 +470,51 @@ mkGenericRhs sel_id tyvar tycon
        Just (EP from to) = tyConGenInfo tycon  -- Caller checked this will succeed
         ep               = EP (HsVar (idName from)) (HsVar (idName to)) 
 
-        -- Takes out the ForAll and the Class rstrictions in front of the
-        -- type of the method.
-       (_,_,op_ty) = splitSigmaTy (idType sel_id)
+        -- Takes out the ForAll and the Class restrictions 
+        -- in front of the type of the method.
+       (_,_,op_ty) = tcSplitSigmaTy (idType sel_id)
+
+        -- Do it again!  This deals with the case where the method type 
+       -- is polymorphic -- see notes above
+       (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
 
        -- Now we probably have a tycon in front
         -- of us, quite probably a FunTyCon.
-        bimap = generate_bimap (tyvar, ep) op_ty
+        bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
 
--- EP is the environment of to/from bimaps, but as we only have one type 
--- variable at the moment, there is only one EP.
+type EPEnv = (TyVar,           -- The class type variable
+             EP RenamedHsExpr, -- The EP it maps to
+             [TyVar]           -- Other in-scope tyvars; they have an identity EP
+            )
 
 -------------------
-generate_bimap ::  (TyVar, EP RenamedHsExpr) -> Type -> EP RenamedHsExpr
+generate_bimap :: EPEnv
+              -> Type
+              -> EP RenamedHsExpr
 -- Top level case - splitting the TyCon.
-generate_bimap (tv,ep) ty | isTyVarTy ty = ASSERT( getTyVar "Generics.generate_bimap" ty == tv) ep
-                         | otherwise    = bimapApp (tv,ep) (splitTyConApp_maybe ty)
+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)
 
 -------------------
-bimapApp :: (TyVar, EP RenamedHsExpr) -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr
-bimapApp ep Nothing                = panic "TcClassDecl: Type Application!"
-bimapApp ep (Just (tycon, ty_args)) 
+bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr
+bimapApp env Nothing               = panic "TcClassDecl: Type Application!"
+bimapApp env (Just (tycon, ty_args)) 
   | tycon == funTyCon       = bimapArrow arg_eps
   | isBoxedTupleTyCon tycon = bimapTuple arg_eps
   | otherwise              =   -- Otherwise validGenericMethodType will 
                                -- have checked that the type is a constant type
-                             ASSERT( isEmptyVarSet (tyVarsOfTypes ty_args) )
-                             EP idexpr idexpr
+                             ASSERT( all (`elem` local_tvs) (varSetElems (tyVarsOfTypes ty_args)) )
+                             idEP
     where
-      arg_eps = map (generate_bimap ep) ty_args
+      arg_eps = map (generate_bimap env) ty_args
+      (_,_,local_tvs) = env
 
 -------------------
+-- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
 bimapArrow [ep1, ep2]
   = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body, 
         toEP   = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body }
@@ -462,7 +527,7 @@ bimapTuple eps
   = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
         toEP   = mk_hs_lam [tuple_pat] to_body }
   where
-    names      = take (length eps) genericNames
+    names      = takeList eps genericNames
     tuple_pat  = TuplePatIn (map VarPatIn names) Boxed
     eps_w_names = eps `zip` names
     to_body     = ExplicitTuple [toEP   ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
@@ -470,9 +535,13 @@ bimapTuple eps
 
 -------------------
 genericNames :: [Name]
-genericNames = [mkSysLocalName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]]
+genericNames = [mkSystemName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]]
 (g1:g2:g3:_) = genericNames
 
-mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body Nothing mkBuiltinSrcLoc))
-idexpr             = mk_hs_lam [VarPatIn g3] (HsVar g3)
+mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType builtinSrcLoc))
+
+idEP :: EP RenamedHsExpr
+idEP = EP idexpr idexpr
+     where
+       idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3)
 \end{code}