[commit: ghc] master: Mark orphan instances and rules in --show-iface output (17b1e0b)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/17b1e0bae7c0d7b4d3f8e1847e919c0e882e55c6/ghc

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

commit 17b1e0bae7c0d7b4d3f8e1847e919c0e882e55c6
Author: Reid Barton <rwbarton at gmail.com>
Date:   Sat Feb 11 19:20:08 2017 -0500

    Mark orphan instances and rules in --show-iface output
    
    Test Plan: new test Orphans
    
    Reviewers: austin, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D3086


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

17b1e0bae7c0d7b4d3f8e1847e919c0e882e55c6
 compiler/iface/IfaceSyn.hs               | 22 ++++++++++++++--------
 testsuite/tests/showIface/Makefile       |  7 +++++++
 testsuite/tests/showIface/Orphans.hs     | 26 ++++++++++++++++++++++++++
 testsuite/tests/showIface/Orphans.stdout |  6 ++++++
 testsuite/tests/showIface/all.T          |  1 +
 5 files changed, 54 insertions(+), 8 deletions(-)

diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
index 9a69b39..6469878 100644
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -43,7 +43,7 @@ module IfaceSyn (
 
 import IfaceType
 import BinFingerprint
-import CoreSyn( IsOrphan )
+import CoreSyn( IsOrphan, isOrphan )
 import PprCore()            -- Printing DFunArgs
 import Demand
 import Class
@@ -1029,8 +1029,11 @@ pprIfaceConDecl ss gadt_style fls tycon tc_binders parent
 
 instance Outputable IfaceRule where
   ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
-                   ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
-    = sep [hsep [pprRuleName name, ppr act,
+                   ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
+                   ifRuleOrph = orph })
+    = sep [hsep [pprRuleName name,
+                 if isOrphan orph then text "[orphan]" else Outputable.empty,
+                 ppr act,
                  text "forall" <+> pprIfaceBndrs bndrs],
            nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),
                         text "=" <+> ppr rhs])
@@ -1038,16 +1041,19 @@ instance Outputable IfaceRule where
 
 instance Outputable IfaceClsInst where
   ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag
-                    , ifInstCls = cls, ifInstTys = mb_tcs})
+                    , ifInstCls = cls, ifInstTys = mb_tcs
+                    , ifInstOrph = orph })
     = hang (text "instance" <+> ppr flag
-                <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
+              <+> (if isOrphan orph then text "[orphan]" else Outputable.empty)
+              <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
          2 (equals <+> ppr dfun_id)
 
 instance Outputable IfaceFamInst where
   ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
-                    , ifFamInstAxiom = tycon_ax})
-    = hang (text "family instance" <+>
-            ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs)
+                    , ifFamInstAxiom = tycon_ax, ifFamInstOrph = orph })
+    = hang (text "family instance"
+              <+> (if isOrphan orph then text "[orphan]" else Outputable.empty)
+              <+> ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs)
          2 (equals <+> ppr tycon_ax)
 
 ppr_rough :: Maybe IfaceTyCon -> SDoc
diff --git a/testsuite/tests/showIface/Makefile b/testsuite/tests/showIface/Makefile
new file mode 100644
index 0000000..49b9034
--- /dev/null
+++ b/testsuite/tests/showIface/Makefile
@@ -0,0 +1,7 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+Orphans:
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c Orphans.hs
+	'$(TEST_HC)' $(TEST_HC_OPTS) --show-iface Orphans.hi | grep -E '^(instance |family instance |"myrule)' | grep -v 'family instance modules:'
diff --git a/testsuite/tests/showIface/Orphans.hs b/testsuite/tests/showIface/Orphans.hs
new file mode 100644
index 0000000..f3b7b6a
--- /dev/null
+++ b/testsuite/tests/showIface/Orphans.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -O -Wno-inline-rule-shadowing #-}
+-- Rules are ignored without -O
+
+module Orphans where
+
+import GHC.Exts (IsList(..))
+
+-- Some orphan things
+instance IsList Bool where
+  type Item Bool = Double
+  fromList = undefined
+  toList = undefined
+
+{-# RULES "myrule1" id id = id #-}
+
+-- And some non-orphan things
+data X = X [Int]
+instance IsList X where
+  type Item X = Int
+  fromList = undefined
+  toList = undefined
+
+f :: X -> X
+f x = x
+{-# RULES "myrule2" id f = f #-}
diff --git a/testsuite/tests/showIface/Orphans.stdout b/testsuite/tests/showIface/Orphans.stdout
new file mode 100644
index 0000000..d61a5c9
--- /dev/null
+++ b/testsuite/tests/showIface/Orphans.stdout
@@ -0,0 +1,6 @@
+instance [orphan] IsList [Bool] = $fIsListBool
+instance IsList [X] = $fIsListX
+family instance Item [X] = D:R:ItemX
+family instance [orphan] Item [Bool] = D:R:ItemBool
+"myrule1" [orphan] forall @ a id @ (a -> a) (id @ a) = id @ a
+"myrule2" forall id @ (X -> X) f = f
diff --git a/testsuite/tests/showIface/all.T b/testsuite/tests/showIface/all.T
new file mode 100644
index 0000000..5c89b70
--- /dev/null
+++ b/testsuite/tests/showIface/all.T
@@ -0,0 +1 @@
+test('Orphans', normal, run_command, ['$MAKE -s --no-print-directory Orphans'])