Commit 17b1e0ba authored by rwbarton's avatar rwbarton Committed by Ben Gamari
Browse files

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
parent 7fac7cdc
......@@ -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
......
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:'
{-# 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 #-}
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
test('Orphans', normal, run_command, ['$MAKE -s --no-print-directory Orphans'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment