{-# LANGUAGE CPP, OverloadedStrings #-}
module Main where
import Text.Highlighting.Kate
import System.IO (hPutStrLn, stderr)
import System.Environment
import System.Console.GetOpt
import System.Exit
import System.FilePath (takeFileName)
import Data.Maybe (listToMaybe)
import Data.Char (toLower)
#if MIN_VERSION_blaze_html(0,5,0)
import Text.Blaze.Html
import Text.Blaze.Html.Renderer.String
#else
import Text.Blaze
import Text.Blaze.Renderer.String
#endif
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
data Flag = Sty String
| Format String
| Help
| Fragment
| List
| NumberLines
| Syntax String
| TitleAttributes
| Version
deriving (Eq, Show)
options :: [OptDescr Flag]
options =
[ Option ['S'] ["style"] (ReqArg Sty "STYLE") "specify style"
, Option ['F'] ["format"] (ReqArg Format "FORMAT") "output format (html|latex)"
, Option ['f'] ["fragment"] (NoArg Fragment) "fragment, without document header"
, Option ['h'] ["help"] (NoArg Help) "show usage message"
, Option ['l'] ["list"] (NoArg List) "list available language syntaxes"
, Option ['n'] ["number-lines"] (NoArg NumberLines) "number lines"
, Option ['s'] ["syntax"] (ReqArg Syntax "SYNTAX") "specify language syntax to use"
, Option ['t'] ["title-attributes"] (NoArg TitleAttributes) "include structure in title attributes"
, Option ['v'] ["version"] (NoArg Version) "print version"
]
syntaxOf :: [Flag] -> Maybe String
syntaxOf [] = Nothing
syntaxOf (Syntax s : _) = Just s
syntaxOf (_:xs) = syntaxOf xs
styleOf :: [Flag] -> Maybe Style
styleOf [] = Nothing
styleOf (Sty s : _) = case map toLower s of
"pygments" -> Just pygments
"espresso" -> Just espresso
"kate" -> Just kate
"tango" -> Just tango
"haddock" -> Just haddock
"monochrome" -> Just monochrome
_ -> error $ "Unknown style: " ++ s
styleOf (_ : xs) = styleOf xs
formatOf :: [Flag] -> String
formatOf [] = "html" -- default
formatOf (Format s : _) = case map toLower s of
"html" -> "html"
"latex" -> "latex"
_ -> error $ "Unknown format: " ++ s
formatOf (_ : xs) = formatOf xs
filterNewlines :: String -> String
filterNewlines ('\r':'\n':xs) = '\n' : filterNewlines xs
filterNewlines ('\r':xs) = '\n' : filterNewlines xs
filterNewlines (x:xs) = x : filterNewlines xs
filterNewlines [] = []
main = do
(opts, fnames, errs) <- getArgs >>= return . getOpt Permute options
prg <- getProgName
let usageHeader = prg ++ " [options] [files...]"
if not (null errs)
then ioError (userError $ concat errs ++ usageInfo usageHeader options)
else return ()
if List `elem` opts
then putStrLn (unwords languages) >> exitWith ExitSuccess
else return ()
if Help `elem` opts
then hPutStrLn stderr (usageInfo usageHeader options) >>
exitWith (ExitFailure 1)
else return ()
if Version `elem` opts
then putStrLn (prg ++ " " ++ highlightingKateVersion ++ " - (c) 2008 John MacFarlane") >>
exitWith ExitSuccess
else return ()
code <- if null fnames
then getContents >>= return . filterNewlines
else mapM readFile fnames >>= return . filterNewlines . concat
let lang' = case syntaxOf opts of
Just e -> Just e
Nothing -> case fnames of
[] -> Nothing
(x:_) -> listToMaybe $ languagesByFilename $ takeFileName x
lang <- if lang' == Nothing
then hPutStrLn stderr "No syntax specified." >>
hPutStrLn stderr (usageInfo usageHeader options) >>
exitWith (ExitFailure 5)
else do let (Just l) = lang'
return (map toLower l)
if not (lang `elem` (map (map toLower) languages))
then hPutStrLn stderr ("Unknown syntax: " ++ lang) >> exitWith (ExitFailure 4)
else return ()
let highlightOpts = defaultFormatOpts{ titleAttributes = TitleAttributes `elem` opts
, numberLines = NumberLines `elem` opts
, lineAnchors = NumberLines `elem` opts
}
let fragment = Fragment `elem` opts
let fname = case fnames of
[] -> ""
(x:_) -> x
case formatOf opts of
"html" -> hlHtml fragment fname highlightOpts (maybe pygments id $ styleOf opts)
lang code
"latex" -> hlLaTeX fragment fname highlightOpts (maybe pygments id $ styleOf opts) lang code
x -> error $ "Uknown format " ++ x
hlHtml :: Bool -- ^ Fragment
-> FilePath -- ^ Filename
-> FormatOptions
-> Style
-> String -- ^ language
-> String -- ^ code
-> IO ()
hlHtml frag fname opts sty lang code =
if frag
then putStrLn $ renderHtml fragment
else putStrLn $ renderHtml $ H.head (pageTitle >> metadata >> css) >> H.body (toHtml fragment)
where fragment = formatHtmlBlock opts $ highlightAs lang code
css = H.style ! A.type_ "text/css" $ toHtml $ styleToCss sty
pageTitle = H.title $ toHtml fname
metadata = H.meta ! A.httpEquiv "Content-Type" ! A.content "text/html; charset=UTF-8" >>
H.meta ! A.name "generator" ! A.content "highlight-kate"
hlLaTeX :: Bool -- ^ Fragment
-> FilePath -- ^ Filename
-> FormatOptions
-> Style
-> String -- ^ language
-> String -- ^ code
-> IO ()
hlLaTeX frag fname opts sty lang code =
if frag
then putStrLn fragment
else putStrLn $ "\\documentclass{article}\n\\usepackage[margin=1in]{geometry}\n" ++
macros ++ pageTitle ++
"\n\\begin{document}\n\\maketitle\n" ++ fragment ++ "\n\\end{document}"
where fragment = formatLaTeXBlock opts $ highlightAs lang code
macros = styleToLaTeX sty
pageTitle = "\\title{" ++ fname ++ "}\n"