{-# LANGUAGE OverloadedStrings #-}
import Control.Monad
import qualified Data.ByteString.Lazy as BL
import Data.Char (toLower)
import qualified Data.Map as Map
import Data.Monoid
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Data.Version (showVersion)
import Paths_skylighting (version)
import Skylighting
import System.Console.GetOpt
import System.Environment
import System.Exit
import System.IO (hPutStrLn, stderr)
import Text.Blaze.Html.Renderer.String
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Text.Printf (printf)
import Text.Show.Pretty (ppShow)
data Flag = Sty String
| Theme String
| Format String
| Help
| Fragment
| List
| NumberLines
| Syn String
| TitleAttributes
| Definition String
| Trace
| Version
deriving (Eq, Show)
data HighlightFormat = FormatHtml
| FormatLaTeX
| FormatNative
deriving (Eq, Show)
options :: [OptDescr Flag]
options =
[Option ['S']
["style"]
(ReqArg Sty "STYLE")
"specify style"
,Option ['t']
["theme"]
(ReqArg Theme "PATH")
"KDE theme file to be used as style"
,Option ['f']
["format"]
(ReqArg Format "FORMAT")
"output format (html|latex|native)"
,Option ['r']
["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 Syn "SYNTAX")
"specify language syntax to use"
,Option ['a']
["title-attributes"]
(NoArg TitleAttributes)
"include structure in title attributes"
,Option ['d']
["definition"]
(ReqArg Definition "PATH")
"load xml syntax definition file (may be repeated)"
,Option ['T']
["trace"]
(NoArg Trace)
"trace tokenizer for debugging"
,Option ['v']
["version"]
(NoArg Version)
"print version"]
syntaxOf :: SyntaxMap -> [FilePath] -> [Flag] -> IO Syntax
syntaxOf smap fps [] = case concatMap (syntaxesByFilename smap) fps of
(s:_) -> return s
_ -> err "No syntax specified: use --syntax."
syntaxOf smap _ (Syn lang : _) = do
case lookupSyntax (Text.pack lang) smap of
Just s -> return s
Nothing -> err ("Could not find syntax definition for " ++ lang)
syntaxOf smap fps (_:xs) = syntaxOf smap fps xs
styleOf :: [Flag] -> IO Style
styleOf [] = return kate
styleOf (Theme fp : _) = do
raw <- BL.readFile fp
case parseTheme raw of
Left e -> err e
Right sty -> return sty
styleOf (Sty s : _) = case map toLower s of
"pygments" -> return pygments
"espresso" -> return espresso
"kate" -> return kate
"tango" -> return tango
"haddock" -> return haddock
"monochrome" -> return monochrome
"breeze-dark" -> return breezeDark
_ -> err $ "Unknown style: " ++ s
styleOf (_ : xs) = styleOf xs
formatOf :: [Flag] -> IO HighlightFormat
formatOf [] = return FormatHtml -- default
formatOf (Format s : _) = case map toLower s of
"html" -> return FormatHtml
"latex" -> return FormatLaTeX
"native" -> return FormatNative
_ -> err $ "Unknown format: " ++ s
formatOf (_ : xs) = formatOf xs
extractDefinitions :: [Flag] -> IO [Syntax]
extractDefinitions [] = return []
extractDefinitions (Definition fp : xs) = do
res <- parseSyntaxDefinition fp
case res of
Left e -> err e
Right s -> do
putStrLn $ "Loaded syntax definition for " ++ Text.unpack (sName s)
(s:) <$> extractDefinitions xs
extractDefinitions (_:xs) = extractDefinitions xs
err :: String -> IO a
err msg = do
hPutStrLn stderr msg
exitWith (ExitFailure 1)
main :: IO ()
main = do
(opts, fnames, errs) <- getArgs >>= return . getOpt Permute options
prg <- getProgName
let usageHeader = prg ++ " [options] [files...]"
when (not (null errs)) $
err (concat errs ++ usageInfo usageHeader options)
when (Help `elem` opts) $ do
hPutStrLn stderr (usageInfo usageHeader options)
exitWith ExitSuccess
when (Version `elem` opts) $ do
putStrLn (prg ++ " " ++ showVersion version)
exitWith ExitSuccess
syntaxMap' <- foldr addSyntaxDefinition defaultSyntaxMap <$>
extractDefinitions opts
{-
case missingIncludes (Map.elems syntaxMap') of
[] -> return ()
xs -> err $ "Missing syntax definitions:\n" ++
unlines (map
(\(syn,dep) -> (Text.unpack syn ++ " requires " ++
Text.unpack dep ++ " through IncludeRules.")) xs)
-}
when (List `elem` opts) $ do
let printSyntaxNames s = putStrLn (printf "%s (%s)"
(Text.unpack (Text.toLower (sShortname s)))
(Text.unpack (sName s)))
mapM_ printSyntaxNames $ Map.elems syntaxMap'
exitWith ExitSuccess
code <- if null fnames
then Text.getContents
else mconcat <$> mapM Text.readFile fnames
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
let trace = Trace `elem` opts
syntax <- syntaxOf syntaxMap' fnames opts
style <- styleOf opts
format <- formatOf opts
let config = TokenizerConfig { traceOutput = trace
, syntaxMap = syntaxMap' }
sourceLines <- case tokenize config syntax code of
Left e -> err e
Right ls -> return ls
case format of
FormatHtml -> hlHtml fragment fname highlightOpts style sourceLines
FormatLaTeX -> hlLaTeX fragment fname highlightOpts style sourceLines
FormatNative -> putStrLn $ ppShow sourceLines
hlHtml :: Bool -- ^ Fragment
-> FilePath -- ^ Filename
-> FormatOptions
-> Style
-> [SourceLine]
-> IO ()
hlHtml frag fname opts sty sourceLines =
if frag
then putStrLn $ renderHtml fragment
else putStrLn $ renderHtml $ do
H.docType
H.html $ do
H.head $ do
pageTitle
metadata
css
H.body $ H.toHtml fragment
where fragment = formatHtmlBlock opts sourceLines
css = H.style H.! A.type_ "text/css" $ H.toHtml $ styleToCss sty
pageTitle = H.title $ H.toHtml fname
metadata = do
H.meta H.! A.charset "utf-8"
H.meta H.! A.name "generator" H.! A.content "highlight-kate"
hlLaTeX :: Bool -- ^ Fragment
-> FilePath -- ^ Filename
-> FormatOptions
-> Style
-> [SourceLine]
-> IO ()
hlLaTeX frag fname opts sty sourceLines =
if frag
then Text.putStrLn fragment
else Text.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 sourceLines
macros = styleToLaTeX sty
pageTitle = "\\title{" <> Text.pack fname <> "}\n"