From db46cd4ec47fabf392bad95cfb040fac468ddfcd Mon Sep 17 00:00:00 2001 From: Jose Pedro Magalhaes Date: Thu, 28 Apr 2011 11:30:22 +0200 Subject: [PATCH] Remove a lot of stuff from the old generic mechanism. --- compiler/typecheck/TcClassDcl.lhs | 137 +---------- compiler/typecheck/TcInstDcls.lhs | 21 +- compiler/types/Generics.lhs | 481 ++----------------------------------- 3 files changed, 27 insertions(+), 612 deletions(-) diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index e4dbf5c..2c13d9e 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -8,7 +8,7 @@ Typechecking class declarations \begin{code} module TcClassDcl ( tcClassSigs, tcClassDecl2, findMethodBind, instantiateMethod, tcInstanceMethodBody, - mkGenericDefMethBind, getGenericInstances, + mkGenericDefMethBind, tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn ) where @@ -385,143 +385,8 @@ mkGenericDefMethBind clas inst_tys sel_id dm_name [mkSimpleMatch [] rhs]) } where rhs = nlHsVar dm_name - ---------------------------- -getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo Name] -getGenericInstances class_decls - = do { gen_inst_infos <- mapM (addLocM get_generics) class_decls - ; let { gen_inst_info = concat gen_inst_infos } - - -- Return right away if there is no generic stuff - ; if null gen_inst_info then return [] - else do - - -- Otherwise print it out - { dumpDerivingInfo $ hang (ptext (sLit "Generic instances")) - 2 (vcat (map pprInstInfoDetails gen_inst_info)) - ; return gen_inst_info }} - -get_generics :: TyClDecl Name -> TcM [InstInfo Name] -get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods}) - | null generic_binds - = return [] -- The comon case: no generic default methods - - | otherwise -- A source class decl with generic default methods - = recoverM (return []) $ - tcAddDeclCtxt decl $ do - clas <- tcLookupLocatedClass class_name - - -- Group by type, and - -- make an InstInfo out of each group - let - groups = groupWith listToBag generic_binds - - inst_infos <- mapM (mkGenericInstance clas) groups - - -- Check that there is only one InstInfo for each type constructor - -- The main way this can fail is if you write - -- f {| a+b |} ... = ... - -- f {| x+y |} ... = ... - -- Then at this point we'll have an InstInfo for each - -- - -- The class should be unary, which is why simpleInstInfoTyCon should be ok - let - tc_inst_infos :: [(TyCon, InstInfo Name)] - tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos] - - bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos, - group `lengthExceeds` 1] - get_uniq (tc,_) = getUnique tc - - mapM_ (addErrTc . dupGenericInsts) bad_groups - - -- Check that there is an InstInfo for each generic type constructor - let - missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos] - - checkTc (null missing) (missingGenericInstances missing) - - return inst_infos - where - generic_binds :: [(HsType Name, LHsBind Name)] - generic_binds = getGenericBinds def_methods -get_generics decl = pprPanic "get_generics" (ppr decl) - - ---------------------------------- -getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)] - -- Takes a group of method bindings, finds the generic ones, and returns - -- them in finite map indexed by the type parameter in the definition. -getGenericBinds binds = concat (map getGenericBind (bagToList binds)) - -getGenericBind :: LHsBindLR Name Name -> [(HsType Name, LHsBindLR Name Name)] -getGenericBind (L loc bind@(FunBind { fun_matches = MatchGroup matches ty })) - = groupWith wrap (mapCatMaybes maybeGenericMatch matches) - where - wrap ms = L loc (bind { fun_matches = MatchGroup ms ty }) -getGenericBind _ - = [] - -groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)] -groupWith _ [] = [] -groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest - where - vs = map snd this - (this,rest) = partition same_t prs - same_t (t', _v) = t `eqPatType` t' - -eqPatLType :: LHsType Name -> LHsType Name -> Bool -eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2 - -eqPatType :: HsType Name -> HsType Name -> Bool --- A very simple equality function, only for --- type patterns in generic function definitions. -eqPatType (HsTyVar v1) (HsTyVar v2) = v1==v2 -eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatLType` s2 && t1 `eqPatLType` t2 -eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t1 `eqPatLType` t2 && unLoc op1 == unLoc op2 -eqPatType (HsNumTy n1) (HsNumTy n2) = n1 == n2 -eqPatType (HsParTy t1) t2 = unLoc t1 `eqPatType` t2 -eqPatType t1 (HsParTy t2) = t1 `eqPatType` unLoc t2 -eqPatType _ _ = False - ---------------------------------- -mkGenericInstance :: Class - -> (HsType Name, LHsBinds Name) - -> TcM (InstInfo Name) - -mkGenericInstance clas (hs_ty, binds) = do - -- Make a generic instance declaration - -- For example: instance (C a, C b) => C (a+b) where { binds } - - -- Extract the universally quantified type variables - -- and wrap them as forall'd tyvars, so that kind inference - -- works in the standard way - let - sig_tvs = userHsTyVarBndrs $ map noLoc $ nameSetToList $ - extractHsTyVars (noLoc hs_ty) - hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty) - - -- Type-check the instance type, and check its form - forall_inst_ty <- tcHsSigType GenPatCtxt hs_forall_ty - let - (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty - - checkTc (validGenericInstanceType inst_ty) - (badGenericInstanceType binds) - - -- Make the dictionary function. - span <- getSrcSpanM - overlap_flag <- getOverlapFlag - dfun_name <- newDFunName clas [inst_ty] span - let - inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars] - dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty] - ispec = mkLocalInstance dfun_id overlap_flag - - return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] False }) \end{code} - %************************************************************************ %* * Error messages diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 68b9106..dfe1efb 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -206,7 +206,7 @@ Just . Instead, we simply rely on the fact that casts are cheap: $df :: forall a. C a => C [a] - {-# INLINE df #} -- NB: INLINE this + {-# INLINE df #-} -- NB: INLINE this $df = /\a. \d. MkC [a] ($cop_list a d) = $cop_list |> forall a. C a -> (sym (Co:C [a])) @@ -379,26 +379,22 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- tythings to the global environment ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do { - -- (3) Instances from generic class declarations - ; generic_inst_info <- getGenericInstances clas_decls -- Next, construct the instance environment so far, consisting -- of -- (a) local instance decls - -- (b) generic instances - -- (c) local family instance decls + -- (b) local family instance decls ; addInsts local_info $ - addInsts generic_inst_info $ addFamInsts at_idx_tycons $ do { - -- (4) Compute instances from "deriving" clauses; + -- (3) Compute instances from "deriving" clauses; -- This stuff computes a context for the derived instance -- decl, so it needs to know about all the instances possible -- NB: class instance declarations can contain derivings as -- part of associated data type declarations - failIfErrsM -- If the addInsts stuff gave any errors, don't - -- try the deriving stuff, because that may give - -- more errors still + failIfErrsM -- If the addInsts stuff gave any errors, don't + -- try the deriving stuff, because that may give + -- more errors still ; (deriv_inst_info, deriv_binds, deriv_dus, deriv_tys, deriv_ty_insts) <- tcDeriving tycl_decls inst_decls deriv_decls @@ -407,9 +403,8 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls ; gbl_env <- addFamInsts (map ATyCon deriv_ty_insts) $ tcExtendGlobalEnv (map ATyCon (deriv_tys ++ deriv_ty_insts)) $ addInsts deriv_inst_info getGblEnv --- ; traceTc "Generic deriving" (vcat (map pprInstInfo deriv_inst_info)) - ; return ( addTcgDUs gbl_env deriv_dus, - generic_inst_info ++ deriv_inst_info ++ local_info, + ; return ( addTcgDUs gbl_env deriv_dus, + deriv_inst_info ++ local_info, aux_binds `plusHsValBinds` deriv_binds) }}} diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs index 20cf242..f8d30fd 100644 --- a/compiler/types/Generics.lhs +++ b/compiler/types/Generics.lhs @@ -1,18 +1,10 @@ % -% (c) The University of Glasgow 2006 +% (c) The University of Glasgow 2011 % \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, mkBindsRep0, tc_mkRep0TyCon, mkBindsMetaD, MetaTyCons(..), metaTyCons2TyCons ) where @@ -28,9 +20,6 @@ import Name hiding (varName) import Module (moduleName, moduleNameString) import RdrName import BasicTypes -import Var hiding (varName) -import VarSet -import Id import TysWiredIn import PrelNames -- For generation of representation types @@ -39,7 +28,6 @@ import TcRnMonad (TcM, newUnique) import HscTypes import SrcLoc -import Util import Bag import Outputable import FastString @@ -47,185 +35,6 @@ import FastString #include "HsVersions.h" \end{code} -Roadmap of what's where in the Generics work. -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Parser -No real checks. - -RnSource.rnHsType - Checks that HsNumTy has a "1" in it. - -TcInstDcls.mkGenericInstance: - Checks for invalid type patterns, such as f {| Int |} - -TcClassDcl.tcClassSig - Checks for a method type that is too complicated; - e.g. has for-alls or lists in it - We could lift this restriction - -TcClassDecl.mkDefMethRhs - Checks that the instance type is simple, in an instance decl - where we let the compiler fill in a generic method. - e.g. instance C (T Int) - is not valid if C has generic methods. - -TcClassDecl.checkGenericClassIsUnary - Checks that we don't have generic methods in a multi-parameter class - -TcClassDecl.checkDefaultBinds - Checks that all the equations for a method in a class decl - are generic, or all are non-generic - - - -Checking that the type constructors which are present in Generic -patterns (not Unit, this is done differently) is done in mk_inst_info -(TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that -HsOpTy is tied to Generic definitions which is not a very good design -feature, indeed a bug. However, the check is easy to move from -tcHsType back to mk_inst_info and everything will be fine. Also see -bug #5. [I don't think that this is the case anymore after SPJ's latest -changes in that regard. Delete this comment? -=chak/7Jun2] - -Generics.lhs - -Making generic information to put into a tycon. Constructs the -representation type, which, I think, are not used later. Perhaps it is -worth removing them from the GI datatype. Although it does get used in -the construction of conversion functions (internally). - -TyCon.lhs - -Just stores generic information, accessible by tyConGenInfo or tyConGenIds. - -TysWiredIn.lhs - -Defines generic and other type and data constructors. - -This is sadly incomplete, but will be added to. - - -Bugs & shortcomings of existing implementation: -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -2. Another pretty big bug I dscovered at the last minute when I was -testing the code is that at the moment the type variable of the class -is scoped over the entire declaration, including the patterns. For -instance, if I have the following code, - -class Er a where - ... - er {| Plus a b |} (Inl x) (Inl y) = er x y - er {| Plus a b |} (Inr x) (Inr y) = er x y - er {| Plus a b |} _ _ = False - -and I print out the types of the generic patterns, I get the -following. Note that all the variable names for "a" are the same, -while for "b" they are all different. - -check_ty - [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-}, - std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-}, - std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}] - -This is a bug as if I change the code to - - er {| Plus c b |} (Inl x) (Inl y) = er x y - -all the names come out to be different. - -Thus, all the types (Plus a b) come out to be different, so I cannot -compare them and test whether they are all the same and thus cannot -return an error if the type variables are different. - -Temporary fix/hack. I am not checking for this, I just assume they are -the same, see line "check_ty = True" in TcInstDecls. When we resolve -the issue with variables, though - I assume that we will make them to -be the same in all the type patterns, jus uncomment the check and -everything should work smoothly. - -Hence, I have also left the rather silly construction of: -* extracting all the type variables from all the types -* putting them *all* into the environment -* typechecking all the types -* selecting one of them and using it as the instance_ty. - -(the alternative is to make sure that all the types are the same, -taking one, extracting its variables, putting them into the environment, -type checking it, using it as the instance_ty) - -6. What happens if we do not supply all of the generic patterns? At -the moment, the compiler crashes with an error message "Non-exhaustive -patterns in a generic declaration" - - -What has not been addressed: -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Contexts. In the generated instance declarations for the 3 primitive -type constructors, we need contexts. It is unclear what those should -be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b) - -Type application. We have type application in expressions -(essentially) on the lhs of an equation. Do we want to allow it on the -RHS? - -Scoping of type variables in a generic definition. At the moment, (see -TcInstDecls) we extract the type variables inside the type patterns -and add them to the environment. See my bug #2 above. This seems pretty -important. - - - -%************************************************************************ -%* * -\subsection{Getting the representation type out} -%* * -%************************************************************************ - -\begin{code} -validGenericInstanceType :: Type -> Bool - -- Checks for validity of the type pattern in a generic - -- declaration. It's ok to have - -- f {| a + b |} ... - -- but it's not OK to have - -- f {| a + Int |} - -validGenericInstanceType inst_ty - = case tcSplitTyConApp_maybe inst_ty of - Just (tycon, tys) -> all isTyVarTy tys && tyConName tycon `elem` genericTyConNames - Nothing -> False - -validGenericMethodType :: Type -> Bool - -- At the moment we only allow method types built from - -- * 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 -validGenericMethodType ty - = valid tau - where - (local_tvs, _, tau) = tcSplitSigmaTy ty - - valid ty - | 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 - no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty)) - - valid_tycon tc = tc == funTyCon || tc == listTyCon || isBoxedTupleTyCon tc - -- Compare bimapApp, below -\end{code} - - %************************************************************************ %* * \subsection{Generating representation types} @@ -238,10 +47,10 @@ canDoGenerics :: ThetaType -> [DataCon] -> Bool -- generic functions for them. (This info is recorded in the interface file for -- imported data types.) -canDoGenerics stupid_theta data_cons - = not (any bad_con data_cons) -- See comment below +canDoGenerics stupid_theta data_cs + = not (any bad_con data_cs) -- See comment below - -- && not (null data_cons) -- No values of the type + -- && 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) @@ -269,19 +78,7 @@ canDoGenerics stupid_theta data_cons \begin{code} type US = Int -- Local unique supply, just a plain Int type Alt = (LPat RdrName, LHsExpr RdrName) -{- -data GenRep = GenRep { - genBindsFrom0 :: TyCon -> LHsBinds RdrName - , genBindsTo0 :: TyCon -> LHsBinds RdrName - , genBindsFrom1 :: TyCon -> LHsBinds RdrName - , genBindsTo1 :: TyCon -> LHsBinds RdrName - , genBindsModuleName :: TyCon -> LHsBinds RdrName - , genBindsConName :: DataCon -> LHsBinds RdrName - , genBindsConFixity :: DataCon -> LHsBinds RdrName - , genBindsConIsRecord :: DataCon -> LHsBinds RdrName - , genBindsSelName :: DataCon -> Int -> LHsBinds RdrName - } --} + -- Bindings for the Representable0 instance mkBindsRep0 :: TyCon -> LHsBinds RdrName mkBindsRep0 tycon = @@ -298,60 +95,9 @@ mkBindsRep0 tycon = from0_alts, to0_alts :: [Alt] (from0_alts, to0_alts) = mkSum (1 :: US) tycon datacons --- Disabled -mkTyConGenericBinds :: TyCon -> LHsBinds RdrName -mkTyConGenericBinds _tycon = - {- - unitBag (L loc (mkFunBind (L loc from0_RDR) from0_matches)) - `unionBags` - unitBag (L loc (mkFunBind (L loc to0_RDR) to0_matches)) - `unionBags` - mkMeta loc tycon - -} - emptyBag -{- - where - from0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from0_alts] - to0_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to0_alts ] - loc = srcLocSpan (getSrcLoc tycon) - datacons = tyConDataCons tycon - (from0_RDR, to0_RDR) = mkGenericNames tycon - - -- Recurse over the sum first - from0_alts, to0_alts :: [Alt] - (from0_alts, to0_alts) = mkSum init_us tycon datacons - init_us = 1 :: US -- Unique supply --} - -------------------------------------------------------------------------------- -- Type representation -------------------------------------------------------------------------------- -{- -mkRep0Ty :: TyCon -> LHsType Name -mkRep0Ty tycon = res - where - res = d1 `nlHsAppTy` (cons datacons) - d1 = nlHsTyVar d1TyConName `nlHsAppTy` nlHsTyVar d1TyConName -- TODO - c1 = nlHsTyVar c1TyConName `nlHsAppTy` nlHsTyVar c1TyConName -- TODO - s1 = nlHsTyVar s1TyConName `nlHsAppTy` nlHsTyVar noSelTyConName -- TODO - plus a b = nlHsTyVar sumTyConName `nlHsAppTy` a `nlHsAppTy` b - times a b = nlHsTyVar prodTyConName `nlHsAppTy` a `nlHsAppTy` b - k1 x = nlHsTyVar k1TyConName `nlHsAppTy` nlHsTyVar x - - datacons = tyConDataCons tycon - n_args datacon = dataConSourceArity datacon - datacon_vars datacon = map mkGenericLocal [1 .. n_args datacon] - - cons ds = c1 `nlHsAppTy` sum ds - sum [] = nlHsTyVar v1TyConName - sum l = foldBal plus (map sel l) - sel d = s1 `nlHsAppTy` prod (dataConOrigArgTys d) - prod [] = nlHsTyVar u1TyConName - prod l = foldBal times (map arg l) - arg :: Type -> LHsType Name - -- TODO - arg t = nlHsTyVar k1TyConName `nlHsAppTy` nlHsTyVar v1TyConName -- TODO --} tc_mkRep0Ty :: -- The type to generate representation for TyCon @@ -370,17 +116,17 @@ tc_mkRep0Ty tycon metaDts = plus <- tcLookupTyCon sumTyConName times <- tcLookupTyCon prodTyConName - let mkSum a b = mkTyConApp plus [a,b] + let mkSum' a b = mkTyConApp plus [a,b] mkProd a b = mkTyConApp times [a,b] mkRec0 a = mkTyConApp rec0 [a] - mkD a = mkTyConApp d1 [metaDTyCon, sum (tyConDataCons 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] - sum [] = mkTyConTy v1 - sum l = ASSERT (length metaCTyCons == length l) - foldBal mkSum [ mkC i d a - | (d,(a,i)) <- zip metaCTyCons (zip l [0..]) ] + 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) @@ -411,12 +157,12 @@ tc_mkRep0TyCon tycon metaDts = -- `rep0` = GHC.Generics.Rep0 (type family) rep0 <- tcLookupTyCon rep0TyConName - let mod = nameModule (tyConName tycon) + let modl = nameModule (tyConName tycon) loc = nameSrcSpan (tyConName tycon) -- `repName` is a name we generate for the synonym - repName = mkExternalName uniq1 mod (mkGenR0 (nameOccName (tyConName tycon))) loc + repName = mkExternalName uniq1 modl (mkGenR0 (nameOccName (tyConName tycon))) loc -- `coName` is a name for the coercion - coName = mkExternalName uniq2 mod (mkGenR0 (nameOccName (tyConName tycon))) loc + coName = mkExternalName uniq2 modl (mkGenR0 (nameOccName (tyConName tycon))) loc -- `tyvars` = [a,b] tyvars = tyConTyVars tycon -- `appT` = D a b @@ -470,9 +216,6 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds) [ (conFixity_RDR, conFixity_matches c) ] ++ ifElseEmpty (length (dataConFieldLabels c) > 0) [ (conIsRecord_RDR, conIsRecord_matches c) ] - ++ ifElseEmpty (isTupleCon c) - [(conIsTuple_RDR - ,conIsTuple_matches (dataConTyCon c))] ) ifElseEmpty p x = if p then x else [] @@ -500,11 +243,6 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds) . dataConName $ c conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)] conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)] - -- TODO: check that this works - conIsTuple_matches c = [mkSimpleHsAlt nlWildPat - (nlHsApp (nlHsVar arityDataCon_RDR) - (nlHsIntLit - (toInteger (tupleTyConArity c))))] selName_matches s = mkStringLHS (showPpr (nameOccName s)) @@ -580,7 +318,7 @@ genLR_E i n e -------------------------------------------------------------------------------- -- Build a product expression -mkProd_E :: US -- Base for unique names +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) @@ -596,7 +334,7 @@ wrapArg_E v = mkM1_E (k1DataCon_RDR `nlHsVarApps` [v]) -- This M1 is meta-information for the selector -- Build a product pattern -mkProd_P :: US -- Base for unique names +mkProd_P :: US -- Base for unique names -> [RdrName] -- List of variables to match -> LPat RdrName -- Resulting product pattern mkProd_P _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR) @@ -611,20 +349,9 @@ wrapArg_P :: RdrName -> LPat RdrName wrapArg_P v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v]) -- This M1 is meta-information for the selector - 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 = ASSERT( isExternalName tc_name ) nameModule tc_name - from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ) - to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ) - mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e @@ -642,175 +369,3 @@ foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l in foldBal' op x a `op` foldBal' op x b \end{code} - -%************************************************************************ -%* * -\subsection{Generating the RHS of a generic default method} -%* * -%************************************************************************ - -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. 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 = - -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. - - -Note [Polymorphic methods] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -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) - -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 - = 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 - - -- 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 Note [Polymorphic methods] above - (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty - - -- Now we probably have a tycon in front - -- of us, quite probably a FunTyCon. - ep = EP (nlHsVar from_RDR) (nlHsVar to_RDR) - bimap = generate_bimap (tyvar, ep, local_tvs) final_ty - -type EPEnv = (TyVar, -- The class type variable - EP (LHsExpr RdrName), -- The EP it maps to - [TyVar] -- Other in-scope tyvars; they have an identity EP - ) - -------------------- -generate_bimap :: EPEnv - -> Type - -> EP (LHsExpr RdrName) --- Top level case - splitting the TyCon. -generate_bimap env@(tv,ep,local_tvs) 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) - -------------------- -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 = 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 } - where - from_body = fromEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ toEP ep1 `mkHsApp` nlHsVar b_RDR)) - 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 :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName) -bimapTuple eps - = EP { fromEP = mkHsLam [noLoc tuple_pat] from_body, - toEP = mkHsLam [noLoc tuple_pat] to_body } - where - names = takeList eps gs_RDR - tuple_pat = TuplePat (map nlVarPat names) Boxed placeHolderType - eps_w_names = eps `zip` names - to_body = mkLHsTupleExpr [toEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] - from_body = mkLHsTupleExpr [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] - -------------------- --- 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, 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) -idEP = EP idexpr idexpr - where - idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR) -\end{code} -- 1.7.10.4