cless 0.1.0.0 → 0.2.0.0

raw patch · 2 files changed

+63/−16 lines, 2 filesdep +process

Dependencies added: process

Files

• cless.cabal +2/−1
• src/Main.hs +61/−15

@@ -1,5 +1,5 @@ name:                cless-version:             0.1.0.0+version:             0.2.0.0 synopsis:            Colorized LESS description:         Print file contents with syntax highlighting homepage:            https://github.com/tanakh/cless@@ -25,6 +25,7 @@                      , wl-pprint-extras                      , terminfo                      , optparse-applicative >=0.11+                     , process >=1.2    hs-source-dirs:      src   default-language:    Haskell2010

@@ -2,15 +2,21 @@  module Main (main) where +import           Control.Exception import           Control.Monad import           Data.Maybe import           Data.Monoid import           Data.String import           Options.Applicative+import           System.Console.Terminfo import           System.Console.Terminfo.Color       as Terminfo import           System.Console.Terminfo.PrettyPrint+import           System.Environment+import           System.IO+import           System.Process import           Text.Highlighting.Kate              as Kate-import           Text.PrettyPrint.Free               (hcat, vcat)+import           Text.PrettyPrint.Free               hiding ((<>))+import           Text.Printf  main :: IO () main = join $ execParser opts where@@ -26,6 +32,9 @@         <*> switch ( long "list-styles"                   <> short 'S'                   <> help "Show the list of supported styles" )+        <*> switch ( long "LINE-NUMBERS"+                  <> short 'N'+                  <> help "Show line numbers" )         <*> optional (strOption ( long "lang"                   <> short 'l'                   <> metavar "LANG"@@ -34,7 +43,7 @@                   <> short 's'                   <> metavar "STYLE"                   <> help "Specify style name (default 'pygments')" ) )-        <*> argument str (metavar "FILE")+        <*> optional (argument str (metavar "FILE"))  styles :: [(String, Style)] styles =@@ -47,31 +56,65 @@   , ("zenburn"   , zenburn   )   ] -process :: Bool -> Bool -> Maybe String -> Maybe String -> FilePath -> IO ()-process True _ _ _ _ =+defaultPager :: String+defaultPager = "less -R"++defaultTerm :: String+defaultTerm = "xterm-256color"++defaultStyle :: Style+defaultStyle = pygments++process :: Bool -> Bool -> Bool -> Maybe String -> Maybe String -> Maybe FilePath -> IO ()+process True _ _ _ _ _ =   mapM_ putStrLn languages -process _ True _ _ _ =+process _ True _ _ _ _ =   mapM_ (putStrLn . fst) styles -process _ _ mb_lang mb_stylename file = do-  con <- readFile file+process _ _ linum mb_lang mb_stylename mb_file = do+  con <- case mb_file of+      Just file -> readFile file+      Nothing   -> getContents -  let lang = fromMaybe (error "cannot determin language")-             $ mb_lang <|> listToMaybe (languagesByFilename file)+  let lang = fromMaybe "plain"+             $ mb_lang <|> do file <- mb_file; listToMaybe (languagesByFilename file)        ss = highlightAs lang con -      style = maybe pygments findStyle mb_stylename+      style = maybe defaultStyle findStyle mb_stylename        findStyle name =         fromMaybe (error $ "invalid style name: " ++ name)         $ lookup name styles -  displayLn $ ppr style ss+      doc = ppr linum style ss <> linebreak+      sdoc = renderPretty 0.6 80 (prettyTerm doc) -ppr :: Style -> [SourceLine] -> TermDoc-ppr Style{..} = vcat . map (hcat . map token) where+  evaluate style -- to raise error eagerly++  termType <- fromMaybe defaultTerm <$> lookupEnv "TERM"+  pager <- fromMaybe defaultPager <$> lookupEnv "PAGER"+  term  <- setupTerm $ if termType == "screen" then defaultTerm else termType++  bracket+    (createProcess (shell pager) { std_in = CreatePipe } )+    ( \(_, _, _, ph) -> waitForProcess ph )+    $ \(Just h, _, _, _) -> do+      case getCapability term $ evalTermState $ displayCap sdoc of+        Just output -> hRunTermOutput h term output+        Nothing -> displayIO h sdoc+      hClose h++ppr :: Bool -> Style -> [SourceLine] -> TermDoc+ppr linum Style{..} = vcat . zipWith addLinum [1..] . map (hcat . map token) where+  addLinum ln line+      | linum =+          let lns = text $ printf "%7d " (ln :: Int)+          in withColors lineNumberColor lineNumberBackgroundColor lns+              <> line+      | otherwise = line+   token (tokenType, ss) =     tokenEffect tokenType $ fromString ss @@ -84,11 +127,14 @@     in styleToEffect tokenStyle    styleToEffect TokenStyle{..} =-    with (maybe Nop (Foreground . cnvColor) tokenColor) .-    with (maybe Nop (Background . cnvColor) tokenBackground) .+    withColors tokenColor tokenBackground .     with (if tokenBold      then Bold      else Nop) .     -- with (if tokenItalic    then Standout  else Nop) .     with (if tokenUnderline then Underline else Nop)++  withColors foreground background =+    with (maybe Nop (Foreground . cnvColor) foreground) .+    with (maybe Nop (Background . cnvColor) background)  cnvColor :: Kate.Color -> Terminfo.Color cnvColor (RGB r g b) = ColorNumber