diff options
| -rw-r--r-- | compiler/iface/IfaceSyn.hs | 22 | ||||
| -rw-r--r-- | testsuite/tests/showIface/Makefile | 7 | ||||
| -rw-r--r-- | testsuite/tests/showIface/Orphans.hs | 26 | ||||
| -rw-r--r-- | testsuite/tests/showIface/Orphans.stdout | 6 | ||||
| -rw-r--r-- | 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 9a69b39b65..646987873f 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 0000000000..49b90342b3 --- /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 0000000000..f3b7b6adec --- /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 0000000000..d61a5c98f3 --- /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 0000000000..5c89b70b59 --- /dev/null +++ b/testsuite/tests/showIface/all.T @@ -0,0 +1 @@ +test('Orphans', normal, run_command, ['$MAKE -s --no-print-directory Orphans']) |