Set `infixr -1 ->`

Summary:
This simply makes explicit what is already the case. Due to special
treatment in the parser, `->` has the lowest fixity. This patch propagates
that information to:

  * GHCi, where `:info ->` now return the right fixity
  * TH, where `reifyFixity` returns the right fixity
  * the generated sources for `GHC.Prim`

See #15235.

Test Plan: make test

Reviewers: bgamari, alanz, RyanGlScott

Reviewed By: RyanGlScott

Subscribers: int-index, RyanGlScott, rwbarton, mpickering, carter

GHC Trac Issues: #15235

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

10 files changed, 26 insertions, 16 deletions

diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs
index 151a040393..cf56957f7b 100644
--- a/compiler/basicTypes/BasicTypes.hs
+++ b/compiler/basicTypes/BasicTypes.hs
@@ -410,7 +410,7 @@ defaultFixity = Fixity NoSourceText maxPrecedence InfixL
 negateFixity, funTyFixity :: Fixity
 -- Wired-in fixities
 negateFixity = Fixity NoSourceText 6 InfixL  -- Fixity of unary negate
-funTyFixity  = Fixity NoSourceText 0 InfixR  -- Fixity of '->'
+funTyFixity  = Fixity NoSourceText (-1) InfixR  -- Fixity of '->', see #15235
 
 {-
 Consider
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 25eb008895..74db997bbb 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -998,7 +998,7 @@ impspec :: { Located (Bool, Located [LIE GhcPs]) }
 prec    :: { Located (SourceText,Int) }
         : {- empty -}           { noLoc (NoSourceText,9) }
         | INTEGER
-                 {% checkPrecP (sL1 $1 (getINTEGERs $1,fromInteger (il_value (getINTEGER $1)))) }
+                 { sL1 $1 (getINTEGERs $1,fromInteger (il_value (getINTEGER $1))) }
 
 infix   :: { Located FixityDirection }
         : 'infix'                               { sL1 $1 InfixN  }
@@ -2378,7 +2378,8 @@ sigdecl :: { LHsDecl GhcPs }
                        [mu AnnDcolon $4] } }
 
         | infix prec ops
-              {% ams (sLL $1 $> $ SigD noExt
+              {% checkPrecP $2 $3 >>
+                 ams (sLL $1 $> $ SigD noExt
                         (FixSig noExt (FixitySig noExt (fromOL $ unLoc $3)
                                 (Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1)))))
                      [mj AnnInfix $1,mj AnnVal $2] }
@@ -3243,6 +3244,7 @@ op      :: { Located RdrName }   -- used in infix decls
         : varop                 { $1 }
         | conop                 { $1 }
         | '->'                  { sL1 $1 $ getRdrName funTyCon }
+        | '~'                   { sL1 $1 $ eqTyCon_RDR }
 
 varop   :: { Located RdrName }
         : varsym                { $1 }
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 91fcb0d3fd..1015319986 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -87,7 +87,7 @@ import BasicTypes
 import TcEvidence       ( idHsWrapper )
 import Lexer
 import Lexeme           ( isLexCon )
-import Type             ( TyThing(..) )
+import Type             ( TyThing(..), funTyCon )
 import TysWiredIn       ( cTupleTyConName, tupleTyCon, tupleDataCon,
                           nilDataConName, nilDataConKey,
                           listTyConName, listTyConKey, eqTyCon_RDR,
@@ -1756,11 +1756,19 @@ cmdStmtFail loc e = parseErrorSDoc loc
 ---------------------------------------------------------------------------
 -- Miscellaneous utilities
 
-checkPrecP :: Located (SourceText,Int) -> P (Located (SourceText,Int))
-checkPrecP (L l (src,i))
- | 0 <= i && i <= maxPrecedence = return (L l (src,i))
- | otherwise
-    = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
+-- | Check if a fixity is valid. We support bypassing the usual bound checks
+-- for some special operators.
+checkPrecP
+        :: Located (SourceText,Int)             -- ^ precedence
+        -> Located (OrdList (Located RdrName))  -- ^ operators
+        -> P ()
+checkPrecP (L l (_,i)) (L _ ol)
+ | 0 <= i, i <= maxPrecedence = pure ()
+ | all specialOp ol = pure ()
+ | otherwise = parseErrorSDoc l (text ("Precedence out of range: " ++ show i))
+  where
+    specialOp op = unLoc op `elem` [ eqTyCon_RDR
+                                   , getRdrName funTyCon ]
 
 mkRecConstrOrUpdate
         :: LHsExpr GhcPs
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 2d2fff4268..7360ccb758 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -169,7 +169,7 @@ primtype (->) a b
    Note that {\tt a -> b} permits levity-polymorphism in both {\tt a} and
    {\tt b}, so that types like {\tt Int\# -> Int\#} can still be well-kinded.
   }
-  with fixity = infixr 0
+  with fixity = infixr -1
          -- This fixity is only the one picked up by Haddock. If you
          -- change this, do update 'ghcPrimIface' in 'LoadIface.hs'.
 
diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst
index 1664dbc571..4a77f3bd7f 100644
--- a/docs/users_guide/glasgow_exts.rst
+++ b/docs/users_guide/glasgow_exts.rst
@@ -2409,8 +2409,7 @@ specifically:
    sets the fixity for both type constructor ``T`` and data constructor
    ``T``, and similarly for ``:*:``. ``Int `a` Bool``.
 
--  Function arrow is ``infixr`` with fixity 0 (this might change; it's
-   not clear what it should be).
+-  The function arrow ``->`` is ``infixr`` with fixity -1.
 
 .. _type-operators:
 
diff --git a/testsuite/tests/ghci/scripts/T8535.stdout b/testsuite/tests/ghci/scripts/T8535.stdout
index 6ae0c4ccfe..a0a5730d2b 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 -1 ->
 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 6ae0c4ccfe..a0a5730d2b 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 -1 ->
 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 6ae0c4ccfe..a0a5730d2b 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 -1 ->
 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/th/T10704.stdout b/testsuite/tests/th/T10704.stdout
index 99b87e28a1..5d6d0156f7 100644
--- a/testsuite/tests/th/T10704.stdout
+++ b/testsuite/tests/th/T10704.stdout
@@ -1,4 +1,4 @@
-Just (Fixity 0 InfixR)
+Just (Fixity (-1) InfixR)
 Nothing
 Nothing
 Just (Fixity 6 InfixL)
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index a0e9d5482e..e4779bf916 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -244,6 +244,7 @@ gen_hs_source (Info defaults entries) =
         ++ "{-# LANGUAGE MultiParamTypeClasses #-}\n"
         ++ "{-# LANGUAGE NoImplicitPrelude #-}\n"
         ++ "{-# LANGUAGE UnboxedTuples #-}\n"
+        ++ "{-# LANGUAGE NegativeLiterals #-}\n"
 
         ++ "{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}\n"
                 -- We generate a binding for coerce, like