From ddf73bf71eeaf80bf41ea4054d161dda839b2573 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Mon, 4 Sep 2006 13:22:12 +0000 Subject: [PATCH] Refactoring for derived Read There are no functional changes in this commit. But the code for derived Read is refactored to make it tidier --- and also to make it very easy if we want derived Read to parse the prefix form of infix ocnstructors. For example, data T = Int `T1` Int According to the H98 report, the derived Read instance will parse infix uses of T1, but not prefix uses (T1 4 3). It's arguable that it should parse both -- and easy to implement, but it would cause a little bit of code bloat. Similarly records. Anyway this commit doesn't implement the change; just makes it easy to do so. --- compiler/typecheck/TcGenDeriv.lhs | 48 ++++++++++++++++++++++--------------- 1 file changed, 29 insertions(+), 19 deletions(-) diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index ec17e69..4291c4b 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -354,6 +354,8 @@ gen_Ord_binds tycon = let eq_expr = nested_compare_expr tys as bs in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b) + nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length + default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about -- inexhaustive patterns | otherwise = eqTag_Expr -- Some nullary constructors; @@ -755,24 +757,29 @@ gen_Read_binds get_fixity tycon [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))] (result_expr con [])] _ -> [nlHsApp (nlHsVar choose_RDR) - (nlList (map mk_pair nullary_cons))] + (nlList (map mk_pair nullary_cons))] - mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)), - nlHsApp (nlHsVar returnM_RDR) (nlHsVar (getRdrName con))] - Boxed + mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)), + result_expr con []] + Boxed read_non_nullary_con data_con - = nlHsApps prec_RDR [nlHsIntLit prec, nlHsDo DoExpr stmts body] + | is_infix = mk_parser infix_prec infix_stmts body + | is_record = mk_parser record_prec record_stmts body +-- Using these two lines instead allows the derived +-- read for infix and record bindings to read the prefix form +-- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body) +-- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body) + | otherwise = prefix_parser where - stmts | is_infix = infix_stmts - | is_record = lbl_stmts - | otherwise = prefix_stmts - body = result_expr data_con as_needed con_str = data_con_str data_con + prefix_parser = mk_parser prefix_prec prefix_stmts body prefix_stmts -- T a b c - = [bindLex (ident_pat (wrapOpParens con_str))] + = (if not (isSym con_str) then + [bindLex (ident_pat con_str)] + else [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"]) ++ read_args infix_stmts -- a %% b, or a `T` b @@ -782,7 +789,7 @@ gen_Read_binds get_fixity tycon else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]) ++ [read_a2] - lbl_stmts -- T { f1 = a, f2 = b } + record_stmts -- T { f1 = a, f2 = b } = [bindLex (ident_pat (wrapOpParens con_str)), read_punc "{"] ++ concat (intersperse [read_punc ","] field_stmts) @@ -798,18 +805,20 @@ gen_Read_binds get_fixity tycon 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 - prec | is_infix = getPrecedence get_fixity dc_nm - | is_record = appPrecedence + 1 -- Record construction binds even more tightly - -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2}) - | otherwise = appPrecedence + + prefix_prec = appPrecedence + infix_prec = getPrecedence get_fixity dc_nm + record_prec = appPrecedence + 1 -- Record construction binds even more tightly + -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2}) ------------------------------------------------------------------------ -- Helpers ------------------------------------------------------------------------ - mk_alt e1 e2 = genOpApp e1 alt_RDR e2 - 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) + mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 + mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b }) + bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP + con_app con as = nlHsVarApps (getRdrName con) as -- con as + result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c' ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo" @@ -1376,6 +1385,7 @@ showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName +nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty nested_compose_Expr [e] = parenify e nested_compose_Expr (e:es) = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es) -- 1.7.10.4