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

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

renderToken :: ColourPrefs -> (TokenType,String) -> String
renderToken :: ColourPrefs -> (TokenType, String) -> String
renderToken pref :: ColourPrefs
pref (t :: TokenType
t,s :: String
s) = [Highlight] -> String -> String
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 String -> String
renderComment String
s else String -> String
escape String
s)

renderAnchors :: (a -> String) -> Either String a -> String
renderAnchors :: (a -> String) -> Either String a -> String
renderAnchors _      (Left v :: String
v) = "<a name=\""String -> String -> String
forall a. [a] -> [a] -> [a]
++String
vString -> String -> String
forall a. [a] -> [a] -> [a]
++"\"></a>"
renderAnchors render :: a -> String
render (Right r :: 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@('h':'t':'t':'p':':':'/':'/':_) =
        String -> String
renderLink String
a String -> String -> String
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 x :: Char
x = Char -> Bool
isAlphaNum Char
x Bool -> Bool -> Bool
|| Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ":/?#[]@!$&'()*+,;=-._~%"
        (a :: String
a,b :: String
b) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isUrlChar String
xs
        renderLink :: String -> String
renderLink link :: String
link = "<a href=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
link String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\">" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
link String -> String -> String
forall a. [a] -> [a] -> [a]
++ "</a>"
        
renderComment (x :: Char
x:xs :: String
xs) = String -> String
escape [Char
x] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
renderComment String
xs
renderComment [] = []

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

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

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

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