module Anansi.HsColour.HTML (loomHTML) where
import Control.Monad (forM_)
import Control.Monad.Reader (asks)
import Control.Monad.Writer (tell)
import qualified Data.ByteString.Char8 as ByteString
import Data.ByteString.Char8 (ByteString)
import Data.Monoid (mappend, mconcat)
import qualified Data.Text
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Anansi hiding (loomHTML)
import qualified Language.Haskell.HsColour as HsColour
import Language.Haskell.HsColour.Colourise (defaultColourPrefs)
loomHTML :: Loom
loomHTML = mapM_ putBlock . documentBlocks where
putBlock b = case b of
BlockText text -> tell (encodeUtf8 text)
BlockFile path content -> do
epath <- escape path
let label = mconcat ["<b>» ", epath, "</b>"]
putContent label content
BlockDefine name content -> do
ename <- escape name
let label = mconcat ["<b>«", ename, "»</b>"]
putContent label content
putContent label cs = do
tell "<pre>"
tell label
tell "\n"
forM_ cs $ \c -> case c of
ContentText _ text -> do
expanded <- expandTabs text
tell (colorize (expanded `mappend` "\n"))
ContentMacro _ indent name -> formatMacro indent name >>= tell
tell "</pre>"
formatMacro :: Text -> Text -> LoomM ByteString
formatMacro indent name = do
ename <- escape name
return $ mconcat
[ encodeUtf8 indent
, "<i>«"
, ename
, "»</i>\n"
]
escape :: Text -> LoomM ByteString
escape txt = do
tabSize <- asks loomOptionTabSize
return $ encodeUtf8 $ Data.Text.concatMap (\c -> case c of
'\t' -> Data.Text.replicate (fromInteger tabSize) " "
'&' -> "&"
'<' -> "<"
'>' -> ">"
'"' -> """
'\'' -> "'"
_ -> Data.Text.singleton c) txt
expandTabs :: Text -> LoomM Text
expandTabs txt = do
tabSize <- asks loomOptionTabSize
return $ Data.Text.concatMap (\c -> case c of
'\t' -> Data.Text.replicate (fromInteger tabSize) " "
_ -> Data.Text.singleton c) txt
colorize :: Text -> ByteString
colorize = ByteString.pack
. dropPre
. HsColour.hscolour HsColour.HTML defaultColourPrefs False True "" False
. ByteString.unpack
. encodeUtf8
dropPre :: String -> String
dropPre = drop 5 . reverse . drop 6 . reverse