hscolour-1.24.2: HsColour.hs
{-# LANGUAGE CPP #-}
module Main where
import Language.Haskell.HsColour
import qualified Language.Haskell.HsColour as HSColour
import Language.Haskell.HsColour.Colourise (readColourPrefs)
import Language.Haskell.HsColour.Options
import Language.Haskell.HsColour.ACSS (breakS, srcModuleName)
import System.Environment as System
import System.Exit
import System.IO hiding (withFile)
import Control.Monad (when, forM_)
import Data.List (intersperse, isSuffixOf)
import Control.Exception (bracket)
--import Debug.Trace
-- Deal with UTF-8 I/O.
#if __GLASGOW_HASKELL__ > 611
-- possibly if MIN_VERSION_base(4,2,0)
import System.IO (hSetEncoding, utf8)
#endif
version :: String
version = show MAJOR ++"."++show MINOR
optionTable :: [(String,Option)]
optionTable = [ ("help", Help)
, ("version", Version)
, ("print-css", Information)
, ("html", Format HTML)
, ("css", Format CSS)
, ("acss", Format ACSS)
, ("icss", Format ICSS)
, ("tty", Format TTY)
, ("tty256", Format (TTYg XTerm256Compatible))
, ("latex", Format LaTeX)
, ("mirc", Format MIRC)
, ("lit", LHS True)
, ("lit-tex",LHS True)
, ("nolit", LHS False)
, ("anchor", Anchors True)
, ("noanchor", Anchors False)
, ("partial", Partial True)
, ("nopartial", Partial False)
]
parseOption :: String -> Either String Option
parseOption ('-':'o':s) = Right (Output s)
parseOption ('-':'a':'n':'n':'o':'t':'=':s) = Right (Annot s)
parseOption s@('-':_) = maybe (Left s) Right
(lookup (dropWhile (== '-') s) optionTable)
parseOption s = Right (Input s)
main :: IO ()
main = do
prog <- System.getProgName
args <- System.getArgs
pref <- readColourPrefs
let options = map parseOption args
bad = [ o | Left o <- options ]
good = [ o | Right o <- options ]
formats = [ f | Format f <- good ]
outFile = [ f | Output f <- good ]
annFile = [ f | Annot f <- good ]
output = useDefault TTY id formats
anchors = useDefault False id [ b | Anchors b <- good ]
partial = useDefault False id [ b | Partial b <- good ]
lhs = useDefault Nothing id [ Just b | LHS b<- good ]
title = useDefault "Haskell code" id [ f | Input f <- good ]
ioWrapper = useDefaults (ttyInteract outFile (guessLiterate lhs ""))
(fileInteract outFile annFile)
[(f, guessLiterate lhs f) | Input f <- good]
when (not (null bad)) $
errorOut ("Unrecognised option(s): "++unwords bad++"\n"++usage prog)
when (Help `elem` good) $ writeResult [] (usage prog)
when (Version `elem` good) $ writeResult [] (prog++" "++version)
when (Information `elem` good) $ writeResult outFile cssDefaults
when (length formats > 1) $
errorOut ("Can only choose one output format at a time: "
++unwords (map show formats))
when (length outFile > 1) $
errorOut ("Can only have one output file at a time.")
when (length annFile > 1) $
errorOut ("Can only use a single annotation file for annotated-CSS output")
ioWrapper (HSColour.hscolour output pref anchors partial title)
where
writeResult outF s = do if null outF then putStrLn s
else writeUTF8File (last outF) s
exitSuccess
fileInteract out ann inFs u
= do h <- case out of
[] -> return stdout
[outF] -> openFile outF WriteMode >>= set_utf8_io_enc
forM_ inFs $ \ (f, lit) -> do
src <- readUTF8File f
a <- readAnnots src ann
hPutStr h $ u lit $ src ++ a
hClose h
ttyInteract [] lit u = do hSetBuffering stdout NoBuffering
Prelude.interact (u lit)
ttyInteract [outF] lit u = do c <- hGetContents stdin
writeUTF8File outF (u lit c)
exitSuccess = exitWith ExitSuccess
errorOut s = hPutStrLn stderr s >> hFlush stderr >> exitFailure
usage prog = "Usage: "++prog
++" options [file.hs]\n where\n options = [ "
++ (indent 15 . unwords . width 58 58 . intersperse "|"
. ("-oOUTPUT":)
. ("-annot=ANNOTATIONFILE":)
. map (('-':) . fst)) optionTable
++ " ]\n"
useDefault d f list | null list = d
| otherwise = f (head list)
useDefaults d f list | null list = d
| otherwise = f list
guessLiterate Nothing f = ".lhs" `isSuffixOf` f || ".ly" `isSuffixOf` f
|| ".lx" `isSuffixOf` f
guessLiterate (Just b) _ = b
readAnnots _ [] = return ""
readAnnots src [annF] = do putStrLn $ "HsColour Annot on Module: " ++ mname
annots <- readUTF8File annF
return $ breakS ++ "\n" ++ mname ++ "\n" ++ annots
where mname = srcModuleName src
-- some simple text formatting for usage messages
width n left [] = []
width n left (s:ss) = if size > left then "\n":s : width n n ss
else s : width n (left-size-1) ss
where size = length s
indent n [] = []
indent n ('\n':s) = '\n':replicate n ' '++indent n s
indent n (c:s) = c: indent n s
-- Rather than have a separate .css file, define some reasonable defaults here.
cssDefaults = concat
[ ".hs-keyglyph, .hs-layout {color: red;}\n"
, ".hs-keyword {color: blue;}\n"
, ".hs-comment, .hs-comment a {color: green;}\n"
, ".hs-str, .hs-chr {color: teal;}\n"
, ".hs-keyword, .hs-conid, .hs-varid, .hs-conop, .hs-varop, .hs-num, "
, ".hs-cpp, .hs-sel, .hs-definition {}\n"
]
-- Deal with UTF-8 input and output.
set_utf8_io_enc :: Handle -> IO Handle
#if __GLASGOW_HASKELL__ > 611
-- possibly if MIN_VERSION_base(4,2,0)
set_utf8_io_enc h = do hSetEncoding h utf8; return h
#else
set_utf8_io_enc h = return h
#endif
-- FILE I(unput) / O(utput) is in UTF8
-- TTY I(unput) / O(utput) is in locale
-- ( may have problems with HsColour IFILE >OFILE
-- , as it differs from HsColour IFILE -oOFILE)
-- TTY stderr is always in locale (always used for user interaction)
--
-- Some common use cases:
-- File I / FILE O (HsColour -css -anchor -oOFILE IFILE)
-- : are both always done in UTF8 mode (cabal hscolour mode)
-- File I / TTY O (HsColour IFILE)
-- : file is read in UTF-8 written in locale
-- TTY I / TTY O (HsColour)
-- : stdin/stdout are both in locale
-- fully mimic Prelude analogues
writeUTF8File f txt = withFile f WriteMode (\hdl -> do set_utf8_io_enc hdl
hPutStr hdl txt)
readUTF8File name = openFile name ReadMode >>=
set_utf8_io_enc >>=
hGetContents
withFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile name mode = bracket (openFile name mode) hClose