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

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

-- |
-- 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
  , 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 -> String -> String
spliceURL Maybe Module
mmod = Maybe ModuleName -> Maybe Name -> Maybe SrcSpan -> String -> String
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 -> String -> String
spliceURL' Maybe ModuleName
maybe_mod Maybe Name
maybe_name Maybe SrcSpan
maybe_loc = String -> String
run
  where
    mdl :: String
mdl = case Maybe ModuleName
maybe_mod of
      Maybe ModuleName
Nothing -> String
""
      Just ModuleName
m -> ModuleName -> String
moduleNameString ModuleName
m

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

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

    run :: String -> String
run String
"" = String
""
    run (Char
'%' : Char
'M' : String
rest) = String
mdl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
run String
rest
    run (Char
'%' : Char
'N' : String
rest) = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
run String
rest
    run (Char
'%' : Char
'K' : String
rest) = String
kind String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
run String
rest
    run (Char
'%' : Char
'L' : String
rest) = String
line String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
run String
rest
    run (Char
'%' : Char
'%' : String
rest) = Char
'%' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
run String
rest
    run (Char
'%' : Char
'{' : Char
'M' : Char
'O' : Char
'D' : Char
'U' : Char
'L' : Char
'E' : Char
'}' : String
rest) = String
mdl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
run String
rest
    run (Char
'%' : Char
'{' : Char
'N' : Char
'A' : Char
'M' : Char
'E' : Char
'}' : String
rest) = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
run String
rest
    run (Char
'%' : Char
'{' : Char
'K' : Char
'I' : Char
'N' : Char
'D' : Char
'}' : String
rest) = String
kind String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
run String
rest
    run (Char
'%' : Char
'{' : Char
'M' : Char
'O' : Char
'D' : Char
'U' : Char
'L' : Char
'E' : Char
'/' : Char
'.' : Char
'/' : Char
c : Char
'}' : String
rest) =
      (Char -> Char) -> String -> String
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) String
mdl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
run String
rest
    run (Char
'%' : Char
'{' : Char
'L' : Char
'I' : Char
'N' : Char
'E' : Char
'}' : String
rest) = String
line String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
run String
rest
    run (Char
c : String
rest) = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
run String
rest

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

-- | 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 :: String -> Html
keyword String
s = Html -> Html
thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"keyword"] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String -> Html
forall a. HTML a => a -> Html
toHtml String
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 = String -> 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 = String -> Html
forall a. HTML a => a -> Html
toHtml String
"[:" 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
+++ String -> Html
forall a. HTML a => a -> Html
toHtml String
":]"
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

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 (String -> Html
forall a. HTML a => a -> Html
toHtml String
" | ")

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

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

atSign :: Html
atSign :: Html
atSign = String -> Html
forall a. HTML a => a -> Html
toHtml String
"@"

multAnnotation :: Html
multAnnotation :: Html
multAnnotation = String -> Html
forall a. HTML a => a -> Html
toHtml String
"%"

dot :: Html
dot :: Html
dot = String -> Html
forall a. HTML a => a -> Html
toHtml String
"."

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

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

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

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

data DetailsState = DetailsOpen | DetailsClosed

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

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

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

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