From dbd81f7e86514498218572b9d978373b1699cc5b Mon Sep 17 00:00:00 2001
From: Tobias Dammers <tdammers@gmail.com>
Date: Wed, 25 Oct 2017 19:09:03 -0400
Subject: Factor out readField (#14364)

Improves compiler performance of deriving Read instances, as suggested
in the issue.

Additionally, we introduce `readSymField`, a companion to `readField`
that parses symbol-type fields (where the field name is a symbol, e.g.
`(#)`, rather than an alphanumeric identifier. The decision between
these two functions is made a compile time, because we already know
which one we need based on the field name.

Reviewers: austin, hvr, bgamari, RyanGlScott

Reviewed By: bgamari

Subscribers: RyanGlScott, rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D4108
---
 compiler/typecheck/TcGenDeriv.hs | 41 ++++++++++++++++++++++------------------
 1 file changed, 23 insertions(+), 18 deletions(-)

(limited to 'compiler/typecheck')

diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 9e27ad5ca1..70ceb30305 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -900,9 +900,7 @@ instance Read T where
         -- Record construction binds even more tightly than application
         do expectP (Ident "T1")
            expectP (Punc '{')
-           expectP (Ident "f1")
-           expectP (Punc '=')
-           x          <- ReadP.reset Read.readPrec
+           x          <- Read.readField "f1" (ReadP.reset readPrec)
            expectP (Punc '}')
            return (T1 { f1 = x }))
       +++
@@ -1068,21 +1066,28 @@ gen_Read_binds get_fixity loc tycon
     read_arg a ty = ASSERT( not (isUnliftedType ty) )
                     noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
 
-    read_field lbl a = read_lbl lbl ++
-                       [read_punc "=",
-                        noLoc (mkBindStmt (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 | isSym lbl_str
-                 = [read_punc "(", symbol_pat lbl_str, read_punc ")"]
-                 | otherwise
-                 = ident_h_pat lbl_str
-                 where
-                   lbl_str = unpackFS lbl
+    -- When reading field labels we might encounter
+    --      a  = 3
+    --      _a = 3
+    -- or   (#) = 4
+    -- Note the parens!
+    read_field lbl a =
+        [noLoc
+          (mkBindStmt
+            (nlVarPat a)
+            (nlHsApps
+              read_field
+              [ nlHsLit (mkHsString lbl_str)
+              , nlHsVarApps reset_RDR [readPrec_RDR]
+              ]
+            )
+          )
+        ]
+        where
+          lbl_str = unpackFS lbl
+          read_field
+              | isSym lbl_str = readSymField_RDR
+              | otherwise = readField_RDR
 
 {-
 ************************************************************************
-- 
cgit v1.2.1