[commit: ghc] master: Fix #15236 by removing parentheses from funTyConName (3397396)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/3397396a385ef9f493cf1e20894e88d21dfec48d/ghc

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

commit 3397396a385ef9f493cf1e20894e88d21dfec48d
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Thu Jun 7 13:30:44 2018 -0400

    Fix #15236 by removing parentheses from funTyConName
    
    Currently, `funTyConName` is defined as:
    
    ```lang=haskell
    funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
    ```
    
    What's strange about this definition is that there are extraneous
    parentheses around `->`, which is quite unlike every other infix
    `Name`. As a result, the `:info (->)` output is totally garbled (see
    Trac #15236).
    
    It's quite straightforward to fix that particular bug by removing the
    extraneous parentheses. However, it turns out that this makes some
    test output involving `Show` instances for `TypeRep` look less
    appealing, since `->` is no longer surrounded with parentheses when
    applied prefix. But neither were any /other/ infix type constructors!
    The right fix there was to change `showTypeable` to put parentheses
    around prefix applications of infix tycons.
    
    Test Plan: ./validate
    
    Reviewers: bgamari, hvr
    
    Reviewed By: bgamari
    
    Subscribers: rwbarton, thomie, carter
    
    GHC Trac Issues: #15236
    
    Differential Revision: https://phabricator.haskell.org/D4799


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

3397396a385ef9f493cf1e20894e88d21dfec48d
 compiler/prelude/TysPrim.hs                        |  2 +-
 libraries/base/Data/Typeable/Internal.hs           | 30 +++++++++++++++++++---
 testsuite/tests/ghci/scripts/T8535.stdout          |  2 +-
 testsuite/tests/ghci/scripts/ghci020.stdout        |  2 +-
 testsuite/tests/ghci/should_run/T10145.stdout      |  2 +-
 testsuite/tests/typecheck/should_run/TypeOf.stdout |  2 +-
 6 files changed, 31 insertions(+), 9 deletions(-)

diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs
index ff61878..754bb8f 100644
--- a/compiler/prelude/TysPrim.hs
+++ b/compiler/prelude/TysPrim.hs
@@ -340,7 +340,7 @@ openBetaTy  = mkTyVarTy openBetaTyVar
 -}
 
 funTyConName :: Name
-funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
+funTyConName = mkPrimTyConName (fsLit "->") funTyConKey funTyCon
 
 -- | The @(->)@ type constructor.
 --
diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs
index 6c52cc5..3b7753d 100644
--- a/libraries/base/Data/Typeable/Internal.hs
+++ b/libraries/base/Data/Typeable/Internal.hs
@@ -85,7 +85,7 @@ import GHC.Base
 import qualified GHC.Arr as A
 import GHC.Types ( TYPE )
 import Data.Type.Equality
-import GHC.List ( splitAt, foldl' )
+import GHC.List ( splitAt, foldl', elem )
 import GHC.Word
 import GHC.Show
 import GHC.TypeLits ( KnownSymbol, symbolVal', AppendSymbol )
@@ -777,11 +777,11 @@ showTypeable _ rep
   | isTupleTyCon tc =
     showChar '(' . showArgs (showChar ',') tys . showChar ')'
   where (tc, tys) = splitApps rep
-showTypeable p (TrTyCon {trTyCon = tycon, trKindVars = []})
-  = showsPrec p tycon
+showTypeable _ (TrTyCon {trTyCon = tycon, trKindVars = []})
+  = showTyCon tycon
 showTypeable p (TrTyCon {trTyCon = tycon, trKindVars = args})
   = showParen (p > 9) $
-    showsPrec p tycon .
+    showTyCon tycon .
     showChar ' ' .
     showArgs (showChar ' ') args
 showTypeable p (TrFun {trFunArg = x, trFunRes = r})
@@ -841,6 +841,28 @@ isTupleTyCon tc
   | ('(':',':_) <- tyConName tc = True
   | otherwise                   = False
 
+-- This is only an approximation. We don't have the general
+-- character-classification machinery here, so we just do our best.
+-- This should work for promoted Haskell 98 data constructors and
+-- for TypeOperators type constructors that begin with ASCII
+-- characters, but it will miss Unicode operators.
+--
+-- If we wanted to catch Unicode as well, we ought to consider moving
+-- GHC.Lexeme from ghc-boot-th to base. Then we could just say:
+--
+--   startsVarSym symb || startsConSym symb
+--
+-- But this is a fair deal of work just for one corner case, so I think I'll
+-- leave it like this unless someone shouts.
+isOperatorTyCon :: TyCon -> Bool
+isOperatorTyCon tc
+  | symb : _ <- tyConName tc
+  , symb `elem` "!#$%&*+./<=>?@\\^|-~:" = True
+  | otherwise                           = False
+
+showTyCon :: TyCon -> ShowS
+showTyCon tycon = showParen (isOperatorTyCon tycon) (shows tycon)
+
 showArgs :: Show a => ShowS -> [a] -> ShowS
 showArgs _   []     = id
 showArgs _   [a]    = showsPrec 10 a
diff --git a/testsuite/tests/ghci/scripts/T8535.stdout b/testsuite/tests/ghci/scripts/T8535.stdout
index 873b992..6ae0c4c 100644
--- a/testsuite/tests/ghci/scripts/T8535.stdout
+++ b/testsuite/tests/ghci/scripts/T8535.stdout
@@ -1,5 +1,5 @@
 data (->) (a :: TYPE q) (b :: TYPE r) 	-- Defined in ‘GHC.Prim’
-infixr 0 `(->)`
+infixr 0 ->
 instance Applicative ((->) a) -- Defined in ‘GHC.Base’
 instance Functor ((->) r) -- Defined in ‘GHC.Base’
 instance Monad ((->) r) -- Defined in ‘GHC.Base’
diff --git a/testsuite/tests/ghci/scripts/ghci020.stdout b/testsuite/tests/ghci/scripts/ghci020.stdout
index 873b992..6ae0c4c 100644
--- a/testsuite/tests/ghci/scripts/ghci020.stdout
+++ b/testsuite/tests/ghci/scripts/ghci020.stdout
@@ -1,5 +1,5 @@
 data (->) (a :: TYPE q) (b :: TYPE r) 	-- Defined in ‘GHC.Prim’
-infixr 0 `(->)`
+infixr 0 ->
 instance Applicative ((->) a) -- Defined in ‘GHC.Base’
 instance Functor ((->) r) -- Defined in ‘GHC.Base’
 instance Monad ((->) r) -- Defined in ‘GHC.Base’
diff --git a/testsuite/tests/ghci/should_run/T10145.stdout b/testsuite/tests/ghci/should_run/T10145.stdout
index 873b992..6ae0c4c 100644
--- a/testsuite/tests/ghci/should_run/T10145.stdout
+++ b/testsuite/tests/ghci/should_run/T10145.stdout
@@ -1,5 +1,5 @@
 data (->) (a :: TYPE q) (b :: TYPE r) 	-- Defined in ‘GHC.Prim’
-infixr 0 `(->)`
+infixr 0 ->
 instance Applicative ((->) a) -- Defined in ‘GHC.Base’
 instance Functor ((->) r) -- Defined in ‘GHC.Base’
 instance Monad ((->) r) -- Defined in ‘GHC.Base’
diff --git a/testsuite/tests/typecheck/should_run/TypeOf.stdout b/testsuite/tests/typecheck/should_run/TypeOf.stdout
index 6e9a28e..912fe39 100644
--- a/testsuite/tests/typecheck/should_run/TypeOf.stdout
+++ b/testsuite/tests/typecheck/should_run/TypeOf.stdout
@@ -21,4 +21,4 @@ Proxy * *
 Proxy * *
 Proxy RuntimeRep 'LiftedRep
 Proxy (Nat,Symbol) ('(,) Nat Symbol 1 "hello")
-Proxy (* -> * -> Constraint) (~~ * *)
+Proxy (* -> * -> Constraint) ((~~) * *)