purescript · JordanMartinez · Jun 22, 2021 · Jun 4, 2021 · Jun 4, 2021 · Jun 4, 2021
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -8,6 +8,32 @@ Breaking changes:
 
 New features:
 
+* Display kind signatures and their comments in documentation (#4100 by JordanMartinez)
+
+  Previously, data/newtype/type/class declarations that have explicit kind
+  signatures would not display those kind signatures in their documentation.
+  For example, the two below types...
+
+  ```purescript
+  data PolyProxy :: forall k. k -> Type
+  data PolyProxy a = PolyProxy
+
+  data TypeProxy :: Type -> Type
+  data TypeProxy a = TypeProxy
+  ```
+
+  ... would only show the following information in their docs. One cannot
+  be distinguished from another due to the missing kind signatures:
+
+  ```
+  data PolyProxy a = PolyProxy
+
+  data TypeProxy a = TypeProxy
+  ```
+
+  Now, these types' kind signatures are displayed above their declarations
+  in their docs, similar to what one would see in the source code.
+
 Bugfixes:
 
 * Ensure unnamed instances appear in documentation (#4109 by @JordanMartinez)

diff --git a/app/static/pursuit.css b/app/static/pursuit.css
@@ -404,14 +404,18 @@ ol li {
   border-radius: 0;
   border-top: 1px solid #cccccc;
   border-bottom: 1px solid #cccccc;
-  padding: 0.328em 0;
+  padding: 0;
 }
 .decl__signature code {
   display: block;
+  padding: 0.328em 0;
   padding-left: 2.441em;
   text-indent: -2.441em;
   white-space: normal;
 }
+.decl__kind {
+  border-bottom: 1px solid #cccccc;
+}
 :target .decl__signature,
 :target .decl__signature code {
   /* We want the background to be transparent, even when the parent is a target */

diff --git a/app/static/pursuit.less b/app/static/pursuit.less
@@ -485,16 +485,21 @@ ol li {
   border-radius: 0;
   border-top: 1px solid darken(@background, 20%);
   border-bottom: 1px solid darken(@background, 20%);
-  padding: 0.328em 0;
+  padding: 0;
 }
 
 .decl__signature code {
   display: block;
+  padding: 0.328em 0;
   padding-left: 2.441em;
   text-indent: -2.441em;
   white-space: normal;
 }
 
+.decl__kind {
+  border-bottom: 1px solid darken(@background, 20%);
+}
+
 :target .decl__signature,
 :target .decl__signature code {
   /* We want the background to be transparent, even when the parent is a target */

diff --git a/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs
@@ -473,7 +473,9 @@ data KindSignatureFor
   | NewtypeSig
   | TypeSynonymSig
   | ClassSig
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Show, Generic)
+
+instance NFData KindSignatureFor
 
 declSourceAnn :: Declaration -> SourceAnn
 declSourceAnn (DataDeclaration sa _ _ _ _) = sa
@@ -495,6 +497,9 @@ declSourceAnn (TypeInstanceDeclaration sa _ _ _ _ _ _ _) = sa
 declSourceSpan :: Declaration -> SourceSpan
 declSourceSpan = fst . declSourceAnn
 
+-- Note: Kind Declarations' names can refer to either a `TyClassName`
+-- or a `TypeName`. Use a helper function for handling `KindDeclaration`s
+-- specifically in the context in which it is needed.
 declName :: Declaration -> Maybe Name
 declName (DataDeclaration _ _ n _ _) = Just (TyName n)
 declName (TypeSynonymDeclaration _ n _ _) = Just (TyName n)

diff --git a/lib/purescript-cst/src/Language/PureScript/AST/Exported.hs b/lib/purescript-cst/src/Language/PureScript/AST/Exported.hs
@@ -7,6 +7,7 @@ import Prelude.Compat
 import Protolude (sortOn)
 
 import Control.Category ((>>>))
+import Control.Applicative ((<|>))
 
 import Data.Maybe (mapMaybe)
 import qualified Data.Map as M
@@ -30,6 +31,8 @@ import Language.PureScript.Names
 -- list, unless there is no export list, in which case they appear in the same
 -- order as they do in the source file.
 --
+-- Kind signatures declarations are also exported if their associated
+-- declaration is exported.
 exportedDeclarations :: Module -> [Declaration]
 exportedDeclarations (Module _ _ mn decls exps) = go decls
   where
@@ -126,6 +129,11 @@ typeInstanceConstituents _ = []
 isExported :: Maybe [DeclarationRef] -> Declaration -> Bool
 isExported Nothing _ = True
 isExported _ TypeInstanceDeclaration{} = True
+isExported (Just exps) (KindDeclaration _ _ n _) = any matches exps
+  where
+  matches declRef = do
+    let refName = declRefName declRef
+    TyName n == refName || TyClassName (tyToClassName n) == refName
 isExported (Just exps) decl = any matches exps
   where
   matches declRef = declName decl == Just (declRefName declRef)
@@ -152,5 +160,14 @@ reorder refs =
   where
   refIndices =
     M.fromList $ zip (map declRefName refs) [(0::Int)..]
-  refIndex decl =
-    declName decl >>= flip M.lookup refIndices
+  refIndex = \case
+    KindDeclaration _ _ n _ ->
+      M.lookup (TyName n) refIndices <|> M.lookup (TyClassName (tyToClassName n)) refIndices
+
+    decl -> declName decl >>= flip M.lookup refIndices
+
+-- |
+-- Workaround to the fact that a `KindDeclaration`'s name's `ProperNameType`
+-- isn't the same as the corresponding `TypeClassDeclaration`'s `ProperNameType`
+tyToClassName :: ProperName 'TypeName -> ProperName 'ClassName
+tyToClassName = coerceProperName
diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs
@@ -145,9 +145,12 @@ declAsHtml r d@Declaration{..} = do
       case declInfo of
         AliasDeclaration fixity alias_ ->
           renderAlias fixity alias_
-        _ ->
-          pre ! A.class_ "decl__signature" $ code $
-            codeAsHtml r (Render.renderDeclaration d)
+        _ -> do
+          pre ! A.class_ "decl__signature" $ do
+            for_ declKind $ \kindInfo -> do
+              code ! A.class_ "decl__kind" $ do
+                codeAsHtml r (Render.renderKindSig declTitle kindInfo)
+            code $ codeAsHtml r (Render.renderDeclaration d)
 
       for_ declComments renderMarkdown
 

diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs
@@ -50,6 +50,7 @@ insertValueTypes ::
 insertValueTypes env m =
   m { modDeclarations = map go (modDeclarations m) }
   where
+  -- insert value types
   go d@Declaration { declInfo = ValueDeclaration P.TypeWildcard{} } =
     let
       ident = P.Ident . CST.getIdent . CST.nameValue . parseIdent $ declTitle d

diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs
@@ -434,6 +434,7 @@ handleEnv TypeClassEnv{..} =
           , declSourceSpan = cdeclSourceSpan
           , declChildren   = []
           , declInfo       = ValueDeclaration (addConstraint constraint typ)
+          , declKind       = Nothing
           }
       _ ->
         internalErrorInModule

diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs
@@ -66,8 +66,19 @@ type IntermediateDeclaration
 -- since they appear at the top level in the AST, and since they might need to
 -- appear as children in two places (for example, if a data type defined in a
 -- module is an instance of a type class also defined in that module).
+--
+-- The AugmentKindSig constructor allows us to add a kind signature
+-- to its corresponding declaration. Comments for both declarations
+-- are also merged together.
 data DeclarationAugment
   = AugmentChild ChildDeclaration
+  | AugmentKindSig KindSignatureInfo
+
+data KindSignatureInfo = KindSignatureInfo
+  { ksiComments :: Maybe Text
+  , ksiKeyword :: P.KindSignatureFor
+  , ksiKind :: Type'
+  }
 
 -- | Augment top-level declarations; the second pass. See the comments under
 -- the type synonym IntermediateDeclaration for more information.
@@ -86,6 +97,15 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) =
 
   augmentWith (AugmentChild child) d =
     d { declChildren = declChildren d ++ [child] }
+  augmentWith (AugmentKindSig KindSignatureInfo{..}) d =
+    d { declComments = mergeComments ksiComments $ declComments d
+      , declKind = Just $ KindInfo { kiKeyword = ksiKeyword, kiKind = ksiKind }
+      }
+    where
+      mergeComments Nothing dc = dc
+      mergeComments kc Nothing = kc
+      mergeComments (Just kcoms) (Just dcoms) =
+        Just $ kcoms <> "\n" <> dcoms
 
 getDeclarationTitle :: P.Declaration -> Maybe Text
 getDeclarationTitle (P.ValueDeclaration vd) = Just (P.showIdent (P.valdeclIdent vd))
@@ -97,6 +117,7 @@ getDeclarationTitle (P.TypeClassDeclaration _ name _ _ _ _) = Just (P.runProperN
 getDeclarationTitle (P.TypeInstanceDeclaration _ _ _ name _ _ _ _) = Just $ either (const "<anonymous>") P.showIdent name
 getDeclarationTitle (P.TypeFixityDeclaration _ _ _ op) = Just ("type " <> P.showOp op)
 getDeclarationTitle (P.ValueFixityDeclaration _ _ _ op) = Just (P.showOp op)
+getDeclarationTitle (P.KindDeclaration _ _ n _) = Just (P.runProperName n)
 getDeclarationTitle _ = Nothing
 
 -- | Create a basic Declaration value.
@@ -107,6 +128,7 @@ mkDeclaration (ss, com) title info =
               , declSourceSpan = Just ss -- TODO: make this non-optional when we next break the format
               , declChildren   = []
               , declInfo       = info
+              , declKind       = Nothing -- kind sigs are added in augment pass
               }
 
 basicDeclaration :: P.SourceAnn -> Text -> DeclarationInfo -> Maybe IntermediateDeclaration
@@ -159,6 +181,11 @@ convertDeclaration (P.ValueFixityDeclaration sa fixity (P.Qualified mn alias) _)
   Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.Qualified mn (Right alias)))
 convertDeclaration (P.TypeFixityDeclaration sa fixity (P.Qualified mn alias) _) title =
   Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.Qualified mn (Left alias)))
+convertDeclaration (P.KindDeclaration sa keyword _ kind) title =
+  Just $ Left ([(title, AugmentType), (title, AugmentClass)], AugmentKindSig ksi)
+  where
+    comms = convertComments $ snd sa
+    ksi = KindSignatureInfo { ksiComments = comms, ksiKeyword = keyword, ksiKind = kind $> () }
 convertDeclaration _ _ = Nothing
 
 convertComments :: [P.Comment] -> Maybe Text

diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs
@@ -183,6 +183,7 @@ primTypeOf gen title comments = Declaration
   , declSourceSpan = Nothing
   , declChildren = []
   , declInfo = ExternDataDeclaration (lookupPrimTypeKindOf gen title)
+  , declKind = Nothing
   }
 
 -- | Lookup the TypeClassData of a Prim class. This function is specifically
@@ -214,6 +215,7 @@ primClassOf gen title comments = Declaration
         fundeps = convertFundepsToStrings args (P.typeClassDependencies tcd)
       in
         TypeClassDeclaration args superclasses fundeps
+  , declKind = Nothing
   }
 
 kindType :: Declaration

diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs
@@ -24,6 +24,15 @@ import qualified Language.PureScript.Environment as P
 import qualified Language.PureScript.Names as P
 import qualified Language.PureScript.Types as P
 
+renderKindSig :: Text -> KindInfo -> RenderedCode
+renderKindSig declTitle KindInfo{..} =
+  mintersperse sp
+      [ keyword $ kindSignatureForKeyword kiKeyword
+      , renderType (P.TypeConstructor () (notQualified declTitle))
+      , syntax "::"
+      , renderType kiKind
+      ]
+
 renderDeclaration :: Declaration -> RenderedCode
 renderDeclaration Declaration{..} =
   mintersperse sp $ case declInfo of

diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs
@@ -30,6 +30,7 @@ module Language.PureScript.Docs.RenderedCode.Types
  , keywordFixity
  , keywordKind
  , keywordAs
+ , kindSignatureFor
  , ident
  , dataCtor
  , typeCtor
@@ -54,6 +55,7 @@ import qualified Data.Text.Encoding as TE
 
 import Language.PureScript.Names
 import Language.PureScript.AST (Associativity(..))
+import qualified Language.PureScript.AST.Declarations as P
 
 -- | Given a list of actions, attempt them all, returning the first success.
 -- If all the actions fail, 'tryAll' returns the first argument.
@@ -307,6 +309,13 @@ keywordKind = keyword "kind"
 keywordAs :: RenderedCode
 keywordAs = keyword "as"
 
+kindSignatureFor :: P.KindSignatureFor -> RenderedCode
+kindSignatureFor = \case
+  P.DataSig -> keywordData
+  P.NewtypeSig -> keywordNewtype
+  P.TypeSynonymSig -> keywordType
+  P.ClassSig -> keywordClass
+
 ident :: Qualified Ident -> RenderedCode
 ident (fromQualified -> (mn, name)) =
   RC [Symbol ValueLevel (runIdent name) (Link mn)]

diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs
@@ -132,6 +132,7 @@ data Declaration = Declaration
   , declSourceSpan :: Maybe P.SourceSpan
   , declChildren   :: [ChildDeclaration]
   , declInfo       :: DeclarationInfo
+  , declKind       :: Maybe KindInfo
   }
   deriving (Show, Eq, Ord, Generic)
 
@@ -184,6 +185,17 @@ data DeclarationInfo
 
 instance NFData DeclarationInfo
 
+-- |
+-- Wraps enough information to properly render the kind signature
+-- of a data/newtype/type/class declaration.
+data KindInfo = KindInfo
+  { kiKeyword :: P.KindSignatureFor
+  , kiKind :: Type'
+  }
+  deriving (Show, Eq, Ord, Generic)
+
+instance NFData KindInfo
+
 convertFundepsToStrings :: [(Text, Maybe Type')] -> [P.FunctionalDependency] -> [([Text], [Text])]
 convertFundepsToStrings args fundeps =
   map (\(P.FunctionalDependency from to) -> toArgs from to) fundeps
@@ -347,6 +359,7 @@ data PackageError
   | InvalidFixity
   | InvalidKind Text
   | InvalidDataDeclType Text
+  | InvalidKindSignatureFor Text
   | InvalidTime
   deriving (Show, Eq, Ord, Generic)
 
@@ -530,6 +543,8 @@ displayPackageError e = case e of
     "Invalid kind: \"" <> str <> "\""
   InvalidDataDeclType str ->
     "Invalid data declaration type: \"" <> str <> "\""
+  InvalidKindSignatureFor str ->
+    "Invalid kind signature keyword: \"" <> str <> "\""
   InvalidTime ->
     "Invalid time"
 
@@ -560,6 +575,7 @@ asDeclaration =
               <*> key "sourceSpan" (perhaps asSourceSpan)
               <*> key "children" (eachInArray asChildDeclaration)
               <*> key "info" asDeclarationInfo
+              <*> keyOrDefault "kind" Nothing (perhaps asKindInfo)
 
 asReExport :: Parse PackageError (InPackage P.ModuleName, [Declaration])
 asReExport =
@@ -631,6 +647,20 @@ asDeclarationInfo = do
     other ->
       throwCustomError (InvalidDeclarationType other)
 
+asKindInfo :: Parse PackageError KindInfo
+asKindInfo =
+  KindInfo <$> key "keyword" asKindSignatureFor
+           <*> key "kind" asType
+
+asKindSignatureFor :: Parse PackageError P.KindSignatureFor
+asKindSignatureFor =
+  withText $ \case
+    "data" -> Right P.DataSig
+    "newtype" -> Right P.NewtypeSig
+    "class" -> Right P.ClassSig
+    "type" -> Right P.TypeSynonymSig
+    x -> Left (InvalidKindSignatureFor x)
+
 asTypeArguments :: Parse PackageError [(Text, Maybe Type')]
 asTypeArguments = eachInArray asTypeArgument
   where
@@ -777,8 +807,22 @@ instance A.ToJSON Declaration where
              , "sourceSpan" .= declSourceSpan
              , "children"   .= declChildren
              , "info"       .= declInfo
+             , "kind"       .= declKind
              ]
 
+instance A.ToJSON KindInfo where
+ toJSON KindInfo{..} =
+   A.object [ "keyword" .= kindSignatureForKeyword kiKeyword
+            , "kind"    .= kiKind
+            ]
+
+kindSignatureForKeyword :: P.KindSignatureFor -> Text
+kindSignatureForKeyword = \case
+  P.DataSig -> "data"
+  P.NewtypeSig -> "newtype"
+  P.TypeSynonymSig -> "type"
+  P.ClassSig -> "class"
+
 instance A.ToJSON ChildDeclaration where
   toJSON ChildDeclaration{..} =
     A.object [ "title"      .= cdeclTitle