cheapskate-terminal (empty) → 0.1.0.0
raw patch · 6 files changed
+352/−0 lines, 6 filesdep +ansi-terminaldep +basedep +cheapskatesetup-changed
Dependencies added: ansi-terminal, base, cheapskate, cheapskate-terminal, data-default, directory, hpygments, hscolour, terminal-size, text
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- app/Main.hs +13/−0
- cheapskate-terminal.cabal +64/−0
- src/Cheapskate/Terminal.hs +241/−0
- test/Spec.hs +2/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Pedro Tacla Yamada (c) 2015++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Pedro Tacla Yamada nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,13 @@+module Main where++import Cheapskate+import Cheapskate.Terminal+import qualified Data.Text.IO as Text (readFile)+import System.Environment (getArgs)+import System.IO++main :: IO ()+main = do+ (f:_) <- getArgs+ hSetBuffering stdout (BlockBuffering (Just 500))+ prettyPrint =<< markdown def <$> Text.readFile f
+ cheapskate-terminal.cabal view
@@ -0,0 +1,64 @@+name: cheapskate-terminal+version: 0.1.0.0+synopsis: Initial project template from stack+description: Please see README.md+homepage: http://github.com/yamadapc/cheapskate-terminal#readme+license: BSD3+license-file: LICENSE+author: Pedro Tacla Yamada+maintainer: tacla.yamada@gmail.com+copyright: Copyright (c) 2015 Pedro Tacla Yamada+category: Web+build-type: Simple+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Cheapskate.Terminal+ build-depends: ansi-terminal >= 0.6.2.3+ , base >= 4.7 && < 5+ , cheapskate+ , data-default >= 0.5.3+ , directory+ , hpygments >= 0.2+ , hscolour+ , terminal-size+ , text+ default-language: Haskell2010++executable cheapskate-terminal+ hs-source-dirs: app+ main-is: Main.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2+ build-depends: ansi-terminal >= 0.6.2.3+ , base+ , cheapskate+ , cheapskate-terminal+ , data-default >= 0.5.3+ , directory+ , hpygments >= 0.2+ , hscolour+ , terminal-size+ , text+ default-language: Haskell2010++test-suite cheapskate-terminal-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: ansi-terminal >= 0.6.2.3+ , base+ , cheapskate+ , cheapskate-terminal+ , data-default >= 0.5.3+ , directory+ , hpygments >= 0.2+ , hscolour+ , terminal-size+ , text+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/yamadapc/cheapskate-terminal
+ src/Cheapskate/Terminal.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Cheapskate.Terminal+ ( -- * Rendering markdown to the terminal+ prettyPrint+ , renderTerminal+ , renderIO+ -- * Options+ , PrettyPrintOptions(..)+ , def+ , renderIOWith+ -- * Pure rendering+ , renderPureWith+ -- * Internal functions and implementation comments+ , renderBlock+ , renderBlockPure+ , renderInline+ )+ where++import Cheapskate+import Control.Monad (foldM)+import Data.Default+import Data.Foldable (toList)+import Data.Maybe (isJust)+import Data.Monoid+import Data.String (IsString)+import qualified Data.Text as Text (Text, lines, pack,+ unpack)+import qualified Data.Text.Lazy as Text.Lazy+import Data.Text.Lazy.Builder+import qualified Data.Text.Lazy.IO as Text.Lazy+import GHC.Int+import Language.Haskell.HsColour+import Language.Haskell.HsColour.Colourise (defaultColourPrefs,+ readColourPrefs)+import System.Console.ANSI+import System.Console.Terminal.Size (Window (..), size)+import System.Directory+import Text.Highlighting.Pygments++-- |+-- An alias for 'renderTerminal'+data PrettyPrintOptions = PrettyPrintOptions { prettyPrintWidth :: Int64+ , prettyPrintColourPrefs :: ColourPrefs+ , prettyPrintHasPygments :: Bool+ }++instance Default PrettyPrintOptions where+ def = PrettyPrintOptions { prettyPrintColourPrefs = defaultColourPrefs+ , prettyPrintWidth = 80+ , prettyPrintHasPygments = False+ }++-- |+-- An alias for 'renderTerminal'+prettyPrint :: Doc -> IO ()+prettyPrint = renderTerminal++-- |+-- Prints a markdown document to the terminal+renderTerminal :: Doc -> IO ()+renderTerminal doc = do+ b <- renderIO doc+ mapM_ Text.Lazy.putStrLn (Text.Lazy.lines b)++-- |+-- Renders a 'Doc' doing 'IO' reading options from the environment+renderIO :: Doc -> IO Text.Lazy.Text+renderIO doc = do+ wid <- size >>= \s -> case s of+ Just (Window _ w) -> return w+ Nothing -> return 80+ prefs <- readColourPrefs+ hasPygments <- isJust <$> findExecutable "pygments"+ let opts = PrettyPrintOptions { prettyPrintWidth = wid+ , prettyPrintHasPygments = hasPygments+ , prettyPrintColourPrefs = prefs+ }+ renderIOWith opts doc++-- |+-- Renders a 'Doc' doing 'IO' with some set of options+renderIOWith :: PrettyPrintOptions -> Doc -> IO Text.Lazy.Text+renderIOWith opts (Doc _ blocks) = toLazyText <$> foldM helper "\n" blocks+ where+ helper m block = do+ t <- renderBlock opts block+ return (m <> fromLazyText t <> "\n")++-- |+-- Renders a 'Doc' without doing 'IO'+renderPureWith :: PrettyPrintOptions -> Doc -> Text.Lazy.Text+renderPureWith opts (Doc _ blocks) = toLazyText (foldl helper "" blocks)+ where+ helper m block = let t = renderBlockPure opts block+ in m <> fromLazyText t <> "\n"++-- |+-- Renders a 'Block' doing 'IO'; this is necessary for @pygments@ usage.+renderBlock :: PrettyPrintOptions -> Block -> IO Text.Lazy.Text+renderBlock opts@PrettyPrintOptions{..} b@(CodeBlock (CodeAttr lang _) t)+ | lang /= "haskell" && prettyPrintHasPygments = do+ mlexer <- getLexerByName (Text.unpack lang)+ case mlexer of+ Nothing -> return (renderBlockPure opts b)+ Just lexer -> do+ let st = Text.unpack t+ highlighted <- highlight lexer terminalFormatter [] st+ return $ mconcatMapF ((<> "\n") . (" " <>) . Text.Lazy.pack)+ (lines highlighted)+renderBlock opts block = return (renderBlockPure opts block)++-- |+-- Renders a 'Block' without doing 'IO'. Uses a 'Text.Lazy.Text' so wrapping is+-- easier to implement. The absolute majority of the time is spent going from+-- 'Text.Lazy.Text' to 'Builder' and back. If we strip out 'Builder' we gain+-- complexity like crazy. Suggestions welcome.+renderBlockPure :: PrettyPrintOptions -> Block -> Text.Lazy.Text+renderBlockPure opts@PrettyPrintOptions{..} block = case block of+ (Header level els) ->+ setSGRCodeText [ SetColor Foreground Vivid Black+ , SetConsoleIntensity BoldIntensity+ ] <>+ Text.Lazy.replicate (fromIntegral level) "#" <> " " <>+ setSGRCodeText [ Reset ] <>+ setSGRCodeText [ SetColor Foreground Vivid Cyan+ , SetConsoleIntensity BoldIntensity+ ] <>+ toLazyText (mconcatMapF renderInline els) <>+ setSGRCodeText [ Reset ] <>+ "\n"+ (Para els) ->+ wordwrap prettyPrintWidth (toLazyText (mconcatMapF renderInline els))+ (List _ (Bullet c) bss) -> flip mconcatMapF bss $+ \bs -> setSGRCodeText [ SetColor Foreground Vivid Black ] <>+ Text.Lazy.pack (" " ++ (c:" ")) <>+ setSGRCodeText [ Reset ] <>+ mconcatMapF (renderBlockPure opts) bs+ (List _ (Numbered w i) bss) ->+ let ibss = zip bss [0..]+ in flip mconcatMapF ibss $ \(bs, j) ->+ setSGRCodeText [ SetColor Foreground Vivid Black ] <>+ let wc = case w of+ PeriodFollowing -> '.'+ ParenFollowing -> ')'+ in Text.Lazy.pack (" " ++ show (i + j) ++ (wc : " ")) <>+ setSGRCodeText [ Reset ] <>+ mconcatMapF (renderBlockPure opts) bs+ (Blockquote bs) -> flip mconcatMapF bs $ \b ->+ setSGRCodeText [ SetColor Foreground Vivid Black ] <>+ " > " <>+ setSGRCodeText [ SetColor Foreground Vivid Blue ] <>+ renderBlockPure opts b+ (CodeBlock (CodeAttr "haskell" _) t) ->+ let code = hscolour+ TTY prettyPrintColourPrefs False True "" False (Text.unpack t)+ in toLazyText (mconcatMapF ((<> "\n") . (" " <>) . fromString) (lines code))+ (CodeBlock (CodeAttr _ _) t) ->+ setSGRCodeText [ SetColor Foreground Dull Yellow ] <>+ mconcat (map (Text.Lazy.fromStrict . (<> "\n") . (" " <>) ) (Text.lines t)) <>+ setSGRCodeText [ Reset ]+ HRule ->+ setSGRCodeText [ SetColor Foreground Vivid Black ] <>+ Text.Lazy.replicate (fromIntegral prettyPrintWidth) "-" <>+ setSGRCodeText [ Reset ]+ (HtmlBlock html) -> Text.Lazy.fromStrict html <> "\n"++-- |+-- Renders an inline to a 'Text' 'Builder'+renderInline :: Inline -> Builder+renderInline el = case el of+ LineBreak -> "\n"+ Space -> " "+ SoftBreak -> " "+ Entity t -> fromText t+ RawHtml t -> fromText t+ (Str s) -> fromText s+ (Link els url _) ->+ "[" <>+ renderInlinesWith [ SetConsoleIntensity BoldIntensity ] els <>+ setSGRCodeBuilder [ Reset ] <>+ "](" <>+ setSGRCodeBuilder [ SetColor Foreground Vivid Blue ] <>+ fromText url <>+ setSGRCodeBuilder [ Reset ] <>+ ")"+ (Emph els) ->+ renderInlinesWith [ SetItalicized True+ , SetUnderlining SingleUnderline+ ] els <>+ setSGRCodeBuilder [ Reset ]+ (Strong els) ->+ renderInlinesWith [ SetConsoleIntensity BoldIntensity ] els <>+ setSGRCodeBuilder [ Reset ]+ (Code s) ->+ setSGRCodeBuilder [ SetColor Foreground Dull Yellow ] <>+ fromText s <>+ setSGRCodeBuilder [ Reset ]+ (Image _ url tit) ->+ "![" <>+ setSGRCodeBuilder [ SetConsoleIntensity BoldIntensity ] <>+ fromText tit <>+ setSGRCodeBuilder [ Reset ] <>+ "](" <>+ setSGRCodeBuilder [ SetColor Foreground Vivid Blue ] <>+ fromText url <>+ setSGRCodeBuilder [ Reset ] <>+ ")"+ where+ renderInlinesWith sgr = mconcatMapF helper+ where+ helper e = setSGRCodeBuilder sgr <> renderInline e++concats :: (IsString a, Monoid a) => [a] -> [a]+concats = scanl1 (\s v -> s <> " " <> v)++wordwrap :: Int64 -> Text.Lazy.Text -> Text.Lazy.Text+wordwrap maxwidth = Text.Lazy.unlines . wordwrap' . Text.Lazy.words+ where+ wordwrap' [] = []+ wordwrap' ws = sentence : wordwrap' restwords+ where+ zipped = zip (concats ws) ws+ (sentences, rest) = span (\(s, _) -> Text.Lazy.length s <= maxwidth) zipped+ sentence = last (map fst sentences)+ restwords = map snd rest++setSGRCodeText :: [SGR] -> Text.Lazy.Text+setSGRCodeText = Text.Lazy.pack . setSGRCode++setSGRCodeTextS :: [SGR] -> Text.Text+setSGRCodeTextS = Text.pack . setSGRCode++setSGRCodeBuilder :: [SGR] -> Builder+setSGRCodeBuilder = fromText . setSGRCodeTextS++-- Probably there's a function in prelude that we don't know that does this+mconcatMapF :: (Foldable f, Monoid m) => (a -> m) -> f a -> m+mconcatMapF f = mconcat . map f . toList
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"