import HscTypes
import PrelInfo
-import PrelNames
+import MkCore ( eRROR_ID )
+import PrelNames hiding (error_RDR)
import PrimOp
import SrcLoc
import TyCon
import TysPrim
import TysWiredIn
import Type
-import Var( TyVar )
import TypeRep
import VarSet
import State
where
(nullary_cons, nonnullary_cons)
| isNewTyCon tycon = ([], tyConDataCons tycon)
- | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
+ | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
no_nullary_cons = null nullary_cons
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 = []
single_con_range
= mk_easy_FunBind loc range_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
- nlHsDo ListComp stmts con_expr
+ noLoc (mkHsComp ListComp stmts con_expr)
where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
read_nullary_cons
= case nullary_cons of
[] -> []
- [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
- (result_expr con [])]
+ [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
_ -> [nlHsApp (nlHsVar choose_RDR)
(nlList (map mk_pair nullary_cons))]
-
+ -- NB For operators the parens around (:=:) are matched by the
+ -- enclosing "parens" call, so here we must match the naked
+ -- data_con_str con
+
+ match_con con | isSym con_str = [symbol_pat con_str]
+ | otherwise = ident_h_pat con_str
+ where
+ con_str = data_con_str con
+ -- For nullary constructors we must match Ident s for normal constrs
+ -- and Symbol s for operators
+
mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
result_expr con []]
-
+
read_non_nullary_con data_con
| is_infix = mk_parser infix_prec infix_stmts body
| is_record = mk_parser record_prec record_stmts body
prefix_parser = mk_parser prefix_prec prefix_stmts body
read_prefix_con
- | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"]
- | otherwise = [bindLex (ident_pat con_str)]
+ | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]
+ | otherwise = ident_h_pat con_str
read_infix_con
- | isSym con_str = [bindLex (symbol_pat con_str)]
- | otherwise = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]
+ | isSym con_str = [symbol_pat con_str]
+ | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]
prefix_stmts -- T a b c
= read_prefix_con ++ read_args
------------------------------------------------------------------------
-- Helpers
------------------------------------------------------------------------
- mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
- mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b })
- bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
- con_app con as = nlHsVarApps (getRdrName con) as -- con as
- result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
+ mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
+ mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b })
+ , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])]
+ bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
+ con_app con as = nlHsVarApps (getRdrName con) as -- con as
+ result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
- ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo"
- symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>"
+
+ -- For constructors and field labels ending in '#', we hackily
+ -- let the lexer generate two tokens, and look for both in sequence
+ -- Thus [Ident "I"; Symbol "#"]. See Trac #5041
+ ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
+ | otherwise = [ ident_pat s ]
+
+ ident_pat s = bindLex $ nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo" <- lexP
+ symbol_pat s = bindLex $ nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>" <- lexP
data_con_str con = occNameString (getOccName con)
-- or (#) = 4
-- Note the parens!
read_lbl lbl | isSym lbl_str
- = [read_punc "(",
- bindLex (symbol_pat lbl_str),
- read_punc ")"]
+ = [read_punc "(", symbol_pat lbl_str, read_punc ")"]
| otherwise
- = [bindLex (ident_pat lbl_str)]
+ = ident_h_pat lbl_str
where
lbl_str = occNameString (getOccName lbl)
\end{code}
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 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
gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
- dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR :: RdrName
-gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
-gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
-toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
-dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
-dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
-dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
-gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
-gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
-mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
-mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
-conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
+ dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
+ constr_RDR, dataType_RDR :: RdrName
+gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
+gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
+toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
+dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
+dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
+dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
+gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
+gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
+mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
+constr_RDR = tcQual_RDR gENERICS (fsLit "Constr")
+mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
+dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType")
+conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
\end{code}
= (unitBag fmap_bind, [])
where
data_cons = tyConDataCons tycon
-
- fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) (map fmap_eqn data_cons)
+ 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
+ eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
+ (error_Expr "Void fmap")]
+ | otherwise = map fmap_eqn data_cons
+
ft_fmap :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
-- Tricky higher order type; I can't say I fully understand this code :-(
ft_fmap = FT { ft_triv = \x -> return x -- fmap f x = x
where (_, xc) = go co x
(yr,yc) = go co y
go co ty@(TyConApp con args)
- | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs,True)
- | null args = (caseTrivial,False) -- T
- | or (init xcs) = (caseWrongArg,True) -- T (..var..) ty
- | last xcs = -- T (..no var..) ty
- (caseTyApp (fst (splitAppTy ty)) (last xrs),True)
+ | not (or xcs) = (caseTrivial, False) -- Variable does not occur
+ -- At this point we know that xrs, xcs is not empty,
+ -- and at least one xr is True
+ | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs, True)
+ | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty
+ | otherwise = -- T (..no var..) ty
+ (caseTyApp (fst (splitAppTy ty)) (last xrs), True)
where (xrs,xcs) = unzip (map (go co) args)
go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
where (xr,xc) = go co x
where
data_cons = tyConDataCons tycon
- foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) (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) (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
fiddling around.
\begin{code}
-genAuxBind :: SrcSpan -> DerivAuxBind -> LHsBind RdrName
+genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName)
genAuxBind loc (GenCon2Tag tycon)
- | lots_of_constructors
- = mk_FunBind loc rdr_name [([], get_tag_rhs)]
-
- | otherwise
- = mk_FunBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
-
+ = (mk_FunBind loc rdr_name eqns,
+ L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
where
rdr_name = con2tag_RDR tycon
- tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
- -- We can't use gerRdrName because that makes an Exact RdrName
- -- and we can't put them in the LocalRdrEnv
+ sig_ty = HsCoreTy $
+ mkSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
+ mkParentType tycon `mkFunTy` intPrimTy
- -- Give a signature to the bound variable, so
- -- that the case expression generated by getTag is
- -- monomorphic. In the push-enter model we get better code.
- get_tag_rhs = L loc $ ExprWithTySig
- (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
- (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
- (noLoc (mkExplicitHsForAllTy (userHsTyVarBndrs (map noLoc tvs))
- (noLoc []) con2tag_ty))
+ lots_of_constructors = tyConFamilySize tycon > 8
+ -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
+ -- but we don't do vectored returns any more.
- con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
- `nlHsFunTy`
- nlHsTyVar (getRdrName intPrimTyCon)
+ eqns | lots_of_constructors = [get_tag_eqn]
+ | otherwise = map mk_eqn (tyConDataCons tycon)
- lots_of_constructors = tyConFamilySize tycon > 8
- -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
- -- but we don't do vectored returns any more.
+ get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
- mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
- mk_stuff con = ([nlWildConPat con],
- nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
+ mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
+ mk_eqn con = ([nlWildConPat con],
+ nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
genAuxBind loc (GenTag2Con tycon)
- = mk_FunBind loc rdr_name
+ = (mk_FunBind loc rdr_name
[([nlConVarPat intDataCon_RDR [a_RDR]],
- noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
- (nlHsTyVar (getRdrName tycon))))]
+ nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
+ L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
where
+ sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $
+ intTy `mkFunTy` mkParentType tycon
+
rdr_name = tag2con_RDR tycon
genAuxBind loc (GenMaxTag tycon)
- = mkHsVarBind loc rdr_name
- (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
+ = (mkHsVarBind loc rdr_name rhs,
+ L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
where
rdr_name = maxtag_RDR tycon
+ 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)
genAuxBind loc (MkTyCon tycon) -- $dT
- = mkHsVarBind loc (mk_data_type_name tycon)
- ( nlHsVar mkDataType_RDR
- `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
- `nlHsApp` nlList constrs )
+ = (mkHsVarBind loc rdr_name rhs,
+ L loc (TypeSig (L loc rdr_name) sig_ty))
where
- constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
+ rdr_name = mk_data_type_name tycon
+ sig_ty = nlHsTyVar dataType_RDR
+ constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
+ rhs = nlHsVar mkDataType_RDR
+ `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
+ `nlHsApp` nlList constrs
genAuxBind loc (MkDataCon dc) -- $cT1 etc
- = mkHsVarBind loc (mk_constr_name dc)
- (nlHsApps mkConstr_RDR constr_args)
+ = (mkHsVarBind loc rdr_name rhs,
+ L loc (TypeSig (L loc rdr_name) sig_ty))
where
+ rdr_name = mk_constr_name dc
+ sig_ty = nlHsTyVar constr_RDR
+ rhs = nlHsApps mkConstr_RDR constr_args
+
constr_args
= [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
mk_constr_name :: DataCon -> RdrName -- "$cC"
mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
+
+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
text "for primitive type" <+> ppr ty)
| otherwise = head res
where
- res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
+ res = [id | (ty',id) <- tbl, ty `eqType` ty']
-----------------------------------------------------------------------
-- impossible_Expr is used in case RHSs that should never happen.
-- We generate these to keep the desugarer from complaining that they *might* happen!
--- impossible_Expr :: LHsExpr RdrName
--- impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
+error_Expr :: String -> LHsExpr RdrName
+error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
-- illegal_Expr is used when signalling error conditions in the RHS of a derived
-- method. It is currently only used by Enum.{succ,pred}
projects / ghc-hetmet.git / blobdiff