diff --git a/.hscolour b/.hscolour --- a/.hscolour +++ b/.hscolour @@ -10,6 +10,8 @@ , string = [Foreground Magenta] , char = [Foreground Magenta] , number = [Foreground Magenta] + , cpp = [Dim,Foreground Magenta] , selection = [Bold, Foreground Magenta] , variantselection = [Dim, Foreground Red, Underscore] + , definition = [Normal] } diff --git a/HsColour.hs b/HsColour.hs --- a/HsColour.hs +++ b/HsColour.hs @@ -5,40 +5,106 @@ import System import IO (hPutStrLn,hFlush,stdout,stderr,hSetBuffering,BufferMode(..)) +import Monad (when) +import List (intersperse) -version = "1.6" +version = "1.9" +-- | Command-line options +data Option = + Help -- ^ print usage message + | Version -- ^ report version + | Information -- ^ report auxiliary information, e.g. CSS defaults + | Format Output -- ^ what type of output to produce + | LHS Bool -- ^ literate input (i.e. multiple embedded fragments) + | Anchors Bool -- ^ whether to add anchors + | Partial Bool -- ^ whether to produce a full document or partial + | Input FilePath -- ^ input source file + | Output FilePath -- ^ output source file + deriving Eq + +optionTable :: [(String,Option)] +optionTable = [ ("help", Help) + , ("version", Version) + , ("print-css", Information) + , ("html", Format HTML) + , ("css", Format CSS) + , ("tty", Format TTY) + , ("latex", Format LaTeX) + , ("mirc", Format MIRC) + , ("lit", 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 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 - (ioWrapper,output,anchors) <- case args of - [] -> errorOut (help prog) - ["-h"] -> errorOut (help prog) - ["-help"] -> errorOut (help prog) - ["--help"] -> errorOut (help prog) - ["-v"] -> errorOut (prog++" "++version) - ["-version"] -> errorOut (prog++" "++version) - ["--version"] -> errorOut (prog++" "++version) - ["-tty"] -> return (ttyInteract, TTY, False) - ["-html"] -> return (ttyInteract, HTML, False) - ["-css"] -> return (ttyInteract, CSS, False) - ["-latex"] -> return (ttyInteract, LaTeX,False) - ["-anchorHTML"] -> return (ttyInteract, HTML, True) - ["-anchorCSS"] -> return (ttyInteract, CSS, True) - [a] -> return (fileInteract a, TTY, False) - ["-tty",a] -> return (fileInteract a, TTY, False) - ["-html",a] -> return (fileInteract a, HTML, False) - ["-css",a] -> return (fileInteract a, CSS, False) - ["-latex",a] -> return (fileInteract a, LaTeX,False) - ["-anchorHTML",a] -> return (fileInteract a, HTML, True) - ["-anchorCSS",a] -> return (fileInteract a, CSS, True) - _ -> errorOut (help prog) - ioWrapper (hscolour output pref anchors) + 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 ] + fileInteract = fileInteractOut outFile + output = useDefault TTY id formats + ioWrapper = useDefault ttyInteract fileInteract [ f | Input f <- good ] + anchors = useDefault False id [ b | Anchors b <- good ] + partial = useDefault False id [ b | Partial b <- good ] + lhs = useDefault False id [ b | LHS b <- good ] + when (not (null bad)) + (errorOut ("Unrecognised option(s): "++unwords bad++"\n"++usage prog)) + when (Help `elem` good) (do putStrLn (usage prog); exitSuccess) + when (Version `elem` good) (do putStrLn (prog++" "++version); exitSuccess) + when (Information `elem` good) + (do writeResult outFile cssDefaults; exitSuccess) + 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.")) + ioWrapper (hscolour output pref anchors partial lhs) hFlush stdout + where - fileInteract f u = do readFile f >>= putStr . u + writeResult outF = if null outF then putStr else writeFile (last outF) + fileInteractOut outF inF u = do readFile inF >>= writeResult outF . u ttyInteract s = do hSetBuffering stdout NoBuffering >> Prelude.interact s + exitSuccess = exitWith ExitSuccess errorOut s = hPutStrLn stderr s >> hFlush stderr >> exitFailure - help p = "Usage: "++p++" [-tty|-html|-css|-latex|-anchorHTML|-anchorCSS] [file.hs]" + usage prog = "Usage: "++prog + ++" options [file.hs]\n where\n options = [ " + ++ (indent 15 . unwords . width 58 58 . intersperse "|" + . ("-oOUTPUT":) + . map (('-':) . fst)) optionTable ++ " ]" + useDefault d f list | null list = d + | otherwise = f (head list) + +-- 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 = "\ +\.keyglyph, .layout {color: red;}\n\ +\.keyword {color: blue;}\n\ +\.comment, .comment a {color: green;}\n\ +\.str, .chr {color: teal;}\n\ +\.keyword,.conid, .varid, .conop, .varop, .num, .cpp, .sel, .definition {}\n\ +\" diff --git a/Language/Haskell/HsColour.hs b/Language/Haskell/HsColour.hs --- a/Language/Haskell/HsColour.hs +++ b/Language/Haskell/HsColour.hs @@ -1,5 +1,5 @@ -- | This is a library with colourises Haskell code. --- It currently has three output formats: +-- It currently has four output formats: -- -- * ANSI terminal codes -- @@ -9,28 +9,78 @@ -- -- * HTML with CSS. -- +-- * mIRC chat client colour codes. +-- module Language.Haskell.HsColour (Output(..), ColourPrefs(..), hscolour) where import Language.Haskell.HsColour.Colourise (ColourPrefs(..)) -import qualified Language.Haskell.HsColour.TTY as TTY -import qualified Language.Haskell.HsColour.HTML as HTML -import qualified Language.Haskell.HsColour.CSS as CSS -import qualified Language.Haskell.HsColour.LaTeX as LaTeX +import qualified Language.Haskell.HsColour.TTY as TTY +import qualified Language.Haskell.HsColour.HTML as HTML +import qualified Language.Haskell.HsColour.CSS as CSS +import qualified Language.Haskell.HsColour.LaTeX as LaTeX +import qualified Language.Haskell.HsColour.MIRC as MIRC -- | The supported output formats. data Output = TTY -- ^ ANSI terminal codes | LaTeX -- ^ TeX macros | HTML -- ^ HTML with font tags | CSS -- ^ HTML with CSS. + | MIRC -- ^ mIRC chat clients + deriving (Eq,Show) --- | Colourise Haskell source code with the give output format. +-- | Colourise Haskell source code with the given output format. hscolour :: Output -- ^ Output format. -> ColourPrefs -- ^ Colour preferences for formats that support it. -> Bool -- ^ Whether to include anchors. + -> Bool -- ^ Whether output document is partial or complete. + -> Bool -- ^ Whether input document is literate haskell or not -> String -- ^ Haskell source code. -> String -- ^ Coloured Haskell source code. -hscolour TTY pref _ = TTY.hscolour pref -hscolour LaTeX pref _ = LaTeX.hscolour pref -hscolour HTML pref anchor = HTML.hscolour pref anchor -hscolour CSS _ anchor = CSS.hscolour anchor +hscolour output pref anchor partial False = + hscolour' output pref anchor partial +hscolour output pref anchor partial True = + concatMap chunk . joinL . map lhsClassify . inlines + where + chunk (Literate c) = c + chunk (Code c) = hscolour' output pref anchor True c + +hscolour' :: Output -- ^ Output format. + -> ColourPrefs -- ^ Colour preferences for formats that support it. + -> Bool -- ^ Whether to include anchors. + -> Bool -- ^ Whether output document is partial or complete. + -> String -- ^ Haskell source code. + -> String -- ^ Coloured Haskell source code. +hscolour' TTY pref _ _ = TTY.hscolour pref +hscolour' MIRC pref _ _ = MIRC.hscolour pref +hscolour' LaTeX pref _ partial = LaTeX.hscolour pref partial +hscolour' HTML pref anchor partial = HTML.hscolour pref anchor partial +hscolour' CSS _ anchor partial = CSS.hscolour anchor partial + +-- | Separating literate files into code\/comment chunks. +data Literate = Code {unL :: String} | Literate {unL :: String} + +-- Re-implementation of 'lines', for better efficiency (but decreased laziness). +-- Also, importantly, accepts non-standard DOS and Mac line ending characters. +-- And retains the trailing '\n' character in each resultant string. +inlines :: String -> [String] +inlines s = lines' s id + where + lines' [] acc = [acc []] + lines' ('\^M':'\n':s) acc = acc ['\n'] : lines' s id -- DOS +--lines' ('\^M':s) acc = acc ['\n'] : lines' s id -- MacOS + lines' ('\n':s) acc = acc ['\n'] : lines' s id -- Unix + lines' (c:s) acc = lines' s (acc . (c:)) + +-- Note, I just pass the > symbol to the colouriser, which assumes that +-- it's token based and not parse-based!!! +lhsClassify :: String -> Literate +lhsClassify ('>':xs) = Code ('>':xs) +lhsClassify xs = Literate xs + +joinL :: [Literate] -> [Literate] +joinL [] = [] +joinL (Code c:Code c2:xs) = joinL (Code (c++c2):xs) +joinL (Literate c:Literate c2:xs) = joinL (Literate (c++c2):xs) +joinL (any:xs) = any: joinL xs + diff --git a/Language/Haskell/HsColour/Anchors.hs b/Language/Haskell/HsColour/Anchors.hs --- a/Language/Haskell/HsColour/Anchors.hs +++ b/Language/Haskell/HsColour/Anchors.hs @@ -3,6 +3,7 @@ ) where import Language.Haskell.HsColour.Classify +import Language.Haskell.HsColour.General import List -- This is an attempt to find the first defining occurrence of an @@ -40,7 +41,7 @@ -- Given that we are at the beginning of a line, determine whether there -- is an identifier defined here, and if so, return it. -- precondition: have just seen a newline token. -identifier st t@((Varid,v):stream) = +identifier st t@((kind,v):stream) | kind`elem`[Varid,Definition] = case skip stream of ((Varop,v):_) | not (v`inST`st) -> Just (fix v) notVarop -- | typesig stream -> Nothing -- not a defn @@ -57,6 +58,7 @@ _ -> Nothing identifier st t@((Keyword,"foreign"):stream) = Nothing -- not yet implemented identifier st t@((Keyword,"data"):stream) = getConid stream +identifier st t@((Keyword,"newtype"):stream) = getConid stream identifier st t@((Keyword,"type"):stream) = getConid stream identifier st t@((Keyword,"class"):stream) = getConid stream identifier st t@((Comment,_):(Space,"\n"):stream) = identifier st stream @@ -81,7 +83,7 @@ munch _ [] = [] -- source is ill-formed -- ensure anchor name is correct for a Varop -fix ('`':v) = init v +fix ('`':v) = dropLast '`' v fix v = v -- look past whitespace and comments to next "real" token @@ -107,7 +109,7 @@ v -> debug v ("(...) =>") v -> debug v ("(...) no =>") v -> debug v ("no Conid or (...)") - where debug (s:t) c = Nothing + where debug _ _ = Nothing -- debug (s:t) c = error ("HsColour: getConid failed: "++show s -- ++"\n in the context of: "++c) @@ -115,6 +117,7 @@ context stream@((Keyglyph,"="):_) = stream context stream@((Keyglyph,"=>"):_) = stream context (_:stream) = context stream +context [] = [] -- simple implementation of a string lookup table. -- replace this with something more sophisticated if needed. diff --git a/Language/Haskell/HsColour/CSS.hs b/Language/Haskell/HsColour/CSS.hs --- a/Language/Haskell/HsColour/CSS.hs +++ b/Language/Haskell/HsColour/CSS.hs @@ -1,27 +1,27 @@ -- | Formats Haskell source code as HTML with CSS. -module Language.Haskell.HsColour.CSS (hscolour, hscolourFragment) where +module Language.Haskell.HsColour.CSS (hscolour) where import Language.Haskell.HsColour.Anchors import Language.Haskell.HsColour.Classify as Classify -import Language.Haskell.HsColour.HTML (renderAnchors, renderComment, escape) +import Language.Haskell.HsColour.HTML (renderAnchors, renderComment, + renderNewLinesAnchors, escape) -- | Formats Haskell source code as a complete HTML document with CSS. -hscolour :: Bool -- ^ Whether to include anchors +hscolour :: Bool -- ^ Whether to include anchors. + -> Bool -- ^ Whether output should be partial + -- (= no stylesheet link will be included.) -> String -- ^ Haskell source code. -> String -- ^ An HTML document containing the coloured -- Haskell source code. -hscolour anchor = top'n'tail . hscolourFragment anchor - --- | Formats Haskell source code as an HTML fragment with CSS. --- No stylesheet link is included in the output. -hscolourFragment :: Bool -- ^ Whether to include anchors - -> String -- ^ Haskell source code. - -> String -- ^ An HTML fragment containing the coloured - -- Haskell source code. -hscolourFragment anchor = - pre . (if anchor - then concatMap (renderAnchors renderToken) . insertAnchors - else concatMap renderToken) . tokenise +hscolour anchor partial = + (if partial then id else top'n'tail) + . pre + . (if anchor + then renderNewLinesAnchors + . concatMap (renderAnchors renderToken) + . insertAnchors + else concatMap renderToken) + . tokenise top'n'tail :: String -> String top'n'tail = (cssPrefix++) . (++cssSuffix) @@ -30,11 +30,14 @@ pre = ("
"++) . (++"
") renderToken :: (TokenType,String) -> String -renderToken (Space,text) = text -renderToken (cls,text) = "" ++ - (if cls == Comment then renderComment text else escape text) ++ - "" +renderToken (cls,text) = + before ++ (if cls == Comment then renderComment text else escape text) ++ after + where + before = if null cls2 then "" else "" + after = if null cls2 then "" else "" + cls2 = cssClass cls + cssClass Keyword = "keyword" cssClass Keyglyph = "keyglyph" cssClass Layout = "layout" @@ -46,7 +49,11 @@ cssClass String = "str" cssClass Char = "chr" cssClass Number = "num" +cssClass Cpp = "cpp" cssClass Error = "sel" +cssClass Definition = "definition" +cssClass _ = "" + cssPrefix = unlines ["" diff --git a/Language/Haskell/HsColour/Classify.hs b/Language/Haskell/HsColour/Classify.hs --- a/Language/Haskell/HsColour/Classify.hs +++ b/Language/Haskell/HsColour/Classify.hs @@ -9,7 +9,10 @@ -- Lex Haskell source code into an annotated token stream, without -- discarding any characters or layout. tokenise :: String -> [(TokenType,String)] -tokenise = map (\s-> (classify s,s)) . glue . chunk +tokenise str = + let chunks = glue . chunk $ str + newline = True : (map ("\n" `isPrefixOf`) chunks) + in map (\(s,n)-> (classify s n,s)) (zip chunks newline) -- Basic Haskell lexing, except we keep whitespace. chunk :: String -> [String] @@ -27,7 +30,7 @@ where (com,s') = eolcomment rest ((tok,rest):_) -> tok: chunk rest -isLinearSpace c = c `elem` " \t" -- " \t\xa0" +isLinearSpace c = c `elem` " \t\f" -- " \t\xa0" -- Glue sequences of tokens into more useful blobs --glue (q:".":n:rest) | Char.isUpper (head q) -- qualified names @@ -35,12 +38,19 @@ glue ("`":rest) = -- `varid` -> varop case glue rest of (qn:"`":rest) -> ("`"++qn++"`"): glue rest - _ -> ("`": rest) + _ -> "`": glue rest glue (s:ss) | all (=='-') s && length s >=2 -- eol comment = (s++concat c): glue rest where (c,rest) = break ('\n'`elem`) ss --glue ("{":"-":ss) = ("{-"++c): glue rest -- nested comment -- where (c,rest) = nestcomment 0 ss +glue ("(":ss) = case rest of + ")":rest -> ("(" ++ concat tuple ++ ")") : glue rest + _ -> "(" : glue ss + where (tuple,rest) = span (==",") ss +glue ("[":"]":ss) = "[]" : glue ss +glue ("\n":"#":ss)= "\n" : ('#':concat line) : glue rest + where (line,rest) = break ('\n'`elem`) ss glue (s:ss) = s: glue ss glue [] = [] @@ -57,17 +67,19 @@ eolcomment :: String -> (String,String) eolcomment s@('\n':_) = ([], s) +eolcomment ('\r':s) = eolcomment s eolcomment (c:s) = (c:cs, s') where (cs,s') = eolcomment s eolcomment [] = ([],[]) -- Classify tokens data TokenType = Space | Keyword | Keyglyph | Layout | Comment | Conid | Varid | - Conop | Varop | String | Char | Number | Error + Conop | Varop | String | Char | Number | Cpp | Error | + Definition deriving (Eq,Show) -classify :: String -> TokenType -classify s@(h:_) +classify :: String -> Bool -> TokenType +classify s@(h:t) newline | isSpace h = Space | all (=='-') s = Comment | "--" `isPrefixOf` s @@ -77,7 +89,10 @@ | s `elem` keyglyphs = Keyglyph | s `elem` layoutchars = Layout | isUpper h = Conid - | isLower h = Varid + | s == "[]" = Conid + | h == '(' && isTupleTail t = Conid + | h == '#' = Cpp + | isLower h = if newline then Definition else Varid | h `elem` symbols = Varop | h==':' = Conop | h=='`' = Varop @@ -85,12 +100,19 @@ | h=='\'' = Char | isDigit h = Number | otherwise = Error +classify _ _ = Space +isTupleTail [')'] = True +isTupleTail (',':xs) = isTupleTail xs +isTupleTail _ = False + + -- Haskell keywords keywords = - ["case","class","data","default","deriving","do","else" + ["case","class","data","default","deriving","do","else","forall" ,"if","import","in","infix","infixl","infixr","instance","let","module" - ,"newtype","of","then","type","where","_","foreign","ccall","as"] + ,"newtype","of","qualified","then","type","where","_" + ,"foreign","ccall","as","safe","unsafe"] keyglyphs = ["..","::","=","\\","|","<-","->","@","~","=>","[","]"] layoutchars = diff --git a/Language/Haskell/HsColour/Colourise.hs b/Language/Haskell/HsColour/Colourise.hs --- a/Language/Haskell/HsColour/Colourise.hs +++ b/Language/Haskell/HsColour/Colourise.hs @@ -8,16 +8,16 @@ import Language.Haskell.HsColour.ColourHighlight import Language.Haskell.HsColour.Classify (TokenType(..)) +import IO (hPutStrLn,stderr) import System (getEnv) -import Char import List -- | Colour preferences. data ColourPrefs = ColourPrefs { keyword, keyglyph, layout, comment , conid, varid, conop, varop - , string, char, number - , selection, variantselection :: [Highlight] + , string, char, number, cpp + , selection, variantselection, definition :: [Highlight] } deriving (Eq,Show,Read) defaultColourPrefs = ColourPrefs @@ -32,19 +32,30 @@ , string = [Foreground Magenta] , char = [Foreground Magenta] , number = [Foreground Magenta] + , cpp = [Foreground Magenta,Dim] , selection = [Bold, Foreground Magenta] , variantselection = [Dim, Foreground Red, Underscore] + , definition = [Foreground Blue] } +-- NOTE, should we give a warning message on a failed reading? +parseColourPrefs :: String -> String -> IO ColourPrefs +parseColourPrefs file x = + case reads x of + (res,_):_ -> return res + _ -> do hPutStrLn stderr ("Could not parse colour prefs from "++file + ++": reverting to defaults") + return defaultColourPrefs + readColourPrefs :: IO ColourPrefs readColourPrefs = catch (do val <- readFile ".hscolour" - return (read val)) - (\e-> catch + parseColourPrefs ".hscolour" val) + (\_-> catch (do home <- getEnv "HOME" val <- readFile (home++"/.hscolour") - return (read val)) - (\e-> return defaultColourPrefs)) + parseColourPrefs (home++"/.hscolour") val) + (\_-> return defaultColourPrefs)) -- Convert classification to colour highlights. colourise :: ColourPrefs -> TokenType -> [Highlight] @@ -60,5 +71,7 @@ colourise pref String = string pref colourise pref Char = char pref colourise pref Number = number pref +colourise pref Cpp = cpp pref colourise pref Error = selection pref +colourise pref Definition = definition pref diff --git a/Language/Haskell/HsColour/General.hs b/Language/Haskell/HsColour/General.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HsColour/General.hs @@ -0,0 +1,15 @@ + +module Language.Haskell.HsColour.General( + dropLast, dropFirst + ) where + + +dropLast :: Eq a => a -> [a] -> [a] +dropLast x [y] | x == y = [] +dropLast x (y:ys) = y : dropLast x ys +dropLast x [] = [] + + +dropFirst :: Eq a => a -> [a] -> [a] +dropFirst x (y:ys) | x == y = ys +dropFirst x ys = ys diff --git a/Language/Haskell/HsColour/HTML.hs b/Language/Haskell/HsColour/HTML.hs --- a/Language/Haskell/HsColour/HTML.hs +++ b/Language/Haskell/HsColour/HTML.hs @@ -2,7 +2,7 @@ module Language.Haskell.HsColour.HTML (hscolour, -- * Internals - renderAnchors, renderComment, escape) where + renderAnchors, renderComment, renderNewLinesAnchors, escape) where import Language.Haskell.HsColour.Anchors import Language.Haskell.HsColour.Classify as Classify @@ -13,17 +13,25 @@ -- | Formats Haskell source code using HTML with font tags. hscolour :: ColourPrefs -- ^ Colour preferences. - -> Bool -- ^ Whether to include anchors + -> Bool -- ^ Whether to include anchors. + -> Bool -- ^ Whether output should be partial. -> String -- ^ Haskell source code. -> String -- ^ Coloured Haskell source code. -hscolour pref anchor = - top'n'tail . (if anchor then concatMap (renderAnchors (renderToken pref)) - . insertAnchors - else concatMap (renderToken pref)) . tokenise +hscolour pref anchor partial = + (if partial then id else top'n'tail) + . pre + . (if anchor then renderNewLinesAnchors + . concatMap (renderAnchors (renderToken pref)) + . insertAnchors + else concatMap (renderToken pref)) + . tokenise top'n'tail :: String -> String -top'n'tail = ("
"++) . (++"
") +top'n'tail = (htmlHeader++) . (++htmlClose) +pre :: String -> String +pre = ("
"++) . (++"
") + renderToken :: ColourPrefs -> (TokenType,String) -> String renderToken pref (t,s) = fontify (colourise pref t) (if t == Comment then renderComment s else escape s) @@ -47,6 +55,10 @@ renderComment (x:xs) = escape [x] ++ renderComment xs renderComment [] = [] +renderNewLinesAnchors :: String -> String +renderNewLinesAnchors = unlines . map render . zip [1..] . lines + where render (line, s) = "" ++ s + -- Html stuff fontify [] s = s fontify (h:hs) s = font h (fontify hs s) @@ -66,3 +78,7 @@ escape ('&':cs) = "&"++escape cs escape (c:cs) = c: escape cs escape [] = [] + +htmlHeader = "" + ++"\n\n" +htmlClose = "\n" diff --git a/Language/Haskell/HsColour/LaTeX.hs b/Language/Haskell/HsColour/LaTeX.hs --- a/Language/Haskell/HsColour/LaTeX.hs +++ b/Language/Haskell/HsColour/LaTeX.hs @@ -1,22 +1,20 @@ -- | Formats Haskell source code using LaTeX macros. -module Language.Haskell.HsColour.LaTeX (hscolour, hscolourFragment) where +module Language.Haskell.HsColour.LaTeX (hscolour) where import Language.Haskell.HsColour.Classify as Classify import Language.Haskell.HsColour.Colourise +import Language.Haskell.HsColour.General -- | Formats Haskell source code as a complete LaTeX document. hscolour :: ColourPrefs -- ^ Colour preferences. + -> Bool -- ^ Whether output should be partial (= no prologue). -> String -- ^ Haskell source code. - -> String -- ^ An LaTeX document containing the coloured + -> String -- ^ A LaTeX document\/fragment containing the coloured -- Haskell source code. -hscolour pref = top'n'tail . hscolourFragment pref - --- | Formats Haskell source code as an LaTeX fragment. -hscolourFragment :: ColourPrefs -- ^ Colour preferences. - -> String -- ^ Haskell source code. - -> String -- ^ An LaTeX fragment containing the coloured - -- Haskell source code. -hscolourFragment pref = concatMap (renderToken pref) . tokenise +hscolour pref partial = + ( if partial then id else top'n'tail) + . concatMap (renderToken pref) + . tokenise top'n'tail :: String -> String top'n'tail = (latexPrefix++) . (++latexSuffix) @@ -25,13 +23,13 @@ -- TODO: filter dangerous characters like "{}_$" renderToken :: ColourPrefs -> (TokenType,String) -> String renderToken pref (Space,text) = filterSpace text -renderToken pref (cls,text) = let - symb = case cls of - String -> "``" ++ (reverse . tail . reverse . tail $ text) ++ "''" - _ -> text - style = colourise pref cls - (pre, post) = unzip $ map latexHighlight style in - (concat pre) ++ filterSpecial symb ++ (concat post) +renderToken pref (cls,text) = + let symb = case cls of + String -> "``" ++ (dropFirst '\"' $ dropLast '\"' $ text) ++ "''" + _ -> text + style = colourise pref cls + (pre, post) = unzip $ map latexHighlight style + in concat pre ++ filterSpecial symb ++ concat post -- | Filter white space characters. filterSpace :: String @@ -52,7 +50,7 @@ filterSpecial ('&':cs) = '\\':'&':(filterSpecial cs) filterSpecial ('~':cs) = "\\tilde{ }"++(filterSpecial cs) filterSpecial ('_':cs) = '\\':'_':(filterSpecial cs) -filterSpecial ('^':cs) = "\\hat{ }"++(filterSpecial cs) +filterSpecial ('^':cs) = "\\ensuremath{\\hat{ }}"++(filterSpecial cs) filterSpecial ('\\':cs) = "$\\backslash$"++(filterSpecial cs) filterSpecial ('{':cs) = '\\':'{':(filterSpecial cs) filterSpecial ('}':cs) = '\\':'}':(filterSpecial cs) diff --git a/Language/Haskell/HsColour/MIRC.hs b/Language/Haskell/HsColour/MIRC.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HsColour/MIRC.hs @@ -0,0 +1,68 @@ +-- | Formats Haskell source code using mIRC codes. +-- (see http://irssi.org/documentation/formats) +module Language.Haskell.HsColour.MIRC (hscolour) where + +import Language.Haskell.HsColour.Classify as Classify +import Language.Haskell.HsColour.Colourise + +import Data.Char(isAlphaNum) + + +-- | Formats Haskell source code using mIRC codes. +hscolour :: ColourPrefs -- ^ Colour preferences. + -> String -- ^ Haskell source code. + -> String -- ^ Coloured Haskell source code. +hscolour pref = concatMap (renderToken pref) . tokenise + +renderToken :: ColourPrefs -> (TokenType,String) -> String +renderToken pref (t,s) = fontify (colourise pref t) s + + +-- mIRC stuff +fontify hs = + mircColours (joinColours hs) + . highlight (filter (`elem`[Normal,Bold,Underscore,ReverseVideo]) hs) + where + highlight [] s = s + highlight (h:hs) s = font h (highlight hs s) + + font Normal s = s + font Bold s = '\^B':s++"\^B" + font Underscore s = '\^_':s++"\^_" + font ReverseVideo s = '\^V':s++"\^V" + +-- mIRC combines colour codes in a non-modular way +data MircColour = Mirc { fg::Colour, dim::Bool, bg::Maybe Colour, blink::Bool} + +joinColours :: [Highlight] -> MircColour +joinColours = foldr join (Mirc {fg=Black, dim=False, bg=Nothing, blink=False}) + where + join Blink mirc = mirc {blink=True} + join Dim mirc = mirc {dim=True} + join (Foreground fg) mirc = mirc {fg=fg} + join (Background bg) mirc = mirc {bg=Just bg} + join Concealed mirc = mirc {fg=Black, bg=Just Black} + join _ mirc = mirc + +mircColours :: MircColour -> String -> String +mircColours (Mirc fg dim Nothing blink) s = '\^C': code fg dim++s++"\^O" +mircColours (Mirc fg dim (Just bg) blink) s = '\^C': code fg dim++',' + : code bg blink++s++"\^O" + +code :: Colour -> Bool -> String +code Black False = "1" +code Red False = "5" +code Green False = "3" +code Yellow False = "7" +code Blue False = "2" +code Magenta False = "6" +code Cyan False = "10" +code White False = "0" +code Black True = "14" +code Red True = "4" +code Green True = "9" +code Yellow True = "8" +code Blue True = "12" +code Magenta True = "13" +code Cyan True = "11" +code White True = "15" diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,9 +1,10 @@ LIBRARY = hscolour -VERSION = 1.6 +VERSION = 1.9 DIRS = Language/Haskell/HsColour SRCS = Language/Haskell/HsColour.hs \ + Language/Haskell/HsColour/General.hs \ Language/Haskell/HsColour/ANSI.hs \ Language/Haskell/HsColour/Anchors.hs \ Language/Haskell/HsColour/CSS.hs \ @@ -12,16 +13,18 @@ Language/Haskell/HsColour/Colourise.hs \ Language/Haskell/HsColour/HTML.hs \ Language/Haskell/HsColour/LaTeX.hs \ - Language/Haskell/HsColour/TTY.hs + Language/Haskell/HsColour/TTY.hs \ + Language/Haskell/HsColour/MIRC.hs AUX = README LICENCE* $(LIBRARY).cabal Setup.hs Makefile \ HsColour.hs hscolour.css .hscolour \ index.html docs/* +GHC = ghc + #all: $(LIBRARY) executable: $(SRCS) HsColour.hs - ghc --make HsColour - mv a.out $(LIBRARY) + $(GHC) --make -o $(LIBRARY) HsColour package: tar cf tmp.tar $(SRCS) $(AUX) mkdir $(LIBRARY)-$(VERSION) @@ -33,7 +36,7 @@ mkdir -p docs/$(LIBRARY) for dir in $(DIRS); do mkdir -p docs/$(LIBRARY)/$$dir; done for file in $(SRCS); \ - do HsColour -anchorHTML $$file \ + do ./$(LIBRARY) -html -anchor $$file \ >docs/$(LIBRARY)/`dirname $$file`/`basename $$file .hs`.html;\ done haddock --html --title=$(LIBRARY) --odir=docs/$(LIBRARY) \ @@ -42,6 +45,23 @@ --source-entity="%{MODULE/.//}.html#%{NAME}" \ $(SRCS) -$(LIBRARY): $(SRCS) - $(HC) $(HFLAGS) $(HEAP) -o $@ $(SRCS) - $(STRIP) $@ +#$(LIBRARY): $(SRCS) +# $(HC) $(HFLAGS) $(HEAP) -o $@ $(SRCS) +# $(STRIP) $@ + +docs: haddock + +install: + install -D $(LIBRARY) $(DESTDIR)/usr/bin/$(LIBRARY) + install -D $(LIBRARY).css $(DESTDIR)/usr/share/doc/$(LIBRARY)/examples/$(LIBRARY).css + +install-docs: + install -D index.html $(DESTDIR)/usr/share/doc/$(LIBRARY)/index.html + cp -a docs/$(LIBRARY)/Language/Haskell/* $(DESTDIR)/usr/share/doc/$(LIBRARY)/ + +clean: + rm -f $(DIRS)/*.o $(DIRS)/*.hi + rm -f Language/Haskell/HsColour.o Language/Haskell/HsColour.hi + rm -f *.o *.hi + rm -f $(LIBRARY) + rm -rf docs diff --git a/README b/README --- a/README +++ b/README @@ -1,6 +1,6 @@ HsColour: A Haskell source-code colouriser. ------------------------------------------- -Copyright: 2003-2006, Malcolm Wallace, University of York +Copyright: 2003-2007, Malcolm Wallace, University of York Licence: GPL Building: @@ -9,21 +9,36 @@ ghc --make HsColour Usage: - HsColour [ -tty | -html | -css | -anchorHTML | -anchorCSS ] [file.hs] + HsColour [-Ofile] + [ -tty | -html | -css | -latex | -mirc ] + [ -lit | -anchor | -partial ] + [ -nolit | -noanchor| -nopartial ] + [file.hs] The program can colourise a Haskell source file for either terminal -output (option -tty) or HTML output with font tags (option -html), or -HTML output with CSS (option -css). The default is for terminal output, -which uses standard ANSI screen codes for the colours. +output (option -tty), or HTML 3.2 output with font tags (option -html), +or HTML 4.01 output with CSS (option -css), or LaTeX output (option +-latex), or IRC chat client (option -mirc). The default is for terminal +output, which uses standard ANSI screen codes for the colours. If no file argument is given, it reads standard input. Output is -always written to standard output. +written to the file specified by the -O option, or by default, stdout. -HsColour can add named anchors (with -anchorHTML or -anchorCSS) to +HsColour can add named anchors in HTML or CSS (option -anchor) to top-level definitions in the source file (functions, datatypes, classes). This enables you to make links to a specific location in the generated file with the standard "file.html#anchor" notation. +If you want to embed several individually colourised fragments into a +larger document, then use the -partial option , to omit the +HTML DOCTYPE header, CSS stylesheet link, or LaTeX prologue. + +Alternatively, if you have a literate input source (e.g. .lhs file), +then the -lit option passes the literate parts untouched, and +colourises only the code fragments (indicated by Bird-tracks - a +> symbol in the left-most column), as if each was called individually +with -partial. + You can configure the colours for different lexical entities by editing a configuration file called .hscolour in the current directory. (An example is included in the distribution.) The file format is as @@ -33,7 +48,7 @@ data ColourPrefs = ColourPrefs { keyword, keyglyph, layout, comment , conid, varid, conop, varop - , string, char, number + , string, char, number, cpp , selection, variantselection :: [Highlight] } diff --git a/docs/hscolour/Language-Haskell-HsColour-LaTeX.html b/docs/hscolour/Language-Haskell-HsColour-LaTeX.html new file mode 100644 --- /dev/null +++ b/docs/hscolour/Language-Haskell-HsColour-LaTeX.html @@ -0,0 +1,247 @@ + + +Language.Haskell.HsColour.LaTeX
hscolourSource codeContentsIndex
Language.Haskell.HsColour.LaTeX
Description
Formats Haskell source code using LaTeX macros. +
Synopsis
hscolour :: ColourPrefs -> String -> String
hscolourFragment :: ColourPrefs -> String -> String
Documentation
hscolourSource
:: ColourPrefsColour preferences. +
-> StringHaskell source code. +
-> StringAn LaTeX document containing the coloured + Haskell source code. +
Formats Haskell source code as a complete LaTeX document. +
hscolourFragmentSource
:: ColourPrefsColour preferences. +
-> StringHaskell source code. +
-> StringAn LaTeX fragment containing the coloured + Haskell source code. +
Formats Haskell source code as an LaTeX fragment. +
Produced by Haddock version 0.8
diff --git a/docs/hscolour/Language/Haskell/HsColour/LaTeX.html b/docs/hscolour/Language/Haskell/HsColour/LaTeX.html new file mode 100644 --- /dev/null +++ b/docs/hscolour/Language/Haskell/HsColour/LaTeX.html @@ -0,0 +1,112 @@ +
-- | Formats Haskell source code using LaTeX macros.
+module Language.Haskell.HsColour.LaTeX (hscolour, hscolourFragment) where
+
+import Language.Haskell.HsColour.Classify as Classify
+import Language.Haskell.HsColour.Colourise
+
+-- | Formats Haskell source code as a complete LaTeX document.
+hscolour :: ColourPrefs -- ^ Colour preferences.
+         -> String      -- ^ Haskell source code.
+         -> String      -- ^ An LaTeX document containing the coloured 
+                        --   Haskell source code.
+hscolour pref = top'n'tail . hscolourFragment pref
+
+-- | Formats Haskell source code as an LaTeX fragment.
+hscolourFragment :: ColourPrefs -- ^ Colour preferences.
+                 -> String -- ^ Haskell source code.
+                 -> String -- ^ An LaTeX fragment containing the coloured 
+                           --   Haskell source code.
+hscolourFragment pref = concatMap (renderToken pref) . tokenise
+
+top'n'tail :: String -> String
+top'n'tail  = (latexPrefix++) . (++latexSuffix)
+
+-- | Wrap each lexeme in the appropriate LaTeX macro.
+--   TODO: filter dangerous characters like "{}_$"
+renderToken :: ColourPrefs -> (TokenType,String) -> String
+renderToken pref (Space,text) = filterSpace text
+renderToken pref (cls,text)   = let 
+	symb = case cls of
+		String -> "``" ++ (reverse . tail . reverse . tail $ text) ++ "''"
+		_      -> text
+	style = colourise pref cls
+	(pre, post) = unzip $ map latexHighlight style in
+	(concat pre) ++ filterSpecial symb ++ (concat post) 
+
+-- | Filter white space characters.
+filterSpace :: String
+            -> String
+filterSpace ('\n':ss) = '\\':'\\':(filterSpace ss)
+filterSpace (' ':ss)  = "\\hsspace "++(filterSpace ss)
+filterSpace ('\t':ss) = "\\hstab "++(filterSpace ss)
+filterSpace (c:ss)    = c:(filterSpace ss)
+filterSpace []        = []
+
+-- | Filters the characters "#$%&~_^\{}" which are special
+--   in LaTeX.
+filterSpecial :: String  -- ^ The string to filter. 
+              -> String  -- ^ The LaTeX-safe string.
+filterSpecial ('#':cs)  = '\\':'#':(filterSpecial cs)
+filterSpecial ('$':cs)  = '\\':'$':(filterSpecial cs)
+filterSpecial ('%':cs)  = '\\':'%':(filterSpecial cs)
+filterSpecial ('&':cs)  = '\\':'&':(filterSpecial cs)
+filterSpecial ('~':cs)  = "\\tilde{ }"++(filterSpecial cs)
+filterSpecial ('_':cs)  = '\\':'_':(filterSpecial cs)
+filterSpecial ('^':cs)  = "\\hat{ }"++(filterSpecial cs)
+filterSpecial ('\\':cs) = "$\\backslash$"++(filterSpecial cs)
+filterSpecial ('{':cs)  = '\\':'{':(filterSpecial cs)
+filterSpecial ('}':cs)  = '\\':'}':(filterSpecial cs)
+filterSpecial ('|':cs)  = "\\ensuremath{|}"++(filterSpecial cs)
+filterSpecial ('<':'-':cs)  = "\\ensuremath{\\leftarrow}"++(filterSpecial cs)
+filterSpecial ('<':cs)  = "\\ensuremath{\\langle}"++(filterSpecial cs)
+filterSpecial ('-':'>':cs)  = "\\ensuremath{\\rightarrow}"++(filterSpecial cs)
+filterSpecial ('>':cs)  = "\\ensuremath{\\rangle}"++(filterSpecial cs)
+filterSpecial (c:cs)    = c:(filterSpecial cs)
+filterSpecial []        = []
+
+
+-- | Constructs the appropriate LaTeX macro for the given style.
+latexHighlight :: Highlight -> (String, String)
+latexHighlight Normal         = ("{\\rm{}", "}")
+latexHighlight Bold           = ("{\\bf{}", "}")
+latexHighlight Dim            = ("", "")
+latexHighlight Underscore     = ("\\underline{", "}")
+latexHighlight Blink          = ("", "")
+latexHighlight ReverseVideo   = ("", "")
+latexHighlight Concealed      = ("\\conceal{", "}")
+latexHighlight (Foreground c) = ("\\textcolor{"++ latexColour c ++"}{", "}")
+latexHighlight (Background c) = ("\\colorbox{"++ latexColour c ++"}{", "}")
+
+-- | Translate a 'Colour' into a LaTeX colour name.
+latexColour :: Colour -> String
+latexColour Black   = "black"
+latexColour Red     = "red"
+latexColour Green   = "green"
+latexColour Yellow  = "yellow"
+latexColour Blue    = "blue"
+latexColour Magenta = "magenta"
+latexColour Cyan    = "cyan"
+latexColour White   = "white"
+
+-- | Generic LaTeX document preamble.
+latexPrefix = unlines
+    ["\\documentclass[a4paper, 12pt]{article}"
+    ,"\\usepackage[usenames]{color}"
+    ,"\\usepackage{hyperref}"
+    ,"\\newsavebox{\\spaceb}"
+    ,"\\newsavebox{\\tabb}"
+    ,"\\savebox{\\spaceb}[1ex]{~}"
+    ,"\\savebox{\\tabb}[4ex]{~}"
+    ,"\\newcommand{\\hsspace}{\\usebox{\\spaceb}}"
+    ,"\\newcommand{\\hstab}{\\usebox{\\tabb}}"
+    ,"\\newcommand{\\conceal}[1]{}"
+    ,"\\begin{document}"
+    ,"\\noindent"
+    ]
+
+-- | Generic LaTeX document postamble.
+latexSuffix = unlines
+    [""
+    ,"\\end{document}"
+    ]
+
diff --git a/docs/hscolour/doc-index-H.html b/docs/hscolour/doc-index-H.html --- a/docs/hscolour/doc-index-H.html +++ b/docs/hscolour/doc-index-H.html @@ -199,16 +199,36 @@ >4 (Function)Language.Haskell.HsColour.LaTeX5 (Function)Language.Haskell.HsColour.TTYhscolourFragment1 (Function)Language.Haskell.HsColour.CSS2 (Function)Language.Haskell.HsColour.LaTeXLanguage.Haskell.HsColour.LaTeXLanguage.Haskell.HsColour.TTY tags, HTML with CSS, and LaTeX. + ANSI terminal codes, HTML 3.2 with tags, HTML 4.01 with CSS, and LaTeX. Exposed-Modules: Language.Haskell.HsColour, Language.Haskell.HsColour.ANSI, @@ -23,8 +23,11 @@ Language.Haskell.HsColour.TTY, Language.Haskell.HsColour.HTML, Language.Haskell.HsColour.LaTeX, + Language.Haskell.HsColour.General, + Language.Haskell.HsColour.MIRC, Language.Haskell.HsColour.CSS -ghc-options: -O2 -W +data-files: hscolour.css +ghc-options: -O -W Executable: HsColour Main-is: HsColour.hs diff --git a/hscolour.css b/hscolour.css --- a/hscolour.css +++ b/hscolour.css @@ -3,3 +3,4 @@ .keyword {color: blue;} .comment, .comment a {color: green;} .str, .chr {color: teal;} +.keyword,.conid, .varid, .conop, .varop, .num, .cpp, .sel, .definition {} diff --git a/index.html b/index.html --- a/index.html +++ b/index.html @@ -10,8 +10,8 @@

hscolour is a small Haskell script to colourise Haskell code. -It currently has four output formats: ANSI terminal codes, HTML with -<font> tags, HTML with CSS, and LaTeX. +It currently has five output formats: ANSI terminal codes, HTML 3.2 with +<font> tags, HTML 4.01 with CSS, LaTeX, and mIRC chat client codes.

Example

@@ -31,6 +31,7 @@

Download

Use

+
  • +HsColour [ -help | -version | -print-css ]
+         [ -oOUTPUT ]
+         [ -tty | -html | -css | -latex | -mirc ]
+         [ -lit | -nolit ]
+         [ -anchor | -noanchor | -partial | -nopartial ]
+         [file.hs]
    +

    • You can colourise a Haskell source file for either ANSI terminal codes -(option -tty), or HTML with font tags (option -html), or HTML output -with CSS (option -css), or for LaTeX. The default is for terminal output. +(option -tty), or HTML 3.2 with font tags (option -html), or HTML 4.01 +output with CSS (option -css), or for LaTeX (option -latex), or for IRC +(option -mirc). The default is for terminal output.

    If no file argument is given, it reads standard input. Output is -always written to standard output. +written to file OUTPUT (option -o), defaulting to stdout.

    -HsColour can add named anchors (options -anchorHTML or -anchorCSS) to +HsColour can add named anchors in HTML (option -anchor) to top-level definitions in the source file (functions, datatypes, classes). This enables you to make links to a specific location in the generated file with the standard file.html#anchor notation (e.g. from haddock-generated library documentation). See below for details. +

    +If you want to embed several individual colourised fragments into a +larger document, then use the -partial option with each +fragment, to omit the HTML DOCTYPE header, CSS stylesheet link, or LaTeX +prologue. +

    +Alternatively, if you have a literate input source (e.g. .lhs file), +then the -lit option will pass the literate parts untouched, +and colourise only the code fragments (indicated by Bird-tracks - a > +in the left-most column), as if each was called individually with +-partial.

    Configuration of colours

    -If you use either -html, -tty, or -latex, you can configure the colours for -different lexical entities by editing a configuration file called -.hscolour in the current directory. +If you use either -html, -tty, -mirc, or -latex, you can configure the +colours for different lexical entities by editing a configuration file +called .hscolour in the current directory. (An example is included in the distribution.) For CSS output, it is sufficient to edit the hscolour.css file, also in -the distribution. +the distribution. The -print-css option prints out the default +CSS definitions, in case you lose the .css file.

    The .hscolour file format is a simple Haskell value of type @@ -90,8 +111,9 @@ 

      data ColourPrefs = ColourPrefs
     { keyword, keyglyph, layout, comment
     , conid, varid, conop, varop
-    , string, char, number
-    , selection, variantselection :: [Highlight]
+    , string, char, number , cpp
+    , selection, variantselection
+    , definition :: [Highlight]
     }
 
   data Colour = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White
@@ -128,12 +150,11 @@
 Let's say you want to generate some pretty-coloured HTML versions of
 your source files, at the same time as you are generating library
 documentation using Haddock.
-Haddock (1.8 onwards, currently only available in darcs) has options
-to link the API docs to the source code itself.  Here is a quick summary
-of the shell commands to use:
+Haddock (0.8 onwards) has options to link the API docs to the source
+code itself.  Here is a quick summary of the shell commands to use:
 
     for file in $(SRCS)
-do HsColour -anchorHTML $file >docs/`dirname $file'/`basename $file .hs`.html
+do HsColour -html -anchor $file >docs/`dirname $file`/`basename $file .hs`.html
 done
 haddock --html --title="My Library" --odir=docs   $(SRCS) \
     --source-module="src/%{MODULE/.//}.html" \
@@ -142,7 +163,7 @@
 
 
    
 
    Copyright and licence
    
-hscolour is © Malcolm Wallace 2003-2006.  It is distributed
+hscolour is © Malcolm Wallace 2003-2007.  It is distributed
 under the Gnu GPL, which can be found in the file
 LICENCE-GPL.
 
@@ -166,6 +187,12 @@
 
    History
    
 
    
 
    
+
    1.9
     added the -mirc and -lit options, and -print-css
    
+
    1.8
     added highlights for cpp lines
+                 
    tuple constructors now treated as ConIds
+                 
    checked for absence of pattern-match failure by Catch
    
+
    1.7
     renamed -anchorHTML -anchorCSS options to -anchor,
+                 added -partial option
    
 
    1.6
     added -latex output mode
    
 
    1.5
     move generated HTML anchors to before comments/typesigs
    
 
    1.4
     made available as a Cabal-ised library
    
@@ -176,7 +203,7 @@
 
    
 
 
    
-This page last modified: 21st December 2006
    
+This page last modified: 8th Jan 2008
    
 Malcolm Wallace