{-# LANGUAGE CPP #-}
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)
formatHtmlInline :: FormatOptions -> [SourceLine] -> Html
formatHtmlInline :: FormatOptions -> [SourceLine] -> Html
formatHtmlInline 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
$ String
"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 String
"\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 FormatOptions
_ (TokenType
NormalTok, String
txt) = String -> Html
forall a. ToMarkup a => a -> Html
toHtml String
txt
tokenToHtml FormatOptions
opts (TokenType
toktype, 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 TokenType
KeywordTok = String
"kw"
short TokenType
DataTypeTok = String
"dt"
short TokenType
DecValTok = String
"dv"
short TokenType
BaseNTok = String
"bn"
short TokenType
FloatTok = String
"fl"
short TokenType
CharTok = String
"ch"
short TokenType
StringTok = String
"st"
short TokenType
CommentTok = String
"co"
short TokenType
OtherTok = String
"ot"
short TokenType
AlertTok = String
"al"
short TokenType
FunctionTok = String
"fu"
short TokenType
RegionMarkerTok = String
"re"
short TokenType
ErrorTok = String
"er"
short TokenType
ConstantTok = String
"cn"
short TokenType
SpecialCharTok = String
"sc"
short TokenType
VerbatimStringTok = String
"vs"
short TokenType
SpecialStringTok = String
"ss"
short TokenType
ImportTok = String
"im"
short TokenType
DocumentationTok = String
"do"
short TokenType
AnnotationTok = String
"an"
short TokenType
CommentVarTok = String
"cv"
short TokenType
VariableTok = String
"va"
short TokenType
ControlFlowTok = String
"cf"
short TokenType
OperatorTok = String
"op"
short TokenType
BuiltInTok = String
"bu"
short TokenType
ExtensionTok = String
"ex"
short TokenType
PreprocessorTok = String
"pp"
short TokenType
AttributeTok = String
"at"
short TokenType
InformationTok = String
"in"
short TokenType
WarningTok = String
"wa"
short TokenType
NormalTok = String
""
sourceLineToHtml :: FormatOptions -> SourceLine -> Html
sourceLineToHtml :: FormatOptions -> SourceLine -> Html
sourceLineToHtml FormatOptions
opts 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 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
formatHtmlBlock :: FormatOptions -> [SourceLine] -> Html
formatHtmlBlock :: FormatOptions -> [SourceLine] -> Html
formatHtmlBlock FormatOptions
opts [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 String
"sourceCode"
classes :: [String]
classes = String
"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
/= String
"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 String
"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
- Int
1)]
lineNum :: a -> Html
lineNum 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 -> 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 String
"\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]
++ String
"\n"
where nStr :: String
nStr = a -> String
forall a. Show a => a -> String
show a
n
styleToCss :: Style -> String
styleToCss :: Style -> String
styleToCss 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
(Maybe Color
Nothing, Maybe Color
Nothing) -> []
(Just Color
c, Maybe Color
Nothing) -> [String
"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]
++ String
"; }"]
(Maybe Color
Nothing, Just Color
c) -> [String
"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]
++ String
"; }"]
(Just Color
c1, Just Color
c2) -> [String
"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]
++ String
"; 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]
++ String
"; }"]
tablespec :: [String]
tablespec = [
String
"table.sourceCode, tr.sourceCode, td.lineNumbers, td.sourceCode {"
,String
" margin: 0; padding: 0; vertical-align: baseline; border: none; }"
,String
"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 String
"" (\Color
c -> String
"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]
++ String
"; ") (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 String
"" (\Color
c -> String
"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]
++ String
"; ") (Style -> Maybe Color
defaultColor Style
f) String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"}"
,String
"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 String
"" (\Color
c -> String
"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]
++ String
"; ") (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 String
"" (\Color
c -> String
"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]
++ String
"; ") (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 String
"" (\Color
c -> String
"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]
++ String
"; ") (Style -> Maybe Color
lineNumberColor Style
f) String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"}"
,String
"td.sourceCode { padding-left: 5px; }"
]
divspec :: [String]
divspec = [ String
"div.sourceCode { overflow-x: auto; }" ]
toCss :: (TokenType, TokenStyle) -> String
toCss :: (TokenType, TokenStyle) -> String
toCss (TokenType
t,TokenStyle
tf) = String
"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 -> 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 -> 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]
++ String
" */"
where colorspec :: String
colorspec = String -> (Color -> String) -> Maybe Color -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Color
col -> String
"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]
++ String
"; ") (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 String
"" (\Color
col -> String
"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]
++ String
"; ") (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 String
"font-weight: bold; " else String
""
stylespec :: String
stylespec = if TokenStyle -> Bool
tokenItalic TokenStyle
tf then String
"font-style: italic; " else String
""
decorationspec :: String
decorationspec = if TokenStyle -> Bool
tokenUnderline TokenStyle
tf then String
"text-decoration: underline; " else String
""
showTokenType :: a -> String
showTokenType a
t = case String -> String
forall a. [a] -> [a]
reverse (a -> String
forall a. Show a => a -> String
show a
t) of
Char
'k':Char
'o':Char
'T':String
xs -> String -> String
forall a. [a] -> [a]
reverse String
xs
String
_ -> String
""