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 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
renderComment :: String -> String
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
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
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) = "<"String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
escape String
cs
escape ('>':cs :: String
cs) = ">"String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
escape String
cs
escape ('&':cs :: String
cs) = "&"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
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>"