-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- Module      :  Haddock.Backends.Html.Util
-- Copyright   :  (c) Simon Marlow   2003-2006,
--                    David Waern    2006-2009,
--                    Mark Lentczner 2010
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
module Haddock.Backends.Xhtml.Utils
  ( renderToBuilder
  , namedAnchor
  , linkedAnchor
  , spliceURL
  , spliceURL'
  , groupId
  , (<+>)
  , (<=>)
  , char
  , keyword
  , punctuate
  , braces
  , brackets
  , pabrackets
  , parens
  , parenList
  , parenBreakableList
  , ubxParenList
  , ubxSumList
  , arrow
  , lollipop
  , comma
  , dcolon
  , dot
  , darrow
  , equals
  , forallSymbol
  , quote
  , promoQuote
  , multAnnotation
  , atSign
  , hsep
  , vcat
  , DetailsState (..)
  , collapseDetails
  , thesummary
  , collapseToggle
  , collapseControl
  ) where

import GHC (Name, SrcSpan (..), srcSpanStartLine)
import GHC.Types.Name (getOccString, isValOcc, nameOccName)
import GHC.Unit.Module (Module, ModuleName, moduleName, moduleNameString)
import Text.XHtml hiding (name, p, quote, title)
import qualified Text.XHtml as XHtml
import qualified Data.Text.Lazy as LText

import Haddock.Utils

-- | Replace placeholder string elements with provided values.
--
-- Used to generate URL for customized external paths, usually provided with
-- @--source-module@, @--source-entity@ and related command-line arguments.
--
-- >>> spliceURL mmod mname Nothing "output/%{MODULE}.hs#%{NAME}"
-- "output/Foo.hs#foo"
spliceURL
  :: Maybe Module
  -> Maybe GHC.Name
  -> Maybe SrcSpan
  -> String
  -> String
spliceURL :: Maybe Module -> Maybe Name -> Maybe SrcSpan -> [Char] -> [Char]
spliceURL Maybe Module
mmod = Maybe ModuleName -> Maybe Name -> Maybe SrcSpan -> [Char] -> [Char]
spliceURL' (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName) -> Maybe Module -> Maybe ModuleName
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Module
mmod)

-- | Same as 'spliceURL' but takes 'ModuleName' instead of 'Module'.
spliceURL'
  :: Maybe ModuleName
  -> Maybe GHC.Name
  -> Maybe SrcSpan
  -> String
  -> String
spliceURL' :: Maybe ModuleName -> Maybe Name -> Maybe SrcSpan -> [Char] -> [Char]
spliceURL' Maybe ModuleName
maybe_mod Maybe Name
maybe_name Maybe SrcSpan
maybe_loc = [Char] -> [Char]
run
  where
    mdl :: [Char]
mdl = case Maybe ModuleName
maybe_mod of
      Maybe ModuleName
Nothing -> [Char]
""
      Just ModuleName
m -> ModuleName -> [Char]
moduleNameString ModuleName
m

    ([Char]
name, [Char]
kind) =
      case Maybe Name
maybe_name of
        Maybe Name
Nothing -> ([Char]
"", [Char]
"")
        Just Name
n
          | OccName -> Bool
isValOcc (Name -> OccName
nameOccName Name
n) -> ([Char] -> [Char]
escapeStr (Name -> [Char]
forall a. NamedThing a => a -> [Char]
getOccString Name
n), [Char]
"v")
          | Bool
otherwise -> ([Char] -> [Char]
escapeStr (Name -> [Char]
forall a. NamedThing a => a -> [Char]
getOccString Name
n), [Char]
"t")

    line :: [Char]
line = case Maybe SrcSpan
maybe_loc of
      Maybe SrcSpan
Nothing -> [Char]
""
      Just SrcSpan
span_ ->
        case SrcSpan
span_ of
          RealSrcSpan RealSrcSpan
span__ Maybe BufSpan
_ ->
            Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
span__
          UnhelpfulSpan UnhelpfulSpanReason
_ -> [Char]
""

    run :: [Char] -> [Char]
run [Char]
"" = [Char]
""
    run (Char
'%' : Char
'M' : [Char]
rest) = [Char]
mdl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
run [Char]
rest
    run (Char
'%' : Char
'N' : [Char]
rest) = [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
run [Char]
rest
    run (Char
'%' : Char
'K' : [Char]
rest) = [Char]
kind [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
run [Char]
rest
    run (Char
'%' : Char
'L' : [Char]
rest) = [Char]
line [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
run [Char]
rest
    run (Char
'%' : Char
'%' : [Char]
rest) = Char
'%' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
run [Char]
rest
    run (Char
'%' : Char
'{' : Char
'M' : Char
'O' : Char
'D' : Char
'U' : Char
'L' : Char
'E' : Char
'}' : [Char]
rest) = [Char]
mdl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
run [Char]
rest
    run (Char
'%' : Char
'{' : Char
'N' : Char
'A' : Char
'M' : Char
'E' : Char
'}' : [Char]
rest) = [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
run [Char]
rest
    run (Char
'%' : Char
'{' : Char
'K' : Char
'I' : Char
'N' : Char
'D' : Char
'}' : [Char]
rest) = [Char]
kind [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
run [Char]
rest
    run (Char
'%' : Char
'{' : Char
'M' : Char
'O' : Char
'D' : Char
'U' : Char
'L' : Char
'E' : Char
'/' : Char
'.' : Char
'/' : Char
c : Char
'}' : [Char]
rest) =
      (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map (\Char
x -> if Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' then Char
c else Char
x) [Char]
mdl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
run [Char]
rest
    run (Char
'%' : Char
'{' : Char
'L' : Char
'I' : Char
'N' : Char
'E' : Char
'}' : [Char]
rest) = [Char]
line [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
run [Char]
rest
    run (Char
c : [Char]
rest) = Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
run [Char]
rest

renderToBuilder :: Bool -> Html -> Builder
renderToBuilder :: Bool -> Html -> Builder
renderToBuilder Bool
debug Html
html
  | Bool
debug = Html -> Builder
forall html. HTML html => html -> Builder
renderHtml Html
html
  | Bool
otherwise = Html -> Builder
forall html. HTML html => html -> Builder
showHtml Html
html

hsep :: [Html] -> Html
hsep :: [Html] -> Html
hsep [] = Html
noHtml
hsep [Html]
htmls = (Html -> Html -> Html) -> [Html] -> Html
forall a. (a -> a -> a) -> [a] -> a
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
foldr1 Html -> Html -> Html
(<+>) [Html]
htmls

-- | Concatenate a series of 'Html' values vertically, with linebreaks in between.
vcat :: [Html] -> Html
vcat :: [Html] -> Html
vcat [] = Html
noHtml
vcat [Html]
htmls = (Html -> Html -> Html) -> [Html] -> Html
forall a. (a -> a -> a) -> [a] -> a
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
foldr1 (\Html
a Html
b -> Html
a Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
br Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
b) [Html]
htmls

infixr 8 <+>
(<+>) :: Html -> Html -> Html
Html
a <+> :: Html -> Html -> Html
<+> Html
b = Html
a Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
sep Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
b
  where
    sep :: Html
sep = if Html -> Bool
isNoHtml Html
a Bool -> Bool -> Bool
|| Html -> Bool
isNoHtml Html
b then Html
noHtml else Text -> Html
forall a. HTML a => a -> Html
toHtml (Text
" " :: LText)

-- | Join two 'Html' values together with a linebreak in between.
--   Has 'noHtml' as left identity.
infixr 8 <=>

(<=>) :: Html -> Html -> Html
Html
a <=> :: Html -> Html -> Html
<=> Html
b = Html
a Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
sep Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
b
  where
    sep :: Html
sep = if Html -> Bool
isNoHtml Html
a then Html
noHtml else Html
br

keyword :: String -> Html
keyword :: [Char] -> Html
keyword [Char]
s = Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [Text -> HtmlAttr
theclass Text
"keyword"] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [Char] -> Html
forall a. HTML a => a -> Html
toHtml [Char]
s

equals, comma :: Html
equals :: Html
equals = Char -> Html
char Char
'='
comma :: Html
comma = Char -> Html
char Char
','

char :: Char -> Html
char :: Char -> Html
char Char
c = [Char] -> Html
forall a. HTML a => a -> Html
toHtml [Char
c]

quote :: Html -> Html
quote :: Html -> Html
quote Html
h = Char -> Html
char Char
'`' Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
h Html -> Char -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Char
'`'

-- | Promoted type quote (e.g. @'[a, b]@, @'(a, b, c)@).
promoQuote :: Html -> Html
promoQuote :: Html -> Html
promoQuote Html
h = Char -> Html
char Char
'\'' Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
h

parens, brackets, pabrackets, braces :: Html -> Html
parens :: Html -> Html
parens Html
h = Char -> Html
char Char
'(' Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
h Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Char -> Html
char Char
')'
brackets :: Html -> Html
brackets Html
h = Char -> Html
char Char
'[' Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
h Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Char -> Html
char Char
']'
pabrackets :: Html -> Html
pabrackets Html
h = Text -> Html
forall a. HTML a => a -> Html
toHtml (Text
"[:" :: LText) Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
h Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Text -> Html
forall a. HTML a => a -> Html
toHtml (Text
":]" :: LText)
braces :: Html -> Html
braces Html
h = Char -> Html
char Char
'{' Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
h Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Char -> Html
char Char
'}'

punctuate :: Html -> [Html] -> [Html]
punctuate :: Html -> [Html] -> [Html]
punctuate Html
_ [] = []
punctuate Html
h (Html
d0 : [Html]
ds) = Html -> [Html] -> [Html]
go Html
d0 [Html]
ds
  where
    go :: Html -> [Html] -> [Html]
go Html
d [] = [Html
d]
    go Html
d (Html
e : [Html]
es) = (Html
d Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
h) Html -> [Html] -> [Html]
forall a. a -> [a] -> [a]
: Html -> [Html] -> [Html]
go Html
e [Html]
es

parenBreakableList :: [Html] -> Html
parenBreakableList :: [Html] -> Html
parenBreakableList = (Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [Text -> HtmlAttr
theclass Text
"breakable"]) (Html -> Html) -> ([Html] -> Html) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Html
parens (Html -> Html) -> ([Html] -> Html) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Html] -> Html
hsep ([Html] -> Html) -> ([Html] -> [Html]) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> [Html] -> [Html]
punctuate Html
comma
                     ([Html] -> [Html]) -> ([Html] -> [Html]) -> [Html] -> [Html]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Html -> Html) -> [Html] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map (Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [Text -> HtmlAttr
theclass Text
"unbreakable"])

parenList :: [Html] -> Html
parenList :: [Html] -> Html
parenList = Html -> Html
parens (Html -> Html) -> ([Html] -> Html) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Html] -> Html
hsep ([Html] -> Html) -> ([Html] -> [Html]) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> [Html] -> [Html]
punctuate Html
comma

ubxParenList :: [Html] -> Html
ubxParenList :: [Html] -> Html
ubxParenList = Html -> Html
ubxparens (Html -> Html) -> ([Html] -> Html) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Html] -> Html
hsep ([Html] -> Html) -> ([Html] -> [Html]) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> [Html] -> [Html]
punctuate Html
comma

ubxSumList :: [Html] -> Html
ubxSumList :: [Html] -> Html
ubxSumList = Html -> Html
ubxparens (Html -> Html) -> ([Html] -> Html) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Html] -> Html
hsep ([Html] -> Html) -> ([Html] -> [Html]) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> [Html] -> [Html]
punctuate (Text -> Html
forall a. HTML a => a -> Html
toHtml (Text
" | " :: LText))

ubxparens :: Html -> Html
ubxparens :: Html -> Html
ubxparens Html
h = Text -> Html
forall a. HTML a => a -> Html
toHtml (Text
"(#" :: LText) Html -> Html -> Html
<+> Html
h Html -> Html -> Html
<+> Text -> Html
forall a. HTML a => a -> Html
toHtml (Text
"#)" :: LText)

dcolon, arrow, lollipop, darrow, forallSymbol :: Bool -> Html
dcolon :: Bool -> Html
dcolon Bool
unicode = Text -> Html
forall a. HTML a => a -> Html
toHtml (if Bool
unicode then Text
"∷" :: LText else Text
"::")
arrow :: Bool -> Html
arrow Bool
unicode = Text -> Html
forall a. HTML a => a -> Html
toHtml (if Bool
unicode then Text
"→" :: LText else Text
"->")
lollipop :: Bool -> Html
lollipop Bool
unicode = Text -> Html
forall a. HTML a => a -> Html
toHtml (if Bool
unicode then Text
"⊸" :: LText else Text
"%1 ->")
darrow :: Bool -> Html
darrow Bool
unicode = Text -> Html
forall a. HTML a => a -> Html
toHtml (if Bool
unicode then Text
"⇒" :: LText else Text
"=>")
forallSymbol :: Bool -> Html
forallSymbol Bool
unicode = if Bool
unicode then Text -> Html
forall a. HTML a => a -> Html
toHtml (Text
"∀" :: LText) else [Char] -> Html
keyword [Char]
"forall"

atSign :: Html
atSign :: Html
atSign = Text -> Html
forall a. HTML a => a -> Html
toHtml (Text
"@" :: LText)

multAnnotation :: Html
multAnnotation :: Html
multAnnotation = Text -> Html
forall a. HTML a => a -> Html
toHtml (Text
"%" :: LText)

dot :: Html
dot :: Html
dot = Text -> Html
forall a. HTML a => a -> Html
toHtml (Text
"." :: LText)

-- | Generate a named anchor
namedAnchor :: LText -> Html -> Html
namedAnchor :: Text -> Html -> Html
namedAnchor Text
n = Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [Text -> HtmlAttr
XHtml.identifier Text
n]

linkedAnchor :: LText -> Html -> Html
linkedAnchor :: Text -> Html -> Html
linkedAnchor Text
n = Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [Text -> HtmlAttr
href (Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n)]

-- | generate an anchor identifier for a group
groupId :: LText -> LText
groupId :: Text -> Text
groupId Text
g = Text -> Text
makeAnchorId (Text
"g:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
g)

--
-- A section of HTML which is collapsible.
--

data DetailsState = DetailsOpen | DetailsClosed

collapseDetails :: LText -> DetailsState -> Html -> Html
collapseDetails :: Text -> DetailsState -> Html -> Html
collapseDetails Text
id_ DetailsState
state = ByteString -> Html -> Html
tag ByteString
"details" (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! (Text -> HtmlAttr
identifier Text
id_ HtmlAttr -> [HtmlAttr] -> [HtmlAttr]
forall a. a -> [a] -> [a]
: [HtmlAttr]
openAttrs)
  where
    openAttrs :: [HtmlAttr]
openAttrs = case DetailsState
state of DetailsState
DetailsOpen -> [Builder -> HtmlAttr
emptyAttr Builder
"open"]; DetailsState
DetailsClosed -> []

thesummary :: Html -> Html
thesummary :: Html -> Html
thesummary = ByteString -> Html -> Html
tag ByteString
"summary"

-- | Attributes for an area that toggles a collapsed area
collapseToggle :: LText -> LText -> [HtmlAttr]
collapseToggle :: Text -> Text -> [HtmlAttr]
collapseToggle Text
id_ Text
classes = [Text -> HtmlAttr
theclass Text
cs, Builder -> Text -> HtmlAttr
strAttr Builder
"data-details-id" Text
id_]
  where
    cs :: Text
cs = [Text] -> Text
LText.unwords (Text -> [Text]
LText.words Text
classes [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"details-toggle"])

-- | Attributes for an area that toggles a collapsed area,
-- and displays a control.
collapseControl :: LText -> LText -> [HtmlAttr]
collapseControl :: Text -> Text -> [HtmlAttr]
collapseControl Text
id_ Text
classes = Text -> Text -> [HtmlAttr]
collapseToggle Text
id_ Text
cs
  where
    cs :: Text
cs = [Text] -> Text
LText.unwords (Text -> [Text]
LText.words Text
classes [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"details-toggle-control"])