-- | Formats Haskell source code as HTML with inline CSS.
module Language.Haskell.HsColour.InlineCSS (hscolour,top'n'tail) where

import Language.Haskell.HsColour.Anchors
import Language.Haskell.HsColour.Classify as Classify
import Language.Haskell.HsColour.Colourise
import Language.Haskell.HsColour.HTML (renderAnchors, renderComment,
                                       renderNewLinesAnchors, escape)
import Text.Printf

-- | Formats Haskell source code as a complete HTML document with inline styling
hscolour :: ColourPrefs	-- ^ Preferences for styling.
         -> Bool   -- ^ Whether to include anchors.
         -> Int    -- ^ Starting line number (for line anchors).
         -> String -- ^ Haskell source code.
         -> String -- ^ An HTML document containing the coloured 
                   --   Haskell source code.
hscolour :: ColourPrefs -> Bool -> Int -> [Char] -> [Char]
hscolour ColourPrefs
prefs Bool
anchor Int
n =
  [Char] -> [Char]
pre
  ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
anchor 
        then Int -> [Char] -> [Char]
renderNewLinesAnchors Int
n
             ([Char] -> [Char])
-> ([(TokenType, [Char])] -> [Char])
-> [(TokenType, [Char])]
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either [Char] (TokenType, [Char]) -> [Char])
-> [Either [Char] (TokenType, [Char])] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((TokenType, [Char]) -> [Char])
-> Either [Char] (TokenType, [Char]) -> [Char]
forall a. (a -> [Char]) -> Either [Char] a -> [Char]
renderAnchors (ColourPrefs -> (TokenType, [Char]) -> [Char]
renderToken ColourPrefs
prefs))
             ([Either [Char] (TokenType, [Char])] -> [Char])
-> ([(TokenType, [Char])] -> [Either [Char] (TokenType, [Char])])
-> [(TokenType, [Char])]
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TokenType, [Char])] -> [Either [Char] (TokenType, [Char])]
insertAnchors
        else ((TokenType, [Char]) -> [Char]) -> [(TokenType, [Char])] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ColourPrefs -> (TokenType, [Char]) -> [Char]
renderToken ColourPrefs
prefs))
  ([(TokenType, [Char])] -> [Char])
-> ([Char] -> [(TokenType, [Char])]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [(TokenType, [Char])]
tokenise

top'n'tail :: String -> String -> String
top'n'tail :: [Char] -> [Char] -> [Char]
top'n'tail [Char]
title  = ([Char] -> [Char]
cssPrefix [Char]
title [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
cssSuffix)

pre :: String -> String
pre :: [Char] -> [Char]
pre =   ([Char]
"<pre style=\"font-family:Consolas, Monaco, Monospace;\">"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
      ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"</pre>")

renderToken :: ColourPrefs -> (TokenType,String) -> String
renderToken :: ColourPrefs -> (TokenType, [Char]) -> [Char]
renderToken ColourPrefs
prefs (TokenType
cls,[Char]
text) =
  [Highlight] -> [Char] -> [Char]
stylise (ColourPrefs -> TokenType -> [Highlight]
colourise ColourPrefs
prefs TokenType
cls) ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$
  if TokenType
cls TokenType -> TokenType -> Bool
forall a. Eq a => a -> a -> Bool
== TokenType
Comment then [Char] -> [Char]
renderComment [Char]
text else [Char] -> [Char]
escape [Char]
text

stylise :: [Highlight] -> String -> String
stylise :: [Highlight] -> [Char] -> [Char]
stylise [Highlight]
hs [Char]
s = [Char]
"<span style=\"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Highlight -> [Char]) -> [Highlight] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Highlight -> [Char]
style [Highlight]
hs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\">" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
s[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"</span>"

cssPrefix :: [Char] -> [Char]
cssPrefix [Char]
title = [[Char]] -> [Char]
unlines
    [[Char]
"<?xml version=\"1.0\" encoding=\"UTF-8\">"
    ,[Char]
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
    ,[Char]
"<html>"
    ,[Char]
"<head>"
    ,[Char]
"<!-- Generated by HsColour, http://code.haskell.org/~malcolm/hscolour/ -->"
    ,[Char]
"<title>"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
title[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"</title>"
    ,[Char]
"</head>"
    ,[Char]
"<body style=\"background-color: #131313; color: #ffffff;\">"
    ]
    
cssSuffix :: [Char]
cssSuffix = [[Char]] -> [Char]
unlines
    [[Char]
"</body>"
    ,[Char]
"</html>"
    ]

style :: Highlight -> String
style :: Highlight -> [Char]
style Highlight
Normal         = [Char]
""
style Highlight
Bold           = [Char]
"font-weight: bold;"
style Highlight
Dim            = [Char]
"font-weight: lighter;"
style Highlight
Underscore     = [Char]
"text-decoration: underline;"
style Highlight
Blink          = [Char]
"text-decoration:  blink;"
style Highlight
ReverseVideo   = [Char]
""
style Highlight
Concealed      = [Char]
"text-decoration:  line-through;"
style (Foreground Colour
c) = [Char]
"color: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Colour -> [Char]
csscolour Colour
c[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
";"
style (Background Colour
c) = [Char]
"background-color: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Colour -> [Char]
csscolour Colour
c[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
";"
style Highlight
Italic         = [Char]
"font-style: italic;"

csscolour :: Colour -> String
csscolour :: Colour -> [Char]
csscolour Colour
Black   = [Char]
"#000000"
csscolour Colour
Red     = [Char]
"#ff0000"
csscolour Colour
Green   = [Char]
"#00ff00"
csscolour Colour
Yellow  = [Char]
"#ffff00"
csscolour Colour
Blue    = [Char]
"#0000ff"
csscolour Colour
Magenta = [Char]
"#ff00ff"
csscolour Colour
Cyan    = [Char]
"#00ffff"
csscolour Colour
White   = [Char]
"#ffffff"
csscolour (Rgb Word8
r Word8
g Word8
b) = [Char] -> Word8 -> Word8 -> Word8 -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"#%02x%02x%02x" Word8
r Word8
g Word8
b