-- | Functions for rendering generated documentation from PureScript code as

module Language.PureScript.Docs.AsHtml (

HtmlOutput(..),

HtmlOutputModule(..),

HtmlRenderContext(..),

nullRenderContext,

packageAsHtml,

moduleAsHtml,

makeFragment,

renderMarkdown

) where

import Prelude

import Control.Category ((>>>))

import Control.Monad (unless)

import Data.Bifunctor (bimap)

import Data.Char (isUpper)

import Data.Either (isRight)

import Data.List.NonEmpty qualified as NE

import Data.Maybe (fromMaybe)

import Data.Foldable (for_)

import Data.String (fromString)

import Data.Text (Text)

import Data.Text qualified as T

import Text.Blaze.Html5 as H hiding (map)

import Text.Blaze.Html5.Attributes qualified as A

import Cheapskate qualified

import Language.PureScript qualified as P

import Language.PureScript.Docs.Types

import Language.PureScript.Docs.RenderedCode (Link(..), outputWith)

import Language.PureScript.Docs.Render qualified as Render

import Language.PureScript.CST qualified as CST

data HtmlOutput a = HtmlOutput

{ htmlIndex :: [(Maybe Char, a)]

, htmlModules :: [(P.ModuleName, HtmlOutputModule a)]

}

deriving (Show, Functor)

data HtmlOutputModule a = HtmlOutputModule

{ htmlOutputModuleLocals :: a

, htmlOutputModuleReExports :: [(InPackage P.ModuleName, a)]

}

deriving (Show, Functor)

data HtmlRenderContext = HtmlRenderContext

{ buildDocLink :: Namespace -> Text -> ContainingModule -> Maybe DocLink

, renderDocLink :: DocLink -> Text

, renderSourceLink :: P.SourceSpan -> Maybe Text

}

-- |

nullRenderContext :: HtmlRenderContext

nullRenderContext = HtmlRenderContext

{ buildDocLink = const (const (const Nothing))

, renderDocLink = const ""

, renderSourceLink = const Nothing

}

packageAsHtml

:: (InPackage P.ModuleName -> Maybe HtmlRenderContext)

-> Package x

-> HtmlOutput Html

packageAsHtml getHtmlCtx Package{..} =

HtmlOutput indexFile modules

where

indexFile = []

modules = moduleAsHtml getHtmlCtx <$> pkgModules

moduleAsHtml

:: (InPackage P.ModuleName -> Maybe HtmlRenderContext)

-> Module

-> (P.ModuleName, HtmlOutputModule Html)

moduleAsHtml getHtmlCtx Module{..} = (modName, HtmlOutputModule modHtml reexports)

where

modHtml = do

let r = fromMaybe nullRenderContext $ getHtmlCtx (Local modName)

in do

for_ modComments renderMarkdown

for_ modDeclarations (declAsHtml r)

reexports =

flip map modReExports $ \(pkg, decls) ->

let r = fromMaybe nullRenderContext $ getHtmlCtx pkg

in (pkg, foldMap (declAsHtml r) decls)

declAsHtml :: HtmlRenderContext -> Declaration -> Html

declAsHtml r d@Declaration{..} = do

let declFragment = makeFragment (declInfoNamespace declInfo) declTitle

H.div ! A.class_ "decl" ! A.id (v (T.drop 1 declFragment)) $ do

h3 ! A.class_ "decl__title clearfix" $ do

a ! A.class_ "decl__anchor" ! A.href (v declFragment) $ "#"

H.span $ text declTitle

text "\x200b" -- Zero-width space to allow double-click selection of title

for_ declSourceSpan (linkToSource r)

H.div ! A.class_ "decl__body" $ do

case declInfo of

AliasDeclaration fixity alias_ ->

renderAlias fixity alias_

_ -> 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

let (instances, dctors, members) = partitionChildren declChildren

unless (null dctors) $ do

h4 "Constructors"

renderChildren r dctors

unless (null members) $ do

h4 "Members"

renderChildren r members

unless (null instances) $ do

h4 "Instances"

renderChildren r instances

where

linkToSource :: HtmlRenderContext -> P.SourceSpan -> Html

linkToSource ctx srcspan =

maybe (return ()) go (renderSourceLink ctx srcspan)

where

go href =

H.span ! A.class_ "decl__source" $

a ! A.href (v href) $ text "Source"

renderChildren :: HtmlRenderContext -> [ChildDeclaration] -> Html

renderChildren _ [] = return ()

renderChildren r xs = ul $ mapM_ item xs

where

item decl =

li ! A.id (v (T.drop 1 (fragment decl))) $ do

renderCode decl

for_ (cdeclComments decl) $ \coms ->

H.div ! A.class_ "decl__child_comments" $ renderMarkdown coms

fragment decl = makeFragment (childDeclInfoNamespace (cdeclInfo decl)) (cdeclTitle decl)

renderCode = code . codeAsHtml r . Render.renderChildDeclaration

codeAsHtml :: HtmlRenderContext -> RenderedCode -> Html

codeAsHtml r = outputWith elemAsHtml

where

elemAsHtml e = case e of

Syntax x ->

withClass "syntax" (text x)

Keyword x ->

withClass "keyword" (text x)

Space ->

text " "

Symbol ns name link_ ->

case link_ of

Link mn ->

let

class_ =

if startsWithUpper name then "ctor" else "ident"

target

| isOp name =

if ns == TypeLevel

then "type (" <> name <> ")"

else "(" <> name <> ")"

| otherwise = name

in

linkToDecl ns target mn (withClass class_ (text name))

NoLink ->

text name

Role role ->

case role of

"nominal" -> renderRole describeNominal "decl__role_nominal"

"phantom" -> renderRole describePhantom "decl__role_phantom"

-- representational is intentionally not rendered

"representational" -> toHtml ("" :: Text)

x -> P.internalError $ "codeAsHtml: unknown value for role annotation: '" <> T.unpack x <> "'"

where

renderRole hoverTextContent className =

H.a ! A.href (v docRepoRolePage) ! A.target (v "_blank") ! A.class_ "decl__role" $ do

H.abbr ! A.class_ "decl__role_hover" ! A.title (v hoverTextContent) $ do

H.sub ! A.class_ className $ do

toHtml ("" :: Text)

docRepoRolePage =

"https://github.com/purescript/documentation/blob/master/language/Roles.md"

describeNominal =

"The 'nominal' role means this argument may not change when coercing the type."

describePhantom =

"The 'phantom' role means this argument can change freely when coercing the type."

linkToDecl = linkToDeclaration r

startsWithUpper :: Text -> Bool

startsWithUpper str = not (T.null str) && isUpper (T.index str 0)

isOp = isRight . runParser CST.parseOperator

runParser :: CST.Parser x -> Text -> Either String x

runParser p' =

bimap (CST.prettyPrintError . NE.head) snd

. CST.runTokenParser p'

. CST.lex

renderLink :: HtmlRenderContext -> DocLink -> Html -> Html

renderLink r link_@DocLink{..} =

a ! A.href (v (renderDocLink r link_ <> fragmentFor link_))

! A.title (v fullyQualifiedName)

where

fullyQualifiedName =

P.runModuleName modName <> "." <> linkTitle

modName = case linkLocation of

LocalModule m -> m

DepsModule _ _ m -> m

BuiltinModule m -> m

makeFragment :: Namespace -> Text -> Text

makeFragment ns = (prefix <>) . escape

where

prefix = case ns of

TypeLevel -> "#t:"

ValueLevel -> "#v:"

-- TODO

escape = id

fragmentFor :: DocLink -> Text

fragmentFor l = makeFragment (linkNamespace l) (linkTitle l)

linkToDeclaration ::

HtmlRenderContext ->

Namespace ->

Text ->

ContainingModule ->

Html ->

Html

linkToDeclaration r ns target containMn =

maybe id (renderLink r) (buildDocLink r ns target containMn)

renderAlias :: P.Fixity -> FixityAlias -> Html

renderAlias (P.Fixity associativity precedence) alias_ =

p $ do

-- TODO: Render a link

toHtml $ "Operator alias for " <> P.showQualified showAliasName alias_ <> " "

em $

text ("(" <> associativityStr <> " / precedence " <> T.pack (show precedence) <> ")")

where

showAliasName (Left valueAlias) = P.runProperName valueAlias

showAliasName (Right typeAlias) = case typeAlias of

(Left identifier) -> P.runIdent identifier

(Right properName) -> P.runProperName properName

associativityStr = case associativity of

P.Infixl -> "left-associative"

P.Infixr -> "right-associative"

P.Infix -> "non-associative"

-- | Render Markdown to HTML. Safe for untrusted input. Relative links are

renderMarkdown :: Text -> H.Html

renderMarkdown =

H.toMarkup . removeRelativeLinks . Cheapskate.markdown opts

where

opts = Cheapskate.def { Cheapskate.allowRawHtml = False }

removeRelativeLinks :: Cheapskate.Doc -> Cheapskate.Doc

removeRelativeLinks = Cheapskate.walk go

where

go :: Cheapskate.Inlines -> Cheapskate.Inlines

go = (>>= stripRelatives)

stripRelatives :: Cheapskate.Inline -> Cheapskate.Inlines

stripRelatives (Cheapskate.Link contents_ href _)

| isRelativeURI href = contents_

stripRelatives other = pure other

-- Tests for a ':' character in the first segment of a URI.

--

-- See Section 4.2 of RFC 3986:

-- https://tools.ietf.org/html/rfc3986#section-4.2

--

-- >>> isRelativeURI "http://example.com/" == False

-- >>> isRelativeURI "mailto:me@example.com" == False

-- >>> isRelativeURI "foo/bar" == True

-- >>> isRelativeURI "/bar" == True

-- >>> isRelativeURI "./bar" == True

isRelativeURI :: Text -> Bool

isRelativeURI =

T.takeWhile (/= '/') >>> T.all (/= ':')

v :: Text -> AttributeValue

v = toValue

withClass :: String -> Html -> Html

withClass className = H.span ! A.class_ (fromString className)

partitionChildren ::

[ChildDeclaration] ->

([ChildDeclaration], [ChildDeclaration], [ChildDeclaration])

partitionChildren =

reverseAll . foldl go ([], [], [])

where

go (instances, dctors, members) rcd =

case cdeclInfo rcd of

ChildInstance _ _ -> (rcd : instances, dctors, members)

ChildDataConstructor _ -> (instances, rcd : dctors, members)

ChildTypeClassMember _ -> (instances, dctors, rcd : members)

reverseAll (xs, ys, zs) = (reverse xs, reverse ys, reverse zs)