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

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

-- |
-- 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
  ( renderToString
  , 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 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

renderToString :: Bool -> Html -> String
renderToString :: Bool -> Html -> [Char]
renderToString Bool
debug Html
html
  | Bool
debug = Html -> [Char]
forall html. HTML html => html -> [Char]
renderHtml Html
html
  | Bool
otherwise = Html -> [Char]
forall html. HTML html => html -> [Char]
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 [Char] -> Html
forall a. HTML a => a -> Html
toHtml [Char]
" "

-- | 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
! [[Char] -> HtmlAttr
theclass [Char]
"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 = [Char] -> Html
forall a. HTML a => a -> Html
toHtml [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
forall a. HTML a => a -> Html
toHtml [Char]
":]"
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
! [[Char] -> HtmlAttr
theclass [Char]
"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
! [[Char] -> HtmlAttr
theclass [Char]
"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 ([Char] -> Html
forall a. HTML a => a -> Html
toHtml [Char]
" | ")

ubxparens :: Html -> Html
ubxparens :: Html -> Html
ubxparens Html
h = [Char] -> Html
forall a. HTML a => a -> Html
toHtml [Char]
"(#" Html -> Html -> Html
<+> Html
h Html -> Html -> Html
<+> [Char] -> Html
forall a. HTML a => a -> Html
toHtml [Char]
"#)"

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

atSign :: Html
atSign :: Html
atSign = [Char] -> Html
forall a. HTML a => a -> Html
toHtml [Char]
"@"

multAnnotation :: Html
multAnnotation :: Html
multAnnotation = [Char] -> Html
forall a. HTML a => a -> Html
toHtml [Char]
"%"

dot :: Html
dot :: Html
dot = [Char] -> Html
forall a. HTML a => a -> Html
toHtml [Char]
"."

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

linkedAnchor :: String -> Html -> Html
linkedAnchor :: [Char] -> Html -> Html
linkedAnchor [Char]
n = Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [[Char] -> HtmlAttr
href (Char
'#' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
n)]

-- | generate an anchor identifier for a group
groupId :: String -> String
groupId :: [Char] -> [Char]
groupId [Char]
g = [Char] -> [Char]
makeAnchorId ([Char]
"g:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
g)

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

data DetailsState = DetailsOpen | DetailsClosed

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

thesummary :: Html -> Html
thesummary :: Html -> Html
thesummary = [Char] -> Html -> Html
tag [Char]
"summary"

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

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