Render.hs

-- |
-- Functions for creating `RenderedCode` values from data types in
-- Language.PureScript.Docs.Types.
--
-- These functions are the ones that are used in markdown/html documentation
-- generation, but the intention is that you are able to supply your own
-- instead if necessary. For example, the Hoogle input file generator
-- substitutes some of these

module Language.PureScript.Docs.Render where

import Prelude

import Data.Maybe (maybeToList)
import Data.Text (Text)
import Data.Text qualified as T

import Language.PureScript.Docs.RenderedCode
import Language.PureScript.Docs.Types (ChildDeclaration(..), ChildDeclarationInfo(..), Constraint', Declaration(..), DeclarationInfo(..), KindInfo(..), Type', isTypeClassMember, kindSignatureForKeyword)
import Language.PureScript.Docs.Utils.MonoidExtras (mintersperse)

import Language.PureScript.AST qualified as P
import Language.PureScript.Environment qualified as P
import Language.PureScript.Names qualified as P
import Language.PureScript.Types qualified 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
    ValueDeclaration ty ->
      [ ident' declTitle
      , syntax "::"
      , renderType ty
      ]
    DataDeclaration dtype args roles ->
      [ keyword (P.showDataDeclType dtype)
      , renderTypeWithRole roles (typeApp declTitle args)
      ]

    -- All FFI declarations, except for `Prim` modules' doc declarations,
    -- will have been converted to `DataDeclaration`s by this point.
    ExternDataDeclaration kind' _ ->
      [ keywordData
      , renderType (P.TypeConstructor () (notQualified declTitle))
      , syntax "::"
      , renderType kind'
      ]
    TypeSynonymDeclaration args ty ->
      [ keywordType
      , renderType (typeApp declTitle args)
      , syntax "="
      , renderType ty
      ]
    TypeClassDeclaration args implies fundeps ->
      [ keywordClass ]
      ++ maybeToList superclasses
      ++ [renderType (typeApp declTitle args)]
      ++ fundepsList
      ++ [keywordWhere | any isTypeClassMember declChildren]

      where
      superclasses
        | null implies = Nothing
        | otherwise = Just $
            syntax "("
            <> mintersperse (syntax "," <> sp) (map renderConstraint implies)
            <> syntax ")" <> sp <> syntax "<="

      fundepsList =
           [syntax "|" | not (null fundeps)]
        ++ [mintersperse
             (syntax "," <> sp)
             [typeVars from <> sp <> syntax "->" <> sp <> typeVars to | (from, to) <- fundeps ]
           ]
        where
          typeVars = mintersperse sp . map typeVar

    AliasDeclaration (P.Fixity associativity precedence) for ->
      [ keywordFixity associativity
      , syntax $ T.pack $ show precedence
      , alias for
      , keywordAs
      , aliasName for declTitle
      ]

renderChildDeclaration :: ChildDeclaration -> RenderedCode
renderChildDeclaration ChildDeclaration{..} =
  mintersperse sp $ case cdeclInfo of
    ChildInstance constraints ty ->
      maybeToList (renderConstraints constraints) ++ [ renderType ty ]
    ChildDataConstructor args ->
      dataCtor' cdeclTitle : map renderTypeAtom args

    ChildTypeClassMember ty ->
      [ ident' cdeclTitle
      , syntax "::"
      , renderType ty
      ]

renderConstraint :: Constraint' -> RenderedCode
renderConstraint (P.Constraint ann pn kinds tys _) =
  renderType $ foldl (P.TypeApp ann) (foldl (P.KindApp ann) (P.TypeConstructor ann (fmap P.coerceProperName pn)) kinds) tys

renderConstraints :: [Constraint'] -> Maybe RenderedCode
renderConstraints constraints
  | null constraints = Nothing
  | otherwise = Just $
        syntax "("
        <> renderedConstraints
        <> syntax ")" <> sp <> syntax "=>"
  where
  renderedConstraints =
    mintersperse (syntax "," <> sp)
                 (map renderConstraint constraints)

notQualified :: Text -> P.Qualified (P.ProperName a)
notQualified = P.Qualified P.ByNullSourcePos . P.ProperName

ident' :: Text -> RenderedCode
ident' = ident . P.Qualified P.ByNullSourcePos . P.Ident

dataCtor' :: Text -> RenderedCode
dataCtor' = dataCtor . notQualified

typeApp :: Text -> [(Text, Maybe Type')] -> Type'
typeApp title typeArgs =
  foldl (P.TypeApp ())
        (P.TypeConstructor () (notQualified title))
        (map toTypeVar typeArgs)

toTypeVar :: (Text, Maybe Type') -> Type'
toTypeVar (s, Nothing) = P.TypeVar () s
toTypeVar (s, Just k) = P.KindedType () (P.TypeVar () s) k