- reads_prec
- = let
- read_con_comprehensions
- = map read_con (tyConDataCons tycon)
- in
- mk_easy_FunMonoBind tycon_loc readsPrec_RDR [a_Pat, b_Pat] [] (
- foldr1 append_Expr read_con_comprehensions
- )
- where
- read_con data_con -- note: "b" is the string being "read"
- = HsApp (
- readParen_Expr read_paren_arg $ HsPar $
- HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
- HsDo ListComp stmts tycon_loc)
- ) (HsVar b_RDR)
- where
- data_con_RDR = qual_orig_name data_con
- data_con_str = occNameUserString (getOccName data_con)
- con_arity = argFieldCount 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
- is_infix = isInfixOccName data_con_str
-
- as_needed = take con_arity as_RDRs
- bs_needed
- | is_infix = take (1 + con_arity) bs_RDRs
- | lab_fields == 0 = take con_arity bs_RDRs
- | otherwise = take (4*lab_fields + 1) bs_RDRs
- -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
-
- (as1:as2:_) = as_needed
- (bs1:bs2:bs3:_) = bs_needed
-
- con_qual
- | not is_infix =
- BindStmt
- (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] True)
- (HsApp (HsVar lex_RDR) c_Expr)
- tycon_loc
- | otherwise =
- BindStmt
- (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] True)
- (HsApp (HsVar lex_RDR) (HsVar bs1))
- tycon_loc
-
-
- str_qual str res draw_from =
- BindStmt
- (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] True)
- (HsApp (HsVar lex_RDR) draw_from)
- tycon_loc
-
- read_label f = [str_qual nm, str_qual "="]
- -- There might be spaces between the label and '='
- where
- nm = occNameUserString (getOccName (fieldLabelName f))
-
- field_quals
- | is_infix =
- snd (mapAccumL mk_qual_infix
- c_Expr
- [ (mk_read_qual lp as1, bs1, bs2)
- , (mk_read_qual rp as2, bs3, bs3)
- ])
- | lab_fields == 0 = -- common case.
- snd (mapAccumL mk_qual
- c_Expr
- (zipWithEqual "as_needed"
- (\ con_field draw_from -> (mk_read_qual 10 con_field,
- draw_from))
- as_needed bs_needed))
- | otherwise =
- snd $
- mapAccumL mk_qual c_Expr
- (zipEqual "bs_needed"
- ((str_qual "{":
- concat (
- intersperse [str_qual ","] $
- zipWithEqual
- "field_quals"
- (\ as b -> as ++ [b])
- -- The labels
- (map read_label labels)
- -- The fields
- (map (mk_read_qual 10) as_needed))) ++ [str_qual "}"])
- bs_needed)
-
- mk_qual_infix draw_from (f, str_left, str_left2) =
- (HsVar str_left2, -- what to draw from down the line...
- f str_left draw_from)
-
- mk_qual draw_from (f, str_left) =
- (HsVar str_left, -- what to draw from down the line...
- f str_left draw_from)
-
- mk_read_qual p con_field res draw_from =
- BindStmt
- (TuplePatIn [VarPatIn con_field, VarPatIn res] True)
- (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt p))) draw_from)
- tycon_loc
-
- result_expr = ExplicitTuple [con_expr, if null bs_needed
- then d_Expr
- else HsVar (last bs_needed)] True
-
- [lp,rp] = getLRPrecs fixities dc_nm
-
- quals
- | is_infix = let (h:t) = field_quals in (h:con_qual:t)
- | otherwise = con_qual:field_quals
-
- stmts = quals ++ [ReturnStmt result_expr]
-
- paren_prec_limit
- | not is_infix = 9
- | otherwise = getFixity fixities dc_nm
-
- read_paren_arg = -- parens depend on precedence...
- HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt paren_prec_limit)))