[commit: ghc] master: Mark orphan instances and rules in --show-iface output (17b1e0b)
git at git.haskell.org
git at git.haskell.org
Sun Feb 12 01:08:41 UTC 2017
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'])
More information about the ghc-commits
mailing list