[commit: ghc] master: Fix #15941 by only special-casing visible infix applications (984b75d)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/984b75de7082689ebcc6e9d17b37f2c9b3702f71/ghc

>---------------------------------------------------------------

commit 984b75de7082689ebcc6e9d17b37f2c9b3702f71
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Mon Nov 26 12:59:50 2018 -0500

    Fix #15941 by only special-casing visible infix applications
    
    Summary:
    The iface pretty-printer had a special case for an
    application of an infix type constructor to two arguments. But this
    didn't take the visibilities of the arguments into account, which
    could lead to strange output like `@{LiftedRep} -> @{LiftedRep}` when
    `-fprint-explicit-kinds` was enabled (#15941). The fix is relatively
    straightforward: simply plumb through the visibilities of each
    argument, and only trigger the special case for infix applications
    if both arguments are visible (i.e., required).
    
    Test Plan: make test TEST=T15941
    
    Reviewers: goldfire, bgamari, monoidal
    
    Reviewed By: goldfire, monoidal
    
    Subscribers: simonpj, rwbarton, carter
    
    GHC Trac Issues: #15941
    
    Differential Revision: https://phabricator.haskell.org/D5375


>---------------------------------------------------------------

984b75de7082689ebcc6e9d17b37f2c9b3702f71
 compiler/iface/IfaceType.hs                | 28 +++++++++++++++++++++++-----
 testsuite/tests/ghci/scripts/T15941.script |  3 +++
 testsuite/tests/ghci/scripts/T15941.stdout |  3 +++
 testsuite/tests/ghci/scripts/all.T         |  1 +
 4 files changed, 30 insertions(+), 5 deletions(-)

diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs
index 2500073..4a42afe 100644
--- a/compiler/iface/IfaceType.hs
+++ b/compiler/iface/IfaceType.hs
@@ -8,6 +8,7 @@ This module defines interface types and binders
 
 {-# LANGUAGE CPP, FlexibleInstances, BangPatterns #-}
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE TupleSections #-}
     -- FlexibleInstances for Binary (DefMethSpec IfaceType)
 
 module IfaceType (
@@ -1334,9 +1335,23 @@ ppr_equality ctxt_prec tc args
 
 
 pprIfaceCoTcApp :: PprPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc
-pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app ppr_co ctxt_prec tc tys
-
-ppr_iface_tc_app :: (PprPrec -> a -> SDoc) -> PprPrec -> IfaceTyCon -> [a] -> SDoc
+pprIfaceCoTcApp ctxt_prec tc tys =
+  ppr_iface_tc_app (\prec (co, _) -> ppr_co prec co) ctxt_prec tc
+    (map (, Required) tys)
+    -- We are trying to re-use ppr_iface_tc_app here, which requires its
+    -- arguments to be accompanied by visibilities. But visibility is
+    -- irrelevant when printing coercions, so just default everything to
+    -- Required.
+
+-- | Pretty-prints an application of a type constructor to some arguments
+-- (whose visibilities are known). This is polymorphic (over @a@) since we use
+-- this function to pretty-print two different things:
+--
+-- 1. Types (from `pprTyTcApp'`)
+--
+-- 2. Coercions (from 'pprIfaceCoTcApp')
+ppr_iface_tc_app :: (PprPrec -> (a, ArgFlag) -> SDoc)
+                 -> PprPrec -> IfaceTyCon -> [(a, ArgFlag)] -> SDoc
 ppr_iface_tc_app pp _ tc [ty]
   | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp topPrec ty)
 
@@ -1347,8 +1362,11 @@ ppr_iface_tc_app pp ctxt_prec tc tys
   | not (isSymOcc (nameOccName (ifaceTyConName tc)))
   = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys)
 
-  | [ty1,ty2] <- tys  -- Infix, two arguments;
-                      -- we know nothing of precedence though
+  | [ ty1@(_, Required)
+    , ty2@(_, Required) ] <- tys
+      -- Infix, two visible arguments (we know nothing of precedence though).
+      -- Don't apply this special case if one of the arguments is invisible,
+      -- lest we print something like (@LiftedRep -> @LiftedRep) (#15941).
   = pprIfaceInfixApp ctxt_prec (ppr tc)
                      (pp opPrec ty1) (pp opPrec ty2)
 
diff --git a/testsuite/tests/ghci/scripts/T15941.script b/testsuite/tests/ghci/scripts/T15941.script
new file mode 100644
index 0000000..b6f44e7
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T15941.script
@@ -0,0 +1,3 @@
+:set -XKindSignatures -fprint-explicit-runtime-reps -fprint-explicit-kinds
+type T = (->)
+:info T
diff --git a/testsuite/tests/ghci/scripts/T15941.stdout b/testsuite/tests/ghci/scripts/T15941.stdout
new file mode 100644
index 0000000..c6f31a7
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T15941.stdout
@@ -0,0 +1,3 @@
+type T =
+  (->) @{'GHC.Types.LiftedRep} @{'GHC.Types.LiftedRep} :: * -> * -> *
+  	-- Defined at <interactive>:2:1
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 8219707..0dc0e5b 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -290,3 +290,4 @@ test('T15591', normal, ghci_script, ['T15591.script'])
 test('T15743b', normal, ghci_script, ['T15743b.script'])
 test('T15827', normal, ghci_script, ['T15827.script'])
 test('T15898', normal, ghci_script, ['T15898.script'])
+test('T15941', normal, ghci_script, ['T15941.script'])