-----------------------------------------------------------------------------
-- |
-- 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 Haddock.Utils

import Text.XHtml hiding ( name, title, p, quote )
import qualified Text.XHtml as XHtml

import GHC              ( SrcSpan(..), srcSpanStartLine, Name )
import GHC.Unit.Module ( Module, ModuleName, moduleName, moduleNameString )
import GHC.Types.Name   ( getOccString, nameOccName, isValOcc )


-- | 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Html
a Html
b -> Html
aHtml -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++Html
brHtml -> 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"])