X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FGenerics.lhs;h=01632d35963183999354deabdd5177da9ec533db;hp=2c973649cfcf8c8836e9d8c8dd65b9cb0b700bd8;hb=66579ff945831c5fc9a17c58c722ff01f2268d76;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs index 2c97364..01632d3 100644 --- a/compiler/types/Generics.lhs +++ b/compiler/types/Generics.lhs @@ -1,4 +1,15 @@ +% +% (c) The University of Glasgow 2006 +% + \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 @@ -6,30 +17,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 +207,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 @@ -386,12 +392,13 @@ splitInHalf list = (left, right) 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 - 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} @@ -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) +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,29 +511,29 @@ 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') +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 } @@ -518,6 +543,7 @@ bimapArrow [ep1, ep2] ------------------- -- 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) } @@ -530,13 +556,17 @@ bimapTuple eps ------------------- -- 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) } ------------------- -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)