module Language.Haskell.HsColour.HTML
( hscolour
, top'n'tail
, 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
hscolour :: ColourPrefs
-> Bool
-> Int
-> String
-> String
hscolour :: ColourPrefs -> Bool -> Int -> String -> String
hscolour ColourPrefs
pref Bool
anchor 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 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 = (String
"<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]
++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 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 a -> String
_ (Left String
v) = String
"<a name=\""String -> String -> String
forall a. [a] -> [a] -> [a]
++String
vString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\"></a>"
renderAnchors a -> String
render (Right a
r) = a -> String
render a
r
renderComment :: String -> String
xs :: String
xs@(Char
'h':Char
't':Char
't':Char
'p':Char
':':Char
'/':Char
'/':String
_) =
String -> String
renderLink String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
renderComment String
b
where
isUrlChar :: Char -> Bool
isUrlChar 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` String
":/?#[]@!$&'()*+,;=-._~%"
(String
a,String
b) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isUrlChar String
xs
renderLink :: String -> String
renderLink String
link = String
"<a href=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
link String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\">" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
link String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"</a>"
renderComment (Char
x: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 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 (a
line, String
s) = String
"<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]
++ String
"\"></a>" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
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>"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"</b>"
font Highlight
Dim String
s = String
"<em>"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"</em>"
font Highlight
Underscore String
s = String
"<u>"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"</u>"
font Highlight
Blink String
s = String
"<blink>"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
sString -> String -> String
forall 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 = String -> Word8 -> Word8 -> Word8 -> String -> String
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 = String -> Word8 -> Word8 -> Word8 -> String -> String
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="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 -> String
forall a. [a] -> [a] -> [a]
++String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"</font>"
font (Background Colour
c) String
s = String
"<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 -> String
forall a. [a] -> [a] -> [a]
++String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"</font>"
font Highlight
Italic String
s = String
"<i>"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"</i>"
escape :: String -> String
escape :: String -> String
escape (Char
'<':String
cs) = String
"<"String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
escape String
cs
escape (Char
'>':String
cs) = String
">"String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
escape String
cs
escape (Char
'&':String
cs) = String
"&"String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
escape String
cs
escape (Char
c:String
cs) = Char
cChar -> String -> String
forall a. a -> [a] -> [a]
: String -> String
escape String
cs
escape [] = []
htmlHeader :: String -> String
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>"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
titleString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"</title>"
, String
"</head>"
, String
"<body>"
]
htmlClose :: String
htmlClose :: String
htmlClose = String
"\n</body>\n</html>"