import RdrName ( RdrName, mkVarUnqual, getRdrName, mkRdrUnqual,
mkDerivedRdrName )
import BasicTypes ( Fixity(..), maxPrecedence, Boxity(..) )
-import FieldLabel ( fieldLabelName )
-import DataCon ( isNullaryDataCon, dataConTag,
+import DataCon ( isNullarySrcDataCon, dataConTag,
dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
- DataCon, dataConName,
+ DataCon, dataConName, dataConIsInfix,
dataConFieldLabels )
import Name ( getOccString, getSrcLoc, Name, NamedThing(..) )
(nullary_cons, nonnullary_cons)
| isNewTyCon tycon = ([], tyConDataCons tycon)
- | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
+ | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
rest
= if (null nullary_cons) then
in
listToBag [
mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
- mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] emptyBag (
+ mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] emptyLHsBinds (
nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
]
where
single_con_type = isSingleton tycon_data_cons
(nullary_cons, nonnullary_cons)
| isNewTyCon tycon = ([], tyConDataCons tycon)
- | otherwise = partition isNullaryDataCon tycon_data_cons
+ | otherwise = partition isNullarySrcDataCon tycon_data_cons
cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match
cmp_eq_match
occ_nm = getOccString tycon
succ_enum
- = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] emptyBag $
+ = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] emptyLHsBinds $
untag_Expr tycon [(a_RDR, ah_RDR)] $
nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
nlHsVarApps intDataCon_RDR [ah_RDR]])
nlHsIntLit 1]))
pred_enum
- = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] emptyBag $
+ = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] emptyLHsBinds $
untag_Expr tycon [(a_RDR, ah_RDR)] $
nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
nlHsVarApps intDataCon_RDR [ah_RDR]])
nlHsLit (HsInt (-1))]))
to_enum
- = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] emptyBag $
+ = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] emptyLHsBinds $
nlHsIf (nlHsApps and_RDR
[nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
(illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
enum_from
- = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] emptyBag $
+ = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] emptyLHsBinds $
untag_Expr tycon [(a_RDR, ah_RDR)] $
nlHsApps map_RDR
[nlHsVar (tag2con_RDR tycon),
(nlHsVar (maxtag_RDR tycon)))]
enum_from_then
- = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] emptyBag $
+ = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] emptyLHsBinds $
untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
nlHsPar (enum_from_then_to_Expr
))
from_enum
- = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] emptyBag $
+ = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] emptyLHsBinds $
untag_Expr tycon [(a_RDR, ah_RDR)] $
(nlHsVarApps intDataCon_RDR [ah_RDR])
\end{code}
enum_range
= mk_easy_FunBind tycon_loc range_RDR
- [nlTuplePat [a_Pat, b_Pat] Boxed] emptyBag $
+ [nlTuplePat [a_Pat, b_Pat] Boxed] emptyLHsBinds $
untag_Expr tycon [(a_RDR, ah_RDR)] $
untag_Expr tycon [(b_RDR, bh_RDR)] $
nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
= mk_easy_FunBind tycon_loc index_RDR
[noLoc (AsPat (noLoc c_RDR)
(nlTuplePat [a_Pat, nlWildPat] Boxed)),
- d_Pat] emptyBag (
+ d_Pat] emptyLHsBinds (
nlHsIf (nlHsPar (nlHsVarApps inRange_RDR [c_RDR, d_RDR])) (
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(d_RDR, dh_RDR)] (
enum_inRange
= mk_easy_FunBind tycon_loc inRange_RDR
- [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyBag (
+ [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyLHsBinds (
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(b_RDR, bh_RDR)] (
untag_Expr tycon [(c_RDR, ch_RDR)] (
--------------------------------------------------------------
single_con_range
= mk_easy_FunBind tycon_loc range_RDR
- [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] emptyBag $
+ [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] emptyLHsBinds $
nlHsDo ListComp stmts
where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
range_size
= mk_easy_FunBind tycon_loc rangeSize_RDR
- [nlTuplePat [a_Pat, b_Pat] Boxed] emptyBag (
+ [nlTuplePat [a_Pat, b_Pat] Boxed] emptyLHsBinds (
genOpApp (
(nlHsApps index_RDR [nlTuple [a_Expr, b_Expr] Boxed,
b_Expr])
= mk_easy_FunBind tycon_loc inRange_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
con_pat cs_needed]
- emptyBag (
+ emptyLHsBinds (
foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
where
in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
loc = getSrcSpan tycon
data_cons = tyConDataCons tycon
- (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons
+ (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
read_prec = mkVarBind loc readPrec_RDR
(nlHsApp (nlHsVar parens_RDR) read_cons)
| otherwise = prefix_stmts
prefix_stmts -- T a b c
- = [bindLex (ident_pat (data_con_str data_con))]
+ = [bindLex (ident_pat (data_con_str_w_parens data_con))]
++ read_args
++ [result_stmt data_con as_needed]
result_stmt data_con [a1,a2]]
lbl_stmts -- T { f1 = a, f2 = b }
- = [bindLex (ident_pat (data_con_str data_con)),
+ = [bindLex (ident_pat (data_con_str_w_parens data_con)),
read_punc "{"]
++ concat (intersperse [read_punc ","] field_stmts)
++ [read_punc "}", result_stmt data_con as_needed]
con_arity = dataConSourceArity data_con
labels = dataConFieldLabels data_con
dc_nm = getName data_con
- is_infix = isDataSymOcc (getOccName dc_nm)
+ is_infix = dataConIsInfix data_con
as_needed = take con_arity as_RDRs
read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
(read_a1:read_a2:_) = read_args
ident_pat s = nlConPat ident_RDR [nlLitPat s] -- Ident "foo"
symbol_pat s = nlConPat symbol_RDR [nlLitPat s] -- Symbol ">>"
- data_con_str con = mkHsString (occNameUserString (getOccName con))
+ data_con_str con = mkHsString (occNameUserString (getOccName con))
+ data_con_str_w_parens con = mkHsString (occNameUserString_with_parens (getOccName con))
read_punc c = bindLex (punc_pat c)
read_arg a ty
bindLex (symbol_pat lbl_lit),
read_punc ")"]
where
- lbl_str = occNameUserString (getOccName (fieldLabelName lbl))
+ lbl_str = occNameUserString (getOccName lbl)
lbl_lit = mkHsString lbl_str
is_id_start c = isAlpha c || c == '_'
\end{code}
dc_nm = getName data_con
dc_occ_nm = getOccName data_con
con_str = occNameUserString dc_occ_nm
+ op_con_str = occNameUserString_with_parens dc_occ_nm
show_thingies
| is_infix = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
- | record_syntax = mk_showString_app (con_str ++ " {") :
+ | record_syntax = mk_showString_app (op_con_str ++ " {") :
show_record_args ++ [mk_showString_app "}"]
- | otherwise = mk_showString_app (con_str ++ " ") : show_prefix_args
+ | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
- show_label l = mk_showString_app (the_name ++ " = ")
+ show_label l = mk_showString_app (nm ++ " = ")
-- Note the spaces around the "=" sign. If we don't have them
-- then we get Foo { x=-1 } and the "=-" parses as a single
-- lexeme. Only the space after the '=' is necessary, but
-- it seems tidier to have them both sides.
where
- occ_nm = getOccName (fieldLabelName l)
- nm = occNameUserString occ_nm
- is_op = isSymOcc occ_nm -- Legal, but rare.
- the_name | is_op = '(':nm ++ ")"
- | otherwise = nm
+ occ_nm = getOccName l
+ nm = occNameUserString_with_parens occ_nm
show_args = zipWith show_arg bs_needed arg_tys
(show_arg1:show_arg2:_) = show_args
box_if_necy "Show" tycon (nlHsVar b) arg_ty]
-- Fixity stuff
- is_infix = isDataSymOcc dc_occ_nm
+ is_infix = dataConIsInfix data_con
con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
arg_prec | record_syntax = 0 -- Record fields don't need parens
| otherwise = con_prec_plus_one
+occNameUserString_with_parens :: OccName -> String
+occNameUserString_with_parens occ
+ | isSymOcc occ = '(':nm ++ ")"
+ | otherwise = nm
+ where
+ nm = occNameUserString occ
+
mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
\end{code}
= unitBag $
mk_easy_FunBind tycon_loc
(mk_typeOf_RDR tycon) -- Name of appropriate type0f function
- [nlWildPat] emptyBag
+ [nlWildPat] emptyLHsBinds
(nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
where
tycon_loc = getSrcSpan tycon
tycon_loc
dataTypeOf_RDR
[nlWildPat]
- emptyBag
+ emptyLHsBinds
(nlHsVar data_type_name)
------------ $dT
nlList labels, -- Field labels
nlHsVar fixity] -- Fixity
where
- labels = map (nlHsLit . mkHsString . getOccString . fieldLabelName)
+ labels = map (nlHsLit . mkHsString . getOccString)
(dataConFieldLabels dc)
dc_occ = getOccName dc
is_infix = isDataSymOcc dc_occ
where
eq_op
| not (isUnLiftedType ty) = eq_RDR
- | otherwise =
+ | otherwise = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
-- we have to do something special for primitive things...
- primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
\end{code}
\begin{code}
projects / ghc-hetmet.git / blobdiff