+ loc = getSrcSpan tycon
+ data_cons = tyConDataCons tycon
+ (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons
+
+ read_prec = mkVarBind loc readPrec_RDR
+ (nlHsApp (nlHsVar parens_RDR) read_cons)
+
+ read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
+ read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
+
+ read_nullary_cons
+ = case nullary_cons of
+ [] -> []
+ [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con)),
+ result_stmt con []]]
+ _ -> [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
+
+ read_non_nullary_con data_con
+ = nlHsApps prec_RDR [nlHsIntLit prec, nlHsDo DoExpr stmts]
+ where
+ 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))]
+ ++ 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]]
+
+ 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
+ labels = dataConFieldLabels data_con
+ dc_nm = getName data_con
+ is_infix = isDataSymOcc (getOccName dc_nm)
+ 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))
+ con_app c as = nlHsVarApps (getRdrName 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 ">>"
+
+ data_con_str con = mkHsString (occNameUserString (getOccName con))
+
+ 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])
+
+ read_field lbl a = read_lbl lbl ++
+ [read_punc "=",
+ nlBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR])]
+
+ -- When reading field labels we might encounter
+ -- a = 3
+ -- _a = 3
+ -- or (#) = 4
+ -- Note the parens!
+ read_lbl lbl | is_id_start (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
+ is_id_start c = isAlpha c || c == '_'