%
% (c) The University of Glasgow 2006
%
\begin{code}
module Generics ( canDoGenerics, mkTyConGenericBinds,
mkGenericRhs,
validGenericInstanceType, validGenericMethodType
) where
import HsSyn
import Type
import TcType
import DataCon
import TyCon
import Name
import RdrName
import BasicTypes
import Var
import VarSet
import Id
import TysWiredIn
import PrelNames
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
validGenericInstanceType inst_ty
= case tcSplitTyConApp_maybe inst_ty of
Just (tycon, tys) -> all isTyVarTy tys && tyConName tycon `elem` genericTyConNames
Nothing -> False
validGenericMethodType :: Type -> Bool
validGenericMethodType ty
= valid tau
where
(local_tvs, _, tau) = tcSplitSigmaTy ty
valid ty
| not (isTauTy ty) = False
| 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
\end{code}
%************************************************************************
%* *
\subsection{Generating representation types}
%* *
%************************************************************************
\begin{code}
canDoGenerics :: [DataCon] -> Bool
canDoGenerics data_cons
= not (any bad_con data_cons)
&& not (null data_cons)
where
bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
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
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
from_alts :: [FromAlt]
(from_alts, to_pat, to_body) = mk_sum_stuff init_us datacons
init_us = 1::Int
mk_sum_stuff :: US
-> [DataCon]
-> ([FromAlt],
InPat RdrName, LHsExpr RdrName)
mk_sum_stuff us [datacon]
= ([from_alt], to_pat, to_body_fn app_exp)
where
n_args = dataConSourceArity datacon
datacon_vars = map mkGenericLocal [us .. us+n_args1]
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 dc alts = [(pat, noLoc (HsApp (nlHsVar dc) rhs)) | (pat,rhs) <- alts]
mk_prod_stuff :: US
-> [RdrName]
-> (US,
LHsExpr RdrName,
InPat RdrName,
LHsExpr RdrName -> LHsExpr RdrName)
mk_prod_stuff us []
= (us+1,
nlHsVar genUnitDataCon_RDR,
noLoc (SigPatIn (nlVarPat (mkGenericLocal us))
(noLoc (HsTyVar (getRdrName genUnitTyConName)))),
\x -> x)
mk_prod_stuff us [arg_var]
= (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x)
mk_prod_stuff us arg_vars
= (us'',
nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs],
nlVarPat to_arg,
\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 -> (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)
\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 )
mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id))
where
(from_RDR, to_RDR) = mkGenericNames tycon
(ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar))
(local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
ep = EP (nlHsVar from_RDR) (nlHsVar to_RDR)
bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
type EPEnv = (TyVar,
EP (LHsExpr RdrName),
[TyVar]
)
generate_bimap :: EPEnv
-> Type
-> EP (LHsExpr RdrName)
generate_bimap env@(tv,ep,local_tvs) ty
| all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
= idEP
| Just tv1 <- getTyVar_maybe ty
= ASSERT( tv == tv1 ) ep
| 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 (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 (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 (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}