\begin{code}
module TcClassDcl ( tcClassSigs, tcClassDecl2,
findMethodBind, instantiateMethod, tcInstanceMethodBody,
- mkGenericDefMethBind, getGenericInstances,
+ mkGenericDefMethBind,
tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
) where
[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
%
-% (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
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
import HscTypes
import SrcLoc
-import Util
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
- | 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}
-- 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)
\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 =
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
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)
-- `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
[ (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 []
. 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))
--------------------------------------------------------------------------------
-- 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)
-- 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)
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
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 = <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.
-
-
-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}
projects / ghc-hetmet.git / commitdiff