Commit c93690df authored by dreixel's avatar dreixel

Fix #5464: Change the way the extra bindings for the generic

representation are generated.

This is an initial commit; things seem to work but some
clean up is still necessary (renaming functions, adding
comments, etc.)
parent a21de087
This diff is collapsed.
......@@ -12,7 +12,7 @@ This is where we do all the grimy bindings' generation.
\begin{code}
module TcGenDeriv (
DerivAuxBinds, isDupAux,
BagDerivStuff, DerivStuff(..),
gen_Bounded_binds,
gen_Enum_binds,
......@@ -28,8 +28,8 @@ module TcGenDeriv (
deepSubtypesContaining, foldDataConArgs,
gen_Foldable_binds,
gen_Traversable_binds,
genAuxBind,
ordOpTbl, boxConTbl
genAuxBinds, isDupAux,
ordOpTbl, boxConTbl
) where
#include "HsVersions.h"
......@@ -62,32 +62,43 @@ import FastString
import Bag
import Fingerprint
import Constants
import Generics (MetaTyCons)
import TcEnv (InstInfo)
import Data.List ( partition, intersperse )
\end{code}
\begin{code}
type DerivAuxBinds = [DerivAuxBind]
data DerivAuxBind -- Please add these auxiliary top-level bindings
= GenCon2Tag TyCon -- The con2Tag for given TyCon
| GenTag2Con TyCon -- ...ditto tag2Con
| GenMaxTag TyCon -- ...and maxTag
-- All these generate ZERO-BASED tag operations
-- I.e first constructor has tag 0
-- Scrap your boilerplate
| MkDataCon DataCon -- For constructor C we get $cC :: Constr
| MkTyCon TyCon -- For tycon T we get $tT :: DataType
isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool
isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1 == tc2
isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1 == tc2
isDupAux (GenMaxTag tc1) (GenMaxTag tc2) = tc1 == tc2
isDupAux (MkDataCon dc1) (MkDataCon dc2) = dc1 == dc2
isDupAux (MkTyCon tc1) (MkTyCon tc2) = tc1 == tc2
isDupAux _ _ = False
type BagDerivStuff = Bag DerivStuff
data DerivStuff -- Please add these auxiliary top-level bindings
= DerivCon2Tag TyCon -- The con2Tag for given TyCon
| DerivTag2Con TyCon -- ...ditto tag2Con
| DerivMaxTag TyCon -- ...and maxTag
-- All these generate ZERO-BASED tag operations
-- I.e first constructor has tag 0
-- Scrap your boilerplate
| DerivDataCon DataCon -- For constructor C we get $cC :: Constr
| DerivTyCon TyCon -- For tycon T we get $tT :: DataType
-- Generics
| DerivGenMetaTyCons MetaTyCons
| DerivGenRepTyCon TyCon
| DerivInst (InstInfo RdrName)
| DerivHsBind (LHsBind RdrName)
isDupAux :: DerivStuff -> DerivStuff -> Bool
isDupAux (DerivCon2Tag tc1) (DerivCon2Tag tc2) = tc1 == tc2
isDupAux (DerivTag2Con tc1) (DerivTag2Con tc2) = tc1 == tc2
isDupAux (DerivMaxTag tc1) (DerivMaxTag tc2) = tc1 == tc2
isDupAux (DerivDataCon dc1) (DerivDataCon dc2) = dc1 == dc2
isDupAux (DerivTyCon tc1) (DerivTyCon tc2) = tc1 == tc2
-- isDupAux (DerivGenRepTyCon tc1) (DerivGenRepTyCon tc2) = tc1 == tc2
-- We are certain we do not introduce duplicates for the other cases
isDupAux _ _ = False
\end{code}
......@@ -166,9 +177,9 @@ instance ... Eq (Foo ...) where
\begin{code}
gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Eq_binds :: SrcSpan -> TyCon -> BagDerivStuff --(LHsBinds RdrName, DerivAuxBinds)
gen_Eq_binds loc tycon
= (method_binds, aux_binds)
= method_binds `unionBags` aux_binds
where
(nullary_cons, nonnullary_cons)
| isNewTyCon tycon = ([], tyConDataCons tycon)
......@@ -186,10 +197,10 @@ gen_Eq_binds loc tycon
untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
(genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
aux_binds | no_nullary_cons = []
| otherwise = [GenCon2Tag tycon]
aux_binds | no_nullary_cons = emptyBag
| otherwise = unitBag (DerivCon2Tag tycon)
method_binds = listToBag [eq_bind, ne_bind]
method_binds = listToBag (map DerivHsBind [eq_bind, ne_bind])
eq_bind = mk_FunBind loc eq_RDR (map pats_etc nonnullary_cons ++ rest)
ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
......@@ -324,15 +335,19 @@ gtResult OrdGE = true_Expr
gtResult OrdGT = true_Expr
------------
gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Ord_binds :: SrcSpan -> TyCon -> BagDerivStuff --(LHsBinds RdrName, DerivAuxBinds)
gen_Ord_binds loc tycon
| null tycon_data_cons -- No data-cons => invoke bale-out case
= (unitBag $ mk_FunBind loc compare_RDR [], [])
= unitBag $ DerivHsBind $ mk_FunBind loc compare_RDR []
| otherwise
= (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
= unitBag (mkOrdOp OrdCompare)
`unionBags`
other_ops
`unionBags`
aux_binds
where
aux_binds | single_con_type = []
| otherwise = [GenCon2Tag tycon]
aux_binds | single_con_type = emptyBag
| otherwise = unitBag (DerivCon2Tag tycon)
-- Note [Do not rely on compare]
other_ops | (last_tag - first_tag) <= 2 -- 1-3 constructors
......@@ -355,9 +370,11 @@ gen_Ord_binds loc tycon
(nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
mkOrdOp :: OrdOp -> LHsBind RdrName
mkOrdOp :: OrdOp -> DerivStuff --LHsBind RdrName
-- Returns a binding op a b = ... compares a and b according to op ....
mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op)
mkOrdOp op = DerivHsBind $
mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat]
(mkOrdOpRhs op)
mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
mkOrdOpRhs op -- RHS for comparing 'a' and 'b' according to op
......@@ -547,19 +564,19 @@ instance ... Enum (Foo ...) where
For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
\begin{code}
gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Enum_binds :: SrcSpan -> TyCon -> BagDerivStuff --(LHsBinds RdrName, DerivAuxBinds)
gen_Enum_binds loc tycon
= (method_binds, aux_binds)
= method_binds `unionBags` aux_binds
where
method_binds = listToBag [
method_binds = listToBag (map DerivHsBind [
succ_enum,
pred_enum,
to_enum,
enum_from,
enum_from_then,
from_enum
]
aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]
])
aux_binds = listToBag [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
occ_nm = getOccString tycon
......@@ -626,13 +643,13 @@ gen_Enum_binds loc tycon
%************************************************************************
\begin{code}
gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Bounded_binds :: SrcSpan -> TyCon -> BagDerivStuff --(LHsBinds RdrName, DerivAuxBinds)
gen_Bounded_binds loc tycon
| isEnumerationTyCon tycon
= (listToBag [ min_bound_enum, max_bound_enum ], [])
= listToBag (map DerivHsBind [min_bound_enum, max_bound_enum])
| otherwise
= ASSERT(isSingleton data_cons)
(listToBag [ min_bound_1con, max_bound_1con ], [])
(listToBag (map DerivHsBind [min_bound_1con, max_bound_1con]))
where
data_cons = tyConDataCons tycon
......@@ -713,16 +730,17 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report
(p.~147).
\begin{code}
gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Ix_binds :: SrcSpan -> TyCon -> BagDerivStuff --(LHsBinds RdrName, DerivAuxBinds)
gen_Ix_binds loc tycon
| isEnumerationTyCon tycon
= (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
= enum_ixes `unionBags`
listToBag [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
| otherwise
= (single_con_ixes, [GenCon2Tag tycon])
= single_con_ixes `unionBags` unitBag (DerivCon2Tag tycon)
where
--------------------------------------------------------------
enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
enum_ixes = listToBag (map DerivHsBind [enum_range, enum_index, enum_inRange])
enum_range
= mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
......@@ -761,8 +779,8 @@ gen_Ix_binds loc tycon
))))
--------------------------------------------------------------
single_con_ixes
= listToBag [single_con_range, single_con_index, single_con_inRange]
single_con_ixes = listToBag (map DerivHsBind
[single_con_range, single_con_index, single_con_inRange])
data_con
= case tyConSingleDataCon_maybe tycon of -- just checking...
......@@ -872,10 +890,10 @@ instance Read T where
\begin{code}
gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> BagDerivStuff --(LHsBinds RdrName, DerivAuxBinds)
gen_Read_binds get_fixity loc tycon
= (listToBag [read_prec, default_readlist, default_readlistprec], [])
= listToBag (map DerivHsBind [read_prec, default_readlist, default_readlistprec])
where
-----------------------------------------------------------------------
default_readlist
......@@ -1041,10 +1059,10 @@ Example
-- the most tightly-binding operator
\begin{code}
gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> BagDerivStuff --(LHsBinds RdrName, DerivAuxBinds)
gen_Show_binds get_fixity loc tycon
= (listToBag [shows_prec, show_list], [])
= listToBag (map DerivHsBind [shows_prec, show_list])
where
-----------------------------------------------------------------------
show_list = mkHsVarBind loc showList_RDR
......@@ -1173,9 +1191,9 @@ we generate
We are passed the Typeable2 class as well as T
\begin{code}
gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName
gen_Typeable_binds :: SrcSpan -> TyCon -> BagDerivStuff --LHsBinds RdrName
gen_Typeable_binds loc tycon
= unitBag $
= unitBag $ DerivHsBind $
mk_easy_FunBind loc
(mk_typeOf_RDR tycon) -- Name of appropriate type0f function
[nlWildPat]
......@@ -1251,15 +1269,12 @@ we generate
\begin{code}
gen_Data_binds :: SrcSpan
-> TyCon
-> (LHsBinds RdrName, -- The method bindings
DerivAuxBinds) -- Auxiliary bindings
gen_Data_binds :: SrcSpan -> TyCon -> BagDerivStuff
gen_Data_binds loc tycon
= (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
`unionBags` gcast_binds,
-- Auxiliary definitions: the data type and constructors
MkTyCon tycon : map MkDataCon data_cons)
= listToBag (map DerivHsBind [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind])
`unionBags` gcast_binds
-- Auxiliary definitions: the data type and constructors
`unionBags` (listToBag (DerivTyCon tycon : map DerivDataCon data_cons))
where
data_cons = tyConDataCons tycon
n_cons = length data_cons
......@@ -1317,7 +1332,7 @@ gen_Data_binds loc tycon
| tycon_kind `eqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
| otherwise = emptyBag
mk_gcast dataCast_RDR gcast_RDR
= unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
= unitBag (DerivHsBind $ mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
(nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
......@@ -1416,12 +1431,12 @@ This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
$(cofmap 'a '(b -> c)) x = \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
\begin{code}
gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Functor_binds :: SrcSpan -> TyCon -> BagDerivStuff --(LHsBinds RdrName, DerivAuxBinds)
gen_Functor_binds loc tycon
= (unitBag fmap_bind, [])
= unitBag fmap_bind
where
data_cons = tyConDataCons tycon
fmap_bind = L loc $ mkRdrFunBind (L loc fmap_RDR) eqns
fmap_bind = DerivHsBind $ L loc $ mkRdrFunBind (L loc fmap_RDR) eqns
fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
where
......@@ -1587,13 +1602,13 @@ Note that the arguments to the real foldr function are the wrong way around,
since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
\begin{code}
gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Foldable_binds :: SrcSpan -> TyCon -> BagDerivStuff --(LHsBinds RdrName, DerivAuxBinds)
gen_Foldable_binds loc tycon
= (unitBag foldr_bind, [])
= unitBag foldr_bind
where
data_cons = tyConDataCons tycon
foldr_bind = L loc $ mkRdrFunBind (L loc foldable_foldr_RDR) eqns
foldr_bind = DerivHsBind $ L loc $ mkRdrFunBind (L loc foldable_foldr_RDR) eqns
eqns = map foldr_eqn data_cons
foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
where
......@@ -1639,13 +1654,13 @@ gives the function: traverse f (T x y) = T <$> pure x <*> f y
instead of: traverse f (T x y) = T x <$> f y
\begin{code}
gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Traversable_binds :: SrcSpan -> TyCon -> BagDerivStuff --(LHsBinds RdrName, DerivAuxBinds)
gen_Traversable_binds loc tycon
= (unitBag traverse_bind, [])
= unitBag traverse_bind
where
data_cons = tyConDataCons tycon
traverse_bind = L loc $ mkRdrFunBind (L loc traverse_RDR) eqns
traverse_bind = DerivHsBind $ L loc $ mkRdrFunBind (L loc traverse_RDR) eqns
eqns = map traverse_eqn data_cons
traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
where
......@@ -1694,8 +1709,8 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
fiddling around.
\begin{code}
genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName)
genAuxBind loc (GenCon2Tag tycon)
genAuxBind :: SrcSpan -> DerivStuff -> (LHsBind RdrName, LSig RdrName)
genAuxBind loc (DerivCon2Tag tycon)
= (mk_FunBind loc rdr_name eqns,
L loc (TypeSig [L loc rdr_name] (L loc sig_ty)))
where
......@@ -1718,7 +1733,7 @@ genAuxBind loc (GenCon2Tag tycon)
mk_eqn con = ([nlWildConPat con],
nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
genAuxBind loc (GenTag2Con tycon)
genAuxBind loc (DerivTag2Con tycon)
= (mk_FunBind loc rdr_name
[([nlConVarPat intDataCon_RDR [a_RDR]],
nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
......@@ -1729,7 +1744,7 @@ genAuxBind loc (GenTag2Con tycon)
rdr_name = tag2con_RDR tycon
genAuxBind loc (GenMaxTag tycon)
genAuxBind loc (DerivMaxTag tycon)
= (mkHsVarBind loc rdr_name rhs,
L loc (TypeSig [L loc rdr_name] (L loc sig_ty)))
where
......@@ -1739,7 +1754,7 @@ genAuxBind loc (GenMaxTag tycon)
max_tag = case (tyConDataCons tycon) of
data_cons -> toInteger ((length data_cons) - fIRST_TAG)
genAuxBind loc (MkTyCon tycon) -- $dT
genAuxBind loc (DerivTyCon tycon) -- $dT
= (mkHsVarBind loc rdr_name rhs,
L loc (TypeSig [L loc rdr_name] sig_ty))
where
......@@ -1750,7 +1765,7 @@ genAuxBind loc (MkTyCon tycon) -- $dT
`nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
`nlHsApp` nlList constrs
genAuxBind loc (MkDataCon dc) -- $cT1 etc
genAuxBind loc (DerivDataCon dc) -- $cT1 etc
= (mkHsVarBind loc rdr_name rhs,
L loc (TypeSig [L loc rdr_name] sig_ty))
where
......@@ -1772,6 +1787,19 @@ genAuxBind loc (MkDataCon dc) -- $cT1 etc
fixity | is_infix = infix_RDR
| otherwise = prefix_RDR
genAuxBind _ _ = error "JPM: TODO"
genAuxBinds :: Monad m => SrcSpan -> BagDerivStuff -> m ( Bag (LHsBind RdrName)
, Bag (LSig RdrName))
genAuxBinds loc bs = mapAndUnzipBagM (return . genAuxBind loc) auxBinds where
f x@(DerivGenMetaTyCons _) = Left x
f x@(DerivGenRepTyCon _) = Left x
f x@(DerivInst _) = Left x
f x@(DerivHsBind _) = Left x
f x = Right x
(_, auxBinds) = partitionBagWith f bs
mk_data_type_name :: TyCon -> RdrName -- "$tT"
mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
......
......@@ -25,7 +25,6 @@ import FamInst
import FamInstEnv
import TcDeriv
import TcEnv
import RnSource ( addTcgDUs )
import TcHsType
import TcUnify
import MkCore ( nO_METHOD_BINDING_ERROR_ID )
......@@ -399,17 +398,22 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
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
-}
; (gbl_env, deriv_inst_info, deriv_binds)
<- tcDeriving tycl_decls inst_decls deriv_decls
-- Extend the global environment also with the generated datatypes for
-- the generic representation
{-
; let all_tycons = map ATyCon (deriv_tys ++ deriv_ty_insts)
; gbl_env <- tcExtendGlobalEnv all_tycons $
tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $
addFamInsts deriv_ty_insts $
addInsts deriv_inst_info getGblEnv
-}
-- Check that if the module is compiled with -XSafe, there are no
-- hand written instances of Typeable as then unsafe casts could be
-- performed. Derivied instances are OK.
......@@ -419,8 +423,8 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
(addErrAt (getSrcSpan $ iSpec x) typInstErr))
local_info
; return ( addTcgDUs gbl_env deriv_dus,
deriv_inst_info ++ local_info,
; return ( gbl_env,
(bagToList deriv_inst_info) ++ local_info,
aux_binds `plusHsValBinds` deriv_binds)
}}}
where
......
......@@ -17,7 +17,8 @@ import DataCon
import TyCon
import Name hiding (varName)
import Module (moduleName, moduleNameString)
import Module (Module, moduleName, moduleNameString)
import IfaceEnv (newGlobalBinder)
import RdrName
import BasicTypes
import TysWiredIn
......@@ -73,9 +74,7 @@ canDoGenerics tycon
then (Just (ppr dc <+> text "must be a vanilla data constructor"))
else Nothing)
-- 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)
......@@ -119,10 +118,11 @@ mkBindsRep tycon =
-- type Rep_D a b = ...representation type for D ...
--------------------------------------------------------------------------------
tc_mkRepTyCon :: TyCon -- The type to generate representation for
tc_mkRepTyCon :: TyCon -- The type to generate representation for
-> MetaTyCons -- Metadata datatypes to refer to
-> Module -- JPM TODO
-> TcM TyCon -- Generated representation0 type
tc_mkRepTyCon tycon metaDts =
tc_mkRepTyCon tycon metaDts mod =
-- Consider the example input tycon `D`, where data D a b = D_ a
do { -- `rep0` = GHC.Generics.Rep (type family)
rep0 <- tcLookupTyCon repTyConName
......@@ -131,7 +131,9 @@ tc_mkRepTyCon tycon metaDts =
; rep0Ty <- tc_mkRepTy tycon metaDts
-- `rep_name` is a name we generate for the synonym
; rep_name <- newImplicitBinder (tyConName tycon) mkGenR
-- ; rep_name <- newImplicitBinder (tyConName tycon) mkGenR
; rep_name <- newGlobalBinder mod (mkGenR (nameOccName (tyConName tycon)))
(nameSrcSpan (tyConName tycon))
; let -- `tyvars` = [a,b]
tyvars = tyConTyVars tycon
......@@ -144,6 +146,8 @@ tc_mkRepTyCon tycon metaDts =
; buildSynTyCon rep_name tyvars (SynonymTyCon rep0Ty) rep_kind
NoParentTyCon (Just (rep0, appT)) }
--------------------------------------------------------------------------------
-- Type representation
--------------------------------------------------------------------------------
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment