AsHtml.hs

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

-- |
-- An HtmlRenderContext for when you don't want to render any links.
nullRenderContext :: HtmlRenderContext
nullRenderContext = HtmlRenderContext
  { buildDocLink = const (const (const Nothing))
  , renderDocLink = const ""
  , renderSourceLink = const Nothing
  }

packageAsHtml
    :: (InPackage P.ModuleName -> Maybe HtmlRenderContext)
    -> Package a
    -> 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)

-- 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 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 " " -- prevent browser from treating
               -- declTitle + linkToSource as one word
      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 a -> Text -> Either String a
  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
-- | removed.
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)