import HscTypes
import PrelInfo
+import MkCore ( eRROR_ID )
import PrelNames
import PrimOp
import SrcLoc
aux_binds | no_nullary_cons = []
| otherwise = [GenCon2Tag tycon]
- method_binds = listToBag [
- mk_FunBind loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
- mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
- nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))]
+ method_binds = listToBag [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])))
------------------------------------------------------------------
pats_etc data_con
------------
gen_Ord_binds :: SrcSpan -> TyCon -> (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 [], [])
+ | otherwise
= (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
where
aux_binds | single_con_type = []
show_list = mkHsVarBind loc showList_RDR
(nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
-----------------------------------------------------------------------
- shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
- where
- pats_etc data_con
- | nullary_con = -- skip the showParen junk...
- ASSERT(null bs_needed)
- ([nlWildPat, con_pat], mk_showString_app op_con_str)
- | otherwise =
- ([a_Pat, con_pat],
- showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
- (nlHsPar (nested_compose_Expr show_thingies)))
- where
+ data_cons = tyConDataCons tycon
+ shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc data_cons)
+
+ pats_etc data_con
+ | nullary_con = -- skip the showParen junk...
+ ASSERT(null bs_needed)
+ ([nlWildPat, con_pat], mk_showString_app op_con_str)
+ | otherwise =
+ ([a_Pat, con_pat],
+ showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
+ (nlHsPar (nested_compose_Expr show_thingies)))
+ where
data_con_RDR = getRdrName data_con
con_arity = dataConSourceArity data_con
bs_needed = take con_arity bs_RDRs
------------ gfoldl
gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
- gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
+
+ gfoldl_eqn con
+ = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
where
con_name :: RdrName
= (unitBag fmap_bind, [])
where
data_cons = tyConDataCons tycon
- fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) eqns
+ fmap_bind = L loc $ mkRdrFunBind (L loc fmap_RDR) eqns
fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
where
parts = foldDataConArgs ft_fmap con
- -- Catch-all eqn looks like fmap _ _ = error "impossible"
- -- It's needed if there no data cons at all
eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
(error_Expr "Void fmap")]
| otherwise = map fmap_eqn data_cons
where
data_cons = tyConDataCons tycon
- foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) eqns
- eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat, nlWildPat]
- (error_Expr "Void foldr")]
- | otherwise = map foldr_eqn data_cons
+ foldr_bind = 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
parts = foldDataConArgs ft_foldr con
where
data_cons = tyConDataCons tycon
- traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) eqns
- eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
- (error_Expr "Void traverse")]
- | otherwise = map traverse_eqn data_cons
+ traverse_bind = 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
parts = foldDataConArgs ft_trav con
genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName)
genAuxBind loc (GenCon2Tag tycon)
= (mk_FunBind loc rdr_name eqns,
- L loc (TypeSig (L loc rdr_name) sig_ty))
+ L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
where
rdr_name = con2tag_RDR tycon
- sig_ty = genForAllTy loc tycon $ \hs_tc_app ->
- hs_tc_app `nlHsFunTy` nlHsTyVar (getRdrName intPrimTyCon)
+ sig_ty = HsCoreTy $
+ mkForAllTys (tyConTyVars tycon) $
+ mkParentType tycon `mkFunTy` intPrimTy
lots_of_constructors = tyConFamilySize tycon > 8
-- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
genAuxBind loc (GenTag2Con tycon)
- = ASSERT( null (tyConTyVars tycon) )
- (mk_FunBind loc rdr_name
+ = (mk_FunBind loc rdr_name
[([nlConVarPat intDataCon_RDR [a_RDR]],
nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
- L loc (TypeSig (L loc rdr_name) sig_ty))
+ L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
where
- sig_ty = nlHsTyVar (getRdrName intTyCon)
- `nlHsFunTy` (nlHsTyVar (getRdrName tycon))
+ sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $
+ intTy `mkFunTy` mkParentType tycon
rdr_name = tag2con_RDR tycon
genAuxBind loc (GenMaxTag tycon)
= (mkHsVarBind loc rdr_name rhs,
- L loc (TypeSig (L loc rdr_name) sig_ty))
+ L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
where
rdr_name = maxtag_RDR tycon
- sig_ty = nlHsTyVar (getRdrName intTyCon)
+ sig_ty = HsCoreTy intTy
rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))
max_tag = case (tyConDataCons tycon) of
data_cons -> toInteger ((length data_cons) - fIRST_TAG)
mk_constr_name :: DataCon -> RdrName -- "$cC"
mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
-genForAllTy :: SrcSpan -> TyCon
- -> (LHsType RdrName -> LHsType RdrName)
- -> LHsType RdrName
--- Wrap a forall type for the variables of the TyCOn
-genForAllTy loc tc thing_inside
- = L loc $ mkExplicitHsForAllTy (userHsTyVarBndrs (map (L loc) tvs)) (L loc []) $
- thing_inside (nlHsTyConApp (getRdrName tc) (map nlHsTyVar tvs))
- where
- tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tc)
- -- We can't use getRdrName because that makes an Exact RdrName
- -- and we can't put them in the LocalRdrEnv
+mkParentType :: TyCon -> Type
+-- Turn the representation tycon of a family into
+-- a use of its family constructor
+mkParentType tc
+ = case tyConFamInst_maybe tc of
+ Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
+ Just (fam_tc,tys) -> mkTyConApp fam_tc tys
\end{code}
%************************************************************************
%************************************************************************
-ToDo: Better SrcLocs.
+\begin{code}
+mk_FunBind :: SrcSpan -> RdrName
+ -> [([LPat RdrName], LHsExpr RdrName)]
+ -> LHsBind RdrName
+mk_FunBind loc fun pats_and_exprs
+ = L loc $ mkRdrFunBind (L loc fun) matches
+ where
+ matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
+
+mkRdrFunBind :: Located RdrName -> [LMatch RdrName] -> HsBind RdrName
+mkRdrFunBind fun@(L _ fun_rdr) matches
+ | null matches = mkFunBind fun [mkMatch [] (error_Expr str) emptyLocalBinds]
+ -- Catch-all eqn looks like
+ -- fmap = error "Void fmap"
+ -- It's needed if there no data cons at all,
+ -- which can happen with -XEmptyDataDecls
+ -- See Trac #4302
+ | otherwise = mkFunBind fun matches
+ where
+ str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
+\end{code}
\begin{code}
box_if_necy :: String -- The class involved
projects / ghc-hetmet.git / blobdiff