X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FGenerics.lhs;fp=ghc%2Fcompiler%2Ftypes%2FGenerics.lhs;h=0000000000000000000000000000000000000000;hb=0065d5ab628975892cea1ec7303f968c3338cbe1;hp=2c973649cfcf8c8836e9d8c8dd65b9cb0b700bd8;hpb=28a464a75e14cece5db40f2765a29348273ff2d2;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs deleted file mode 100644 index 2c97364..0000000 --- a/ghc/compiler/types/Generics.lhs +++ /dev/null @@ -1,546 +0,0 @@ -\begin{code} -module Generics ( canDoGenerics, mkTyConGenericBinds, - mkGenericRhs, - validGenericInstanceType, validGenericMethodType - ) where - - -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 PrelNames - -import SrcLoc ( srcLocSpan, noLoc, Located(..) ) -import Util ( takeList, isSingleton ) -import Bag -import Outputable -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 - | 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} -%* * -%************************************************************************ - -\begin{code} -canDoGenerics :: [DataCon] -> 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 data_cons - = not (any bad_con data_cons) -- See comment below - && not (null data_cons) -- No values of the type - where - bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc) - -- 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 - - -- Nor can we do the job if it's an existential data constructor, - - -- Nor if the args are polymorphic types (I don't think) - bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty) -\end{code} - -%************************************************************************ -%* * -\subsection{Generating the RHS of a generic default method} -%* * -%************************************************************************ - -\begin{code} -type US = Int -- Local unique supply, just a plain Int -type FromAlt = (LPat RdrName, LHsExpr RdrName) - -mkTyConGenericBinds :: TyCon -> LHsBinds RdrName -mkTyConGenericBinds tycon - = unitBag (L loc (mkFunBind (L loc from_RDR) from_matches)) - `unionBags` - unitBag (L loc (mkFunBind (L loc to_RDR) to_matches)) - where - from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts] - to_matches = [mkSimpleHsAlt to_pat to_body] - loc = srcLocSpan (getSrcLoc tycon) - datacons = tyConDataCons tycon - (from_RDR, to_RDR) = mkGenericNames tycon - - -- Recurse over the sum first - from_alts :: [FromAlt] - (from_alts, to_pat, to_body) = mk_sum_stuff init_us datacons - init_us = 1::Int -- Unique supply - ----------------------------------------------------- --- Dealing with sums ----------------------------------------------------- - -mk_sum_stuff :: US -- Base for generating unique names - -> [DataCon] -- The data constructors - -> ([FromAlt], -- Alternatives for the T->Trep "from" function - InPat RdrName, LHsExpr RdrName) -- Arg and body of the Trep->T "to" function - --- For example, given --- data T = C | D Int Int Int --- --- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))], --- case cd of { Inl u -> C; --- Inr abc -> case abc of { a :*: bc -> --- case bc of { b :*: c -> --- D a b c }} }, --- cd) - -mk_sum_stuff us [datacon] - = ([from_alt], to_pat, to_body_fn app_exp) - where - n_args = dataConSourceArity datacon -- Existentials already excluded - - datacon_vars = map mkGenericLocal [us .. us+n_args-1] - us' = us + n_args - - datacon_rdr = getRdrName datacon - app_exp = nlHsVarApps datacon_rdr datacon_vars - from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs) - - (_, from_alt_rhs, to_pat, to_body_fn) = mk_prod_stuff us' datacon_vars - -mk_sum_stuff us datacons - = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts, - nlVarPat to_arg, - noLoc (HsCase (nlHsVar to_arg) - (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body, - mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body]))) - where - (l_datacons, r_datacons) = splitInHalf datacons - (l_from_alts, l_to_pat, l_to_body) = mk_sum_stuff us' l_datacons - (r_from_alts, r_to_pat, r_to_body) = mk_sum_stuff us' r_datacons - - to_arg = mkGenericLocal us - us' = us+1 - - wrap :: RdrName -> [FromAlt] -> [FromAlt] - -- Wrap an application of the Inl or Inr constructor round each alternative - wrap dc alts = [(pat, noLoc (HsApp (nlHsVar dc) rhs)) | (pat,rhs) <- alts] - - ----------------------------------------------------- --- Dealing with products ----------------------------------------------------- -mk_prod_stuff :: US -- Base for unique names - -> [RdrName] -- arg-ids; args of the original user-defined constructor - -- They are bound enclosing from_rhs - -- Please bind these in the to_body_fn - -> (US, -- Depleted unique-name supply - LHsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids - InPat RdrName, -- to_pat: - LHsExpr RdrName -> LHsExpr RdrName) -- to_body_fn: takes apart the representation - --- For example: --- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c), --- abc, --- \ -> case abc of { a :*: bc -> --- case bc of { b :*: c -> --- ) - --- We need to use different uniques in the branches --- because the returned to_body_fns are nested. --- Hence the returned unqique-name supply - -mk_prod_stuff us [] -- Unit case - = (us+1, - nlHsVar genUnitDataCon_RDR, - noLoc (SigPatIn (nlVarPat (mkGenericLocal us)) - (noLoc (HsTyVar (getRdrName genUnitTyConName)))), - -- Give a signature to the pattern so we get - -- data S a = Nil | S a - -- toS = \x -> case x of { Inl (g :: Unit) -> Nil - -- Inr x -> S x } - -- The (:: Unit) signature ensures that we'll infer the right - -- type for toS. If we leave it out, the type is too polymorphic - - \x -> x) - -mk_prod_stuff us [arg_var] -- Singleton case - = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x) - -mk_prod_stuff us arg_vars -- Two or more - = (us'', - nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs], - nlVarPat to_arg, --- gaw 2004 FIX? - \x -> noLoc (HsCase (nlHsVar to_arg) - (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))]))) - where - to_arg = mkGenericLocal us - (l_arg_vars, r_arg_vars) = splitInHalf arg_vars - (us', l_alt_rhs, l_to_pat, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars - (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars - pat = nlConPat crossDataCon_RDR [l_to_pat, r_to_pat] - -splitInHalf :: [a] -> ([a],[a]) -splitInHalf list = (left, right) - where - half = length list `div` 2 - left = take half list - right = drop half list - -mkGenericLocal :: US -> RdrName -mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u)) - -mkGenericNames tycon - = (from_RDR, to_RDR) - where - tc_name = tyConName tycon - tc_occ = nameOccName tc_name - tc_mod = nameModule tc_name - from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ) - to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ) -\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) - -\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 - = 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 :: EPEnv -> Maybe (TyCon, [Type]) -> EP (LHsExpr RdrName) -bimapApp env Nothing = panic "TcClassDecl: Type Application!" -bimapApp env (Just (tycon, ty_args)) - | 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 - -------------------- --- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b') -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 eps - = EP { fromEP = mkHsLam [noLoc tuple_pat] (noLoc from_body), - toEP = mkHsLam [noLoc tuple_pat] (noLoc to_body) } - where - names = takeList eps gs_RDR - tuple_pat = TuplePat (map nlVarPat names) Boxed placeHolderType - eps_w_names = eps `zip` names - to_body = ExplicitTuple [toEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed - from_body = ExplicitTuple [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed - -------------------- --- bimapList :: EP a b -> EP [a] [b] -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") -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}