Mark orphan instances and rules in --show-iface output
authorReid Barton <rwbarton@gmail.com>
Sun, 12 Feb 2017 00:20:08 +0000 (19:20 -0500)
committerBen Gamari <ben@smart-cactus.org>
Sun, 12 Feb 2017 00:20:16 +0000 (19:20 -0500)
Test Plan: new test Orphans

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D3086

compiler/iface/IfaceSyn.hs
testsuite/tests/showIface/Makefile [new file with mode: 0644]
testsuite/tests/showIface/Orphans.hs [new file with mode: 0644]
testsuite/tests/showIface/Orphans.stdout [new file with mode: 0644]
testsuite/tests/showIface/all.T [new file with mode: 0644]

index 9a69b39..6469878 100644 (file)
@@ -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 (file)
index 0000000..49b9034
--- /dev/null
@@ -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 (file)
index 0000000..f3b7b6a
--- /dev/null
@@ -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 (file)
index 0000000..d61a5c9
--- /dev/null
@@ -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 (file)
index 0000000..5c89b70
--- /dev/null
@@ -0,0 +1 @@
+test('Orphans', normal, run_command, ['$MAKE -s --no-print-directory Orphans'])