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

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 qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe)
import Data.Foldable (for_)
import Data.String (fromString)

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

import Text.Blaze.Html5 as H hiding (map)
import qualified Text.Blaze.Html5.Attributes as A
import qualified Cheapskate

import qualified Language.PureScript as P

import Language.PureScript.Docs.Types
import Language.PureScript.Docs.RenderedCode hiding (sp)
import qualified Language.PureScript.Docs.Render as Render
import qualified Language.PureScript.CST as CST

data HtmlOutput a = HtmlOutput
  { forall a. HtmlOutput a -> [(Maybe Char, a)]
htmlIndex     :: [(Maybe Char, a)]
  , forall a. HtmlOutput a -> [(ModuleName, HtmlOutputModule a)]
htmlModules   :: [(P.ModuleName, HtmlOutputModule a)]
  }
  deriving (Int -> HtmlOutput a -> ShowS
forall a. Show a => Int -> HtmlOutput a -> ShowS
forall a. Show a => [HtmlOutput a] -> ShowS
forall a. Show a => HtmlOutput a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HtmlOutput a] -> ShowS
$cshowList :: forall a. Show a => [HtmlOutput a] -> ShowS
show :: HtmlOutput a -> String
$cshow :: forall a. Show a => HtmlOutput a -> String
showsPrec :: Int -> HtmlOutput a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> HtmlOutput a -> ShowS
Show, forall a b. a -> HtmlOutput b -> HtmlOutput a
forall a b. (a -> b) -> HtmlOutput a -> HtmlOutput b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> HtmlOutput b -> HtmlOutput a
$c<$ :: forall a b. a -> HtmlOutput b -> HtmlOutput a
fmap :: forall a b. (a -> b) -> HtmlOutput a -> HtmlOutput b
$cfmap :: forall a b. (a -> b) -> HtmlOutput a -> HtmlOutput b
Functor)

data HtmlOutputModule a = HtmlOutputModule
  { forall a. HtmlOutputModule a -> a
htmlOutputModuleLocals    :: a
  , forall a. HtmlOutputModule a -> [(InPackage ModuleName, a)]
htmlOutputModuleReExports :: [(InPackage P.ModuleName, a)]
  }
  deriving (Int -> HtmlOutputModule a -> ShowS
forall a. Show a => Int -> HtmlOutputModule a -> ShowS
forall a. Show a => [HtmlOutputModule a] -> ShowS
forall a. Show a => HtmlOutputModule a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HtmlOutputModule a] -> ShowS
$cshowList :: forall a. Show a => [HtmlOutputModule a] -> ShowS
show :: HtmlOutputModule a -> String
$cshow :: forall a. Show a => HtmlOutputModule a -> String
showsPrec :: Int -> HtmlOutputModule a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> HtmlOutputModule a -> ShowS
Show, forall a b. a -> HtmlOutputModule b -> HtmlOutputModule a
forall a b. (a -> b) -> HtmlOutputModule a -> HtmlOutputModule b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> HtmlOutputModule b -> HtmlOutputModule a
$c<$ :: forall a b. a -> HtmlOutputModule b -> HtmlOutputModule a
fmap :: forall a b. (a -> b) -> HtmlOutputModule a -> HtmlOutputModule b
$cfmap :: forall a b. (a -> b) -> HtmlOutputModule a -> HtmlOutputModule b
Functor)

data HtmlRenderContext = HtmlRenderContext
  { HtmlRenderContext
-> Namespace -> Text -> ContainingModule -> Maybe DocLink
buildDocLink :: Namespace -> Text -> ContainingModule -> Maybe DocLink
  , HtmlRenderContext -> DocLink -> Text
renderDocLink :: DocLink -> Text
  , HtmlRenderContext -> SourceSpan -> Maybe Text
renderSourceLink :: P.SourceSpan -> Maybe Text
  }

-- |
-- An HtmlRenderContext for when you don't want to render any links.
nullRenderContext :: HtmlRenderContext
nullRenderContext :: HtmlRenderContext
nullRenderContext = HtmlRenderContext
  { buildDocLink :: Namespace -> Text -> ContainingModule -> Maybe DocLink
buildDocLink = forall a b. a -> b -> a
const (forall a b. a -> b -> a
const (forall a b. a -> b -> a
const forall a. Maybe a
Nothing))
  , renderDocLink :: DocLink -> Text
renderDocLink = forall a b. a -> b -> a
const Text
""
  , renderSourceLink :: SourceSpan -> Maybe Text
renderSourceLink = forall a b. a -> b -> a
const forall a. Maybe a
Nothing
  }

packageAsHtml
    :: (InPackage P.ModuleName -> Maybe HtmlRenderContext)
    -> Package a
    -> HtmlOutput Html
packageAsHtml :: forall a.
(InPackage ModuleName -> Maybe HtmlRenderContext)
-> Package a -> HtmlOutput Html
packageAsHtml InPackage ModuleName -> Maybe HtmlRenderContext
getHtmlCtx Package{a
[(PackageName, Version)]
[Module]
Maybe UTCTime
(GithubUser, GithubRepo)
Version
Map ModuleName PackageName
Text
PackageMeta
pkgCompilerVersion :: forall a. Package a -> Version
pkgUploader :: forall a. Package a -> a
pkgGithub :: forall a. Package a -> (GithubUser, GithubRepo)
pkgResolvedDependencies :: forall a. Package a -> [(PackageName, Version)]
pkgModuleMap :: forall a. Package a -> Map ModuleName PackageName
pkgModules :: forall a. Package a -> [Module]
pkgTagTime :: forall a. Package a -> Maybe UTCTime
pkgVersionTag :: forall a. Package a -> Text
pkgVersion :: forall a. Package a -> Version
pkgMeta :: forall a. Package a -> PackageMeta
pkgCompilerVersion :: Version
pkgUploader :: a
pkgGithub :: (GithubUser, GithubRepo)
pkgResolvedDependencies :: [(PackageName, Version)]
pkgModuleMap :: Map ModuleName PackageName
pkgModules :: [Module]
pkgTagTime :: Maybe UTCTime
pkgVersionTag :: Text
pkgVersion :: Version
pkgMeta :: PackageMeta
..} =
  forall a.
[(Maybe Char, a)]
-> [(ModuleName, HtmlOutputModule a)] -> HtmlOutput a
HtmlOutput forall {a}. [a]
indexFile [(ModuleName, HtmlOutputModule Html)]
modules
  where
  indexFile :: [a]
indexFile = []
  modules :: [(ModuleName, HtmlOutputModule Html)]
modules = (InPackage ModuleName -> Maybe HtmlRenderContext)
-> Module -> (ModuleName, HtmlOutputModule Html)
moduleAsHtml InPackage ModuleName -> Maybe HtmlRenderContext
getHtmlCtx forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Module]
pkgModules

moduleAsHtml
    :: (InPackage P.ModuleName -> Maybe HtmlRenderContext)
    -> Module
    -> (P.ModuleName, HtmlOutputModule Html)
moduleAsHtml :: (InPackage ModuleName -> Maybe HtmlRenderContext)
-> Module -> (ModuleName, HtmlOutputModule Html)
moduleAsHtml InPackage ModuleName -> Maybe HtmlRenderContext
getHtmlCtx Module{[(InPackage ModuleName, [Declaration])]
[Declaration]
Maybe Text
ModuleName
modReExports :: Module -> [(InPackage ModuleName, [Declaration])]
modDeclarations :: Module -> [Declaration]
modComments :: Module -> Maybe Text
modName :: Module -> ModuleName
modReExports :: [(InPackage ModuleName, [Declaration])]
modDeclarations :: [Declaration]
modComments :: Maybe Text
modName :: ModuleName
..} = (ModuleName
modName, forall a. a -> [(InPackage ModuleName, a)] -> HtmlOutputModule a
HtmlOutputModule Html
modHtml [(InPackage ModuleName, Html)]
reexports)
  where
  modHtml :: Html
modHtml = do
    let r :: HtmlRenderContext
r = forall a. a -> Maybe a -> a
fromMaybe HtmlRenderContext
nullRenderContext forall a b. (a -> b) -> a -> b
$ InPackage ModuleName -> Maybe HtmlRenderContext
getHtmlCtx (forall a. a -> InPackage a
Local ModuleName
modName)
     in do
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Text
modComments Text -> Html
renderMarkdown
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Declaration]
modDeclarations (HtmlRenderContext -> Declaration -> Html
declAsHtml HtmlRenderContext
r)
  reexports :: [(InPackage ModuleName, Html)]
reexports =
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [(InPackage ModuleName, [Declaration])]
modReExports forall a b. (a -> b) -> a -> b
$ \(InPackage ModuleName
pkg, [Declaration]
decls) ->
        let r :: HtmlRenderContext
r = forall a. a -> Maybe a -> a
fromMaybe HtmlRenderContext
nullRenderContext forall a b. (a -> b) -> a -> b
$ InPackage ModuleName -> Maybe HtmlRenderContext
getHtmlCtx InPackage ModuleName
pkg
         in (InPackage ModuleName
pkg, forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (HtmlRenderContext -> Declaration -> Html
declAsHtml HtmlRenderContext
r) [Declaration]
decls)

-- renderIndex :: LinksContext -> [(Maybe Char, Html)]
-- renderIndex LinksContext{..} = go ctxBookmarks
--   where
--   go = takeLocals
--      >>> groupIndex getIndex renderEntry
--      >>> map (second (ul . mconcat))
--
--   getIndex (_, title_) = do
--     c <- textHeadMay title_
--     guard (toUpper c `elem` ['A'..'Z'])
--     pure c
--
--   textHeadMay t =
--     case T.length t of
--       0 -> Nothing
--       _ -> Just (T.index t 0)
--
--   renderEntry (mn, title_) =
--     li $ do
--       let url = T.pack (filePathFor mn `relativeTo` "index") <> "#" <> title_
--       code $
--         a ! A.href (v url) $ text title_
--       sp
--       text ("(" <> P.runModuleName mn <> ")")
--
--   groupIndex :: Ord i => (a -> Maybe i) -> (a -> b) -> [a] -> [(Maybe i, [b])]
--   groupIndex f g =
--     map (second DList.toList) . M.toList . foldr go' M.empty . sortBy (comparing f)
--     where
--     go' x = insertOrAppend (f x) (g x)
--     insertOrAppend idx val m =
--       let cur = M.findWithDefault DList.empty idx m
--           new = DList.snoc cur val
--       in  M.insert idx new m

declAsHtml :: HtmlRenderContext -> Declaration -> Html
declAsHtml :: HtmlRenderContext -> Declaration -> Html
declAsHtml HtmlRenderContext
r d :: Declaration
d@Declaration{[ChildDeclaration]
Maybe Text
Maybe SourceSpan
Maybe KindInfo
Text
DeclarationInfo
declKind :: Declaration -> Maybe KindInfo
declInfo :: Declaration -> DeclarationInfo
declChildren :: Declaration -> [ChildDeclaration]
declSourceSpan :: Declaration -> Maybe SourceSpan
declComments :: Declaration -> Maybe Text
declTitle :: Declaration -> Text
declKind :: Maybe KindInfo
declInfo :: DeclarationInfo
declChildren :: [ChildDeclaration]
declSourceSpan :: Maybe SourceSpan
declComments :: Maybe Text
declTitle :: Text
..} = do
  let declFragment :: Text
declFragment = Namespace -> Text -> Text
makeFragment (DeclarationInfo -> Namespace
declInfoNamespace DeclarationInfo
declInfo) Text
declTitle
  Html -> Html
H.div forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"decl" forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id (Text -> AttributeValue
v (Int -> Text -> Text
T.drop Int
1 Text
declFragment)) forall a b. (a -> b) -> a -> b
$ do
    Html -> Html
h3 forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"decl__title clearfix" forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
a forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"decl__anchor" forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (Text -> AttributeValue
v Text
declFragment) forall a b. (a -> b) -> a -> b
$ Html
"#"
      Html -> Html
H.span forall a b. (a -> b) -> a -> b
$ Text -> Html
text Text
declTitle
      Text -> Html
text Text
" " -- prevent browser from treating
               -- declTitle + linkToSource as one word
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe SourceSpan
declSourceSpan (HtmlRenderContext -> SourceSpan -> Html
linkToSource HtmlRenderContext
r)

    Html -> Html
H.div forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"decl__body" forall a b. (a -> b) -> a -> b
$ do
      case DeclarationInfo
declInfo of
        AliasDeclaration Fixity
fixity FixityAlias
alias_ ->
          Fixity -> FixityAlias -> Html
renderAlias Fixity
fixity FixityAlias
alias_
        DeclarationInfo
_ -> do
          Html -> Html
pre forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"decl__signature" forall a b. (a -> b) -> a -> b
$ do
            forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe KindInfo
declKind forall a b. (a -> b) -> a -> b
$ \KindInfo
kindInfo -> do
              Html -> Html
code forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"decl__kind" forall a b. (a -> b) -> a -> b
$ do
                HtmlRenderContext -> RenderedCode -> Html
codeAsHtml HtmlRenderContext
r (Text -> KindInfo -> RenderedCode
Render.renderKindSig Text
declTitle KindInfo
kindInfo)
            Html -> Html
code forall a b. (a -> b) -> a -> b
$ HtmlRenderContext -> RenderedCode -> Html
codeAsHtml HtmlRenderContext
r (Declaration -> RenderedCode
Render.renderDeclaration Declaration
d)

      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Text
declComments Text -> Html
renderMarkdown

      let ([ChildDeclaration]
instances, [ChildDeclaration]
dctors, [ChildDeclaration]
members) = [ChildDeclaration]
-> ([ChildDeclaration], [ChildDeclaration], [ChildDeclaration])
partitionChildren [ChildDeclaration]
declChildren

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ChildDeclaration]
dctors) forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
h4 Html
"Constructors"
        HtmlRenderContext -> [ChildDeclaration] -> Html
renderChildren HtmlRenderContext
r [ChildDeclaration]
dctors

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ChildDeclaration]
members) forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
h4 Html
"Members"
        HtmlRenderContext -> [ChildDeclaration] -> Html
renderChildren HtmlRenderContext
r [ChildDeclaration]
members

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ChildDeclaration]
instances) forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
h4 Html
"Instances"
        HtmlRenderContext -> [ChildDeclaration] -> Html
renderChildren HtmlRenderContext
r [ChildDeclaration]
instances
  where
    linkToSource :: HtmlRenderContext -> P.SourceSpan -> Html
    linkToSource :: HtmlRenderContext -> SourceSpan -> Html
linkToSource HtmlRenderContext
ctx SourceSpan
srcspan =
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) Text -> Html
go (HtmlRenderContext -> SourceSpan -> Maybe Text
renderSourceLink HtmlRenderContext
ctx SourceSpan
srcspan)
      where
      go :: Text -> Html
go Text
href =
        Html -> Html
H.span forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"decl__source" forall a b. (a -> b) -> a -> b
$
          Html -> Html
a forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (Text -> AttributeValue
v Text
href) forall a b. (a -> b) -> a -> b
$ Text -> Html
text Text
"Source"

renderChildren :: HtmlRenderContext -> [ChildDeclaration] -> Html
renderChildren :: HtmlRenderContext -> [ChildDeclaration] -> Html
renderChildren HtmlRenderContext
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
renderChildren HtmlRenderContext
r [ChildDeclaration]
xs = Html -> Html
ul forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ChildDeclaration -> Html
item [ChildDeclaration]
xs
  where
  item :: ChildDeclaration -> Html
item ChildDeclaration
decl =
    Html -> Html
li forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id (Text -> AttributeValue
v (Int -> Text -> Text
T.drop Int
1 (ChildDeclaration -> Text
fragment ChildDeclaration
decl))) forall a b. (a -> b) -> a -> b
$ do
      ChildDeclaration -> Html
renderCode ChildDeclaration
decl
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (ChildDeclaration -> Maybe Text
cdeclComments ChildDeclaration
decl) forall a b. (a -> b) -> a -> b
$ \Text
coms ->
        Html -> Html
H.div forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"decl__child_comments" forall a b. (a -> b) -> a -> b
$ Text -> Html
renderMarkdown Text
coms

  fragment :: ChildDeclaration -> Text
fragment ChildDeclaration
decl = Namespace -> Text -> Text
makeFragment (ChildDeclarationInfo -> Namespace
childDeclInfoNamespace (ChildDeclaration -> ChildDeclarationInfo
cdeclInfo ChildDeclaration
decl)) (ChildDeclaration -> Text
cdeclTitle ChildDeclaration
decl)
  renderCode :: ChildDeclaration -> Html
renderCode = Html -> Html
code forall b c a. (b -> c) -> (a -> b) -> a -> c
. HtmlRenderContext -> RenderedCode -> Html
codeAsHtml HtmlRenderContext
r forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChildDeclaration -> RenderedCode
Render.renderChildDeclaration

codeAsHtml :: HtmlRenderContext -> RenderedCode -> Html
codeAsHtml :: HtmlRenderContext -> RenderedCode -> Html
codeAsHtml HtmlRenderContext
r = forall a.
Monoid a =>
(RenderedCodeElement -> a) -> RenderedCode -> a
outputWith RenderedCodeElement -> Html
elemAsHtml
  where
  elemAsHtml :: RenderedCodeElement -> Html
elemAsHtml RenderedCodeElement
e = case RenderedCodeElement
e of
    Syntax Text
x ->
      String -> Html -> Html
withClass String
"syntax" (Text -> Html
text Text
x)
    Keyword Text
x ->
      String -> Html -> Html
withClass String
"keyword" (Text -> Html
text Text
x)
    RenderedCodeElement
Space ->
      Text -> Html
text Text
" "
    Symbol Namespace
ns Text
name Link
link_ ->
      case Link
link_ of
        Link ContainingModule
mn ->
          let
            class_ :: String
class_ =
              if Text -> Bool
startsWithUpper Text
name then String
"ctor" else String
"ident"
            target :: Text
target
              | Text -> Bool
isOp Text
name =
                  if Namespace
ns forall a. Eq a => a -> a -> Bool
== Namespace
TypeLevel
                    then Text
"type (" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
")"
                    else Text
"(" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
")"
              | Bool
otherwise = Text
name
          in
            Namespace -> Text -> ContainingModule -> Html -> Html
linkToDecl Namespace
ns Text
target ContainingModule
mn (String -> Html -> Html
withClass String
class_ (Text -> Html
text Text
name))
        Link
NoLink ->
          Text -> Html
text Text
name
    Role Text
role ->
      case Text
role of
        Text
"nominal" -> Text -> AttributeValue -> Html
renderRole Text
describeNominal AttributeValue
"decl__role_nominal"
        Text
"phantom" -> Text -> AttributeValue -> Html
renderRole Text
describePhantom AttributeValue
"decl__role_phantom"

        -- representational is intentionally not rendered
        Text
"representational" -> forall a. ToMarkup a => a -> Html
toHtml (Text
"" :: Text)

        Text
x -> forall a. HasCallStack => String -> a
P.internalError forall a b. (a -> b) -> a -> b
$ String
"codeAsHtml: unknown value for role annotation: '" forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
x forall a. Semigroup a => a -> a -> a
<> String
"'"
      where
        renderRole :: Text -> AttributeValue -> Html
renderRole Text
hoverTextContent AttributeValue
className =
          Html -> Html
H.a forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (Text -> AttributeValue
v Text
docRepoRolePage) forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.target (Text -> AttributeValue
v Text
"_blank") forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"decl__role" forall a b. (a -> b) -> a -> b
$ do
            Html -> Html
H.abbr forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"decl__role_hover" forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.title (Text -> AttributeValue
v Text
hoverTextContent) forall a b. (a -> b) -> a -> b
$ do
              Html -> Html
H.sub forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
className forall a b. (a -> b) -> a -> b
$ do
                forall a. ToMarkup a => a -> Html
toHtml (Text
"" :: Text)

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

        describeNominal :: Text
describeNominal =
          Text
"The 'nominal' role means this argument may not change when coercing the type."
        describePhantom :: Text
describePhantom =
          Text
"The 'phantom' role means this argument can change freely when coercing the type."

  linkToDecl :: Namespace -> Text -> ContainingModule -> Html -> Html
linkToDecl = HtmlRenderContext
-> Namespace -> Text -> ContainingModule -> Html -> Html
linkToDeclaration HtmlRenderContext
r

  startsWithUpper :: Text -> Bool
  startsWithUpper :: Text -> Bool
startsWithUpper Text
str = Bool -> Bool
not (Text -> Bool
T.null Text
str) Bool -> Bool -> Bool
&& Char -> Bool
isUpper (Text -> Int -> Char
T.index Text
str Int
0)

  isOp :: Text -> Bool
isOp = forall a b. Either a b -> Bool
isRight forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Text -> Either String a
runParser Parser OpName
CST.parseOperator

  runParser :: CST.Parser a -> Text -> Either String a
  runParser :: forall a. Parser a -> Text -> Either String a
runParser Parser a
p' =
    forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (ParserError -> String
CST.prettyPrintError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NE.head) forall a b. (a, b) -> b
snd
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
Parser a
-> [LexResult]
-> Either (NonEmpty ParserError) ([ParserWarning], a)
CST.runTokenParser Parser a
p'
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [LexResult]
CST.lex

renderLink :: HtmlRenderContext -> DocLink -> Html -> Html
renderLink :: HtmlRenderContext -> DocLink -> Html -> Html
renderLink HtmlRenderContext
r link_ :: DocLink
link_@DocLink{Text
Namespace
LinkLocation
linkNamespace :: DocLink -> Namespace
linkTitle :: DocLink -> Text
linkLocation :: DocLink -> LinkLocation
linkNamespace :: Namespace
linkTitle :: Text
linkLocation :: LinkLocation
..} =
  Html -> Html
a forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (Text -> AttributeValue
v (HtmlRenderContext -> DocLink -> Text
renderDocLink HtmlRenderContext
r DocLink
link_ forall a. Semigroup a => a -> a -> a
<> DocLink -> Text
fragmentFor DocLink
link_))
    forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.title (Text -> AttributeValue
v Text
fullyQualifiedName)
  where
  fullyQualifiedName :: Text
fullyQualifiedName =
    ModuleName -> Text
P.runModuleName ModuleName
modName forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> Text
linkTitle

  modName :: ModuleName
modName = case LinkLocation
linkLocation of
    LocalModule ModuleName
m    -> ModuleName
m
    DepsModule PackageName
_ Version
_ ModuleName
m -> ModuleName
m
    BuiltinModule ModuleName
m  -> ModuleName
m

makeFragment :: Namespace -> Text -> Text
makeFragment :: Namespace -> Text -> Text
makeFragment Namespace
ns = (Text
prefix forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. a -> a
escape
  where
  prefix :: Text
prefix = case Namespace
ns of
    Namespace
TypeLevel -> Text
"#t:"
    Namespace
ValueLevel -> Text
"#v:"

  -- TODO
  escape :: a -> a
escape = forall {a}. a -> a
id

fragmentFor :: DocLink -> Text
fragmentFor :: DocLink -> Text
fragmentFor DocLink
l = Namespace -> Text -> Text
makeFragment (DocLink -> Namespace
linkNamespace DocLink
l) (DocLink -> Text
linkTitle DocLink
l)

linkToDeclaration ::
  HtmlRenderContext ->
  Namespace ->
  Text ->
  ContainingModule ->
  Html ->
  Html
linkToDeclaration :: HtmlRenderContext
-> Namespace -> Text -> ContainingModule -> Html -> Html
linkToDeclaration HtmlRenderContext
r Namespace
ns Text
target ContainingModule
containMn =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. a -> a
id (HtmlRenderContext -> DocLink -> Html -> Html
renderLink HtmlRenderContext
r) (HtmlRenderContext
-> Namespace -> Text -> ContainingModule -> Maybe DocLink
buildDocLink HtmlRenderContext
r Namespace
ns Text
target ContainingModule
containMn)

renderAlias :: P.Fixity -> FixityAlias -> Html
renderAlias :: Fixity -> FixityAlias -> Html
renderAlias (P.Fixity Associativity
associativity Precedence
precedence) FixityAlias
alias_ =
  Html -> Html
p forall a b. (a -> b) -> a -> b
$ do
    -- TODO: Render a link
    forall a. ToMarkup a => a -> Html
toHtml forall a b. (a -> b) -> a -> b
$ Text
"Operator alias for " forall a. Semigroup a => a -> a -> a
<> forall a. (a -> Text) -> Qualified a -> Text
P.showQualified forall {a :: ProperNameType} {a :: ProperNameType}.
Either (ProperName a) (Either Ident (ProperName a)) -> Text
showAliasName FixityAlias
alias_ forall a. Semigroup a => a -> a -> a
<> Text
" "
    Html -> Html
em forall a b. (a -> b) -> a -> b
$
      Text -> Html
text (Text
"(" forall a. Semigroup a => a -> a -> a
<> Text
associativityStr forall a. Semigroup a => a -> a -> a
<> Text
" / precedence " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show Precedence
precedence) forall a. Semigroup a => a -> a -> a
<> Text
")")
  where
  showAliasName :: Either (ProperName a) (Either Ident (ProperName a)) -> Text
showAliasName (Left ProperName a
valueAlias) = forall (a :: ProperNameType). ProperName a -> Text
P.runProperName ProperName a
valueAlias
  showAliasName (Right Either Ident (ProperName a)
typeAlias) = case Either Ident (ProperName a)
typeAlias of
    (Left Ident
identifier)  -> Ident -> Text
P.runIdent Ident
identifier
    (Right ProperName a
properName) -> forall (a :: ProperNameType). ProperName a -> Text
P.runProperName ProperName a
properName
  associativityStr :: Text
associativityStr = case Associativity
associativity of
    Associativity
P.Infixl -> Text
"left-associative"
    Associativity
P.Infixr -> Text
"right-associative"
    Associativity
P.Infix  -> Text
"non-associative"

-- | Render Markdown to HTML. Safe for untrusted input. Relative links are
-- | removed.
renderMarkdown :: Text -> H.Html
renderMarkdown :: Text -> Html
renderMarkdown =
  forall a. ToMarkup a => a -> Html
H.toMarkup forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
removeRelativeLinks forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Text -> Doc
Cheapskate.markdown Options
opts
  where
  opts :: Options
opts = forall a. Default a => a
Cheapskate.def { allowRawHtml :: Bool
Cheapskate.allowRawHtml = Bool
False }

removeRelativeLinks :: Cheapskate.Doc -> Cheapskate.Doc
removeRelativeLinks :: Doc -> Doc
removeRelativeLinks = forall a b. (Data a, Data b) => (a -> a) -> b -> b
Cheapskate.walk Inlines -> Inlines
go
  where
  go :: Cheapskate.Inlines -> Cheapskate.Inlines
  go :: Inlines -> Inlines
go = (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Inline -> Inlines
stripRelatives)

  stripRelatives :: Cheapskate.Inline -> Cheapskate.Inlines
  stripRelatives :: Inline -> Inlines
stripRelatives (Cheapskate.Link Inlines
contents_ Text
href Text
_)
    | Text -> Bool
isRelativeURI Text
href = Inlines
contents_
  stripRelatives Inline
other = forall (f :: * -> *) a. Applicative f => a -> f a
pure Inline
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 :: Text -> Bool
isRelativeURI =
    (Char -> Bool) -> Text -> Text
T.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'/') forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Char -> Bool) -> Text -> Bool
T.all (forall a. Eq a => a -> a -> Bool
/= Char
':')

v :: Text -> AttributeValue
v :: Text -> AttributeValue
v = forall a. ToValue a => a -> AttributeValue
toValue

withClass :: String -> Html -> Html
withClass :: String -> Html -> Html
withClass String
className = Html -> Html
H.span forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ (forall a. IsString a => String -> a
fromString String
className)

partitionChildren ::
  [ChildDeclaration] ->
  ([ChildDeclaration], [ChildDeclaration], [ChildDeclaration])
partitionChildren :: [ChildDeclaration]
-> ([ChildDeclaration], [ChildDeclaration], [ChildDeclaration])
partitionChildren =
  forall {a} {a} {a}. ([a], [a], [a]) -> ([a], [a], [a])
reverseAll forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ([ChildDeclaration], [ChildDeclaration], [ChildDeclaration])
-> ChildDeclaration
-> ([ChildDeclaration], [ChildDeclaration], [ChildDeclaration])
go ([], [], [])
  where
  go :: ([ChildDeclaration], [ChildDeclaration], [ChildDeclaration])
-> ChildDeclaration
-> ([ChildDeclaration], [ChildDeclaration], [ChildDeclaration])
go ([ChildDeclaration]
instances, [ChildDeclaration]
dctors, [ChildDeclaration]
members) ChildDeclaration
rcd =
    case ChildDeclaration -> ChildDeclarationInfo
cdeclInfo ChildDeclaration
rcd of
      ChildInstance [Constraint']
_ Type'
_      -> (ChildDeclaration
rcd forall a. a -> [a] -> [a]
: [ChildDeclaration]
instances, [ChildDeclaration]
dctors, [ChildDeclaration]
members)
      ChildDataConstructor [Type']
_ -> ([ChildDeclaration]
instances, ChildDeclaration
rcd forall a. a -> [a] -> [a]
: [ChildDeclaration]
dctors, [ChildDeclaration]
members)
      ChildTypeClassMember Type'
_ -> ([ChildDeclaration]
instances, [ChildDeclaration]
dctors, ChildDeclaration
rcd forall a. a -> [a] -> [a]
: [ChildDeclaration]
members)

  reverseAll :: ([a], [a], [a]) -> ([a], [a], [a])
reverseAll ([a]
xs, [a]
ys, [a]
zs) = (forall a. [a] -> [a]
reverse [a]
xs, forall a. [a] -> [a]
reverse [a]
ys, forall a. [a] -> [a]
reverse [a]
zs)