Make ppr_tc_args aware of -fprint-explicit-kinds
authorRyan Scott <ryan.gl.scott@gmail.com>
Thu, 5 Jul 2018 12:52:20 +0000 (08:52 -0400)
committerRyan Scott <ryan.gl.scott@gmail.com>
Thu, 5 Jul 2018 13:51:15 +0000 (09:51 -0400)
Summary:
`ppr_tc_args` was printing invisible kind arguments even
when `-fprint-explicit-kinds` wasn't enabled. Easily fixed.

Test Plan: make test TEST=T15341

Reviewers: goldfire, bgamari, simonpj

Reviewed By: simonpj

Subscribers: simonpj, rwbarton, thomie, carter

GHC Trac Issues: #15341

Differential Revision: https://phabricator.haskell.org/D4932

compiler/iface/IfaceType.hs
testsuite/tests/ghci/scripts/T15341.hs [new file with mode: 0644]
testsuite/tests/ghci/scripts/T15341.script [new file with mode: 0644]
testsuite/tests/ghci/scripts/T15341.stdout [new file with mode: 0644]
testsuite/tests/ghci/scripts/T7939.stdout
testsuite/tests/ghci/scripts/all.T
testsuite/tests/indexed-types/should_fail/ClosedFam3.stderr

index d741265..5a7f761 100644 (file)
@@ -824,11 +824,15 @@ pprParendIfaceTcArgs = ppr_tc_args appPrec
 
 ppr_tc_args :: PprPrec -> IfaceTcArgs -> SDoc
 ppr_tc_args ctx_prec args
- = let pprTys t ts = ppr_ty ctx_prec t <+> ppr_tc_args ctx_prec ts
+ = let ppr_rest    = ppr_tc_args ctx_prec
+       pprTys t ts = ppr_ty ctx_prec t <+> ppr_rest ts
    in case args of
         ITC_Nil        -> empty
         ITC_Vis   t ts -> pprTys t ts
-        ITC_Invis t ts -> pprTys t ts
+        ITC_Invis t ts -> sdocWithDynFlags $ \dflags ->
+                          if gopt Opt_PrintExplicitKinds dflags
+                             then pprTys t ts
+                             else ppr_rest ts
 
 -------------------
 pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc
diff --git a/testsuite/tests/ghci/scripts/T15341.hs b/testsuite/tests/ghci/scripts/T15341.hs
new file mode 100644 (file)
index 0000000..b84c1bb
--- /dev/null
@@ -0,0 +1,6 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+module T15341 where
+
+type family Foo (a :: k) :: k where
+  Foo a = a
diff --git a/testsuite/tests/ghci/scripts/T15341.script b/testsuite/tests/ghci/scripts/T15341.script
new file mode 100644 (file)
index 0000000..0a3ffdc
--- /dev/null
@@ -0,0 +1,4 @@
+:load T15341.hs
+:info Foo
+:set -fprint-explicit-kinds
+:info Foo
diff --git a/testsuite/tests/ghci/scripts/T15341.stdout b/testsuite/tests/ghci/scripts/T15341.stdout
new file mode 100644 (file)
index 0000000..1d29dc7
--- /dev/null
@@ -0,0 +1,6 @@
+type family Foo (a :: k) :: k
+  where Foo a = a
+       -- Defined at T15341.hs:5:1
+type family Foo k (a :: k) :: k
+  where Foo k a = a
+       -- Defined at T15341.hs:5:1
index db2590c..82a8658 100644 (file)
@@ -15,13 +15,13 @@ type family H (a :: Bool) :: Bool
 H :: Bool -> Bool
 type family J (a :: [k]) :: Bool
   where
-      J '[] = 'False
-      J (h : t) = 'True
+      J '[] = 'False
+      J (h : t) = 'True
        -- Defined at T7939.hs:17:1
 J :: [k] -> Bool
 type family K (a1 :: [a]) :: Maybe a
   where
-      K '[] = 'Nothing
-      K (h : t) = 'Just h
+      K '[] = 'Nothing
+      K (h : t) = 'Just h
        -- Defined at T7939.hs:21:1
 K :: [a] -> Maybe a
index 29fbdf8..8954594 100755 (executable)
@@ -269,3 +269,4 @@ test('T14676', extra_files(['../prog002']), ghci_script, ['T14676.script'])
 test('T14796', normal, ghci_script, ['T14796.script'])
 test('T14969', normal, ghci_script, ['T14969.script'])
 test('T15259', normal, ghci_script, ['T15259.script'])
+test('T15341', normal, ghci_script, ['T15341.script'])
index ba1f46e..cab5078 100644 (file)
@@ -27,5 +27,5 @@ ClosedFam3.hs-boot:12:1: error:
     Main module: type family Baz a :: *
                    where Baz Int = Bool
     Boot file:   type family Baz (a :: k) :: *
-                   where Baz Int = Bool
+                   where Baz Int = Bool
     The types have different kinds