From 2c23e2e37d6c937a425c53da643aec90bda01ef6 Mon Sep 17 00:00:00 2001
From: mniip <mniip@mniip.com>
Date: Wed, 22 Apr 2020 22:40:58 +0300
Subject: [PATCH] Include docs for non-primop entries in primops.txt as well
---
compiler/GHC/Builtin/PrimOps.hs | 8 +++++++-
compiler/GHC/Builtin/Utils.hs | 13 ++++++++++---
utils/genprimopcode/Main.hs | 13 +++++--------
3 files changed, 22 insertions(+), 12 deletions(-)
diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs
index b3861c83aae9..75622f739945 100644
--- a/compiler/GHC/Builtin/PrimOps.hs
+++ b/compiler/GHC/Builtin/PrimOps.hs
@@ -167,9 +167,15 @@ primOpFixity :: PrimOp -> Maybe Fixity
\subsubsection{Docs}
* *
************************************************************************
+
+@primOpDocs@ contains the documentation from @primops.txt@ as a list of
+pairs (name, docs). We use stringy names here because wired-in names are
+not available yet, and not all of them are a @PrimOp@ (they could be
+tycons or pseudoops for example)
+
-}
-primOpDocs :: PrimOp -> Maybe String
+primOpDocs :: [(String, String)]
#include "primop-docs.hs-incl"
{-
diff --git a/compiler/GHC/Builtin/Utils.hs b/compiler/GHC/Builtin/Utils.hs
index 1c7ede7c6486..2b8b0bf69832 100644
--- a/compiler/GHC/Builtin/Utils.hs
+++ b/compiler/GHC/Builtin/Utils.hs
@@ -75,7 +75,7 @@ import GHC.Builtin.Types.Literals ( typeNatTyCons )
import GHC.Hs.Doc
import Control.Applicative ((<|>))
-import Data.List ( intercalate )
+import Data.List ( intercalate , find )
import Data.Array
import Data.Maybe
import qualified Data.Map as Map
@@ -260,8 +260,15 @@ ghcPrimExports
| 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
+ghcPrimDeclDocs = DeclDocMap $ Map.fromList $ mapMaybe findName primOpDocs
+ where
+ names = map idName ghcPrimIds ++
+ map (idName . primOpId) allThePrimOps ++
+ map tyConName (funTyCon : exposedPrimTyCons)
+ findName (nameStr, doc)
+ | Just name <- find ((nameStr ==) . getOccString) names
+ = Just (name, mkHsDocString doc)
+ | otherwise = Nothing
{-
************************************************************************
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index 93291698b3ad..63b51b9f5d61 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -388,6 +388,7 @@ 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 PrimVecTypeSpec{ ty = TyApp tc _ } = Just (show tc)
getName _ = Nothing
{- Note [Placeholder declarations]
@@ -790,15 +791,11 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults entries)
gen_wired_in_docs :: Info -> String
gen_wired_in_docs (Info _ entries)
- = unlines $ catMaybes (map mkAlt (filter is_primop entries)) ++ [funName ++ " _ = Nothing"]
+ = "primOpDocs =\n [ " ++ intercalate "\n , " (catMaybes $ map mkDoc $ concatMap desugarVectorSpec entries) ++ "\n ]\n"
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"
+ mkDoc po | Just poName <- getName po
+ , not $ null $ desc po = Just $ show (poName, unlatex $ desc po)
+ | otherwise = Nothing
------------------------------------------------------------------
-- Create PrimOpInfo text from PrimOpSpecs -----------------------
--
GitLab