X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FGenerics.lhs;h=50b6b96a03fe7621e246a51e464fc10c70d6b498;hb=858cdd2f2725c75d35dabf7411dbafa932d84095;hp=f8d30fd3a6a03390ed8c67f37919477eff387de1;hpb=db46cd4ec47fabf392bad95cfb040fac468ddfcd;p=ghc-hetmet.git diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs index f8d30fd..50b6b96 100644 --- a/compiler/types/Generics.lhs +++ b/compiler/types/Generics.lhs @@ -26,7 +26,7 @@ import PrelNames import TcEnv (tcLookupTyCon) import TcRnMonad (TcM, newUnique) import HscTypes - + import SrcLoc import Bag import Outputable @@ -42,18 +42,18 @@ import FastString %************************************************************************ \begin{code} -canDoGenerics :: ThetaType -> [DataCon] -> Bool +canDoGenerics :: TyCon -> Bool -- Called on source-code data types, to see if we should generate --- generic functions for them. (This info is recorded in the interface file for --- imported data types.) - -canDoGenerics stupid_theta data_cs - = not (any bad_con data_cs) -- See comment below - - -- && not (null data_cs) -- No values of the type - -- JPM: we now support empty datatypes - - && null stupid_theta -- We do not support datatypes with context (for now) +-- generic functions for them. + +canDoGenerics tycon + = let result = not (any bad_con (tyConDataCons tycon)) -- See comment below + -- We do not support datatypes with context (for now) + && null (tyConStupidTheta tycon) + -- We don't like type families + && not (isFamilyTyCon tycon) + + in {- pprTrace "canDoGenerics" (ppr (tycon,result)) -} result where bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc) -- If any of the constructor has an unboxed type as argument, @@ -65,8 +65,6 @@ canDoGenerics stupid_theta data_cs -- Nor if the args are polymorphic types (I don't think) bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty) - -- JPM: TODO: I'm not sure I know what isTauTy checks for, so I'm leaving it - -- like this for now... \end{code} %************************************************************************ @@ -107,36 +105,49 @@ tc_mkRep0Ty :: -- The type to generate representation for -> TcM Type tc_mkRep0Ty tycon metaDts = do - d1 <- tcLookupTyCon d1TyConName - c1 <- tcLookupTyCon c1TyConName - s1 <- tcLookupTyCon s1TyConName - rec0 <- tcLookupTyCon rec0TyConName - u1 <- tcLookupTyCon u1TyConName - v1 <- tcLookupTyCon v1TyConName - plus <- tcLookupTyCon sumTyConName + d1 <- tcLookupTyCon d1TyConName + c1 <- tcLookupTyCon c1TyConName + s1 <- tcLookupTyCon s1TyConName + nS1 <- tcLookupTyCon noSelTyConName + rec0 <- tcLookupTyCon rec0TyConName + par0 <- tcLookupTyCon par0TyConName + u1 <- tcLookupTyCon u1TyConName + v1 <- tcLookupTyCon v1TyConName + plus <- tcLookupTyCon sumTyConName times <- tcLookupTyCon prodTyConName let mkSum' a b = mkTyConApp plus [a,b] mkProd a b = mkTyConApp times [a,b] mkRec0 a = mkTyConApp rec0 [a] + mkPar0 a = mkTyConApp par0 [a] mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)] - mkC i d a = mkTyConApp c1 [d, prod i (dataConOrigArgTys a)] - mkS d a = mkTyConApp s1 [d, a] + mkC i d a = mkTyConApp c1 [d, prod i (dataConOrigArgTys a) + (null (dataConFieldLabels a))] + -- This field has no label + mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a] + -- This field has a label + mkS False d a = mkTyConApp s1 [d, a] sumP [] = mkTyConTy v1 sumP l = ASSERT (length metaCTyCons == length l) foldBal mkSum' [ mkC i d a | (d,(a,i)) <- zip metaCTyCons (zip l [0..])] - prod :: Int -> [Type] -> Type - prod i [] = ASSERT (length metaSTyCons > i) - ASSERT (length (metaSTyCons !! i) == 0) - mkTyConTy u1 - prod i l = ASSERT (length metaSTyCons > i) - ASSERT (length l == length (metaSTyCons !! i)) - foldBal mkProd [ arg d a - | (d,a) <- zip (metaSTyCons !! i) l ] + -- The Bool is True if this constructor has labelled fields + prod :: Int -> [Type] -> Bool -> Type + prod i [] _ = ASSERT (length metaSTyCons > i) + ASSERT (length (metaSTyCons !! i) == 0) + mkTyConTy u1 + prod i l b = ASSERT (length metaSTyCons > i) + ASSERT (length l == length (metaSTyCons !! i)) + foldBal mkProd [ arg d t b + | (d,t) <- zip (metaSTyCons !! i) l ] - arg d t = mkS d (mkRec0 t) + arg :: Type -> Type -> Bool -> Type + arg d t b = mkS b d (recOrPar t (getTyVar_maybe t)) + -- Argument is not a type variable, use Rec0 + recOrPar t Nothing = mkRec0 t + -- Argument is a type variable, use Par0 + recOrPar t (Just _) = mkPar0 t metaDTyCon = mkTyConTy (metaD metaDts) metaCTyCons = map mkTyConTy (metaC metaDts) @@ -318,9 +329,9 @@ genLR_E i n e -------------------------------------------------------------------------------- -- Build a product expression -mkProd_E :: US -- Base for unique names - -> [RdrName] -- List of variables matched on the lhs - -> LHsExpr RdrName -- Resulting product expression +mkProd_E :: US -- Base for unique names + -> [RdrName] -- List of variables matched on the lhs + -> LHsExpr RdrName -- Resulting product expression mkProd_E _ [] = mkM1_E (nlHsVar u1DataCon_RDR) mkProd_E _ vars = mkM1_E (foldBal prod appVars) -- These M1s are meta-information for the constructor @@ -328,7 +339,6 @@ mkProd_E _ vars = mkM1_E (foldBal prod appVars) appVars = map wrapArg_E vars prod a b = prodDataCon_RDR `nlHsApps` [a,b] --- TODO: Produce a P0 when v is a parameter wrapArg_E :: RdrName -> LHsExpr RdrName wrapArg_E v = mkM1_E (k1DataCon_RDR `nlHsVarApps` [v]) -- This M1 is meta-information for the selector @@ -344,7 +354,6 @@ mkProd_P _ vars = mkM1_P (foldBal prod appVars) appVars = map wrapArg_P vars prod a b = prodDataCon_RDR `nlConPat` [a,b] --- TODO: Produce a P0 when v is a parameter wrapArg_P :: RdrName -> LPat RdrName wrapArg_P v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v]) -- This M1 is meta-information for the selector