Improve generated `GHC.Prim` docs

Summary:
* Extended `genprimcode` to generate Haddock-compatible deprecations,
  as well as displaying information about which functions are LLVM-only
  and which functions can fail with an unchecked exception.

* Ported existing deprecations to the new format, and also added a
  deprecation on `par#` (see Trac #15227).

* Emit an error on fixity/deprecation of builtins, unless we are
  processing the module in which that name is defined (see Trac #15233).
  That means the following is no longer accepted (outside of `GHC.Types`):

```
infixr 7 :
{-# DEPRECATED (:) "cons is deprecated" #-}
```

* Generate `data (->) a b` with docs and fixity in `GHC.Prim`. This
  means: GHC can now parse `data (->) a b` and `infixr 0 ->` (only in
  `GHC.Prim`) and `genprimcode` can digest `primtype (->) a b` (See Trac
  #4861)

as well as some misc fixes along the way.

Reviewers: bgamari, RyanGlScott

Reviewed By: RyanGlScott

Subscribers: RyanGlScott, rwbarton, mpickering, carter

GHC Trac Issues: #15227, #15233, #4861

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

3 files changed, 91 insertions, 47 deletions

diff --git a/utils/genprimopcode/Lexer.x b/utils/genprimopcode/Lexer.x
index ad2590bcb8..06624b2ec0 100644
--- a/utils/genprimopcode/Lexer.x
+++ b/utils/genprimopcode/Lexer.x
@@ -68,7 +68,7 @@ words :-
     <0>         "VECTUPLE"          { mkT TVECTUPLE }
     <0>         [a-z][a-zA-Z0-9\#_]* { mkTv TLowerName }
     <0>         [A-Z][a-zA-Z0-9\#_]* { mkTv TUpperName }
-    <0>         [0-9][0-9]*         { mkTv (TInteger . read) }
+    <0>         \-? [0-9][0-9]*     { mkTv (TInteger . read) }
     <0>         \" [^\"]* \"        { mkTv (TString . tail . init) }
     <in_braces> [^\{\}]+            { mkTv TNoBraces }
     <in_braces> \n                  { mkTv TNoBraces }
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index c409050250..a0e9d5482e 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -273,7 +273,7 @@ gen_hs_source (Info defaults entries) =
                      -- the base package when haddocking ghc-prim
 
        -- Now the main payload
-    ++ unlines (concatMap ent entries') ++ "\n\n\n"
+    ++ "\n" ++ unlines (concatMap ent entries') ++ "\n\n\n"
 
      where entries' = concatMap desugarVectorSpec entries
 
@@ -288,11 +288,17 @@ gen_hs_source (Info defaults entries) =
            hdr (PrimOpSpec { name = n })                         = wrapOp n ++ ","
            hdr (PrimVecOpSpec { name = n })                      = wrapOp n ++ ","
            hdr (PseudoOpSpec { name = n })                       = wrapOp n ++ ","
-           hdr (PrimTypeSpec { ty = TyApp (TyCon n) _ })         = wrapTy n ++ ","
+           hdr (PrimTypeSpec { ty = TyApp (TyCon "->") _ })      = ""
+                  -- GHC lacks the syntax to explicitly export "->"
+           hdr (PrimTypeSpec { ty = TyApp (TyCon n) _ })         = wrapOp n ++ ","
            hdr (PrimTypeSpec {})                                 = error $ "Illegal type spec"
-           hdr (PrimVecTypeSpec { ty = TyApp (VecTyCon n _) _ }) = wrapTy n ++ ","
+           hdr (PrimVecTypeSpec { ty = TyApp (VecTyCon n _) _ }) = wrapOp n ++ ","
            hdr (PrimVecTypeSpec {})                              = error $ "Illegal type spec"
 
+           sec s = "\n-- * " ++ escape (title s) ++ "\n"
+                    ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s)
+
+
            ent   (Section {})         = []
            ent o@(PrimOpSpec {})      = spec o
            ent o@(PrimVecOpSpec {})   = spec o
@@ -300,48 +306,67 @@ gen_hs_source (Info defaults entries) =
            ent o@(PrimVecTypeSpec {}) = spec o
            ent o@(PseudoOpSpec {})    = spec o
 
-           sec s = "\n-- * " ++ escape (title s) ++ "\n"
-                        ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s) ++ "\n"
-
-           spec o = comm : decls
-             where decls = case o of  -- See Note [Placeholder declarations]
-                        PrimOpSpec { name = n, ty = t, opts = options } ->
-                            prim_fixity n options ++ prim_decl n t
-                        PrimVecOpSpec { name = n, ty = t, opts = options } ->
-                            prim_fixity n options ++ prim_decl n t
-                        PseudoOpSpec { name = n, ty = t } ->
-                            prim_decl n t
-                        PrimTypeSpec { ty = t }   ->
-                            [ "data " ++ pprTy t ]
-                        PrimVecTypeSpec { ty = t }   ->
-                            [ "data " ++ pprTy t ]
-                        Section { } -> []
-
-                   comm = case (desc o) of
-                        [] -> ""
-                        d -> "\n" ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ d)
-
-           prim_fixity n options = [ pprFixity fixity n | OptionFixity (Just fixity) <- options ]
-
-           prim_decl n t = [ wrapOp n ++ " :: " ++ pprTy t,
-                             wrapOp n ++ " = " ++ wrapOpRhs n ]
-
-           wrapOp nm | isAlpha (head nm) = nm
-                     | otherwise         = "(" ++ nm ++ ")"
-
-           wrapTy nm | isAlpha (head nm) = nm
-                     | otherwise         = "(" ++ nm ++ ")"
-
-           wrapOpRhs "tagToEnum#" = "let x = x in x"
-           wrapOpRhs nm           = wrapOp nm
+           spec o = ([ "" ] ++) . concat $
+             -- Doc comments
+             [ case unlatex (escape (desc o)) ++ extra (opts o) of
+                 "" -> []
+                 cmmt -> map ("-- " ++) $ lines $ "|" ++ cmmt
+
+             -- Deprecations
+             , [ d | Just n <- [getName o], d <- prim_deprecated (opts o) n ]
+
+             -- Fixity
+             , [ f | Just n <- [getName o], f <- prim_fixity (opts o) n ]
+
+             -- Declarations (see Note [Placeholder declarations])
+             , case o of
+                 PrimOpSpec { name = n, ty = t }    -> prim_func n t
+                 PrimVecOpSpec { name = n, ty = t } -> prim_func n t
+                 PseudoOpSpec { name = n, ty = t }  -> prim_func n t
+                 PrimTypeSpec { ty = t }    -> prim_data t
+                 PrimVecTypeSpec { ty = t } -> prim_data t
+                 Section { } -> error "Section is not an entity"
+             ]
+
+           extra options = case on_llvm_only options ++ can_fail options of
+             [m1,m2] -> "\n\n__/Warning:/__ this " ++ m1 ++ " and " ++ m2 ++ "."
+             [m] -> "\n\n__/Warning:/__ this " ++ m ++ "."
+             _ -> ""
+
+           on_llvm_only options
+             = [ "is only available on LLVM"
+               | Just (OptionTrue _) <- [lookup_attrib "llvm_only" options] ]
+
+           can_fail options
+             = [ "can fail with an unchecked exception"
+               | Just (OptionTrue _) <- [lookup_attrib "can_fail" options] ]
+
+           prim_deprecated options n
+              = [ "{-# DEPRECATED " ++ wrapOp n ++ " \"" ++ msg ++ "\" #-}"
+                | Just (OptionString _ msg)
+                    <- [lookup_attrib "deprecated_msg" options] ]
+
+           prim_fixity options n
+              = [ pprFixityDir d ++ " " ++ show i ++ " " ++ asInfix n
+                | OptionFixity (Just (Fixity _ i d)) <- options ]
+
+           prim_func n t = [ wrapOp n ++ " :: " ++ pprTy t,
+                             wrapOp n ++ " = " ++ funcRhs n ]
+
+           funcRhs "tagToEnum#" = "let x = x in x"
+           funcRhs nm           = wrapOp nm
               -- Special case for tagToEnum#: see Note [Placeholder declarations]
 
+           prim_data t = [ "data " ++ pprTy t ]
+
            unlatex s = case s of
                 '\\':'t':'e':'x':'t':'t':'t':'{':cs -> markup "@" "@" cs
+                '{':'\\':'t':'e':'x':'t':'t':'t':' ':cs -> markup "@" "@" cs
                 '{':'\\':'t':'t':cs -> markup "@" "@" cs
                 '{':'\\':'i':'t':cs -> markup "/" "/" cs
+                '{':'\\':'e':'m':cs -> markup "/" "/" cs
                 c : cs -> c : unlatex cs
-                [] -> []
+                "" -> ""
            markup s t xs = s ++ mk (dropWhile isSpace xs)
                 where mk ""        = t
                       mk ('\n':cs) = ' ' : mk cs
@@ -350,8 +375,13 @@ gen_hs_source (Info defaults entries) =
            escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[])
                 where special = "/'`\"@<"
 
-           pprFixity (Fixity _ i d) n
-             = pprFixityDir d ++ " " ++ show i ++ " " ++ n
+-- | Extract a string representation of the name
+getName :: Entry -> Maybe String
+getName PrimOpSpec{ name = n } = Just n
+getName PrimVecOpSpec{ name = n } = Just n
+getName PseudoOpSpec{ name = n } = Just n
+getName PrimTypeSpec{ ty = TyApp tc _ } = Just (show tc)
+getName _ = Nothing
 
 {- Note [Placeholder declarations]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -374,13 +404,15 @@ We don't do this for *all* bindings because for ones with an unboxed
 RHS we would get other complaints (e.g.can't unify "*" with "#").
 -}
 
+-- | "Pretty"-print a type
 pprTy :: Ty -> String
 pprTy = pty
     where
           pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
           pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2
           pty t      = pbty t
-          pbty (TyApp tc ts) = show tc ++ concat (map (' ' :) (map paty ts))
+
+          pbty (TyApp tc ts) = unwords (wrapOp (show tc) : map paty ts)
           pbty (TyUTup ts)   = "(# "
                             ++ concat (intersperse "," (map pty ts))
                             ++ " #)"
@@ -389,6 +421,16 @@ pprTy = pty
           paty (TyVar tv)    = tv
           paty t             = "(" ++ pty t ++ ")"
 
+-- | Turn an identifier or operator into its prefix form
+wrapOp :: String -> String
+wrapOp nm | isAlpha (head nm) = nm
+          | otherwise         = "(" ++ nm ++ ")"
+
+-- | Turn an identifer or operator into its infix form
+asInfix :: String -> String
+asInfix nm | isAlpha (head nm) = "`" ++ nm ++ "`"
+           | otherwise         = nm
+
 gen_latex_doc :: Info -> String
 gen_latex_doc (Info defaults entries)
    = "\\primopdefaults{"
@@ -565,9 +607,10 @@ gen_latex_doc (Info defaults entries)
 
 gen_wrappers :: Info -> String
 gen_wrappers (Info _ entries)
-   = "{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples #-}\n"
+   =    "{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples #-}\n"
         -- Dependencies on Prelude must be explicit in libraries/base, but we
         -- don't need the Prelude here so we add NoImplicitPrelude.
+     ++ "{-# OPTIONS_GHC -Wno-deprecations #-}\n"
      ++ "module GHC.PrimopWrappers where\n"
      ++ "import qualified GHC.Prim\n"
      ++ "import GHC.Tuple ()\n"
diff --git a/utils/genprimopcode/Parser.y b/utils/genprimopcode/Parser.y
index cd712d7584..89e61d5236 100644
--- a/utils/genprimopcode/Parser.y
+++ b/utils/genprimopcode/Parser.y
@@ -183,10 +183,11 @@ ppT : lowerName { TyVar $1 }
 
 pTycon :: { TyCon }
 pTycon : upperName { TyCon $1 }
-       | '(' ')'   { TyCon "()" }
-       | SCALAR    { SCALAR }
-       | VECTOR    { VECTOR }
-       | VECTUPLE  { VECTUPLE }
+       | '(' ')'      { TyCon "()" }
+       | '(' '->' ')' { TyCon "->" }
+       | SCALAR       { SCALAR }
+       | VECTOR       { VECTOR }
+       | VECTUPLE     { VECTUPLE }
 
 {
 parse :: String -> Either String Info