hscolour-1.18: 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
import IO
import Control.Monad (when, forM_)
import List (intersperse, isSuffixOf)
--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 = "1.18"
optionTable :: [(String,Option)]
optionTable = [ ("help", Help)
, ("version", Version)
, ("print-css", Information)
, ("html", Format HTML)
, ("css", Format CSS)
, ("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 putStr 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