-----------------------------------------------------------------------------
-- |
-- 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, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote,
  atSign,

  hsep, vcat,

  DetailsState(..), collapseDetails, thesummary,
  collapseToggle, collapseControl,
) where


import Haddock.Utils

import Data.Maybe

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

import GHC      ( SrcSpan(..), srcSpanStartLine, Name )
import Module   ( Module, ModuleName, moduleName, moduleNameString )
import 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 Nothing mmod mname Nothing "output/%{MODULE}.hs#%{NAME}"
-- "output/Foo.hs#foo"
spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name ->
             Maybe SrcSpan -> String -> String
spliceURL :: Maybe FilePath
-> Maybe Module
-> Maybe Name
-> Maybe SrcSpan
-> FilePath
-> FilePath
spliceURL Maybe FilePath
mfile Maybe Module
mmod = Maybe FilePath
-> Maybe ModuleName
-> Maybe Name
-> Maybe SrcSpan
-> FilePath
-> FilePath
spliceURL' Maybe FilePath
mfile (Module -> 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 FilePath -> Maybe ModuleName -> Maybe GHC.Name ->
              Maybe SrcSpan -> String -> String
spliceURL' :: Maybe FilePath
-> Maybe ModuleName
-> Maybe Name
-> Maybe SrcSpan
-> FilePath
-> FilePath
spliceURL' Maybe FilePath
maybe_file Maybe ModuleName
maybe_mod Maybe Name
maybe_name Maybe SrcSpan
maybe_loc = FilePath -> FilePath
run
 where
  file :: FilePath
file = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"" Maybe FilePath
maybe_file
  mdl :: FilePath
mdl = case Maybe ModuleName
maybe_mod of
          Maybe ModuleName
Nothing           -> FilePath
""
          Just ModuleName
m -> ModuleName -> FilePath
moduleNameString ModuleName
m

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

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

  run :: FilePath -> FilePath
run FilePath
"" = FilePath
""
  run (Char
'%':Char
'M':FilePath
rest) = FilePath
mdl  FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
run FilePath
rest
  run (Char
'%':Char
'F':FilePath
rest) = FilePath
file FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
run FilePath
rest
  run (Char
'%':Char
'N':FilePath
rest) = FilePath
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
run FilePath
rest
  run (Char
'%':Char
'K':FilePath
rest) = FilePath
kind FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
run FilePath
rest
  run (Char
'%':Char
'L':FilePath
rest) = FilePath
line FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
run FilePath
rest
  run (Char
'%':Char
'%':FilePath
rest) = Char
'%'   Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath -> FilePath
run FilePath
rest

  run (Char
'%':Char
'{':Char
'M':Char
'O':Char
'D':Char
'U':Char
'L':Char
'E':Char
'}':FilePath
rest) = FilePath
mdl  FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
run FilePath
rest
  run (Char
'%':Char
'{':Char
'F':Char
'I':Char
'L':Char
'E':Char
'}':FilePath
rest)         = FilePath
file FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
run FilePath
rest
  run (Char
'%':Char
'{':Char
'N':Char
'A':Char
'M':Char
'E':Char
'}':FilePath
rest)         = FilePath
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
run FilePath
rest
  run (Char
'%':Char
'{':Char
'K':Char
'I':Char
'N':Char
'D':Char
'}':FilePath
rest)         = FilePath
kind FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
run FilePath
rest

  run (Char
'%':Char
'{':Char
'M':Char
'O':Char
'D':Char
'U':Char
'L':Char
'E':Char
'/':Char
'.':Char
'/':Char
c:Char
'}':FilePath
rest) =
    (Char -> Char) -> FilePath -> FilePath
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) FilePath
mdl FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
run FilePath
rest

  run (Char
'%':Char
'{':Char
'F':Char
'I':Char
'L':Char
'E':Char
'/':Char
'/':Char
'/':Char
c:Char
'}':FilePath
rest) =
    (Char -> Char) -> FilePath -> FilePath
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) FilePath
file FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
run FilePath
rest

  run (Char
'%':Char
'{':Char
'L':Char
'I':Char
'N':Char
'E':Char
'}':FilePath
rest)         = FilePath
line FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
run FilePath
rest

  run (Char
c:FilePath
rest) = Char
c Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath -> FilePath
run FilePath
rest


renderToString :: Bool -> Html -> String
renderToString :: Bool -> Html -> FilePath
renderToString Bool
debug Html
html
  | Bool
debug = Html -> FilePath
forall html. HTML html => html -> FilePath
renderHtml Html
html
  | Bool
otherwise = Html -> FilePath
forall html. HTML html => html -> FilePath
showHtml Html
html


hsep :: [Html] -> Html
hsep :: [Html] -> Html
hsep [] = Html
noHtml
hsep [Html]
htmls = (Html -> Html -> Html) -> [Html] -> Html
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 (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 FilePath -> Html
forall a. HTML a => a -> Html
toHtml FilePath
" "

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


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


dcolon, arrow, darrow, forallSymbol, atSign :: Bool -> Html
dcolon :: Bool -> Html
dcolon Bool
unicode = FilePath -> Html
forall a. HTML a => a -> Html
toHtml (if Bool
unicode then FilePath
"∷" else FilePath
"::")
arrow :: Bool -> Html
arrow  Bool
unicode = FilePath -> Html
forall a. HTML a => a -> Html
toHtml (if Bool
unicode then FilePath
"→" else FilePath
"->")
darrow :: Bool -> Html
darrow Bool
unicode = FilePath -> Html
forall a. HTML a => a -> Html
toHtml (if Bool
unicode then FilePath
"⇒" else FilePath
"=>")
forallSymbol :: Bool -> Html
forallSymbol Bool
unicode = if Bool
unicode then FilePath -> Html
forall a. HTML a => a -> Html
toHtml FilePath
"∀" else FilePath -> Html
keyword FilePath
"forall"
atSign :: Bool -> Html
atSign Bool
unicode = FilePath -> Html
forall a. HTML a => a -> Html
toHtml (if Bool
unicode then FilePath
"@" else FilePath
"@")

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


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


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


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

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

data DetailsState = DetailsOpen | DetailsClosed

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

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

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

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