-- | Formats Haskell source code using HTML with font tags.
module Language.Haskell.HsColour.HTML 
    ( hscolour
    , top'n'tail
     -- * Internals
    , renderAnchors, renderComment, renderNewLinesAnchors, escape
    ) where

import Language.Haskell.HsColour.Anchors
import Language.Haskell.HsColour.Classify as Classify
import Language.Haskell.HsColour.Colourise

import Data.Char(isAlphaNum)
import Text.Printf


-- | Formats Haskell source code using HTML with font tags.
hscolour :: ColourPrefs -- ^ Colour preferences.
         -> Bool        -- ^ Whether to include anchors.
         -> Int         -- ^ Starting line number (for line anchors).
         -> String      -- ^ Haskell source code.
         -> String      -- ^ Coloured Haskell source code.
hscolour :: ColourPrefs -> Bool -> Int -> [Char] -> [Char]
hscolour ColourPrefs
pref 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
pref))
                      ([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
pref))
    ([(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]
htmlHeader [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]
htmlClose)

pre :: String -> String
pre :: [Char] -> [Char]
pre = ([Char]
"<pre>"[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
pref (TokenType
t,[Char]
s) = [Highlight] -> [Char] -> [Char]
fontify (ColourPrefs -> TokenType -> [Highlight]
colourise ColourPrefs
pref TokenType
t)
                         (if TokenType
t TokenType -> TokenType -> Bool
forall a. Eq a => a -> a -> Bool
== TokenType
Comment then [Char] -> [Char]
renderComment [Char]
s else [Char] -> [Char]
escape [Char]
s)

renderAnchors :: (a -> String) -> Either String a -> String
renderAnchors :: forall a. (a -> [Char]) -> Either [Char] a -> [Char]
renderAnchors a -> [Char]
_      (Left [Char]
v) = [Char]
"<a name=\""[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
v[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\"></a>"
renderAnchors a -> [Char]
render (Right a
r) = a -> [Char]
render a
r

-- if there are http://links/ in a comment, turn them into
-- hyperlinks
renderComment :: String -> String
renderComment :: [Char] -> [Char]
renderComment xs :: [Char]
xs@(Char
'h':Char
't':Char
't':Char
'p':Char
':':Char
'/':Char
'/':[Char]
_) =
        [Char] -> [Char]
renderLink [Char]
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
renderComment [Char]
b
    where
        -- see http://www.gbiv.com/protocols/uri/rfc/rfc3986.html#characters
        isUrlChar :: Char -> Bool
isUrlChar Char
x = Char -> Bool
isAlphaNum Char
x Bool -> Bool -> Bool
|| Char
x Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
":/?#[]@!$&'()*+,;=-._~%"
        ([Char]
a,[Char]
b) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isUrlChar [Char]
xs
        renderLink :: [Char] -> [Char]
renderLink [Char]
link = [Char]
"<a href=\"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
link [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\">" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
escape [Char]
link [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"</a>"
        
renderComment (Char
x:[Char]
xs) = [Char] -> [Char]
escape [Char
x] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
renderComment [Char]
xs
renderComment [] = []

renderNewLinesAnchors :: Int -> String -> String
renderNewLinesAnchors :: Int -> [Char] -> [Char]
renderNewLinesAnchors Int
n = [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, [Char]) -> [Char]) -> [(Int, [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Int, [Char]) -> [Char]
forall {a}. Show a => (a, [Char]) -> [Char]
render ([(Int, [Char])] -> [[Char]])
-> ([Char] -> [(Int, [Char])]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [[Char]] -> [(Int, [Char])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
n..] ([[Char]] -> [(Int, [Char])])
-> ([Char] -> [[Char]]) -> [Char] -> [(Int, [Char])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines
    where render :: (a, [Char]) -> [Char]
render (a
line, [Char]
s) = [Char]
"<a name=\"line-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
line [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\"></a>" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s

-- Html stuff
fontify ::  [Highlight] -> String -> String
fontify :: [Highlight] -> [Char] -> [Char]
fontify [] [Char]
s     = [Char]
s
fontify (Highlight
h:[Highlight]
hs) [Char]
s = Highlight -> [Char] -> [Char]
font Highlight
h ([Highlight] -> [Char] -> [Char]
fontify [Highlight]
hs [Char]
s)

font ::  Highlight -> String -> String
font :: Highlight -> [Char] -> [Char]
font Highlight
Normal         [Char]
s = [Char]
s
font Highlight
Bold           [Char]
s = [Char]
"<b>"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
s[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"</b>"
font Highlight
Dim            [Char]
s = [Char]
"<em>"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
s[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"</em>"
font Highlight
Underscore     [Char]
s = [Char]
"<u>"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
s[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"</u>"
font Highlight
Blink          [Char]
s = [Char]
"<blink>"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
s[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"</blink>"
font Highlight
ReverseVideo   [Char]
s = [Char]
s
font Highlight
Concealed      [Char]
s = [Char]
s
font (Foreground (Rgb Word8
r Word8
g Word8
b)) [Char]
s = [Char] -> Word8 -> Word8 -> Word8 -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf   [Char]
"<font color=\"#%02x%02x%02x\">%s</font>" Word8
r Word8
g Word8
b [Char]
s
font (Background (Rgb Word8
r Word8
g Word8
b)) [Char]
s = [Char] -> Word8 -> Word8 -> Word8 -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"<font bgcolor=\"#%02x%02x%02x\">%s</font>" Word8
r Word8
g Word8
b [Char]
s
font (Foreground Colour
c) [Char]
s =   [Char]
"<font color="[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Colour -> [Char]
forall a. Show a => a -> [Char]
show Colour
c[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]
"</font>"
font (Background Colour
c) [Char]
s = [Char]
"<font bgcolor="[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Colour -> [Char]
forall a. Show a => a -> [Char]
show Colour
c[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]
"</font>"
font Highlight
Italic         [Char]
s = [Char]
"<i>"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
s[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"</i>"

escape ::  String -> String
escape :: [Char] -> [Char]
escape (Char
'<':[Char]
cs) = [Char]
"&lt;"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char] -> [Char]
escape [Char]
cs
escape (Char
'>':[Char]
cs) = [Char]
"&gt;"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char] -> [Char]
escape [Char]
cs
escape (Char
'&':[Char]
cs) = [Char]
"&amp;"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char] -> [Char]
escape [Char]
cs
escape (Char
c:[Char]
cs)   = Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
escape [Char]
cs
escape []       = []

htmlHeader ::  String -> String
htmlHeader :: [Char] -> [Char]
htmlHeader [Char]
title = [[Char]] -> [Char]
unlines
  [ [Char]
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">"
  , [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>"
  ]
htmlClose ::  String
htmlClose :: [Char]
htmlClose  = [Char]
"\n</body>\n</html>"