- 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 = dataConSourceArity 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 = isDataSymOcc (getOccName dc_nm)
-
- 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] Boxed)
- (HsApp (HsVar lex_RDR) c_Expr)
- tycon_loc
- | otherwise =
- BindStmt
- (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] Boxed)
- (HsApp (HsVar lex_RDR) (HsVar bs1))
- tycon_loc
-
-
- str_qual str res draw_from =
- BindStmt
- (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed)
- (HsApp (HsVar lex_RDR) draw_from)
- tycon_loc
-
- 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 "="]
- -- There might be spaces between the label and '='
- where
- 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
-
- 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
- d_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 d_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] Boxed)
- (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)] Boxed
-
- [lp,rp] = getLRPrecs is_infix fixity_env 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]
-
- {-
- c.f. Figure 18 in Haskell 1.1 report.
- -}
- paren_prec_limit
- | not is_infix = fromInt maxPrecedence
- | otherwise = getFixity fixity_env dc_nm
-
- read_paren_arg -- parens depend on precedence...
- | nullary_con = false_Expr -- it's optional.
- | otherwise = HsPar (genOpApp zz_a_Expr gt_RDR (HsLit (HsInt paren_prec_limit)))
+ stmts | is_infix = infix_stmts
+ | length labels > 0 = lbl_stmts
+ | otherwise = prefix_stmts
+
+ prefix_stmts -- T a b c
+ = [bindLex (ident_pat (data_con_str data_con))]
+ ++ map read_arg as_needed
+ ++ [result_stmt data_con as_needed]
+
+ infix_stmts -- a %% b
+ = [read_arg a1,
+ bindLex (symbol_pat (data_con_str data_con)),
+ read_arg a2,
+ result_stmt data_con [a1,a2]]
+
+ lbl_stmts -- T { f1 = a, f2 = b }
+ = [bindLex (ident_pat (data_con_str data_con)),
+ read_punc "{"]
+ ++ concat (intersperse [read_punc ","] field_stmts)
+ ++ [read_punc "}", result_stmt data_con as_needed]
+
+ field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
+
+ con_arity = dataConSourceArity data_con
+ nullary_con = con_arity == 0
+ labels = dataConFieldLabels data_con
+ lab_fields = length labels
+ dc_nm = getName data_con
+ is_infix = isDataSymOcc (getOccName dc_nm)
+ as_needed = take con_arity as_RDRs
+ (a1:a2:_) = as_needed
+ prec = getPrec is_infix get_fixity dc_nm
+
+ ------------------------------------------------------------------------
+ -- Helpers
+ ------------------------------------------------------------------------
+ mk_alt e1 e2 = genOpApp e1 alt_RDR e2
+ bindLex pat = BindStmt pat (HsVar lexP_RDR) loc
+ result_stmt c as = ResultStmt (HsApp (HsVar returnM_RDR) (con_app c as)) loc
+ con_app c as = mkHsVarApps (getRdrName c) as
+
+ punc_pat s = ConPatIn punc_RDR (PrefixCon [LitPat (mkHsString s)]) -- Punc 'c'
+ ident_pat s = ConPatIn ident_RDR (PrefixCon [LitPat s]) -- Ident "foo"
+ symbol_pat s = ConPatIn symbol_RDR (PrefixCon [LitPat s]) -- Symbol ">>"
+
+ data_con_str con = mkHsString (occNameUserString (getOccName con))
+
+ read_punc c = bindLex (punc_pat c)
+ read_arg a = BindStmt (VarPat a) (mkHsVarApps step_RDR [readPrec_RDR]) loc
+
+ read_field lbl a = read_lbl lbl ++
+ [read_punc "=",
+ BindStmt (VarPat a) (mkHsVarApps reset_RDR [readPrec_RDR]) loc]
+
+ -- When reading field labels we might encounter
+ -- a = 3
+ -- or (#) = 4
+ -- Note the parens!
+ read_lbl lbl | isAlpha (head lbl_str)
+ = [bindLex (ident_pat lbl_lit)]
+ | otherwise
+ = [read_punc "(",
+ bindLex (symbol_pat lbl_lit),
+ read_punc ")"]
+ where
+ lbl_str = occNameUserString (getOccName (fieldLabelName lbl))
+ lbl_lit = mkHsString lbl_str