Add :doc to GHC.Prim

7 files changed, 60 insertions, 18 deletions

diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs
index e85c12a55d..b3861c83aa 100644
--- a/compiler/GHC/Builtin/PrimOps.hs
+++ b/compiler/GHC/Builtin/PrimOps.hs
@@ -16,7 +16,7 @@ module GHC.Builtin.PrimOps (
 
         primOpOutOfLine, primOpCodeSize,
         primOpOkForSpeculation, primOpOkForSideEffects,
-        primOpIsCheap, primOpFixity,
+        primOpIsCheap, primOpFixity, primOpDocs,
 
         getPrimOpResultInfo,  isComparisonPrimOp, PrimOpResultInfo(..),
 
@@ -164,6 +164,17 @@ primOpFixity :: PrimOp -> Maybe Fixity
 {-
 ************************************************************************
 *                                                                      *
+\subsubsection{Docs}
+*                                                                      *
+************************************************************************
+-}
+
+primOpDocs :: PrimOp -> Maybe String
+#include "primop-docs.hs-incl"
+
+{-
+************************************************************************
+*                                                                      *
 \subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops}
 *                                                                      *
 ************************************************************************
diff --git a/compiler/GHC/Builtin/Utils.hs b/compiler/GHC/Builtin/Utils.hs
index 0725ee85fa..1c7ede7c64 100644
--- a/compiler/GHC/Builtin/Utils.hs
+++ b/compiler/GHC/Builtin/Utils.hs
@@ -34,6 +34,7 @@ module GHC.Builtin.Utils (
         primOpRules, builtinRules,
 
         ghcPrimExports,
+        ghcPrimDeclDocs,
         primOpId,
 
         -- * Random other things
@@ -71,11 +72,13 @@ import GHC.Core.TyCon
 import GHC.Types.Unique.FM
 import Util
 import GHC.Builtin.Types.Literals ( typeNatTyCons )
+import GHC.Hs.Doc
 
 import Control.Applicative ((<|>))
 import Data.List        ( intercalate )
 import Data.Array
 import Data.Maybe
+import qualified Data.Map as Map
 
 {-
 ************************************************************************
@@ -256,6 +259,10 @@ ghcPrimExports
    [ AvailTC n [n] []
    | tc <- funTyCon : exposedPrimTyCons, let n = tyConName tc  ]
 
+ghcPrimDeclDocs :: DeclDocMap
+ghcPrimDeclDocs = DeclDocMap $ Map.fromList $ mapMaybe mkDeclDoc allThePrimOps
+  where mkDeclDoc po = fmap (\doc -> (idName (primOpId po), mkHsDocString doc)) $ primOpDocs po
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
index 8fc46734c2..4a0ed966d1 100644
--- a/compiler/GHC/Iface/Load.hs
+++ b/compiler/GHC/Iface/Load.hs
@@ -1049,7 +1049,8 @@ ghcPrimIface
         mi_exports  = ghcPrimExports,
         mi_decls    = [],
         mi_fixities = fixities,
-        mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities }
+        mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities },
+        mi_decl_docs = ghcPrimDeclDocs
         }
   where
     empty_iface = emptyFullModIface gHC_PRIM
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index 561926af44..d86aae9771 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -119,7 +119,8 @@ PRIMOP_BITS_NAMES = primop-data-decl.hs-incl        \
                     primop-vector-uniques.hs-incl   \
                     primop-vector-tys.hs-incl       \
                     primop-vector-tys-exports.hs-incl \
-                    primop-vector-tycons.hs-incl
+                    primop-vector-tycons.hs-incl    \
+                    primop-docs.hs-incl
 
 PRIMOP_BITS_STAGE1 = $(addprefix compiler/stage1/build/,$(PRIMOP_BITS_NAMES))
 PRIMOP_BITS_STAGE2 = $(addprefix compiler/stage2/build/,$(PRIMOP_BITS_NAMES))
@@ -166,6 +167,8 @@ compiler/stage$1/build/primop-vector-tys-exports.hs-incl: compiler/stage$1/build
 	"$$(genprimopcode_INPLACE)" --primop-vector-tys-exports < $$< > $$@
 compiler/stage$1/build/primop-vector-tycons.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE)
 	"$$(genprimopcode_INPLACE)" --primop-vector-tycons      < $$< > $$@
+compiler/stage$1/build/primop-docs.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE)
+	"$$(genprimopcode_INPLACE)" --wired-in-docs             < $$< > $$@
 
 # Usages aren't used any more; but the generator
 # can still generate them if we want them back
diff --git a/hadrian/src/Rules/Generate.hs b/hadrian/src/Rules/Generate.hs
index c943d97129..51afdf8724 100644
--- a/hadrian/src/Rules/Generate.hs
+++ b/hadrian/src/Rules/Generate.hs
@@ -73,7 +73,8 @@ compilerDependencies = do
                   , "primop-vector-tycons.hs-incl"
                   , "primop-vector-tys-exports.hs-incl"
                   , "primop-vector-tys.hs-incl"
-                  , "primop-vector-uniques.hs-incl" ] ]
+                  , "primop-vector-uniques.hs-incl"
+                  , "primop-docs.hs-incl" ] ]
 
 generatedDependencies :: Expr [FilePath]
 generatedDependencies = do
diff --git a/hadrian/src/Settings/Builders/GenPrimopCode.hs b/hadrian/src/Settings/Builders/GenPrimopCode.hs
index e616ed3b43..2640ee14c7 100644
--- a/hadrian/src/Settings/Builders/GenPrimopCode.hs
+++ b/hadrian/src/Settings/Builders/GenPrimopCode.hs
@@ -21,4 +21,5 @@ genPrimopCodeBuilderArgs = builder GenPrimopCode ? mconcat
     , output "//primop-vector-tys.hs-incl"         ? arg "--primop-vector-tys"
     , output "//primop-vector-tys-exports.hs-incl" ? arg "--primop-vector-tys-exports"
     , output "//primop-vector-tycons.hs-incl"      ? arg "--primop-vector-tycons"
+    , output "//primop-docs.hs-incl"               ? arg "--wired-in-docs"
     , output "//primop-usage.hs-incl"              ? arg "--usage" ]
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index 5e34ee97c1..93291698b3 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -189,6 +189,9 @@ main = getArgs >>= \args ->
                       "--make-latex-doc"
                          -> putStr (gen_latex_doc p_o_specs)
 
+                      "--wired-in-docs"
+                         -> putStr (gen_wired_in_docs p_o_specs)
+
                       _ -> error "Should not happen, known_args out of sync?"
                    )
 
@@ -211,7 +214,8 @@ known_args
        "--primop-vector-tycons",
        "--make-haskell-wrappers",
        "--make-haskell-source",
-       "--make-latex-doc"
+       "--make-latex-doc",
+       "--wired-in-docs"
      ]
 
 ------------------------------------------------------------------
@@ -360,22 +364,24 @@ gen_hs_source (Info defaults entries) =
 
            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
-                      mk ('}':cs)  = t ++ unlatex cs
-                      mk (c:cs)    = c : mk cs
            escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[])
                 where special = "/'`\"@<"
 
+unlatex :: String -> String
+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
+  "" -> ""
+  where markup b e xs = b ++ mk (dropWhile isSpace xs)
+          where mk ""        = e
+                mk ('\n':cs) = ' ' : mk cs
+                mk ('}':cs)  = e ++ unlatex cs
+                mk (c:cs)    = c : mk cs
+
 -- | Extract a string representation of the name
 getName :: Entry -> Maybe String
 getName PrimOpSpec{ name = n } = Just n
@@ -782,6 +788,18 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults entries)
                -> unlines alternatives
                   ++ fn_name ++ " _ = " ++ getAltRhs xx ++ "\n"
 
+gen_wired_in_docs :: Info -> String
+gen_wired_in_docs (Info _ entries)
+  = unlines $ catMaybes (map mkAlt (filter is_primop entries)) ++ [funName ++ " _ = Nothing"]
+    where
+      mkAlt po | null (desc po) = Nothing
+               | otherwise = Just (funName ++ " " ++ mkLHS po ++ " = Just " ++ show (unlatex (desc po)))
+      mkLHS po = case vecOptions po of
+        [] -> cons po
+        _  -> "(" ++ cons po ++ " _ _ _)"
+
+      funName = "primOpDocs"
+
 ------------------------------------------------------------------
 -- Create PrimOpInfo text from PrimOpSpecs -----------------------
 ------------------------------------------------------------------