intDataCon_RDR, true_RDR, false_RDR )
import Util ( zipWithEqual, isSingleton,
zipWith3Equal, nOfThem, zipEqual )
-import Char ( isAlpha )
import Constants
import List ( partition, intersperse )
import Outputable
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] emptyLHsBinds (
+ mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] (
nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
]
where
tycon_loc = getSrcSpan tycon
--------------------------------------------------------------------
- compare = mk_easy_FunBind tycon_loc compare_RDR
- [a_Pat, b_Pat] (unitBag cmp_eq) compare_rhs
+ compare = L tycon_loc (FunBind (L tycon_loc compare_RDR) False compare_matches placeHolderNames)
+ compare_matches = mkMatchGroup [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
+ cmp_eq_binds = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
+
compare_rhs
| single_con_type = cmp_eq_Expr a_Expr b_Expr
| otherwise
occ_nm = getOccString tycon
succ_enum
- = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] emptyLHsBinds $
+ = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] $
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] emptyLHsBinds $
+ = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] $
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] emptyLHsBinds $
+ = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] $
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] emptyLHsBinds $
+ = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] $
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] emptyLHsBinds $
+ = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] $
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] emptyLHsBinds $
+ = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] $
untag_Expr tycon [(a_RDR, ah_RDR)] $
(nlHsVarApps intDataCon_RDR [ah_RDR])
\end{code}
enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
enum_range
- = mk_easy_FunBind tycon_loc range_RDR
- [nlTuplePat [a_Pat, b_Pat] Boxed] emptyLHsBinds $
+ = mk_easy_FunBind tycon_loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
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 unsafeIndex_RDR
[noLoc (AsPat (noLoc c_RDR)
(nlTuplePat [a_Pat, nlWildPat] Boxed)),
- d_Pat] emptyLHsBinds (
+ d_Pat] (
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(d_RDR, dh_RDR)] (
let
)
enum_inRange
- = mk_easy_FunBind tycon_loc inRange_RDR
- [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyLHsBinds (
+ = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(b_RDR, bh_RDR)] (
untag_Expr tycon [(c_RDR, ch_RDR)] (
(genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
) {-else-} (
false_Expr
- )))))
+ ))))
--------------------------------------------------------------
single_con_ixes
--------------------------------------------------------------
single_con_range
= mk_easy_FunBind tycon_loc range_RDR
- [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] emptyLHsBinds $
+ [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
nlHsDo ListComp stmts con_expr
where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
single_con_index
= mk_easy_FunBind tycon_loc unsafeIndex_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
- con_pat cs_needed] emptyBag
+ con_pat cs_needed]
(mk_index (zip3 as_needed bs_needed cs_needed))
where
-- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
single_con_inRange
= mk_easy_FunBind tycon_loc inRange_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
- con_pat cs_needed]
- emptyLHsBinds (
- foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
+ con_pat cs_needed] $
+ 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,
nlHsVar c]
_ -> [nlHsApp (nlHsVar choose_RDR)
(nlList (map mk_pair nullary_cons))]
- mk_pair con = nlTuple [nlHsLit (data_con_str con),
- nlHsApp (nlHsVar returnM_RDR) (nlHsVar (getRdrName con))]
- Boxed
+ mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
+ nlHsApp (nlHsVar returnM_RDR) (nlHsVar (getRdrName con))]
+ Boxed
read_non_nullary_con data_con
= nlHsApps prec_RDR [nlHsIntLit prec, nlHsDo DoExpr stmts body]
| otherwise = prefix_stmts
body = result_expr data_con as_needed
+ con_str = data_con_str data_con
prefix_stmts -- T a b c
- = [bindLex (ident_pat (data_con_str_w_parens data_con))]
+ = [bindLex (ident_pat (wrapOpParens con_str))]
++ read_args
- infix_stmts -- a %% b
- = [read_a1,
- bindLex (symbol_pat (data_con_str data_con)),
- read_a2]
+ infix_stmts -- a %% b, or a `T` b
+ = [read_a1]
+ ++ (if isSym con_str
+ then [bindLex (symbol_pat con_str)]
+ else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"])
+ ++ [read_a2]
lbl_stmts -- T { f1 = a, f2 = b }
- = [bindLex (ident_pat (data_con_str_w_parens data_con)),
+ = [bindLex (ident_pat (wrapOpParens con_str)),
read_punc "{"]
++ concat (intersperse [read_punc ","] field_stmts)
++ [read_punc "}"]
con_app c as = nlHsVarApps (getRdrName c) as
result_expr c as = nlHsApp (nlHsVar returnM_RDR) (con_app c as)
- punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
- ident_pat s = nlConPat ident_RDR [nlLitPat s] -- Ident "foo"
- symbol_pat s = nlConPat symbol_RDR [nlLitPat s] -- Symbol ">>"
+ 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 ">>"
- data_con_str con = mkHsString (occNameUserString (getOccName con))
- data_con_str_w_parens con = mkHsString (occNameUserString_with_parens (getOccName con))
+ data_con_str con = occNameString (getOccName con)
read_punc c = bindLex (punc_pat c)
read_arg a ty
-- _a = 3
-- or (#) = 4
-- Note the parens!
- read_lbl lbl | is_id_start (head lbl_str)
- = [bindLex (ident_pat lbl_lit)]
- | otherwise
+ read_lbl lbl | isSym lbl_str
= [read_punc "(",
- bindLex (symbol_pat lbl_lit),
+ bindLex (symbol_pat lbl_str),
read_punc ")"]
+ | otherwise
+ = [bindLex (ident_pat lbl_str)]
where
- lbl_str = occNameUserString (getOccName lbl)
- lbl_lit = mkHsString lbl_str
- is_id_start c = isAlpha c || c == '_'
+ lbl_str = occNameString (getOccName lbl)
\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
+ con_str = occNameString dc_occ_nm
+ op_con_str = wrapOpParens con_str
+ backquote_str = wrapOpBackquotes con_str
show_thingies
- | is_infix = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
+ | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
| record_syntax = mk_showString_app (op_con_str ++ " {") :
show_record_args ++ [mk_showString_app "}"]
| otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
-- it seems tidier to have them both sides.
where
occ_nm = getOccName l
- nm = occNameUserString_with_parens occ_nm
+ nm = wrapOpParens (occNameString occ_nm)
show_args = zipWith show_arg bs_needed arg_tys
(show_arg1:show_arg2:_) = show_args
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
+wrapOpParens :: String -> String
+wrapOpParens s | isSym s = '(' : s ++ ")"
+ | otherwise = s
+
+wrapOpBackquotes :: String -> String
+wrapOpBackquotes s | isSym s = s
+ | otherwise = '`' : s ++ "`"
+
+isSym :: String -> Bool
+isSym "" = False
+isSym (c:cs) = startsVarSym c || startsConSym c
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] emptyLHsBinds
+ [nlWildPat]
(nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
where
tycon_loc = getSrcSpan tycon
tycon_loc
dataTypeOf_RDR
[nlWildPat]
- emptyLHsBinds
(nlHsVar data_type_name)
------------ $dT
constr_args dc =
[ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
nlHsVar data_type_name, -- DataType
- nlHsLit (mkHsString (occNameUserString dc_occ)), -- String name
+ nlHsLit (mkHsString (occNameString dc_occ)), -- String name
nlList labels, -- Field labels
nlHsVar fixity] -- Fixity
where
= mkDerivedRdrName tc_name mk_occ
where
tc_name = tyConName tycon
- mk_occ tc_occ = mkOccFS varName (mkFastString new_str)
+ mk_occ tc_occ = mkVarOccFS (mkFastString new_str)
where
new_str = str ++ occNameString tc_occ ++ "#"
\end{code}
projects / ghc-hetmet.git / blobdiff