diff --git a/HsColour.hs b/HsColour.hs --- a/HsColour.hs +++ b/HsColour.hs @@ -5,9 +5,10 @@ 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 Monad (when) +import Control.Monad (when, forM_) import List (intersperse, isSuffixOf) --import Debug.Trace @@ -17,7 +18,7 @@ import System.IO (hSetEncoding, utf8) #endif -version = "1.17" +version = "1.18" optionTable :: [(String,Option)] optionTable = [ ("help", Help) @@ -27,6 +28,7 @@ , ("css", Format CSS) , ("icss", Format ICSS) , ("tty", Format TTY) + , ("tty256", Format (TTYg XTerm256Compatible)) , ("latex", Format LaTeX) , ("mirc", Format MIRC) , ("lit", LHS True) @@ -40,6 +42,7 @@ 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) @@ -54,14 +57,15 @@ 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) [ (f,guessLiterate lhs f) - | Input f <- good ] + (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) @@ -72,20 +76,24 @@ ++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 inFs u = do h <- case out of - [] -> return stdout - [outF] -> openFile outF WriteMode >>= - set_utf8_io_enc - mapM_ (\ (f,lit)-> - readUTF8File f >>= hPutStr h . u lit) - inFs - hClose h + 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 @@ -96,6 +104,7 @@ ++" 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 @@ -105,6 +114,12 @@ 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 [] = [] diff --git a/Language/Haskell/HsColour.hs b/Language/Haskell/HsColour.hs --- a/Language/Haskell/HsColour.hs +++ b/Language/Haskell/HsColour.hs @@ -20,6 +20,7 @@ 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.ACSS as ACSS import qualified Language.Haskell.HsColour.InlineCSS as ICSS import qualified Language.Haskell.HsColour.LaTeX as LaTeX import qualified Language.Haskell.HsColour.MIRC as MIRC @@ -53,23 +54,27 @@ -> Bool -- ^ Whether to include anchors. -> String -- ^ Haskell source code. -> String -- ^ Coloured Haskell source code. -hscolour' TTY pref _ = TTY.hscolour pref -hscolour' MIRC pref _ = MIRC.hscolour pref -hscolour' LaTeX pref _ = LaTeX.hscolour pref -hscolour' HTML pref anchor = HTML.hscolour pref anchor -hscolour' CSS _ anchor = CSS.hscolour anchor -hscolour' ICSS pref anchor = ICSS.hscolour pref anchor +hscolour' TTY pref _ = TTY.hscolour pref +hscolour' (TTYg tt) pref _ = TTY.hscolourG tt pref +hscolour' MIRC pref _ = MIRC.hscolour pref +hscolour' LaTeX pref _ = LaTeX.hscolour pref +hscolour' HTML pref anchor = HTML.hscolour pref anchor +hscolour' CSS _ anchor = CSS.hscolour anchor +hscolour' ICSS pref anchor = ICSS.hscolour pref anchor +hscolour' ACSS _ anchor = ACSS.hscolour anchor -- | Choose the right headers\/footers, depending on the output format. top'n'tail :: Output -- ^ Output format -> String -- ^ Title for output -> (String->String) -- ^ Output transformer top'n'tail TTY _ = id +top'n'tail (TTYg _) _ = id top'n'tail MIRC _ = id top'n'tail LaTeX title = LaTeX.top'n'tail title top'n'tail HTML title = HTML.top'n'tail title top'n'tail CSS title = CSS.top'n'tail title top'n'tail ICSS title = ICSS.top'n'tail title +top'n'tail ACSS title = CSS.top'n'tail title -- | Separating literate files into code\/comment chunks. data Lit = Code {unL :: String} | Lit {unL :: String} deriving (Show) @@ -88,6 +93,7 @@ -- | The code for classify is largely stolen from Language.Preprocessor.Unlit. +classify :: [String] -> [Lit] classify [] = [] classify (x:xs) | "\\begin{code}"`isPrefixOf`x = Lit x: allProg xs diff --git a/Language/Haskell/HsColour/ACSS.hs b/Language/Haskell/HsColour/ACSS.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HsColour/ACSS.hs @@ -0,0 +1,146 @@ +-- | Formats Haskell source code as HTML with CSS and Mouseover Type Annotations +module Language.Haskell.HsColour.ACSS ( + hscolour + , hsannot + , AnnMap (..) + , Loc (..) + , breakS + , srcModuleName + ) where + +import Language.Haskell.HsColour.Anchors +import Language.Haskell.HsColour.Classify as Classify +import Language.Haskell.HsColour.HTML (renderAnchors, renderComment, + renderNewLinesAnchors, escape) +import qualified Language.Haskell.HsColour.CSS as CSS + +import Data.Maybe (fromMaybe) +import qualified Data.Map as M +import Data.List (isSuffixOf, findIndex, elemIndices, intercalate) +import Data.Char (isLower, isSpace, isAlphaNum) +import Text.Printf +import Debug.Trace + +newtype AnnMap = Ann (M.Map Loc (String, String)) +newtype Loc = L (Int, Int) deriving (Eq, Ord, Show) + +-- | Formats Haskell source code using HTML and mouse-over annotations +hscolour :: Bool -- ^ Whether to include anchors. + -> String -- ^ Haskell source code, Annotations as comments at end + -> String -- ^ Coloured Haskell source code. + +hscolour anchor = hsannot anchor . splitSrcAndAnns + +-- | Formats Haskell source code using HTML and mouse-over annotations +hsannot :: Bool -- ^ Whether to include anchors. + -> (String, AnnMap) -- ^ Haskell Source, Annotations + -> String -- ^ Coloured Haskell source code. + +hsannot anchor = + CSS.pre + . (if anchor then -- renderNewLinesAnchors . + concatMap (renderAnchors renderAnnotToken) + . insertAnnotAnchors + else concatMap renderAnnotToken) + . annotTokenise + +annotTokenise :: (String, AnnMap) -> [(TokenType, String, Maybe String)] +annotTokenise (src, Ann annm) + = zipWith (\(x,y) z -> (x,y, snd `fmap` z)) toks annots + where toks = tokenise src + spans = tokenSpans $ map snd toks + annots = map (`M.lookup` annm) spans + +tokenSpans :: [String] -> [Loc] +tokenSpans = scanl plusLoc (L (1, 1)) + +plusLoc :: Loc -> String -> Loc +plusLoc (L (l, c)) s + = case '\n' `elemIndices` s of + [] -> L (l, (c + n)) + is -> L ((l + length is), (n - maximum is)) + where n = length s + +renderAnnotToken :: (TokenType, String, Maybe String) -> String +renderAnnotToken (x,y, Nothing) + = CSS.renderToken (x, y) +renderAnnotToken (x,y, Just ann) + = printf template (escape ann) (CSS.renderToken (x, y)) + where template = "%s%s" + +{- Example Annotation: +x#agV:Int -> {VV_int:Int | (0 <= VV_int),(x#agV <= VV_int)} +NOWTRYTHIS +-} + + +insertAnnotAnchors :: [(TokenType, String, a)] -> [Either String (TokenType, String, a)] +insertAnnotAnchors toks + = stitch (zip toks' toks) $ insertAnchors toks' + where toks' = [(x,y) | (x,y,_) <- toks] + +stitch :: Eq b => [(b, c)] -> [Either a b] -> [Either a c] +stitch xys ((Left a) : rest) + = (Left a) : stitch xys rest +stitch ((x,y):xys) ((Right x'):rest) + | x == x' + = (Right y) : stitch xys rest + | otherwise + = error "stitch" +stitch _ [] + = [] + + +splitSrcAndAnns :: String -> (String, AnnMap) +splitSrcAndAnns s = + let ls = lines s in + case findIndex (breakS ==) ls of + Nothing -> (s, Ann M.empty) + Just i -> (src, {- trace ("annm =" ++ show ann) -} ann) + where (codes, _:mname:annots) = splitAt i ls + ann = annotParse mname $ dropWhile isSpace $ unlines annots + src = unlines codes + -- mname = srcModuleName src + +srcModuleName :: String -> String +srcModuleName = fromMaybe "Main" . tokenModule . tokenise + +tokenModule toks + = do i <- findIndex ((Keyword, "module") ==) toks + let (_, toks') = splitAt (i+2) toks + j <- findIndex ((Space ==) . fst) toks' + let (toks'', _) = splitAt j toks' + return $ concatMap snd toks'' + +breakS = "MOUSEOVER ANNOTATIONS" + +annotParse :: String -> String -> AnnMap +annotParse mname = Ann . M.fromList . parseLines mname 0 . lines + +parseLines mname i [] + = [] +parseLines mname i ("":ls) + = parseLines mname (i+1) ls +parseLines mname i (x:f:l:c:n:rest) + | f /= mname -- `isSuffixOf` mname + = {- trace ("wrong annot f = " ++ f ++ " mname = " ++ mname) $ -} parseLines mname (i + 5 + num) rest' + | otherwise + = (L (line, col), (x, anns)) : parseLines mname (i + 5 + num) rest' + where line = (read l) :: Int + col = (read c) :: Int + num = (read n) :: Int + anns = intercalate "\n" $ take num rest + rest' = drop num rest +parseLines _ i _ + = error $ "Error Parsing Annot Input on Line: " ++ show i + +takeFileName s = map slashWhite s + where slashWhite '/' = ' ' + +instance Show AnnMap where + show (Ann m) = "\n\n" ++ (concatMap ppAnnot $ M.toList m) + where ppAnnot (L (l, c), (x,s)) = x ++ "\n" + ++ show l ++ "\n" + ++ show c ++ "\n" + ++ show (length $ lines s) ++ "\n" + ++ s ++ "\n\n\n" diff --git a/Language/Haskell/HsColour/ANSI.hs b/Language/Haskell/HsColour/ANSI.hs --- a/Language/Haskell/HsColour/ANSI.hs +++ b/Language/Haskell/HsColour/ANSI.hs @@ -1,8 +1,8 @@ -- | Partially taken from Hugs AnsiScreen.hs library: module Language.Haskell.HsColour.ANSI - ( highlightOn + ( highlightOnG,highlightOn , highlightOff - , highlight + , highlightG,highlight , cleareol, clearbol, clearline, clearDown, clearUp, cls , goto , cursorUp, cursorDown, cursorLeft, cursorRight @@ -12,14 +12,17 @@ , colourCycle , enableScrollRegion, scrollUp, scrollDown , lineWrap + , TerminalType(..) ) where import Language.Haskell.HsColour.ColourHighlight +import Language.Haskell.HsColour.Output(TerminalType(..)) import List (intersperse,isPrefixOf) import Char (isDigit) + -- Basic screen control codes: type Pos = (Int,Int) @@ -64,20 +67,42 @@ fromEnum Blink = 5 fromEnum ReverseVideo = 7 fromEnum Concealed = 8 + -- The translation of these depends on the terminal type, and they don't translate to single numbers anyway. Should we really use the Enum class for this purpose rather than simply moving this table to 'renderAttrG'? + fromEnum (Foreground (Rgb _ _ _)) = error "Internal error: fromEnum (Foreground (Rgb _ _ _))" + fromEnum (Background (Rgb _ _ _)) = error "Internal error: fromEnum (Background (Rgb _ _ _))" fromEnum (Foreground c) = 30 + fromEnum c fromEnum (Background c) = 40 + fromEnum c fromEnum Italic = 2 + +-- | = 'highlightG' 'Ansi16Colour' +highlight :: [Highlight] -> String -> String +highlight = highlightG Ansi16Colour + +-- | = 'highlightOn' 'Ansi16Colour' +highlightOn :: [Highlight] -> String +highlightOn = highlightOnG Ansi16Colour + + -- | Make the given string appear with all of the listed highlights -highlight :: [Highlight] -> String -> String -highlight attrs s = highlightOn attrs ++ s ++ highlightOff +highlightG :: TerminalType -> [Highlight] -> String -> String +highlightG tt attrs s = highlightOnG tt attrs ++ s ++ highlightOff -highlightOn [] = highlightOn [Normal] -highlightOn attrs = "\ESC[" - ++ concat (intersperse ";" (map (show.fromEnum) attrs)) - ++"m" +highlightOnG :: TerminalType -> [Highlight] -> String +highlightOnG tt [] = highlightOnG tt [Normal] +highlightOnG tt attrs = "\ESC[" + ++ concat (intersperse ";" (concatMap (renderAttrG tt) attrs)) + ++"m" +highlightOff :: [Char] highlightOff = "\ESC[0m" +renderAttrG :: TerminalType -> Highlight -> [String] +renderAttrG XTerm256Compatible (Foreground (Rgb r g b)) = + [ "38", "5", show ( rgb24bit_to_xterm256 r g b ) ] +renderAttrG XTerm256Compatible (Background (Rgb r g b)) = + [ "48", "5", show ( rgb24bit_to_xterm256 r g b ) ] +renderAttrG _ a = + [ show (fromEnum (hlProjectToBasicColour8 a)) ] -- | An infinite supply of colours. colourCycle :: [Colour] @@ -88,10 +113,13 @@ enableScrollRegion :: Int -> Int -> String enableScrollRegion start end = "\ESC["++show start++';':show end++"r" +scrollDown :: String scrollDown = "\ESCD" +scrollUp :: String scrollUp = "\ESCM" -- Line-wrapping mode +lineWrap :: Bool -> [Char] lineWrap True = "\ESC[7h" lineWrap False = "\ESC[7l" 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 @@ -5,6 +5,7 @@ import Language.Haskell.HsColour.Classify import Language.Haskell.HsColour.General import List +import Char -- This is an attempt to find the first defining occurrence of an -- identifier (function, datatype, class) in a Haskell source file. @@ -27,13 +28,29 @@ -- looks at first token in the left-most position of each line -- precondition: have just seen a newline token. +anchor :: ST -> [(TokenType, String)] -> [Either String (TokenType, String)] anchor st s = case identifier st s of Nothing -> emit st s - Just v -> Left v: emit (insertST v st) s + Just v -> Left (escape v): emit (insertST v st) s +-- some chars are not valid in anchor URIs: http://www.ietf.org/rfc/rfc3986 +-- NOTE: This code assumes characters are 8-bit. +-- Ideally, it should transcode to utf8 octets first. +escape :: String -> String +escape = concatMap enc + where enc x | isDigit x + || isURIFragmentValid x + || isLower x + || isUpper x = [x] + | otherwise = ['%',hexHi (ord x), hexLo (ord x)] + hexHi d = intToDigit (d`div`16) + hexLo d = intToDigit (d`mod`16) + isURIFragmentValid x = x `elem` "!$&'()*+,;=/?-._~:@" + -- emit passes stuff through until the next newline has been encountered, -- then jumps back into the anchor function -- pre-condition: newlines are explicitly single tokens +emit :: ST -> [(TokenType, String)] -> [Either String (TokenType, String)] emit st (t@(Space,"\n"):stream) = Right t: anchor st stream emit st (t:stream) = Right t: emit st stream emit _ [] = [] @@ -41,6 +58,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 -> [(TokenType, String)] -> Maybe String identifier st t@((kind,v):stream) | kind`elem`[Varid,Definition] = case skip stream of ((Varop,v):_) | not (v`inST`st) -> Just (fix v) @@ -75,6 +93,7 @@ typesig _ = False -- throw away everything from opening paren to matching close +munchParens :: [(TokenType, String)] -> [(TokenType, String)] munchParens = munch (0::Int) -- already seen open paren where munch 0 ((Layout,")"):rest) = rest munch n ((Layout,")"):rest) = munch (n-1) rest @@ -83,16 +102,19 @@ munch _ [] = [] -- source is ill-formed -- ensure anchor name is correct for a Varop +fix :: String -> String fix ('`':v) = dropLast '`' v fix v = v -- look past whitespace and comments to next "real" token +skip :: [(TokenType, t)] -> [(TokenType, t)] skip ((Space,_):stream) = skip stream skip ((Comment,_):stream) = skip stream skip stream = stream -- skip possible context up to and including "=>", returning next Conid token -- (this function is highly partial - relies on source being parse-correct) +getConid :: [(TokenType, String)] -> Maybe String getConid stream = case skip stream of ((Conid,c):rest) -> case context rest of @@ -114,6 +136,7 @@ -- ++"\n in the context of: "++c) -- jump past possible class context +context :: [(TokenType, String)] -> [(TokenType, String)] context stream@((Keyglyph,"="):_) = stream context stream@((Keyglyph,"=>"):_) = stream context (_:stream) = context stream 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,5 +1,10 @@ -- | Formats Haskell source code as HTML with CSS. -module Language.Haskell.HsColour.CSS (hscolour,top'n'tail) where +module Language.Haskell.HsColour.CSS + ( hscolour + , top'n'tail + , renderToken + , pre + ) where import Language.Haskell.HsColour.Anchors import Language.Haskell.HsColour.Classify as Classify @@ -57,7 +62,7 @@ ,"" ,"" ,"" - ,"" + ,"" ,""++title++"" ,"" ,"" diff --git a/Language/Haskell/HsColour/ColourHighlight.hs b/Language/Haskell/HsColour/ColourHighlight.hs --- a/Language/Haskell/HsColour/ColourHighlight.hs +++ b/Language/Haskell/HsColour/ColourHighlight.hs @@ -1,12 +1,78 @@ module Language.Haskell.HsColour.ColourHighlight ( Colour(..) , Highlight(..) + , base256, unbase + , rgb24bit_to_xterm256 + , projectToBasicColour8 + , hlProjectToBasicColour8 ) where +import Data.Word + -- | Colours supported by ANSI codes. -data Colour = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White - deriving (Eq,Show,Read,Enum) +data Colour = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White | Rgb Word8 Word8 Word8 + deriving (Eq,Show,Read) +-- | Convert an integer in the range [0,2^24-1] to its base 256-triplet, passing the result to the given continuation (avoid unnecessary tupleism). +base256 :: Integral int => (Word8 -> Word8 -> Word8 -> r) -> int -> r +base256 kont x = + let + (r,gb) = divMod x 256 + (g,b) = divMod gb 256 + fi = fromIntegral + in + kont (fi r) (fi g) (fi b) + +-- | Convert a three-digit numeral in the given (as arg 1) base to its integer value. +unbase :: Integral int => int -> Word8 -> Word8 -> Word8 -> int +unbase base r g b = (fi r*base+fi g)*base+fi b + where fi = fromIntegral + +-- | Approximate a 24-bit Rgb colour with a colour in the xterm256 6x6x6 colour cube, returning its index. +rgb24bit_to_xterm256 :: (Integral t) => Word8 -> Word8 -> Word8 -> t +rgb24bit_to_xterm256 r g b = let f = (`div` 43) + in 16 + unbase 6 (f r) (f g) (f b) + + +-- | Ap\"proxi\"mate a 24-bit Rgb colour with an ANSI8 colour. Will leave other colours unchanged and will never return an 'Rgb' constructor value. +projectToBasicColour8 :: Colour -> Colour +projectToBasicColour8 (Rgb r g b) = let f = (`div` 128) + in toEnum ( unbase 2 (f r) (f g) (f b) ) +projectToBasicColour8 x = x + + +-- | Lift 'projectToBasicColour8' to 'Highlight's +hlProjectToBasicColour8 :: Highlight -> Highlight +hlProjectToBasicColour8 (Foreground c) = Foreground (projectToBasicColour8 c) +hlProjectToBasicColour8 (Background c) = Background (projectToBasicColour8 c) +hlProjectToBasicColour8 h = h + + + +instance Enum Colour where + toEnum 0 = Black + toEnum 1 = Red + toEnum 2 = Green + toEnum 3 = Yellow + toEnum 4 = Blue + toEnum 5 = Magenta + toEnum 6 = Cyan + toEnum 7 = White + -- Arbitrary extension; maybe just 'error' out instead + toEnum x = base256 Rgb (x-8) + + fromEnum Black = 0 + fromEnum Red = 1 + fromEnum Green = 2 + fromEnum Yellow = 3 + fromEnum Blue = 4 + fromEnum Magenta = 5 + fromEnum Cyan = 6 + fromEnum White = 7 + -- Arbitrary extension; maybe just 'error' out instead + fromEnum (Rgb r g b) = 8 + unbase 256 r g b + + -- | Types of highlighting supported by ANSI codes (and some extra styles). data Highlight = Normal @@ -18,7 +84,10 @@ | Concealed | Foreground Colour | Background Colour - -- Above are ANSI-only. Below are extra styles. + -- The above styles are ANSI-supported, with the exception of the 'Rgb' constructor for 'Colour's. Below are extra styles (e.g. for Html rendering). | Italic deriving (Eq,Show,Read) + + + 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 @@ -11,6 +11,7 @@ import Language.Haskell.HsColour.Colourise import Char(isAlphaNum) +import Text.Printf -- | Formats Haskell source code using HTML with font tags. @@ -36,8 +37,7 @@ renderToken pref (t,s) = fontify (colourise pref t) (if t == Comment then renderComment s else escape s) -renderAnchors :: ((TokenType,String)->String) - -> Either String (TokenType,String) -> String +renderAnchors :: (a -> String) -> Either String a -> String renderAnchors _ (Left v) = "" renderAnchors render (Right r) = render r @@ -60,9 +60,11 @@ where render (line, s) = "" ++ s -- Html stuff +fontify :: [Highlight] -> String -> String fontify [] s = s fontify (h:hs) s = font h (fontify hs s) +font :: Highlight -> String -> String font Normal s = s font Bold s = ""++s++"" font Dim s = ""++s++"" @@ -70,23 +72,28 @@ font Blink s = ""++s++"" font ReverseVideo s = s font Concealed s = s -font (Foreground c) s = ""++s++"" +font (Foreground (Rgb r g b)) s = printf "%s" r g b s +font (Background (Rgb r g b)) s = printf "%s" r g b s +font (Foreground c) s = ""++s++"" font (Background c) s = ""++s++"" font Italic s = ""++s++"" +escape :: String -> String escape ('<':cs) = "<"++escape cs escape ('>':cs) = ">"++escape cs escape ('&':cs) = "&"++escape cs escape (c:cs) = c: escape cs escape [] = [] +htmlHeader :: String -> String htmlHeader title = unlines [ "" , "" , "" - ,"" + ,"" , ""++title++"" , "" , "" ] +htmlClose :: String htmlClose = "\n\n" diff --git a/Language/Haskell/HsColour/InlineCSS.hs b/Language/Haskell/HsColour/InlineCSS.hs --- a/Language/Haskell/HsColour/InlineCSS.hs +++ b/Language/Haskell/HsColour/InlineCSS.hs @@ -6,6 +6,7 @@ import Language.Haskell.HsColour.Colourise import Language.Haskell.HsColour.HTML (renderAnchors, renderComment, renderNewLinesAnchors, escape) +import Text.Printf -- | Formats Haskell source code as a complete HTML document with inline styling hscolour :: ColourPrefs -- ^ Preferences for styling. @@ -42,7 +43,7 @@ ,"" ,"" ,"" - ,"" + ,"" ,""++title++"" ,"" ,"" @@ -62,7 +63,7 @@ style ReverseVideo = "" style Concealed = "text-decoration: line-through;" style (Foreground c) = "color: "++csscolour c++";" -style (Background c) = "background-colour: "++csscolour c++";" +style (Background c) = "background-color: "++csscolour c++";" style Italic = "font-style: italic;" csscolour :: Colour -> String @@ -74,4 +75,5 @@ csscolour Magenta = "#ff00ff" csscolour Cyan = "#00ffff" csscolour White = "#ffffff" +csscolour (Rgb r g b) = printf "#%02x%02x%02x" r g b 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 @@ -82,6 +82,8 @@ latexColour Magenta = "magenta" latexColour Cyan = "cyan" latexColour White = "white" +-- | TODO: How are these properly encoded in Latex? +latexColour c@(Rgb _ _ _) = latexColour (projectToBasicColour8 c) -- | Generic LaTeX document preamble. latexPrefix title = unlines diff --git a/Language/Haskell/HsColour/MIRC.hs b/Language/Haskell/HsColour/MIRC.hs --- a/Language/Haskell/HsColour/MIRC.hs +++ b/Language/Haskell/HsColour/MIRC.hs @@ -66,3 +66,4 @@ code Magenta True = "13" code Cyan True = "11" code White True = "15" +code c@(Rgb _ _ _) b = code (projectToBasicColour8 c) b diff --git a/Language/Haskell/HsColour/Options.hs b/Language/Haskell/HsColour/Options.hs --- a/Language/Haskell/HsColour/Options.hs +++ b/Language/Haskell/HsColour/Options.hs @@ -1,6 +1,7 @@ module Language.Haskell.HsColour.Options ( Option(..) , Output(..) + , TerminalType(..) ) where import Language.Haskell.HsColour.Output @@ -16,4 +17,5 @@ | Partial Bool -- ^ whether to produce a full document or partial | Input FilePath -- ^ input source file | Output FilePath -- ^ output source file + | Annot FilePath -- ^ annotations file deriving Eq diff --git a/Language/Haskell/HsColour/Output.hs b/Language/Haskell/HsColour/Output.hs --- a/Language/Haskell/HsColour/Output.hs +++ b/Language/Haskell/HsColour/Output.hs @@ -1,10 +1,17 @@ -module Language.Haskell.HsColour.Output where +module Language.Haskell.HsColour.Output(TerminalType(..),Output(..)) where +data TerminalType = + Ansi16Colour -- ^ @\\033[Xm@-style escape sequences (with /X/ =~ [34][0-7]) + | XTerm256Compatible -- ^ 'Ansi16Colour', and also @\\033[Y8;5;Zm]@-style escape sequences (with /Y/ =~ [3,4] and /Z/ an integer in [0,255] with the XTerm colour cube semantics). + deriving (Show,Eq,Ord) + -- | The supported output formats. -data Output = TTY -- ^ ANSI terminal codes +data Output = TTY -- ^ ANSI terminal codes. Equivalent to 'TTYg' 'Ansi16Colour' but left in for backwards compatibility. + | TTYg TerminalType -- ^ Terminal codes appropriate for the 'TerminalType'. | LaTeX -- ^ TeX macros | HTML -- ^ HTML with font tags | CSS -- ^ HTML with CSS. + | ACSS -- ^ HTML with CSS and mouseover types. | ICSS -- ^ HTML with inline CSS. | MIRC -- ^ mIRC chat clients deriving (Eq,Show) diff --git a/Language/Haskell/HsColour/TTY.hs b/Language/Haskell/HsColour/TTY.hs --- a/Language/Haskell/HsColour/TTY.hs +++ b/Language/Haskell/HsColour/TTY.hs @@ -1,15 +1,22 @@ -- | Highlights Haskell code with ANSI terminal codes. -module Language.Haskell.HsColour.TTY (hscolour) where +module Language.Haskell.HsColour.TTY (hscolour,hscolourG) where import Language.Haskell.HsColour.ANSI as ANSI import Language.Haskell.HsColour.Classify import Language.Haskell.HsColour.Colourise +import Language.Haskell.HsColour.Output(TerminalType(Ansi16Colour)) --- | Highlights Haskell code with ANSI terminal codes. +-- | = 'hscolourG' 'Ansi16Colour' hscolour :: ColourPrefs -- ^ Colour preferences. -> String -- ^ Haskell source code. -> String -- ^ Coloured Haskell source code. -hscolour pref = concatMap (renderToken pref) . tokenise +hscolour = hscolourG Ansi16Colour +-- | Highlights Haskell code with ANSI terminal codes. +hscolourG terminalType pref = concatMap (renderTokenG terminalType pref) . tokenise + + renderToken :: ColourPrefs -> (TokenType,String) -> String -renderToken pref (t,s) = ANSI.highlight (colourise pref t) s +renderToken = renderTokenG Ansi16Colour + +renderTokenG terminalType pref (t,s) = ANSI.highlightG terminalType (colourise pref t) s diff --git a/data/rgb24-example-.hscolour b/data/rgb24-example-.hscolour new file mode 100644 --- /dev/null +++ b/data/rgb24-example-.hscolour @@ -0,0 +1,25 @@ +ColourPrefs + { keyword = [Foreground (Rgb 255 255 150 ), Background (Rgb 0 0 0)] + , keyglyph = [Foreground (Rgb 255 255 150 ), Background (Rgb 0 0 0)] + , layout = [Foreground (Rgb 150 255 150 ), Background (Rgb 0 0 0 ), Bold] + , comment = [Foreground (Rgb 0 0 0 ), Background (Rgb 150 255 150 ), Italic] + , conid = [Foreground (Rgb 150 150 255 ), Background (Rgb 0 0 0 ), Bold] + , varid = [Foreground (Rgb 150 150 255 ), Background (Rgb 0 0 0)] + , conop = [Foreground (Rgb 255 150 150 ), Background (Rgb 0 0 0 ), Bold] + , varop = [Foreground (Rgb 255 150 150 ), Background (Rgb 0 0 0)] + , string = [Foreground (Rgb 0 0 0 ), Background (Rgb 150 150 255)] + , char = [Foreground (Rgb 0 0 0 ), Background (Rgb 150 150 255)] + , number = [Foreground (Rgb 255 255 150 ), Background (Rgb 0 0 0)] + , cpp = [Foreground (Rgb 0 0 0 ), Background (Rgb 255 150 150)] + , selection = [Foreground (Rgb 150 255 150 ), Background (Rgb 0 0 0)] + , variantselection = [Dim, Foreground Red, Underscore] + , definition = [Foreground (Rgb 150 255 150 ), Background (Rgb 0 0 0)] + } + + + +-- This example configuration file would take effect if you moved it to ~/.hscolour. + +-- Note: Comments currently have to come *after* the above block + +-- vim: ft=haskell diff --git a/hscolour.cabal b/hscolour.cabal --- a/hscolour.cabal +++ b/hscolour.cabal @@ -1,43 +1,58 @@ Name: hscolour -Version: 1.17 -Copyright: 2003-2010 Malcolm Wallace, University of York; 2006 Bjorn Bringert +Version: 1.18 +Copyright: 2003-2011 Malcolm Wallace, University of York; 2006 Bjorn Bringert Maintainer: Malcolm Wallace Author: Malcolm Wallace -Homepage: http://www.cs.york.ac.uk/fp/darcs/hscolour/ +Homepage: http://code.haskell.org/~malcolm/hscolour/ License: GPL License-file: LICENCE-GPL -Build-depends: haskell98, base < 10 -Extensions: Synopsis: Colourise Haskell code. Description: hscolour is a small Haskell script to colourise Haskell code. It currently has six output formats: - ANSI terminal codes, + ANSI terminal codes (optionally XTerm-256colour codes), HTML 3.2 with tags, HTML 4.01 with CSS, + HTML 4.01 with CSS and mouseover annotations, XHTML 1.0 with inline CSS styling, LaTeX, and mIRC chat codes. Category: Language -Exposed-Modules: - Language.Haskell.HsColour - Language.Haskell.HsColour.ANSI - Language.Haskell.HsColour.Anchors - Language.Haskell.HsColour.CSS - Language.Haskell.HsColour.Classify - Language.Haskell.HsColour.ColourHighlight - Language.Haskell.HsColour.Colourise - Language.Haskell.HsColour.General - Language.Haskell.HsColour.HTML - Language.Haskell.HsColour.InlineCSS - Language.Haskell.HsColour.LaTeX - Language.Haskell.HsColour.MIRC - Language.Haskell.HsColour.Options - Language.Haskell.HsColour.Output - Language.Haskell.HsColour.TTY -data-files: hscolour.css ---ghc-options: -O -W Build-Type: Simple +Data-files: hscolour.css, data/rgb24-example-.hscolour +Cabal-version: >=1.6 -Executable: HsColour -Main-is: HsColour.hs + +Library + Build-depends: haskell98, base < 10, containers + Exposed-Modules: + Language.Haskell.HsColour + Language.Haskell.HsColour.ANSI + Language.Haskell.HsColour.Anchors + Language.Haskell.HsColour.ACSS + Language.Haskell.HsColour.CSS + Language.Haskell.HsColour.Classify + Language.Haskell.HsColour.ColourHighlight + Language.Haskell.HsColour.Colourise + Language.Haskell.HsColour.General + Language.Haskell.HsColour.HTML + Language.Haskell.HsColour.InlineCSS + Language.Haskell.HsColour.LaTeX + Language.Haskell.HsColour.MIRC + Language.Haskell.HsColour.Options + Language.Haskell.HsColour.Output + Language.Haskell.HsColour.TTY + --ghc-options: -O -W + Extensions: + + +Executable HsColour + Build-depends: haskell98, base < 10, containers + Main-is: HsColour.hs + --ghc-options: -O -W + Extensions: + + +Source-repository head + Type : darcs + Location: http://code.haskell.org/~malcolm/hscolour diff --git a/hscolour.css b/hscolour.css --- a/hscolour.css +++ b/hscolour.css @@ -1,6 +1,38 @@ - .hs-keyglyph, .hs-layout {color: red;} .hs-keyword {color: blue;} .hs-comment, .hs-comment a {color: green;} .hs-str, .hs-chr {color: teal;} .hs-keyword,.hs-conid, .hs-varid, .hs-conop, .hs-varop, .hs-num, .hs-cpp, .hs-sel, .hs-definition {} + + +/* For Mouseover Annotations */ + +a.annot{ + position:relative; + color:#000; + text-decoration:none + } + +a.annot:hover{z-index:25; background-color:#ff0} + +a.annot span.annottext{display: none} + +a.annot:hover span.annottext{ + border-radius: 5px 5px; + + -moz-border-radius: 5px; + -webkit-border-radius: 5px; + + box-shadow: 5px 5px 5px rgba(0, 0, 0, 0.1); + -webkit-box-shadow: 5px 5px rgba(0, 0, 0, 0.1); + -moz-box-shadow: 5px 5px rgba(0, 0, 0, 0.1); + + display:block; + position: absolute; + left: 1em; top: 2em; + z-index: 99; + margin-left: 5; + background: #FFFFAA; + border: 2px solid #FFAD33; + padding: 0.8em 1em; +}