-- | Formats Haskell source code as HTML with CSS.
module Language.Haskell.HsColour.CSS 
  ( hscolour
  , top'n'tail
  , renderToken 
  , pre 
  ) where

import Language.Haskell.HsColour.Anchors
import Language.Haskell.HsColour.Classify as Classify
import Language.Haskell.HsColour.HTML (renderAnchors, renderComment,
                                       renderNewLinesAnchors, escape)

-- | Formats Haskell source code as a complete HTML document with CSS.
hscolour :: Bool   -- ^ Whether to include anchors.
         -> Int    -- ^ Starting line number (for line anchors).
         -> String -- ^ Haskell source code.
         -> String -- ^ An HTML document containing the coloured 
                   --   Haskell source code.
hscolour :: Bool -> Int -> String -> String
hscolour 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 (TokenType, String) -> String
renderToken)
             ([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 (TokenType, String) -> String
renderToken)
  ([(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
cssPrefix 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
cssSuffix)

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 :: (TokenType,String) -> String
renderToken :: (TokenType, String) -> String
renderToken (cls :: TokenType
cls,text :: String
text) =
        String
before String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if TokenType
cls TokenType -> TokenType -> Bool
forall a. Eq a => a -> a -> Bool
== TokenType
Comment then String -> String
renderComment String
text else String -> String
escape String
text) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
after
    where
        before :: String
before = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
cls2 then "" else "<span class='" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cls2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'>"
        after :: String
after  = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
cls2 then "" else "</span>"
        cls2 :: String
cls2 = TokenType -> String
cssClass TokenType
cls


cssClass :: TokenType -> String
cssClass Keyword  = "hs-keyword"
cssClass Keyglyph = "hs-keyglyph"
cssClass Layout   = "hs-layout"
cssClass Comment  = "hs-comment"
cssClass Conid    = "hs-conid"
cssClass Varid    = "hs-varid"
cssClass Conop    = "hs-conop"
cssClass Varop    = "hs-varop"
cssClass String   = "hs-str"
cssClass Char     = "hs-chr"
cssClass Number   = "hs-num"
cssClass Cpp      = "hs-cpp"
cssClass Error    = "hs-sel"
cssClass Definition = "hs-definition"
cssClass _        = ""


cssPrefix :: String -> String
cssPrefix title :: String
title = [String] -> String
unlines
    ["<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
    ,"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
    ,"<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>"
    ,"<link type='text/css' rel='stylesheet' href='hscolour.css' />"
    ,"</head>"
    ,"<body>"
    ]
    
cssSuffix :: String
cssSuffix = [String] -> String
unlines
    ["</body>"
    ,"</html>"
    ]