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, dataConIsInfix,
dataConFieldLabels )
(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] (
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
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] $
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] $
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] $
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] $
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] $
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] $
untag_Expr tycon [(a_RDR, ah_RDR)] $
(nlHsVarApps intDataCon_RDR [ah_RDR])
\end{code}
map tag2con_Foo (enumFromTo (I# a#) (I# b#))
}}
- index c@(a, b) d
- = if inRange c d
- then case (con2tag_Foo d -# con2tag_Foo a) of
+ -- Generate code for unsafeIndex, becuase using index leads
+ -- to lots of redundant range tests
+ unsafeIndex c@(a, b) d
+ = case (con2tag_Foo d -# con2tag_Foo a) of
r# -> I# r#
- else error "Ix.Foo.index: out of range"
inRange (a, b) c
= let
then enum_ixes
else single_con_ixes
where
- tycon_str = getOccString tycon
tycon_loc = getSrcSpan tycon
--------------------------------------------------------------
enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
enum_range
- = mk_easy_FunBind tycon_loc range_RDR
- [nlTuplePat [a_Pat, b_Pat] Boxed] emptyBag $
+ = 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]) $
(nlHsVarApps intDataCon_RDR [bh_RDR]))
enum_index
- = mk_easy_FunBind tycon_loc index_RDR
+ = mk_easy_FunBind tycon_loc unsafeIndex_RDR
[noLoc (AsPat (noLoc c_RDR)
(nlTuplePat [a_Pat, nlWildPat] Boxed)),
- d_Pat] emptyBag (
- nlHsIf (nlHsPar (nlHsVarApps inRange_RDR [c_RDR, d_RDR])) (
+ d_Pat] (
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(d_RDR, dh_RDR)] (
let
(genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
[mkSimpleHsAlt (nlVarPat c_RDR) rhs]
))
- ) {-else-} (
- nlHsApp (nlHsVar error_RDR) (nlHsLit (HsString (mkFastString ("Ix."++tycon_str++".index: out of range\n"))))
- ))
+ )
enum_inRange
- = mk_easy_FunBind tycon_loc inRange_RDR
- [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyBag (
+ = 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] emptyBag $
- nlHsDo ListComp stmts
+ [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
- ++
- [nlResultStmt con_expr]
- mk_qual a b c = nlBindStmt (nlVarPat c)
+ mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
(nlHsApp (nlHsVar range_RDR)
(nlTuple [nlHsVar a, nlHsVar b] Boxed))
----------------
single_con_index
- = mk_easy_FunBind tycon_loc index_RDR
+ = mk_easy_FunBind tycon_loc unsafeIndex_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
- con_pat cs_needed] (unitBag range_size) (
- foldl mk_index (nlHsIntLit 0) (zip3 as_needed bs_needed cs_needed))
+ con_pat cs_needed]
+ (mk_index (zip3 as_needed bs_needed cs_needed))
where
- mk_index multiply_by (l, u, i)
+ -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
+ mk_index [] = nlHsIntLit 0
+ mk_index [(l,u,i)] = mk_one l u i
+ mk_index ((l,u,i) : rest)
= genOpApp (
- (nlHsApps index_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed,
- nlHsVar i])
- ) plus_RDR (
+ mk_one l u i
+ ) plus_RDR (
genOpApp (
- (nlHsApp (nlHsVar rangeSize_RDR)
+ (nlHsApp (nlHsVar unsafeRangeSize_RDR)
(nlTuple [nlHsVar l, nlHsVar u] Boxed))
- ) times_RDR multiply_by
+ ) times_RDR (mk_index rest)
)
-
- range_size
- = mk_easy_FunBind tycon_loc rangeSize_RDR
- [nlTuplePat [a_Pat, b_Pat] Boxed] emptyBag (
- genOpApp (
- (nlHsApps index_RDR [nlTuple [a_Expr, b_Expr] Boxed,
- b_Expr])
- ) plus_RDR (nlHsIntLit 1))
+ mk_one l u i
+ = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
------------------
single_con_inRange
= mk_easy_FunBind tycon_loc inRange_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
- con_pat cs_needed]
- emptyBag (
- 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]
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)
read_nullary_cons
= case nullary_cons of
[] -> []
- [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con)),
- result_stmt con []]]
+ [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
+ (result_expr con [])]
_ -> [nlHsApp (nlHsVar choose_RDR)
(nlList (map mk_pair nullary_cons))]
Boxed
read_non_nullary_con data_con
- = nlHsApps prec_RDR [nlHsIntLit prec, nlHsDo DoExpr stmts]
+ = nlHsApps prec_RDR [nlHsIntLit prec, nlHsDo DoExpr stmts body]
where
stmts | is_infix = infix_stmts
| length labels > 0 = lbl_stmts
| otherwise = prefix_stmts
+ body = result_expr data_con as_needed
+
prefix_stmts -- T a b c
= [bindLex (ident_pat (data_con_str_w_parens data_con))]
++ read_args
- ++ [result_stmt data_con as_needed]
infix_stmts -- a %% b
= [read_a1,
bindLex (symbol_pat (data_con_str data_con)),
- read_a2,
- result_stmt data_con [a1,a2]]
+ read_a2]
lbl_stmts -- T { f1 = a, f2 = b }
= [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]
+ ++ [read_punc "}"]
field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
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
- (a1:a2:_) = as_needed
prec = getPrec is_infix get_fixity dc_nm
------------------------------------------------------------------------
-- Helpers
------------------------------------------------------------------------
mk_alt e1 e2 = genOpApp e1 alt_RDR e2
- bindLex pat = nlBindStmt pat (nlHsVar lexP_RDR)
- result_stmt c as = nlResultStmt (nlHsApp (nlHsVar returnM_RDR) (con_app c as))
+ bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))
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"
read_punc c = bindLex (punc_pat c)
read_arg a ty
| isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
- | otherwise = nlBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])
+ | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
read_field lbl a = read_lbl lbl ++
[read_punc "=",
- nlBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR])]
+ noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
-- When reading field labels we might encounter
-- a = 3
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}
-- lexeme. Only the space after the '=' is necessary, but
-- it seems tidier to have them both sides.
where
- occ_nm = getOccName (fieldLabelName l)
+ occ_nm = getOccName l
nm = occNameUserString_with_parens occ_nm
show_args = zipWith show_arg bs_needed arg_tys
= unitBag $
mk_easy_FunBind tycon_loc
(mk_typeOf_RDR tycon) -- Name of appropriate type0f function
- [nlWildPat] emptyBag
+ [nlWildPat]
(nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
where
tycon_loc = getSrcSpan tycon
mk_typeOf_RDR :: TyCon -> RdrName
-- Use the arity of the TyCon to make the right typeOfn function
-mk_typeOf_RDR tycon = varQual_RDR tYPEABLE_Name (mkFastString ("typeOf" ++ suffix))
+mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
where
arity = tyConArity tycon
suffix | arity == 0 = ""
tycon_loc
dataTypeOf_RDR
[nlWildPat]
- emptyBag
(nlHsVar data_type_name)
- ------------ $dT
+ ------------ $dT
data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
datatype_bind = mkVarBind
constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
- ------------ $cT1 etc
+ ------------ $cT1 etc
mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
mk_con_bind dc = mkVarBind
tycon_loc
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
fixity | is_infix = infix_RDR
| otherwise = prefix_RDR
-gfoldl_RDR = varQual_RDR gENERICS_Name FSLIT("gfoldl")
-gunfold_RDR = varQual_RDR gENERICS_Name FSLIT("gunfold")
-toConstr_RDR = varQual_RDR gENERICS_Name FSLIT("toConstr")
-dataTypeOf_RDR = varQual_RDR gENERICS_Name FSLIT("dataTypeOf")
-mkConstr_RDR = varQual_RDR gENERICS_Name FSLIT("mkConstr")
-mkDataType_RDR = varQual_RDR gENERICS_Name FSLIT("mkDataType")
-conIndex_RDR = varQual_RDR gENERICS_Name FSLIT("constrIndex")
-prefix_RDR = dataQual_RDR gENERICS_Name FSLIT("Prefix")
-infix_RDR = dataQual_RDR gENERICS_Name FSLIT("Infix")
+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")
+mkConstr_RDR = varQual_RDR gENERICS FSLIT("mkConstr")
+mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType")
+conIndex_RDR = varQual_RDR gENERICS FSLIT("constrIndex")
+prefix_RDR = dataQual_RDR gENERICS FSLIT("Prefix")
+infix_RDR = dataQual_RDR gENERICS FSLIT("Infix")
\end{code}
%************************************************************************
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}
ch_RDR = mkVarUnqual FSLIT("c#")
dh_RDR = mkVarUnqual FSLIT("d#")
cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq")
-rangeSize_RDR = mkVarUnqual FSLIT("rangeSize")
as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]