[commit: ghc] wip/T11970: tabs (ceea42f)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T11970
Link       : http://ghc.haskell.org/trac/ghc/changeset/ceea42f684a1382ba116948e672607f4ab2433da/ghc

>---------------------------------------------------------------

commit ceea42f684a1382ba116948e672607f4ab2433da
Author: Matthew Pickering <matthewtpickering at gmail.com>
Date:   Sat May 21 23:47:41 2016 +0100

    tabs


>---------------------------------------------------------------

ceea42f684a1382ba116948e672607f4ab2433da
 compiler/typecheck/TcRnDriver.hs                   | 62 ++++++++++------------
 .../overloadedrecflds/should_fail/NoParent.hs      |  3 --
 .../overloadedrecflds/should_fail/NoParent.stderr  |  6 +++
 3 files changed, 33 insertions(+), 38 deletions(-)

diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 9852eb2..d55b5d6 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -2347,9 +2347,9 @@ tc_export_with :: Name  -- ^ Type constructor
 tc_export_with n ns fls = do
   ty_con <- tcLookupTyCon n
   things <- mapM tcLookupGlobal ns
-  let data_cons = [("data constructor", c,  dataConTyCon c)
+  let data_cons = [(c,  dataConTyCon c)
                         | AConLike (RealDataCon c) <- things ]
-      ps  			= [(psErr p,p) | AConLike (PatSynCon p) <- things]
+      ps        = [(psErr p,p) | AConLike (PatSynCon p) <- things]
       ps_sels   = [(selErr i,p) | AnId i <- things
                         , isId i
                         , RecSelId {sel_tycon = RecSelPatSyn p} <- [idDetails i]]
@@ -2358,7 +2358,7 @@ tc_export_with n ns fls = do
           mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con))
 
   mapM_ (tc_one_dc_export_with ty_con) data_cons
-  mapM_ (tc_flds actual_res_ty ty_con)  (partitionFieldLabels fls)
+  mapM_ (tc_flds ty_con)  (partitionFieldLabels fls)
 
   let pat_syns = ps ++ ps_sels
 
@@ -2379,28 +2379,29 @@ tc_export_with n ns fls = do
         assemble [] = panic "partitionFieldLabels"
         assemble fls@(fl:_) = (flLabel fl, map flSelector fls)
 
-		-- This is only used for normal record field labels
-    tc_flds :: Type -> TyCon -> (FastString, [Name]) -> TcM ()
-    tc_flds actual_res_ty ty_con (fs, flds) = do
+    dcErrMsg :: Outputable a => TyCon -> String -> a -> [SDoc] -> SDoc
+    dcErrMsg ty_con what_is thing parents =
+            let capitalise [] = []
+                capitalise (c:cs) = toUpper c : cs
+            in
+              text "The type constructor" <+> quotes (ppr ty_con)
+                    <+> text "is not the parent of the" <+> text what_is
+                    <+> quotes (ppr thing) <> char '.'
+                    $$ text (capitalise what_is) <> text "s can only be exported with their parent type constructor."
+                    $$ (case parents of
+                          [] -> empty
+                          [_] -> text "Parent:"
+                          _  -> text "Parents:") <+> fsep (punctuate comma parents)
+
+    -- This is only used for normal record field labels
+    tc_flds :: TyCon -> (FastString, [Name]) -> TcM ()
+    tc_flds ty_con (fs, flds) = do
       fldIds <- mapM tcLookupId flds
       traceTc "tc_flds" (ppr fldIds)
-
-      case fldIds of
-        [] -> return ()
-        -- If there is just one, fall back to the original checks
-        [fldId] -> case idDetails fldId of
-                     RecSelId { sel_tycon = RecSelData  p } ->
-                      tc_one_dc_export_with ty_con ("record selector", fldId, p)
-                     _ -> panic "tc_flds"
-        fldIds ->
-          let parents = [tc | i <- fldIds, RecSelId { sel_tycon = RecSelData tc }
-                                            <- [idDetails i]] in
-          unless (any (ty_con ==) parents) $
-            let
-                errMsg = quotes (ppr fs) <+> text "is not a label"
-                         <+> text "the type constructor" <+> quotes (ppr ty_con) <> char '.'
-                         $$ text "Parents:" <+> fsep (punctuate comma (map ppr parents))
-            in addErrTc errMsg
+      let parents = [tc | i <- fldIds, RecSelId { sel_tycon = RecSelData tc }
+                                        <- [idDetails i]]
+      unless (any (ty_con ==) parents) $
+        addErrTc (dcErrMsg ty_con "record selector" fs (map ppr parents))
 
 
 
@@ -2410,19 +2411,10 @@ tc_export_with n ns fls = do
 
     -- Check whether a data constructor is exported with its parent.
     tc_one_dc_export_with :: Outputable a =>
-                              TyCon -> (String, a, TyCon) -> TcM ()
-    tc_one_dc_export_with ty_con (what_is, thing, tc) =
-      let capitalise [] = []
-          capitalise (c:cs) = toUpper c : cs
-          errMsg = text "The type constructor" <+> quotes (ppr ty_con)
-                    <+> text "is not the parent of the" <+> text what_is
-                    <+> quotes (ppr thing) <> char '.'
-                    $$ text (capitalise what_is) <> text "s can only be exported with their parent type constructor."
-                    $$ text "Parent:" <+> ppr tc
-      in
-
+                              TyCon -> (a, TyCon) -> TcM ()
+    tc_one_dc_export_with ty_con (thing, tc) =
       unless (ty_con == tc)
-        (addErrTc errMsg)
+        (addErrTc (dcErrMsg ty_con "data constructor" thing [ppr tc]))
 
 
 
diff --git a/testsuite/tests/overloadedrecflds/should_fail/NoParent.hs b/testsuite/tests/overloadedrecflds/should_fail/NoParent.hs
index f6d984d..2d05c47 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/NoParent.hs
+++ b/testsuite/tests/overloadedrecflds/should_fail/NoParent.hs
@@ -4,6 +4,3 @@ module NoParent (A(x)) where
 data A = A
 data B = B { x :: Int }
 data C = C { x :: String }
-
-
-
diff --git a/testsuite/tests/overloadedrecflds/should_fail/NoParent.stderr b/testsuite/tests/overloadedrecflds/should_fail/NoParent.stderr
new file mode 100644
index 0000000..cea2b76
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/NoParent.stderr
@@ -0,0 +1,6 @@
+
+NoParent.hs:2:18: error:
+    • The type constructor ‘A’ is not the parent of the record selector ‘x’.
+      Record selectors can only be exported with their parent type constructor.
+      Parents: C, B
+    • In the export: A(x, x)