[commit: ghc] master: Pretty-print built in synonym families in interfaces (96a8980)
git at git.haskell.org
git at git.haskell.org
Sat Jun 7 12:51:17 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/96a8980183ed12a354db1b92f271b98bccce9ae8/ghc
>---------------------------------------------------------------
commit 96a8980183ed12a354db1b92f271b98bccce9ae8
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Sat Jun 7 13:18:55 2014 +0200
Pretty-print built in synonym families in interfaces
This closes #9181.
>---------------------------------------------------------------
96a8980183ed12a354db1b92f271b98bccce9ae8
compiler/iface/IfaceSyn.lhs | 5 ++++
compiler/iface/MkIface.lhs | 2 +-
compiler/iface/TcIface.lhs | 2 ++
testsuite/tests/ghci/scripts/T9181.stdout | 50 +++++++++++++++++++++++++++++++
testsuite/tests/ghci/scripts/all.T | 2 +-
5 files changed, 59 insertions(+), 2 deletions(-)
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 79e2359..afd7363 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -275,6 +275,7 @@ data IfaceSynTyConRhs
[IfaceAxBranch] -- for pretty printing purposes only
| IfaceAbstractClosedSynFamilyTyCon
| IfaceSynonymTyCon IfaceType
+ | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only
instance Binary IfaceSynTyConRhs where
put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0
@@ -282,6 +283,8 @@ instance Binary IfaceSynTyConRhs where
>> put_ bh br
put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 2
put_ bh (IfaceSynonymTyCon ty) = putByte bh 3 >> put_ bh ty
+ put_ _ IfaceBuiltInSynFamTyCon
+ = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" empty
get bh = do { h <- getByte bh
; case h of
@@ -1255,6 +1258,7 @@ pprIfaceDecl ss (IfaceSyn { ifName = tycon, ifTyVars = tyvars
pp_rhs IfaceOpenSynFamilyTyCon = ppShowIface ss (ptext (sLit "open"))
pp_rhs IfaceAbstractClosedSynFamilyTyCon = ppShowIface ss (ptext (sLit "closed, abstract"))
pp_rhs (IfaceClosedSynFamilyTyCon _ (_:_)) = ptext (sLit "where")
+ pp_rhs IfaceBuiltInSynFamTyCon = ppShowIface ss (ptext (sLit "built-in"))
pp_rhs _ = panic "pprIfaceDecl syn"
pp_branches (IfaceClosedSynFamilyTyCon ax brs)
@@ -1635,6 +1639,7 @@ freeNamesIfSynRhs IfaceOpenSynFamilyTyCon = emptyNameSet
freeNamesIfSynRhs (IfaceClosedSynFamilyTyCon ax br)
= unitNameSet ax &&& fnList freeNamesIfAxBranch br
freeNamesIfSynRhs IfaceAbstractClosedSynFamilyTyCon = emptyNameSet
+freeNamesIfSynRhs IfaceBuiltInSynFamTyCon = emptyNameSet
freeNamesIfContext :: IfaceContext -> NameSet
freeNamesIfContext = fnList freeNamesIfType
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index e3c0ac3..f2d2058 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1626,7 +1626,7 @@ tyConToIfaceDecl env tycon
= IfaceSynonymTyCon (tidyToIfaceType env1 ty)
to_ifsyn_rhs (BuiltInSynFamTyCon {})
- = pprPanic "toIfaceDecl: BuiltInFamTyCon" (ppr tycon)
+ = IfaceBuiltInSynFamTyCon
ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index e4a415a..1a2a447 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -494,6 +494,8 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
tc_syn_rhs IfaceAbstractClosedSynFamilyTyCon = return AbstractClosedSynFamilyTyCon
tc_syn_rhs (IfaceSynonymTyCon ty) = do { rhs_ty <- tcIfaceType ty
; return (SynonymTyCon rhs_ty) }
+ tc_syn_rhs IfaceBuiltInSynFamTyCon = pprPanic "tc_iface_decl"
+ (ptext (sLit "IfaceBuiltInSynFamTyCon in interface file"))
tc_iface_decl _parent ignore_prags
(IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ,
diff --git a/testsuite/tests/ghci/scripts/T9181.stdout b/testsuite/tests/ghci/scripts/T9181.stdout
new file mode 100644
index 0000000..fb9cf5d
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T9181.stdout
@@ -0,0 +1,50 @@
+type family (GHC.TypeLits.*) (a :: GHC.TypeLits.Nat)
+ (b :: GHC.TypeLits.Nat) ::
+ GHC.TypeLits.Nat
+type family (GHC.TypeLits.+) (a :: GHC.TypeLits.Nat)
+ (b :: GHC.TypeLits.Nat) ::
+ GHC.TypeLits.Nat
+type family (GHC.TypeLits.-) (a :: GHC.TypeLits.Nat)
+ (b :: GHC.TypeLits.Nat) ::
+ GHC.TypeLits.Nat
+type (GHC.TypeLits.<=) (x :: GHC.TypeLits.Nat)
+ (y :: GHC.TypeLits.Nat) =
+ (x GHC.TypeLits.<=? y) ~ 'True
+type family (GHC.TypeLits.<=?) (a :: GHC.TypeLits.Nat)
+ (b :: GHC.TypeLits.Nat) ::
+ Bool
+type family GHC.TypeLits.CmpNat (a :: GHC.TypeLits.Nat)
+ (b :: GHC.TypeLits.Nat) ::
+ Ordering
+type family GHC.TypeLits.CmpSymbol (a :: GHC.TypeLits.Symbol)
+ (b :: GHC.TypeLits.Symbol) ::
+ Ordering
+class GHC.TypeLits.KnownNat (n :: GHC.TypeLits.Nat) where
+ GHC.TypeLits.natSing :: GHC.TypeLits.SNat n
+class GHC.TypeLits.KnownSymbol (n :: GHC.TypeLits.Symbol) where
+ GHC.TypeLits.symbolSing :: GHC.TypeLits.SSymbol n
+data GHC.TypeLits.Nat
+data GHC.TypeLits.SomeNat where
+ GHC.TypeLits.SomeNat :: GHC.TypeLits.KnownNat n =>
+ (Data.Proxy.Proxy n) -> GHC.TypeLits.SomeNat
+data GHC.TypeLits.SomeSymbol where
+ GHC.TypeLits.SomeSymbol :: GHC.TypeLits.KnownSymbol n =>
+ (Data.Proxy.Proxy n) -> GHC.TypeLits.SomeSymbol
+data GHC.TypeLits.Symbol
+type family (GHC.TypeLits.^) (a :: GHC.TypeLits.Nat)
+ (b :: GHC.TypeLits.Nat) ::
+ GHC.TypeLits.Nat
+GHC.TypeLits.natVal ::
+ GHC.TypeLits.KnownNat n => proxy n -> Integer
+GHC.TypeLits.sameNat ::
+ (GHC.TypeLits.KnownNat a, GHC.TypeLits.KnownNat b) =>
+ Data.Proxy.Proxy a
+ -> Data.Proxy.Proxy b -> Maybe (a Data.Type.Equality.:~: b)
+GHC.TypeLits.sameSymbol ::
+ (GHC.TypeLits.KnownSymbol a, GHC.TypeLits.KnownSymbol b) =>
+ Data.Proxy.Proxy a
+ -> Data.Proxy.Proxy b -> Maybe (a Data.Type.Equality.:~: b)
+GHC.TypeLits.someNatVal :: Integer -> Maybe GHC.TypeLits.SomeNat
+GHC.TypeLits.someSymbolVal :: String -> GHC.TypeLits.SomeSymbol
+GHC.TypeLits.symbolVal ::
+ GHC.TypeLits.KnownSymbol n => proxy n -> String
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 1ae9105..b71dfd1 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -174,4 +174,4 @@ test('T8917', normal, ghci_script, ['T8917.script'])
test('T8931', normal, ghci_script, ['T8931.script'])
test('T8959', normal, ghci_script, ['T8959.script'])
test('T8959b', expect_broken(8959), ghci_script, ['T8959b.script'])
-test('T9181', expect_broken(9181), ghci_script, ['T9181.script'])
+test('T9181', normal, ghci_script, ['T9181.script'])
More information about the ghc-commits
mailing list