-- | 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 -> String -> String
hscolour ColourPrefs
pref Bool
anchor Int
n = 
    String -> String
pre
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
anchor then Int -> String -> String
renderNewLinesAnchors Int
n
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. (a -> String) -> Either String a -> String
renderAnchors (ColourPrefs -> (TokenType, String) -> String
renderToken ColourPrefs
pref))
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TokenType, String)] -> [Either String (TokenType, String)]
insertAnchors
                 else forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ColourPrefs -> (TokenType, String) -> String
renderToken ColourPrefs
pref))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(TokenType, String)]
tokenise

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

pre :: String -> String
pre :: String -> String
pre = (String
"<pre>"forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++String
"</pre>")

renderToken :: ColourPrefs -> (TokenType,String) -> String
renderToken :: ColourPrefs -> (TokenType, String) -> String
renderToken ColourPrefs
pref (TokenType
t,String
s) = [Highlight] -> String -> String
fontify (ColourPrefs -> TokenType -> [Highlight]
colourise ColourPrefs
pref TokenType
t)
                         (if TokenType
t forall a. Eq a => a -> a -> Bool
== TokenType
Comment then String -> String
renderComment String
s else String -> String
escape String
s)

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

-- if there are http://links/ in a comment, turn them into
-- hyperlinks
renderComment :: String -> String
renderComment :: String -> String
renderComment xs :: String
xs@(Char
'h':Char
't':Char
't':Char
'p':Char
':':Char
'/':Char
'/':String
_) =
        String -> String
renderLink String
a forall a. [a] -> [a] -> [a]
++ String -> String
renderComment String
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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
":/?#[]@!$&'()*+,;=-._~%"
        (String
a,String
b) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isUrlChar String
xs
        renderLink :: String -> String
renderLink String
link = String
"<a href=\"" forall a. [a] -> [a] -> [a]
++ String
link forall a. [a] -> [a] -> [a]
++ String
"\">" forall a. [a] -> [a] -> [a]
++ String -> String
escape String
link forall a. [a] -> [a] -> [a]
++ String
"</a>"
        
renderComment (Char
x:String
xs) = String -> String
escape [Char
x] forall a. [a] -> [a] -> [a]
++ String -> String
renderComment String
xs
renderComment [] = []

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

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

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

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

htmlHeader ::  String -> String
htmlHeader :: String -> String
htmlHeader String
title = [String] -> String
unlines
  [ String
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">"
  , String
"<html>"
  , String
"<head>"
  ,String
"<!-- Generated by HsColour, http://code.haskell.org/~malcolm/hscolour/ -->"
  , String
"<title>"forall a. [a] -> [a] -> [a]
++String
titleforall a. [a] -> [a] -> [a]
++String
"</title>"
  , String
"</head>"
  , String
"<body>"
  ]
htmlClose ::  String
htmlClose :: String
htmlClose  = String
"\n</body>\n</html>"