{-# LANGUAGE CPP #-}
{- |
   Module      : Text.Highlighting.Kate.Format.HTML
   Copyright   : Copyright (C) 2008-2011 John MacFarlane
   License     : GNU GPL, version 2 or above

   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : portable

Formatters that convert a list of annotated source lines to HTML.
-}

module Text.Highlighting.Kate.Format.HTML (
      formatHtmlInline, formatHtmlBlock, styleToCss
   ) where
import Text.Highlighting.Kate.Types
#if MIN_VERSION_blaze_html(0,5,0)
import Text.Blaze.Html
#else
import Text.Blaze
#endif
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Data.Monoid
import Data.List (intersperse)

-- | Format tokens using HTML spans inside @code@ tags. For example,
-- A @KeywordTok@ is rendered as a span with class @kw@.
-- Short class names correspond to 'TokenType's as follows:
-- 'KeywordTok' = @kw@, 'DataTypeTok' = @dt@,
-- 'DecValTok' = @dv@, 'BaseNTok' = @bn@, 'FloatTok' = @fl@,
-- 'CharTok' = @ch@, 'StringTok' = @st@, 'CommontTok' = @co@,
-- 'OtherTok' = @ot@, 'AlertTok' = @al@, 'FunctionTok' = @fu@,
-- 'RegionMarkerTok' = @re@, 'ErrorTok' = @er@,
-- 'ConstantTok' = @cn@, 'SpecialCharTok' = @sc@,
-- 'VerbatimStringTok' = @vs@, 'SpecialStringTok' = @ss@,
-- 'ImportTok' = @im@, 'DocumentationTok' = @do@,
-- 'AnnotationTok' = @an@, 'CommentVarTok' = @cv@,
-- 'VariableTok' = @va@, 'ControlFlowTok' = @cf@,
-- 'OperatorTok' = @op@, 'BuiltInTok' = @bu@,
-- 'ExtensionTok' = @ex@, 'PreprocessorTok' = @pp@,
-- 'AttributeTok' = @at@, 'InformationTok' = @in@,
-- 'WarningTok' = @wa@.
-- A 'NormalTok' is not marked up at all.
formatHtmlInline :: FormatOptions -> [SourceLine] -> Html
formatHtmlInline :: FormatOptions -> [SourceLine] -> Html
formatHtmlInline opts :: FormatOptions
opts = (Html -> Html
H.code (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ (String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
                                                    ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ "sourceCode" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: FormatOptions -> [String]
codeClasses FormatOptions
opts))
                                (Html -> Html) -> ([SourceLine] -> Html) -> [SourceLine] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html)
-> ([SourceLine] -> [Html]) -> [SourceLine] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> [Html] -> [Html]
forall a. a -> [a] -> [a]
intersperse (String -> Html
forall a. ToMarkup a => a -> Html
toHtml "\n")
                                ([Html] -> [Html])
-> ([SourceLine] -> [Html]) -> [SourceLine] -> [Html]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SourceLine -> Html) -> [SourceLine] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map (FormatOptions -> SourceLine -> Html
sourceLineToHtml FormatOptions
opts)

tokenToHtml :: FormatOptions -> Token -> Html
tokenToHtml :: FormatOptions -> Token -> Html
tokenToHtml _ (NormalTok, txt :: String
txt)  = String -> Html
forall a. ToMarkup a => a -> Html
toHtml String
txt
tokenToHtml opts :: FormatOptions
opts (toktype :: TokenType
toktype, txt :: String
txt) =
  if FormatOptions -> Bool
titleAttributes FormatOptions
opts
     then Html
sp Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.title (String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ TokenType -> String
forall a. Show a => a -> String
show TokenType
toktype)
     else Html
sp
   where sp :: Html
sp = Html -> Html
H.span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ (String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ TokenType -> String
short TokenType
toktype) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. ToMarkup a => a -> Html
toHtml String
txt

short :: TokenType -> String
short :: TokenType -> String
short KeywordTok        = "kw"
short DataTypeTok       = "dt"
short DecValTok         = "dv"
short BaseNTok          = "bn"
short FloatTok          = "fl"
short CharTok           = "ch"
short StringTok         = "st"
short CommentTok        = "co"
short OtherTok          = "ot"
short AlertTok          = "al"
short FunctionTok       = "fu"
short RegionMarkerTok   = "re"
short ErrorTok          = "er"
short ConstantTok       = "cn"
short SpecialCharTok    = "sc"
short VerbatimStringTok = "vs"
short SpecialStringTok  = "ss"
short ImportTok         = "im"
short DocumentationTok  = "do"
short AnnotationTok     = "an"
short CommentVarTok     = "cv"
short VariableTok       = "va"
short ControlFlowTok    = "cf"
short OperatorTok       = "op"
short BuiltInTok        = "bu"
short ExtensionTok      = "ex"
short PreprocessorTok   = "pp"
short AttributeTok      = "at"
short InformationTok    = "in"
short WarningTok        = "wa"
short NormalTok         = ""

sourceLineToHtml :: FormatOptions -> SourceLine -> Html
sourceLineToHtml :: FormatOptions -> SourceLine -> Html
sourceLineToHtml opts :: FormatOptions
opts contents :: SourceLine
contents = (Token -> Html) -> SourceLine -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FormatOptions -> Token -> Html
tokenToHtml FormatOptions
opts) SourceLine
contents

formatHtmlBlockPre :: FormatOptions -> [SourceLine] -> Html
formatHtmlBlockPre :: FormatOptions -> [SourceLine] -> Html
formatHtmlBlockPre opts :: FormatOptions
opts = Html -> Html
H.pre (Html -> Html) -> ([SourceLine] -> Html) -> [SourceLine] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FormatOptions -> [SourceLine] -> Html
formatHtmlInline FormatOptions
opts

-- | Format tokens as an HTML @pre@ block. If line numbering is
-- selected, this is put into a table row with line numbers in the
-- left cell.  The whole code block is wrapped in a @div@ element
-- to aid styling (e.g. the overflow-x property).
formatHtmlBlock :: FormatOptions -> [SourceLine] -> Html
formatHtmlBlock :: FormatOptions -> [SourceLine] -> Html
formatHtmlBlock opts :: FormatOptions
opts ls :: [SourceLine]
ls = Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
sourceCode (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
                            Html
container Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ (String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String]
classes)
  where  container :: Html
container = if FormatOptions -> Bool
numberLines FormatOptions
opts
                        then Html -> Html
H.table (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.tr (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
sourceCode (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
                                 Html
nums Html -> Html -> Html
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Html
source
                        else Html
pre
         sourceCode :: AttributeValue
sourceCode = String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue "sourceCode"
         classes :: [String]
classes = "sourceCode" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
                   [String
x | String
x <- FormatOptions -> [String]
containerClasses FormatOptions
opts, String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= "sourceCode"]
         pre :: Html
pre = FormatOptions -> [SourceLine] -> Html
formatHtmlBlockPre FormatOptions
opts [SourceLine]
ls
         source :: Html
source = Html -> Html
H.td (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
sourceCode (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
pre
         startNum :: Int
startNum = FormatOptions -> Int
startNumber FormatOptions
opts
         nums :: Html
nums = Html -> Html
H.td (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ (String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue "lineNumbers")
                     (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.pre
                     (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ (Int -> Html) -> [Int] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> Html
forall a. Show a => a -> Html
lineNum [Int
startNum..(Int
startNum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [SourceLine] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceLine]
ls Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)]
         lineNum :: a -> Html
lineNum n :: a
n = if FormatOptions -> Bool
lineAnchors FormatOptions
opts
                        then (Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id (String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue String
nStr) (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ "#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nStr) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. ToMarkup a => a -> Html
toHtml (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
n)
                              Html -> Html -> Html
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Html
forall a. ToMarkup a => a -> Html
toHtml "\n"
                        else String -> Html
forall a. ToMarkup a => a -> Html
toHtml (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n"
           where nStr :: String
nStr = a -> String
forall a. Show a => a -> String
show a
n

-- | Returns CSS for styling highlighted code according to the given style.
styleToCss :: Style -> String
styleToCss :: Style -> String
styleToCss f :: Style
f = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
divspec [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
tablespec [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
colorspec [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((TokenType, TokenStyle) -> String)
-> [(TokenType, TokenStyle)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (TokenType, TokenStyle) -> String
toCss (Style -> [(TokenType, TokenStyle)]
tokenStyles Style
f)
   where colorspec :: [String]
colorspec = case (Style -> Maybe Color
defaultColor Style
f, Style -> Maybe Color
backgroundColor Style
f) of
                          (Nothing, Nothing) -> []
                          (Just c :: Color
c, Nothing)  -> ["pre, code { color: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Color -> String
forall a. FromColor a => Color -> a
fromColor Color
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ "; }"]
                          (Nothing, Just c :: Color
c)  -> ["pre, code { background-color: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Color -> String
forall a. FromColor a => Color -> a
fromColor Color
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ "; }"]
                          (Just c1 :: Color
c1, Just c2 :: Color
c2) -> ["pre, code { color: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Color -> String
forall a. FromColor a => Color -> a
fromColor Color
c1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "; background-color: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                  Color -> String
forall a. FromColor a => Color -> a
fromColor Color
c2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "; }"]
         tablespec :: [String]
tablespec = [
           "table.sourceCode, tr.sourceCode, td.lineNumbers, td.sourceCode {"
          ,"  margin: 0; padding: 0; vertical-align: baseline; border: none; }"
          ,"table.sourceCode { width: 100%; line-height: 100%; " String -> String -> String
forall a. [a] -> [a] -> [a]
++
             String -> (Color -> String) -> Maybe Color -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (\c :: Color
c -> "background-color: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Color -> String
forall a. FromColor a => Color -> a
fromColor Color
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ "; ") (Style -> Maybe Color
backgroundColor Style
f) String -> String -> String
forall a. [a] -> [a] -> [a]
++
             String -> (Color -> String) -> Maybe Color -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (\c :: Color
c -> "color: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Color -> String
forall a. FromColor a => Color -> a
fromColor Color
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ "; ") (Style -> Maybe Color
defaultColor Style
f) String -> String -> String
forall a. [a] -> [a] -> [a]
++
             "}"
          ,"td.lineNumbers { text-align: right; padding-right: 4px; padding-left: 4px; " String -> String -> String
forall a. [a] -> [a] -> [a]
++
             String -> (Color -> String) -> Maybe Color -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (\c :: Color
c -> "background-color: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Color -> String
forall a. FromColor a => Color -> a
fromColor Color
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ "; ") (Style -> Maybe Color
lineNumberBackgroundColor Style
f) String -> String -> String
forall a. [a] -> [a] -> [a]
++
             String -> (Color -> String) -> Maybe Color -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (\c :: Color
c -> "color: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Color -> String
forall a. FromColor a => Color -> a
fromColor Color
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ "; ") (Style -> Maybe Color
lineNumberColor Style
f) String -> String -> String
forall a. [a] -> [a] -> [a]
++
             String -> (Color -> String) -> Maybe Color -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (\c :: Color
c -> "border-right: 1px solid " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Color -> String
forall a. FromColor a => Color -> a
fromColor Color
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ "; ") (Style -> Maybe Color
lineNumberColor Style
f) String -> String -> String
forall a. [a] -> [a] -> [a]
++
             "}"
          ,"td.sourceCode { padding-left: 5px; }"
          ]
         divspec :: [String]
divspec = [ "div.sourceCode { overflow-x: auto; }" ]

toCss :: (TokenType, TokenStyle) -> String
toCss :: (TokenType, TokenStyle) -> String
toCss (t :: TokenType
t,tf :: TokenStyle
tf) = "code > span." String -> String -> String
forall a. [a] -> [a] -> [a]
++ TokenType -> String
short TokenType
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ " { "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
colorspec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
backgroundspec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
weightspec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stylespec
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
decorationspec String -> String -> String
forall a. [a] -> [a] -> [a]
++ "} /* " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TokenType -> String
forall a. Show a => a -> String
showTokenType TokenType
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ " */"
  where colorspec :: String
colorspec = String -> (Color -> String) -> Maybe Color -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (\col :: Color
col -> "color: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Color -> String
forall a. FromColor a => Color -> a
fromColor Color
col String -> String -> String
forall a. [a] -> [a] -> [a]
++ "; ") (Maybe Color -> String) -> Maybe Color -> String
forall a b. (a -> b) -> a -> b
$ TokenStyle -> Maybe Color
tokenColor TokenStyle
tf
        backgroundspec :: String
backgroundspec = String -> (Color -> String) -> Maybe Color -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (\col :: Color
col -> "background-color: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Color -> String
forall a. FromColor a => Color -> a
fromColor Color
col String -> String -> String
forall a. [a] -> [a] -> [a]
++ "; ") (Maybe Color -> String) -> Maybe Color -> String
forall a b. (a -> b) -> a -> b
$ TokenStyle -> Maybe Color
tokenBackground TokenStyle
tf
        weightspec :: String
weightspec = if TokenStyle -> Bool
tokenBold TokenStyle
tf then "font-weight: bold; " else ""
        stylespec :: String
stylespec  = if TokenStyle -> Bool
tokenItalic TokenStyle
tf then "font-style: italic; " else ""
        decorationspec :: String
decorationspec = if TokenStyle -> Bool
tokenUnderline TokenStyle
tf then "text-decoration: underline; " else ""
        showTokenType :: a -> String
showTokenType t :: a
t = case String -> String
forall a. [a] -> [a]
reverse (a -> String
forall a. Show a => a -> String
show a
t) of
                             'k':'o':'T':xs :: String
xs -> String -> String
forall a. [a] -> [a]
reverse String
xs
                             _              -> ""