Commit e9e66402 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Better -ddump-types

The debug flag -ddump-types is supposed to show the type
of Ids, and the kinds of type constructors.  It was doing
the former but not the latter -- instead it was using
showTyTying, which is actually less helpful when debugging.

This patch changes it to print the kind and roles of the thing.

I also made -ddump-types show pattern synonyms
parent bd789853
......@@ -66,6 +66,7 @@ import DynFlags
import HsSyn
import IfaceSyn ( ShowSub(..), showToHeader )
import IfaceType( ShowForAllFlag(..) )
import PatSyn( pprPatSynType )
import PrelNames
import PrelInfo
import RdrName
......@@ -76,7 +77,6 @@ import TcRnExports
import TcEvidence
import qualified BooleanFormula as BF
import PprTyThing( pprTyThingInContext )
import MkIface( tyThingToIfaceDecl )
import Coercion( pprCoAxiom )
import CoreFVs( orphNamesOfFamInst )
import FamInst
......@@ -2683,9 +2683,10 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
tcg_imports = imports })
= vcat [ ppr_types type_env
, ppr_tycons fam_insts type_env
, ppr_patsyns type_env
, ppr_insts insts
, ppr_fam_insts fam_insts
, vcat (map ppr rules)
, ppr_rules rules
, text "Dependent modules:" <+>
pprUFM (imp_dep_mods imports) (ppr . sort)
, text "Dependent packages:" <+>
......@@ -2693,6 +2694,12 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
where -- The use of sort is just to reduce unnecessary
-- wobbling in testsuite output
ppr_rules :: [LRuleDecl GhcTc] -> SDoc
ppr_rules rules
= ppUnless (null rules) $
hang (text "RULES")
2 (vcat (map ppr rules))
ppr_types :: TypeEnv -> SDoc
ppr_types type_env = getPprDebug $ \dbg ->
let
......@@ -2705,7 +2712,7 @@ ppr_types type_env = getPprDebug $ \dbg ->
-- Top-level user-defined things have External names.
-- Suppress internally-generated things unless -dppr-debug
in
text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids)
ppr_sigs ids
ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
ppr_tycons fam_insts type_env = getPprDebug $ \dbg ->
......@@ -2717,24 +2724,35 @@ ppr_tycons fam_insts type_env = getPprDebug $ \dbg ->
isExternalName (tyConName tycon) &&
not (tycon `elem` fi_tycons)
in
vcat [ text "TYPE CONSTRUCTORS"
, nest 2 (ppr_tydecls tycons)
, text "COERCION AXIOMS"
, nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ]
vcat [ hang (text "TYPE CONSTRUCTORS")
2 (ppr_tydecls tycons)
, hang (text "COERCION AXIOMS")
2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ]
ppr_patsyns :: TypeEnv -> SDoc
ppr_patsyns type_env
= ppUnless (null patsyns) $
hang (text "PATTERN SYNONYMS")
2 (vcat (map ppr_ps patsyns))
where
patsyns = typeEnvPatSyns type_env
ppr_ps ps = ppr ps <+> dcolon <+> pprPatSynType ps
ppr_insts :: [ClsInst] -> SDoc
ppr_insts [] = empty
ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
ppr_insts ispecs
= ppUnless (null ispecs) $
hang (text "INSTANCES") 2 (pprInstances ispecs)
ppr_fam_insts :: [FamInst] -> SDoc
ppr_fam_insts [] = empty
ppr_fam_insts fam_insts =
text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts)
ppr_fam_insts fam_insts
= ppUnless (null fam_insts) $
hang (text "FAMILY INSTANCES")
2 (pprFamInsts fam_insts)
ppr_sigs :: [Var] -> SDoc
ppr_sigs ids
-- Print type signatures; sort by OccName
= vcat (map ppr_sig (sortBy (comparing getOccName) ids))
ppr_sigs ids -- Print type signatures; sort by OccName
= hang (text "TYPE SIGNATURES")
2 (vcat (map ppr_sig (sortBy (comparing getOccName) ids)))
where
ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id)))
......@@ -2742,11 +2760,21 @@ ppr_tydecls :: [TyCon] -> SDoc
ppr_tydecls tycons
-- Print type constructor info for debug purposes
-- Sort by OccName to reduce unnecessary changes
= vcat [ ppr (tyThingToIfaceDecl (ATyCon tc))
| tc <- sortBy (comparing getOccName) tycons ]
-- The Outputable instance for IfaceDecl uses
-- showToIface, which is what we want here, whereas
-- pprTyThing uses ShowSome.
= getPprDebug $ \ debug ->
vcat $ map (ppr_tc debug) $ sortBy (comparing getOccName) tycons
where
ppr_tc debug tc
= vcat [ ppWhen show_roles $
hang (text "type role" <+> ppr tc)
2 (hsep (map ppr roles))
, hang (ppr tc <+> dcolon)
2 (ppr (tidyTopType (tyConKind tc))) ]
where
roles = tyConRoles tc
show_roles = debug || not (all (== boring_role) roles)
boring_role | isClassTyCon tc = Nominal
| otherwise = Representational
-- Matches the choice in IfaceSyn, calls to pprRoles
{-
********************************************************************************
......
{"span": null,"doc": "TYPE SIGNATURES\n foo :: forall a. a -> a\nTYPE CONSTRUCTORS\nCOERCION AXIOMS\nDependent modules: []\nDependent packages: [base-4.12.0.0, ghc-prim-0.5.3,\n integer-gmp-1.0.2.0]","severity": "SevOutput","reason": null}
{"span": null,"doc": "TYPE SIGNATURES foo :: forall a. a -> a\nTYPE CONSTRUCTORS\nCOERCION AXIOMS\nDependent modules: []\nDependent packages: [base-4.12.0.0, ghc-prim-0.5.3,\n integer-gmp-1.0.2.0]","severity": "SevOutput","reason": null}
......@@ -6,12 +6,8 @@ TYPE SIGNATURES
test2 ::
forall c a b. (Coll c, Num a, Num b, Elem c ~ (a, b)) => c -> c
TYPE CONSTRUCTORS
class Coll c where
type family Elem c :: * open
empty :: c
insert :: Elem c -> c -> c
{-# MINIMAL empty, insert #-}
data ListColl a = L [a]
Coll :: * -> Constraint
ListColl :: * -> *
COERCION AXIOMS
axiom Foo.D:R:ElemListColl ::
Elem (ListColl a) = a -- Defined at T3017.hs:13:9
......
......@@ -2,7 +2,7 @@ TYPE SIGNATURES
ADT.Foo :: forall x y z. x -> y -> z -> Foo x y z
bar :: Int -> Foo Bool () Int
TYPE CONSTRUCTORS
data Foo x y z = Foo x y z
Foo :: * -> * -> * -> *
COERCION AXIOMS
Dependent modules: []
Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3,
......
......@@ -11,8 +11,9 @@ TYPE SIGNATURES
DataFamilyInstanceLHS.R:SingMyKind_ _
foo :: Sing 'A
TYPE CONSTRUCTORS
data MyKind = A | B
data family Sing (a :: k)
MyKind :: *
type role Sing nominal nominal
Sing :: forall k. k -> *
COERCION AXIOMS
axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 ::
Sing _ = DataFamilyInstanceLHS.R:SingMyKind_
......
......@@ -5,7 +5,7 @@ TYPE SIGNATURES
NukeMonad param1 param2 () -> NukeMonad param1 param2 ()
TYPE CONSTRUCTORS
type role NukeMonad phantom phantom phantom
data NukeMonad a b c
NukeMonad :: * -> * -> * -> *
COERCION AXIOMS
INSTANCES
instance Functor (NukeMonad a b) -- Defined at Meltdown.hs:8:10
......
......@@ -10,8 +10,9 @@ TYPE SIGNATURES
(_a ~ 'B) =>
NamedWildcardInDataFamilyInstanceLHS.R:SingMyKind_a _a
TYPE CONSTRUCTORS
data MyKind = A | B
data family Sing (a :: k)
MyKind :: *
type role Sing nominal nominal
Sing :: forall k. k -> *
COERCION AXIOMS
axiom NamedWildcardInDataFamilyInstanceLHS.D:R:SingMyKind_a0 ::
Sing _a = NamedWildcardInDataFamilyInstanceLHS.R:SingMyKind_a
......
TYPE SIGNATURES
TYPE CONSTRUCTORS
type family F a :: *
where
F _t = Int
axiom NamedWildcardInTypeFamilyInstanceLHS.D:R:F
type role F nominal
F :: * -> *
COERCION AXIOMS
axiom NamedWildcardInTypeFamilyInstanceLHS.D:R:F ::
F _t = Int
......
......@@ -6,7 +6,7 @@ TYPE SIGNATURES
skipMany' ::
forall tok st a. GenParser tok st a -> GenParser tok st ()
TYPE CONSTRUCTORS
data GenParser tok st a = GenParser tok st a
GenParser :: * -> * -> * -> *
COERCION AXIOMS
Dependent modules: []
Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3,
......
TYPE SIGNATURES
foo :: F Int Char -> Int
TYPE CONSTRUCTORS
type family F a b :: * open
type role F nominal nominal
F :: * -> * -> *
COERCION AXIOMS
axiom TypeFamilyInstanceLHS.D:R:FBool_ ::
F Bool _ = Bool -- Defined at TypeFamilyInstanceLHS.hs:6:15
......
......@@ -8,17 +8,17 @@ TYPE SIGNATURES
Roles1.K7 :: forall {k} (a :: k) b. b -> T7 a b
TYPE CONSTRUCTORS
type role T1 nominal
data T1 a = K1 a
data T2 a = K2 a
type role T3 phantom
data T3 (a :: k) = K3
T1 :: * -> *
T2 :: * -> *
type role T3 nominal phantom
T3 :: forall k. k -> *
type role T4 nominal nominal
data T4 (a :: * -> *) b = K4 (a b)
data T5 a = K5 a
type role T6 phantom
data T6 (a :: k) = K6
type role T7 phantom representational
data T7 (a :: k) b = K7 b
T4 :: (* -> *) -> * -> *
T5 :: * -> *
type role T6 nominal phantom
T6 :: forall {k}. k -> *
type role T7 nominal phantom representational
T7 :: forall {k}. k -> * -> *
COERCION AXIOMS
Dependent modules: []
Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3,
......
......@@ -2,9 +2,7 @@ TYPE SIGNATURES
meth2 :: forall a. C2 a => a -> a
TYPE CONSTRUCTORS
type role C2 representational
class C2 a where
meth2 :: a -> a
{-# MINIMAL meth2 #-}
C2 :: * -> Constraint
COERCION AXIOMS
axiom Roles12.N:C2 :: C2 a = a -> a -- Defined at Roles14.hs:6:1
Dependent modules: []
......
......@@ -2,9 +2,9 @@ TYPE SIGNATURES
Roles2.K1 :: forall a. IO a -> T1 a
Roles2.K2 :: forall a. FunPtr a -> T2 a
TYPE CONSTRUCTORS
data T1 a = K1 (IO a)
T1 :: * -> *
type role T2 phantom
data T2 a = K2 (FunPtr a)
T2 :: * -> *
COERCION AXIOMS
Dependent modules: []
Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3,
......
......@@ -4,22 +4,15 @@ TYPE SIGNATURES
meth3 :: forall a b. C3 a b => a -> F3 b -> F3 b
meth4 :: forall a b. C4 a b => a -> F4 b -> F4 b
TYPE CONSTRUCTORS
class C1 a where
meth1 :: a -> a
{-# MINIMAL meth1 #-}
class C2 a b where
meth2 :: (a ~ b) => a -> b
{-# MINIMAL meth2 #-}
class C3 a b where
type family F3 b :: * open
meth3 :: a -> F3 b -> F3 b
{-# MINIMAL meth3 #-}
class C4 a b where
meth4 :: a -> F4 b -> F4 b
{-# MINIMAL meth4 #-}
type family F4 a :: * open
type Syn1 a = F4 a
type Syn2 a = [a]
C1 :: * -> Constraint
C2 :: * -> * -> Constraint
C3 :: * -> * -> Constraint
C4 :: * -> * -> Constraint
type role F4 nominal
F4 :: * -> *
type role Syn1 nominal
Syn1 :: * -> *
Syn2 :: * -> *
COERCION AXIOMS
axiom Roles3.N:C1 :: C1 a = a -> a -- Defined at Roles3.hs:6:1
axiom Roles3.N:C2 ::
......
......@@ -2,13 +2,9 @@ TYPE SIGNATURES
meth1 :: forall a. C1 a => a -> a
meth3 :: forall a. C3 a => a -> Syn1 a
TYPE CONSTRUCTORS
class C1 a where
meth1 :: a -> a
{-# MINIMAL meth1 #-}
class C3 a where
meth3 :: a -> Syn1 a
{-# MINIMAL meth3 #-}
type Syn1 a = [a]
C1 :: * -> Constraint
C3 :: * -> Constraint
Syn1 :: * -> *
COERCION AXIOMS
axiom Roles4.N:C1 :: C1 a = a -> a -- Defined at Roles4.hs:6:1
axiom Roles4.N:C3 ::
......
......@@ -5,10 +5,10 @@ TYPE SIGNATURES
T8958.MkMap :: forall k v. [(k, v)] -> Map k v
TYPE CONSTRUCTORS
type role Map nominal representational
newtype (Nominal k, Representational v) => Map k v = MkMap [(k, v)]
class Nominal a
Map :: * -> * -> *
Nominal :: * -> Constraint
type role Representational representational
class Representational a
Representational :: * -> Constraint
COERCION AXIOMS
axiom T8958.N:Map :: Map k v = [(k, v)] -- Defined at T8958.hs:13:1
INSTANCES
......
TYPE SIGNATURES
TYPE CONSTRUCTORS
type role T representational
data T (a :: k)
type role T nominal representational
T :: forall k. k -> *
COERCION AXIOMS
Dependent modules: []
Dependent packages: [array-0.5.2.0, base-4.11.0.0, deepseq-1.4.3.0,
ghc-boot-th-8.3, ghc-prim-0.5.2.1, integer-gmp-1.0.1.0,
pretty-1.1.3.5, template-haskell-2.14.0.0]
Dependent packages: [array-0.5.2.0, base-4.12.0.0, deepseq-1.4.4.0,
ghc-boot-th-8.7, ghc-prim-0.5.3, integer-gmp-1.0.2.0,
pretty-1.1.3.6, template-haskell-2.14.0.0]
==================== Typechecker ====================
TH_Roles2.$tcT
......
......@@ -2,9 +2,7 @@ TYPE SIGNATURES
f :: Int -> ()
m :: forall a. C a => a -> ()
TYPE CONSTRUCTORS
class C a | -> a where
m :: a -> ()
{-# MINIMAL m #-}
C :: * -> Constraint
COERCION AXIOMS
axiom T12763.N:C :: C a = a -> () -- Defined at T12763.hs:6:1
INSTANCES
......
......@@ -8,15 +8,13 @@ TYPE SIGNATURES
huh :: forall s a b chain. Zork s a b => Q s a chain -> ST s ()
s :: forall t t1. Q t (Z [Char]) t1 -> Q t (Z [Char]) t1
TYPE CONSTRUCTORS
data Q s a chain = Node s a chain
data Z a = Z a
class Zork s a b | a -> b where
huh :: Q s a chain -> ST s ()
{-# MINIMAL huh #-}
Q :: * -> * -> * -> *
Z :: * -> *
Zork :: * -> * -> * -> Constraint
COERCION AXIOMS
axiom N:Zork ::
Zork s a b = forall chain. Q s a chain -> ST s ()
-- Defined at tc231.hs:25:1
Dependent modules: []
Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3,
integer-simple-0.1.1.1]
integer-gmp-1.0.2.0]
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