cless 0.2.0.0 → 0.3.0.0

raw patch · 2 files changed

+73/−31 lines, 2 files

Files

• cless.cabal +1/−1
• src/Main.hs +72/−30

@@ -1,5 +1,5 @@ name:                cless-version:             0.2.0.0+version:             0.3.0.0 synopsis:            Colorized LESS description:         Print file contents with syntax highlighting homepage:            https://github.com/tanakh/cless

@@ -4,9 +4,11 @@  import           Control.Exception import           Control.Monad+import           Data.Char import           Data.Maybe import           Data.Monoid import           Data.String+import           Data.Version import           Options.Applicative import           System.Console.Terminfo import           System.Console.Terminfo.Color       as Terminfo@@ -18,6 +20,8 @@ import           Text.PrettyPrint.Free               hiding ((<>)) import           Text.Printf +import           Paths_cless                         (version)+ main :: IO () main = join $ execParser opts where   opts = info (helper <*> cmd)@@ -26,21 +30,18 @@         <> header "cless: Colorized LESS" )    cmd = process-        <$> switch ( long "list-langs"-                  <> short 'L'+        <$> switch ( long "version" <> short 'v'+                  <> help "Show version information" )+        <*> switch ( long "list-langs" <> short 'L'                   <> help "Show the list of supported languages" )-        <*> switch ( long "list-styles"-                  <> short 'S'+        <*> switch ( long "list-styles" <> short 'S'                   <> help "Show the list of supported styles" )-        <*> switch ( long "LINE-NUMBERS"-                  <> short 'N'+        <*> switch ( long "LINE-NUMBERS" <> short 'N'                   <> help "Show line numbers" )-        <*> optional (strOption ( long "lang"-                  <> short 'l'+        <*> optional (strOption ( long "lang" <> short 'l'                   <> metavar "LANG"                   <> help "Specify language name" ) )-        <*> optional (strOption ( long "style"-                  <> short 's'+        <*> optional (strOption ( long "style" <> short 's'                   <> metavar "STYLE"                   <> help "Specify style name (default 'pygments')" ) )         <*> optional (argument str (metavar "FILE"))@@ -65,34 +66,38 @@ defaultStyle :: Style defaultStyle = pygments -process :: Bool -> Bool -> Bool -> Maybe String -> Maybe String -> Maybe FilePath -> IO ()-process True _ _ _ _ _ =-  mapM_ putStrLn languages--process _ True _ _ _ _ =-  mapM_ (putStrLn . fst) styles+process :: Bool -> Bool -> Bool -> Bool -> Maybe String -> Maybe String -> Maybe FilePath -> IO ()+process showVer showLangs showStyles linum mb_lang mb_stylename mb_file+  | showVer =+    putStrLn $ "cless version " ++ showVersion version+  | showLangs =+    mapM_ putStrLn languages+  | showStyles =+    mapM_ (putStrLn . fst) styles+  | otherwise = do+    process' linum mb_lang mb_stylename mb_file -process _ _ linum mb_lang mb_stylename mb_file = do+process' :: Bool -> Maybe String -> Maybe String -> Maybe FilePath -> IO ()+process' linum mb_lang mb_stylename mb_file = do   con <- case mb_file of-      Just file -> readFile file-      Nothing   -> getContents--  let lang = fromMaybe "plain"-             $ mb_lang <|> do file <- mb_file; listToMaybe (languagesByFilename file)--      ss = highlightAs lang con+    Just file -> readFile file+    Nothing   -> do+      isTerm <- hIsTerminalDevice stdin+      when isTerm $+        error "Missing filename (\"cless --help\" for help)"+      getContents +  let lang  = determineLanguage mb_lang mb_file con       style = maybe defaultStyle findStyle mb_stylename -      findStyle name =-        fromMaybe (error $ "invalid style name: " ++ name)-        $ lookup name styles+  -- to raise error eagerly+  evaluate lang+  evaluate style -      doc = ppr linum style ss <> linebreak+  let ss   = highlightAs lang con+      doc  = ppr linum style ss <> linebreak       sdoc = renderPretty 0.6 80 (prettyTerm doc) -  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@@ -105,6 +110,43 @@         Just output -> hRunTermOutput h term output         Nothing -> displayIO h sdoc       hClose h++-- determin using language:+--   1. user specified (must be correct)+--   2. filename+--   3. content+determineLanguage :: Maybe String -> Maybe String -> String -> String+determineLanguage mb_lang mb_file content = fromMaybe "plain" $+  (isValid <$> mb_lang) <|>+  (listToMaybe . languagesByFilename =<< mb_file) <|>+  (findSupportedLanguage =<< detectLanguage content)+  where+    isValid lang+      | Just lang' <- findSupportedLanguage lang = lang'+      | otherwise = error $ "Unsupported language: " ++ lang++-- detect language from shebang+detectLanguage :: String -> Maybe String+detectLanguage ss+  | take 2 ss == "#!" =+    let sb = head $ lines ss+    in listToMaybe $ catMaybes+       [ findSupportedLanguage w+       | w <- words $ map (\c -> if c == '/' then ' ' else c) sb+       ]+  | otherwise =+     Nothing++findSupportedLanguage :: String -> Maybe String+findSupportedLanguage lang+  | map toLower lang `elem` map (map toLower) languages = Just lang+  | (lang': _) <- languagesByExtension lang             = Just lang'+  | otherwise = Nothing++findStyle :: String -> Style+findStyle name =+  fromMaybe (error $ "invalid style name: " ++ name)+  $ lookup name styles  ppr :: Bool -> Style -> [SourceLine] -> TermDoc ppr linum Style{..} = vcat . zipWith addLinum [1..] . map (hcat . map token) where