import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..),
Match(..), GRHSs(..), Stmt(..), HsLit(..),
HsBinds(..), StmtCtxt(..), HsType(..),
import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..),
Match(..), GRHSs(..), Stmt(..), HsLit(..),
HsBinds(..), StmtCtxt(..), HsType(..),
-import RdrHsSyn ( mkOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
+import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
-import RnMonad ( Fixities )
-import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) )
+import RnMonad ( FixityEnv, lookupFixity )
+import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..)
+ , maxPrecedence
+ , Boxity(..)
+ )
import FieldLabel ( fieldLabelName )
import DataCon ( isNullaryDataCon, dataConTag,
import FieldLabel ( fieldLabelName )
import DataCon ( isNullaryDataCon, dataConTag,
dataConFieldLabels )
import Name ( getOccString, getOccName, getSrcLoc, occNameString,
occNameUserString, nameRdrName, varName,
dataConFieldLabels )
import Name ( getOccString, getOccName, getSrcLoc, occNameString,
occNameUserString, nameRdrName, varName,
import PrelInfo -- Lots of RdrNames
import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
import PrelInfo -- Lots of RdrNames
import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
import Util ( mapAccumL, zipEqual, zipWithEqual,
zipWith3Equal, nOfThem )
import Panic ( panic, assertPanic )
import Util ( mapAccumL, zipEqual, zipWithEqual,
zipWith3Equal, nOfThem )
import Panic ( panic, assertPanic )
con_arity = length tys_needed
as_needed = take con_arity as_RDRs
bs_needed = take con_arity bs_RDRs
con_arity = length tys_needed
as_needed = take con_arity as_RDRs
bs_needed = take con_arity bs_RDRs
con_arity = length tys_needed
as_needed = take con_arity as_RDRs
bs_needed = take con_arity bs_RDRs
con_arity = length tys_needed
as_needed = take con_arity as_RDRs
bs_needed = take con_arity bs_RDRs
nested_compare_expr [ty] [a] [b]
= careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
nested_compare_expr [ty] [a] [b]
= careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
untag_Expr tycon [(a_RDR, ah_RDR)] $
untag_Expr tycon [(b_RDR, bh_RDR)] $
HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
untag_Expr tycon [(a_RDR, ah_RDR)] $
untag_Expr tycon [(b_RDR, bh_RDR)] $
HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
d_Pat] [] (
HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
untag_Expr tycon [(a_RDR, ah_RDR)] (
d_Pat] [] (
HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(b_RDR, bh_RDR)] (
untag_Expr tycon [(c_RDR, ch_RDR)] (
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_FunMonoBind tycon_loc range_RDR
--------------------------------------------------------------
single_con_range
= mk_easy_FunMonoBind tycon_loc range_RDR
HsDo ListComp stmts tycon_loc
where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
HsDo ListComp stmts tycon_loc
where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
con_pat cs_needed] [range_size] (
foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
where
mk_index multiply_by (l, u, i)
= genOpApp (
(HsApp (HsApp (HsVar index_RDR)
con_pat cs_needed] [range_size] (
foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
where
mk_index multiply_by (l, u, i)
= genOpApp (
(HsApp (HsApp (HsVar index_RDR)
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 = HsApp (HsApp (HsVar inRange_RDR)
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 = HsApp (HsApp (HsVar inRange_RDR)
con_expr = mk_easy_App data_con_RDR as_needed
nullary_con = con_arity == 0
labels = dataConFieldLabels data_con
lab_fields = length labels
dc_nm = getName data_con
con_expr = mk_easy_App data_con_RDR as_needed
nullary_con = con_arity == 0
labels = dataConFieldLabels data_con
lab_fields = length labels
dc_nm = getName data_con
- read_label f = [str_qual nm, str_qual "="]
+ str_qual_paren str res draw_from =
+ BindStmt
+ (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed)
+ (HsApp (readParen_Expr true_Expr (HsVar lex_RDR)) draw_from)
+ tycon_loc
+
+ read_label f = [rd_lab, str_qual "="]
- nm = occNameUserString (getOccName (fieldLabelName f))
+ rd_lab
+ | is_op = str_qual_paren nm
+ | otherwise = str_qual nm
+
+ occ_nm = getOccName (fieldLabelName f)
+ is_op = isSymOcc occ_nm
+ nm = occNameUserString occ_nm
(HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt p))) draw_from)
tycon_loc
result_expr = ExplicitTuple [con_expr, if null bs_needed
then d_Expr
(HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt p))) draw_from)
tycon_loc
result_expr = ExplicitTuple [con_expr, if null bs_needed
then d_Expr
bs_needed = take con_arity bs_RDRs
con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
nullary_con = con_arity == 0
labels = dataConFieldLabels data_con
lab_fields = length labels
bs_needed = take con_arity bs_RDRs
con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
nullary_con = con_arity == 0
labels = dataConFieldLabels data_con
lab_fields = length labels
- dc_occ_nm = occNameUserString (getOccName data_con)
- dc_nm = getName data_con
+ dc_nm = getName data_con
+ dc_occ_nm = getOccName data_con
+ dc_occ_nm_str = occNameUserString dc_occ_nm
- nm = occNameUserString (getOccName (fieldLabelName l))
+ occ_nm = getOccName (fieldLabelName l)
+ -- legal, but rare.
+ is_op = isSymOcc occ_nm
+ the_name
+ | is_op = '(':nm ++ ")"
+ | otherwise = nm
+
+ nm = occNameUserString occ_nm
-getLRPrecs :: Fixities -> Name -> [Integer]
-getLRPrecs fixs_assoc nm = [lp, rp]
+getLRPrecs :: Bool -> FixityEnv -> Name -> [Integer]
+getLRPrecs is_infix fixity_env nm = [lp, rp]
- ( con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc nm
- paren_prec_limit = 9
+ {-
+ Figuring out the fixities of the arguments to a constructor,
+ cf. Figures 16-18 in Haskell 1.1 report.
+ -}
+ (con_left_assoc, con_right_assoc) = isLRAssoc fixity_env nm
+ paren_con_prec = getFixity fixity_env nm
+ maxPrec = fromInt maxPrecedence
- | con_left_assoc = paren_prec_limit
- | otherwise = paren_prec_limit + 1
+ | not is_infix = maxPrec + 1
+ | con_left_assoc = paren_con_prec
+ | otherwise = paren_con_prec + 1
- | con_right_assoc = paren_prec_limit
- | otherwise = paren_prec_limit + 1
+ | not is_infix = maxPrec + 1
+ | con_right_assoc = paren_con_prec
+ | otherwise = paren_con_prec + 1
-getFixity :: Fixities -> Name -> Integer
-getFixity fixs_assoc nm =
- case assocMaybe fixs_assoc nm of
- Nothing -> 9
- Just (Fixity x _) -> fromInt x + 1
-
-isLRAssoc :: Fixities -> Name -> (Bool, Bool)
+isLRAssoc :: FixityEnv -> Name -> (Bool, Bool)
- case assocMaybe fixs_assoc nm of
- Just (Fixity _ InfixL) -> (True, False)
- Just (Fixity _ InfixR) -> (False, True)
- _ -> (False, False)
+ case lookupFixity fixs_assoc nm of
+ Fixity _ InfixN -> (False, False)
+ Fixity _ InfixR -> (False, True)
+ Fixity _ InfixL -> (True, False)
var_RDR = qual_orig_name var
gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
= mk_FunMonoBind (getSrcLoc tycon) rdr_name
[([ConPatIn mkInt_RDR [VarPatIn a_RDR]],
ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
var_RDR = qual_orig_name var
gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
= mk_FunMonoBind (getSrcLoc tycon) rdr_name
[([ConPatIn mkInt_RDR [VarPatIn a_RDR]],
ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
= mk_easy_FunMonoBind (getSrcLoc tycon)
gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
= mk_easy_FunMonoBind (getSrcLoc tycon)
= FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
mk_easy_Match loc pats binds expr
= FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
mk_easy_Match loc pats binds expr
-- The renamer expects everything in its input to be a
-- "recursive" MonoBinds, and it is its job to sort things out
-- from there.
-- The renamer expects everything in its input to be a
-- "recursive" MonoBinds, and it is its job to sort things out
-- from there.
untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
untag_Expr tycon [] expr = expr
untag_Expr tycon ((untag_this, put_tag_here) : more) expr
untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
untag_Expr tycon [] expr = expr
untag_Expr tycon ((untag_this, put_tag_here) : more) expr
-- For some reason the renamer doesn't reassociate it right, and I can't
-- be bothered to find out why just now.
-- For some reason the renamer doesn't reassociate it right, and I can't
-- be bothered to find out why just now.
a_RDR = varUnqual SLIT("a")
b_RDR = varUnqual SLIT("b")
c_RDR = varUnqual SLIT("c")
a_RDR = varUnqual SLIT("a")
b_RDR = varUnqual SLIT("b")
c_RDR = varUnqual SLIT("c")