├── Setup.hs ├── .gitignore ├── img ├── screenshot1.png └── screenshot2.png ├── LICENSE ├── cless.cabal ├── README.md └── src └── Main.hs /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /.cabal-sandbox/ 2 | /dist/ 3 | /cabal.sandbox.config 4 | -------------------------------------------------------------------------------- /img/screenshot1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tanakh/cless/HEAD/img/screenshot1.png -------------------------------------------------------------------------------- /img/screenshot2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tanakh/cless/HEAD/img/screenshot2.png -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Hideyuki Tanaka 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /cless.cabal: -------------------------------------------------------------------------------- 1 | name: cless 2 | version: 0.3.0.0 3 | synopsis: Colorized LESS 4 | description: Print file contents with syntax highlighting 5 | homepage: https://github.com/tanakh/cless 6 | license: MIT 7 | license-file: LICENSE 8 | author: Hideyuki Tanaka 9 | maintainer: tanaka.hideyuki@gmail.com 10 | copyright: (c) 2015 Hideyuki Tanaka 11 | category: Text 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | 15 | source-repository head 16 | type: git 17 | location: https://github.com/tanakh/cless.git 18 | 19 | executable cless 20 | main-is: Main.hs 21 | 22 | build-depends: base >=4.7 && <4.8 23 | , highlighting-kate >=0.5 24 | , wl-pprint-terminfo >=3.7 25 | , wl-pprint-extras 26 | , terminfo 27 | , optparse-applicative >=0.11 28 | , process >=1.2 29 | 30 | hs-source-dirs: src 31 | default-language: Haskell2010 32 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # cless: Colorized LESS 2 | 3 | # Install 4 | 5 | * Install [Haskell Platform](https://www.haskell.org/platform/). 6 | 7 | * Install `cless` using `cabal`. 8 | 9 | ```bash 10 | $ cabal update 11 | $ cabal install cless 12 | ``` 13 | 14 | # Usage 15 | 16 | ```bash 17 | > cless --help 18 | cless: Colorized LESS 19 | 20 | Usage: cless [-v|--version] [-L|--list-langs] [-S|--list-styles] 21 | [-N|--LINE-NUMBERS] [-l|--lang LANG] [-s|--style STYLE] [FILE] 22 | Print the content of FILE with syntax highlighting 23 | 24 | Available options: 25 | -h,--help Show this help text 26 | -v,--version Show version information 27 | -L,--list-langs Show the list of supported languages 28 | -S,--list-styles Show the list of supported styles 29 | -N,--LINE-NUMBERS Show line numbers 30 | -l,--lang LANG Specify language name 31 | -s,--style STYLE Specify style name (default 'pygments') 32 | ``` 33 | 34 | # Screenshots 35 | 36 | ![screenshot1](https://raw.githubusercontent.com/tanakh/cless/master/img/screenshot1.png) 37 | ![screenshot2](https://raw.githubusercontent.com/tanakh/cless/master/img/screenshot2.png) 38 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Main (main) where 4 | 5 | import Control.Exception 6 | import Control.Monad 7 | import Data.Char 8 | import Data.Maybe 9 | import Data.Monoid 10 | import Data.String 11 | import Data.Version 12 | import Options.Applicative 13 | import System.Console.Terminfo 14 | import System.Console.Terminfo.Color as Terminfo 15 | import System.Console.Terminfo.PrettyPrint 16 | import System.Environment 17 | import System.IO 18 | import System.Process 19 | import Text.Highlighting.Kate as Kate 20 | import Text.PrettyPrint.Free hiding ((<>)) 21 | import Text.Printf 22 | 23 | import Paths_cless (version) 24 | 25 | main :: IO () 26 | main = join $ execParser opts where 27 | opts = info (helper <*> cmd) 28 | ( fullDesc 29 | <> progDesc "Print the content of FILE with syntax highlighting" 30 | <> header "cless: Colorized LESS" ) 31 | 32 | cmd = process 33 | <$> switch ( long "version" <> short 'v' 34 | <> help "Show version information" ) 35 | <*> switch ( long "list-langs" <> short 'L' 36 | <> help "Show the list of supported languages" ) 37 | <*> switch ( long "list-styles" <> short 'S' 38 | <> help "Show the list of supported styles" ) 39 | <*> switch ( long "LINE-NUMBERS" <> short 'N' 40 | <> help "Show line numbers" ) 41 | <*> optional (strOption ( long "lang" <> short 'l' 42 | <> metavar "LANG" 43 | <> help "Specify language name" ) ) 44 | <*> optional (strOption ( long "style" <> short 's' 45 | <> metavar "STYLE" 46 | <> help "Specify style name (default 'pygments')" ) ) 47 | <*> optional (argument str (metavar "FILE")) 48 | 49 | styles :: [(String, Style)] 50 | styles = 51 | [ ("pygments" , pygments ) 52 | , ("kate" , kate ) 53 | , ("espresso" , espresso ) 54 | , ("tango" , tango ) 55 | , ("haddock" , haddock ) 56 | , ("monochrome", monochrome) 57 | , ("zenburn" , zenburn ) 58 | ] 59 | 60 | defaultPager :: String 61 | defaultPager = "less -R" 62 | 63 | defaultTerm :: String 64 | defaultTerm = "xterm-256color" 65 | 66 | defaultStyle :: Style 67 | defaultStyle = pygments 68 | 69 | process :: Bool -> Bool -> Bool -> Bool -> Maybe String -> Maybe String -> Maybe FilePath -> IO () 70 | process showVer showLangs showStyles linum mb_lang mb_stylename mb_file 71 | | showVer = 72 | putStrLn $ "cless version " ++ showVersion version 73 | | showLangs = 74 | mapM_ putStrLn languages 75 | | showStyles = 76 | mapM_ (putStrLn . fst) styles 77 | | otherwise = do 78 | process' linum mb_lang mb_stylename mb_file 79 | 80 | process' :: Bool -> Maybe String -> Maybe String -> Maybe FilePath -> IO () 81 | process' linum mb_lang mb_stylename mb_file = do 82 | con <- case mb_file of 83 | Just file -> readFile file 84 | Nothing -> do 85 | isTerm <- hIsTerminalDevice stdin 86 | when isTerm $ 87 | error "Missing filename (\"cless --help\" for help)" 88 | getContents 89 | 90 | let lang = determineLanguage mb_lang mb_file con 91 | style = maybe defaultStyle findStyle mb_stylename 92 | 93 | -- to raise error eagerly 94 | evaluate lang 95 | evaluate style 96 | 97 | let ss = highlightAs lang con 98 | doc = ppr linum style ss <> linebreak 99 | sdoc = renderPretty 0.6 80 (prettyTerm doc) 100 | 101 | termType <- fromMaybe defaultTerm <$> lookupEnv "TERM" 102 | pager <- fromMaybe defaultPager <$> lookupEnv "PAGER" 103 | term <- setupTerm $ if termType == "screen" then defaultTerm else termType 104 | 105 | bracket 106 | (createProcess (shell pager) { std_in = CreatePipe } ) 107 | ( \(_, _, _, ph) -> waitForProcess ph ) 108 | $ \(Just h, _, _, _) -> do 109 | case getCapability term $ evalTermState $ displayCap sdoc of 110 | Just output -> hRunTermOutput h term output 111 | Nothing -> displayIO h sdoc 112 | hClose h 113 | 114 | -- determin using language: 115 | -- 1. user specified (must be correct) 116 | -- 2. filename 117 | -- 3. content 118 | determineLanguage :: Maybe String -> Maybe String -> String -> String 119 | determineLanguage mb_lang mb_file content = fromMaybe "plain" $ 120 | (isValid <$> mb_lang) <|> 121 | (listToMaybe . languagesByFilename =<< mb_file) <|> 122 | (findSupportedLanguage =<< detectLanguage content) 123 | where 124 | isValid lang 125 | | Just lang' <- findSupportedLanguage lang = lang' 126 | | otherwise = error $ "Unsupported language: " ++ lang 127 | 128 | -- detect language from shebang 129 | detectLanguage :: String -> Maybe String 130 | detectLanguage ss 131 | | take 2 ss == "#!" = 132 | let sb = head $ lines ss 133 | in listToMaybe $ catMaybes 134 | [ findSupportedLanguage w 135 | | w <- words $ map (\c -> if c == '/' then ' ' else c) sb 136 | ] 137 | | otherwise = 138 | Nothing 139 | 140 | findSupportedLanguage :: String -> Maybe String 141 | findSupportedLanguage lang 142 | | map toLower lang `elem` map (map toLower) languages = Just lang 143 | | (lang': _) <- languagesByExtension lang = Just lang' 144 | | otherwise = Nothing 145 | 146 | findStyle :: String -> Style 147 | findStyle name = 148 | fromMaybe (error $ "invalid style name: " ++ name) 149 | $ lookup name styles 150 | 151 | ppr :: Bool -> Style -> [SourceLine] -> TermDoc 152 | ppr linum Style{..} = vcat . zipWith addLinum [1..] . map (hcat . map token) where 153 | addLinum ln line 154 | | linum = 155 | let lns = text $ printf "%7d " (ln :: Int) 156 | in withColors lineNumberColor lineNumberBackgroundColor lns 157 | <> line 158 | | otherwise = line 159 | 160 | token (tokenType, ss) = 161 | tokenEffect tokenType $ fromString ss 162 | 163 | tokenEffect :: TokenType -> TermDoc -> TermDoc 164 | tokenEffect tokenType = 165 | let tokenStyle = fromMaybe defs $ lookup tokenType tokenStyles 166 | defs = defStyle { tokenColor = defaultColor 167 | , tokenBackground = Nothing -- backgroundColor 168 | } 169 | in styleToEffect tokenStyle 170 | 171 | styleToEffect TokenStyle{..} = 172 | withColors tokenColor tokenBackground . 173 | with (if tokenBold then Bold else Nop) . 174 | -- with (if tokenItalic then Standout else Nop) . 175 | with (if tokenUnderline then Underline else Nop) 176 | 177 | withColors foreground background = 178 | with (maybe Nop (Foreground . cnvColor) foreground) . 179 | with (maybe Nop (Background . cnvColor) background) 180 | 181 | cnvColor :: Kate.Color -> Terminfo.Color 182 | cnvColor (RGB r g b) = ColorNumber 183 | $ 16 184 | + lucol (fromIntegral r) * 6 * 6 185 | + lucol (fromIntegral g) * 6 186 | + lucol (fromIntegral b) 187 | where 188 | tbl = [0x00, 0x5f, 0x87, 0xaf, 0xd7, 0xff :: Int] 189 | lucol v = snd $ minimum [ (abs $ a - v, i) | (a, i) <- zip tbl [0..] ] 190 | --------------------------------------------------------------------------------