patat 0.2.0.0 → 0.3.0.0
raw patch · 6 files changed
+275/−107 lines, 6 filesdep +highlighting-kate
Dependencies added: highlighting-kate
Files
- CHANGELOG.md +4/−0
- patat.cabal +3/−1
- src/Patat/Presentation/Display.hs +23/−30
- src/Patat/Presentation/Display/CodeBlock.hs +79/−0
- src/Patat/Presentation/Interactive.hs +5/−5
- src/Patat/Theme.hs +161/−71
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Changelog +- 0.3.0.0 (2016-10-17)+ * Add syntax highlighting support.+ * Fixed slide clipping after reload.+ - 0.2.0.0 (2016-10-13) * Add theming support. * Fix links display.
patat.cabal view
@@ -1,5 +1,5 @@ Name: patat-Version: 0.2.0.0+Version: 0.3.0.0 Synopsis: Terminal-based presentations using Pandoc Description: Terminal-based presentations using Pandoc License: GPL-2@@ -32,6 +32,7 @@ containers >= 0.5 && < 0.6, directory >= 1.2 && < 1.3, filepath >= 1.4 && < 1.5,+ highlighting-kate >= 0.6 && < 0.7, mtl >= 2.2 && < 2.3, optparse-applicative >= 0.12 && < 0.14, pandoc >= 1.17 && < 1.18,@@ -46,6 +47,7 @@ Data.Data.Extended Patat.Presentation Patat.Presentation.Display+ Patat.Presentation.Display.CodeBlock Patat.Presentation.Display.Table Patat.Presentation.Interactive Patat.Presentation.Internal
src/Patat/Presentation/Display.hs view
@@ -9,23 +9,24 @@ ---------------------------------------------------------------------------------import Control.Applicative ((<$>))-import Control.Monad (mplus)-import qualified Data.Aeson.Extended as A-import Data.Data.Extended (grecQ)-import Data.List (intersperse)-import Data.Maybe (fromMaybe)-import Data.Monoid (mconcat, mempty, (<>))-import qualified Data.Text as T+import Control.Applicative ((<$>))+import Control.Monad (mplus, unless)+import qualified Data.Aeson.Extended as A+import Data.Data.Extended (grecQ)+import Data.List (intersperse)+import Data.Maybe (fromMaybe)+import Data.Monoid (mconcat, mempty, (<>))+import qualified Data.Text as T+import Patat.Presentation.Display.CodeBlock import Patat.Presentation.Display.Table import Patat.Presentation.Internal-import Patat.PrettyPrint ((<$$>), (<+>))-import qualified Patat.PrettyPrint as PP-import Patat.Theme (Theme (..))-import qualified Patat.Theme as Theme-import qualified System.Console.ANSI as Ansi-import qualified System.Console.Terminal.Size as Terminal-import qualified Text.Pandoc.Extended as Pandoc+import Patat.PrettyPrint ((<$$>), (<+>))+import qualified Patat.PrettyPrint as PP+import Patat.Theme (Theme (..))+import qualified Patat.Theme as Theme+import qualified System.Console.ANSI as Ansi+import qualified System.Console.Terminal.Size as Terminal+import qualified Text.Pandoc.Extended as Pandoc import Prelude @@ -51,10 +52,11 @@ titleOffset = (columns - titleWidth) `div` 2 borders = themed (themeBorders theme) - Ansi.setCursorColumn titleOffset- PP.putDoc $ borders $ PP.string title- putStrLn ""- putStrLn ""+ unless (null title) $ do+ Ansi.setCursorColumn titleOffset+ PP.putDoc $ borders $ PP.string title+ putStrLn ""+ putStrLn "" let slide = case drop pActiveSlide pSlides of [] -> mempty@@ -110,17 +112,8 @@ themed themeHeader (PP.string (replicate i '#') <+> prettyInlines theme inlines) <> PP.hardline -prettyBlock Theme {..} (Pandoc.CodeBlock _ txt) = PP.vcat- [ let ind = PP.NotTrimmable " " in- PP.indent ind ind $ themed themeCodeBlock $ PP.string line- | line <- blockified txt- ] <> PP.hardline- where- blockified str =- let ls = lines str- longest = foldr max 0 (map length ls)- extend l = " " ++ l ++ replicate (longest - length l) ' ' ++ " " in- map extend $ [""] ++ ls ++ [""]+prettyBlock theme (Pandoc.CodeBlock (_, classes, _) txt) =+ prettyCodeBlock theme classes txt prettyBlock theme (Pandoc.BulletList bss) = PP.vcat [ PP.indent
+ src/Patat/Presentation/Display/CodeBlock.hs view
@@ -0,0 +1,79 @@+--------------------------------------------------------------------------------+-- | Displaying code blocks, optionally with syntax highlighting.+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Patat.Presentation.Display.CodeBlock+ ( prettyCodeBlock+ ) where+++--------------------------------------------------------------------------------+import Data.Char (toLower)+import Data.List (find)+import Data.Monoid (mconcat, (<>))+import qualified Data.Set as S+import Patat.Presentation.Display.Table (themed)+import qualified Patat.PrettyPrint as PP+import Patat.Theme+import qualified Text.Highlighting.Kate as Kate+import Prelude+++--------------------------------------------------------------------------------+lower :: String -> String+lower = map toLower+++--------------------------------------------------------------------------------+supportedLanguages :: S.Set String+supportedLanguages = S.fromList (map lower Kate.languages)+++--------------------------------------------------------------------------------+highlight :: [String] -> String -> [Kate.SourceLine]+highlight classes rawCodeBlock =+ case find (\c -> lower c `S.member` supportedLanguages) classes of+ Nothing -> zeroHighlight rawCodeBlock+ Just lang -> Kate.highlightAs lang rawCodeBlock+++--------------------------------------------------------------------------------+-- | This does fake highlighting, everything becomes a normal token. That makes+-- things a bit easier, since we only need to deal with one cases in the+-- renderer.+zeroHighlight :: String -> [Kate.SourceLine]+zeroHighlight str = [[(Kate.NormalTok, line)] | line <- lines str]+++--------------------------------------------------------------------------------+prettyCodeBlock :: Theme -> [String] -> String -> PP.Doc+prettyCodeBlock theme@Theme {..} classes rawCodeBlock =+ PP.vcat (map blockified sourceLines) <>+ PP.hardline+ where+ sourceLines :: [Kate.SourceLine]+ sourceLines =+ [[]] ++ highlight classes rawCodeBlock ++ [[]]++ prettySourceLine :: Kate.SourceLine -> PP.Doc+ prettySourceLine = mconcat . map prettyToken++ prettyToken :: Kate.Token -> PP.Doc+ prettyToken (tokenType, str) =+ themed (syntaxHighlight theme tokenType) (PP.string str)++ sourceLineLength :: Kate.SourceLine -> Int+ sourceLineLength line = sum [length str | (_, str) <- line]++ blockWidth :: Int+ blockWidth = foldr max 0 (map sourceLineLength sourceLines)++ blockified :: Kate.SourceLine -> PP.Doc+ blockified line =+ let len = sourceLineLength line+ indent = PP.NotTrimmable " " in+ PP.indent indent indent $+ themed themeCodeBlock $+ " " <>+ prettySourceLine line <>+ PP.string (replicate (blockWidth - len) ' ') <> " "
src/Patat/Presentation/Interactive.hs view
@@ -83,18 +83,18 @@ SkipForward -> return $ goToSlide (\x -> x + 10) SkipBackward -> return $ goToSlide (\x -> x - 10) First -> return $ goToSlide (\_ -> 0)- Last -> return $ goToSlide (\_ -> numSlides - 1)+ Last -> return $ goToSlide (\_ -> numSlides presentation - 1) Reload -> reloadPresentation where- numSlides = length (pSlides presentation)- clip idx = min (max 0 idx) (numSlides - 1)+ numSlides pres = length (pSlides pres)+ clip idx pres = min (max 0 idx) (numSlides pres - 1) goToSlide f = UpdatedPresentation $- presentation {pActiveSlide = clip (f $ pActiveSlide presentation)}+ presentation {pActiveSlide = clip (f $ pActiveSlide presentation) presentation} reloadPresentation = do errOrPres <- readPresentation (pFilePath presentation) return $ case errOrPres of Left err -> ErroredPresentation err Right pres -> UpdatedPresentation $- pres {pActiveSlide = clip (pActiveSlide presentation)}+ pres {pActiveSlide = clip (pActiveSlide presentation) pres}
src/Patat/Theme.hs view
@@ -5,47 +5,55 @@ module Patat.Theme ( Theme (..) , defaultTheme+ , Style (..)++ , SyntaxHighlighting (..)+ , defaultSyntaxHighlighting+ , syntaxHighlight ) where ---------------------------------------------------------------------------------import Control.Monad (mplus)+import Control.Monad (forM_, mplus) import qualified Data.Aeson as A import qualified Data.Aeson.TH.Extended as A-import Data.Char (toUpper)-import Data.List (intercalate)+import Data.Char (toLower, toUpper)+import Data.List (intercalate, isSuffixOf) import qualified Data.Map as M import Data.Maybe (mapMaybe, maybeToList) import Data.Monoid (Monoid (..), (<>)) import qualified Data.Text as T import qualified System.Console.ANSI as Ansi+import qualified Text.Highlighting.Kate as Kate+import Text.Read (readMaybe) import Prelude -------------------------------------------------------------------------------- data Theme = Theme- { themeBorders :: !(Maybe Style)- , themeHeader :: !(Maybe Style)- , themeCodeBlock :: !(Maybe Style)- , themeBulletList :: !(Maybe Style)- , themeBulletListMarkers :: !(Maybe T.Text)- , themeOrderedList :: !(Maybe Style)- , themeBlockQuote :: !(Maybe Style)- , themeDefinitionTerm :: !(Maybe Style)- , themeDefinitionList :: !(Maybe Style)- , themeTableHeader :: !(Maybe Style)- , themeTableSeparator :: !(Maybe Style)- , themeEmph :: !(Maybe Style)- , themeStrong :: !(Maybe Style)- , themeCode :: !(Maybe Style)- , themeLinkText :: !(Maybe Style)- , themeLinkTarget :: !(Maybe Style)- , themeStrikeout :: !(Maybe Style)- , themeQuoted :: !(Maybe Style)- , themeMath :: !(Maybe Style)- , themeImageText :: !(Maybe Style)- , themeImageTarget :: !(Maybe Style)+ { themeBorders :: !(Maybe Style)+ , themeHeader :: !(Maybe Style)+ , themeCodeBlock :: !(Maybe Style)+ , themeBulletList :: !(Maybe Style)+ , themeBulletListMarkers :: !(Maybe T.Text)+ , themeOrderedList :: !(Maybe Style)+ , themeBlockQuote :: !(Maybe Style)+ , themeDefinitionTerm :: !(Maybe Style)+ , themeDefinitionList :: !(Maybe Style)+ , themeTableHeader :: !(Maybe Style)+ , themeTableSeparator :: !(Maybe Style)+ , themeEmph :: !(Maybe Style)+ , themeStrong :: !(Maybe Style)+ , themeCode :: !(Maybe Style)+ , themeLinkText :: !(Maybe Style)+ , themeLinkTarget :: !(Maybe Style)+ , themeStrikeout :: !(Maybe Style)+ , themeQuoted :: !(Maybe Style)+ , themeMath :: !(Maybe Style)+ , themeImageText :: !(Maybe Style)+ , themeImageTarget :: !(Maybe Style)+ , themeSyntaxHighlighting :: !(Maybe SyntaxHighlighting) } deriving (Show) @@ -54,59 +62,62 @@ mempty = Theme Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing- Nothing Nothing Nothing+ Nothing Nothing Nothing Nothing mappend l r = Theme- { themeBorders = mplusOn themeBorders- , themeHeader = mplusOn themeHeader- , themeCodeBlock = mplusOn themeCodeBlock- , themeBulletList = mplusOn themeBulletList- , themeBulletListMarkers = mplusOn themeBulletListMarkers- , themeOrderedList = mplusOn themeOrderedList- , themeBlockQuote = mplusOn themeBlockQuote- , themeDefinitionTerm = mplusOn themeDefinitionTerm- , themeDefinitionList = mplusOn themeDefinitionList- , themeTableHeader = mplusOn themeTableHeader- , themeTableSeparator = mplusOn themeTableSeparator- , themeEmph = mplusOn themeEmph- , themeStrong = mplusOn themeStrong- , themeCode = mplusOn themeCode- , themeLinkText = mplusOn themeLinkText- , themeLinkTarget = mplusOn themeLinkTarget- , themeStrikeout = mplusOn themeStrikeout- , themeQuoted = mplusOn themeQuoted- , themeMath = mplusOn themeMath- , themeImageText = mplusOn themeImageText- , themeImageTarget = mplusOn themeImageTarget+ { themeBorders = mplusOn themeBorders+ , themeHeader = mplusOn themeHeader+ , themeCodeBlock = mplusOn themeCodeBlock+ , themeBulletList = mplusOn themeBulletList+ , themeBulletListMarkers = mplusOn themeBulletListMarkers+ , themeOrderedList = mplusOn themeOrderedList+ , themeBlockQuote = mplusOn themeBlockQuote+ , themeDefinitionTerm = mplusOn themeDefinitionTerm+ , themeDefinitionList = mplusOn themeDefinitionList+ , themeTableHeader = mplusOn themeTableHeader+ , themeTableSeparator = mplusOn themeTableSeparator+ , themeEmph = mplusOn themeEmph+ , themeStrong = mplusOn themeStrong+ , themeCode = mplusOn themeCode+ , themeLinkText = mplusOn themeLinkText+ , themeLinkTarget = mplusOn themeLinkTarget+ , themeStrikeout = mplusOn themeStrikeout+ , themeQuoted = mplusOn themeQuoted+ , themeMath = mplusOn themeMath+ , themeImageText = mplusOn themeImageText+ , themeImageTarget = mplusOn themeImageTarget+ , themeSyntaxHighlighting = mappendOn themeSyntaxHighlighting } where- mplusOn f = f l `mplus` f r+ mplusOn f = f l `mplus` f r+ mappendOn f = f l `mappend` f r -------------------------------------------------------------------------------- defaultTheme :: Theme defaultTheme = Theme- { themeBorders = dull Ansi.Yellow- , themeHeader = dull Ansi.Blue- , themeCodeBlock = dull Ansi.White <> ondull Ansi.Black- , themeBulletList = dull Ansi.Magenta- , themeBulletListMarkers = Just "-*"- , themeOrderedList = dull Ansi.Magenta- , themeBlockQuote = dull Ansi.Green- , themeDefinitionTerm = dull Ansi.Blue- , themeDefinitionList = dull Ansi.Magenta- , themeTableHeader = dull Ansi.Blue- , themeTableSeparator = dull Ansi.Magenta- , themeEmph = dull Ansi.Green- , themeStrong = dull Ansi.Red <> bold- , themeCode = dull Ansi.White <> ondull Ansi.Black- , themeLinkText = dull Ansi.Green- , themeLinkTarget = dull Ansi.Cyan <> underline- , themeStrikeout = ondull Ansi.Red- , themeQuoted = dull Ansi.Green- , themeMath = dull Ansi.Green- , themeImageText = dull Ansi.Green- , themeImageTarget = dull Ansi.Cyan <> underline+ { themeBorders = dull Ansi.Yellow+ , themeHeader = dull Ansi.Blue+ , themeCodeBlock = dull Ansi.White <> ondull Ansi.Black+ , themeBulletList = dull Ansi.Magenta+ , themeBulletListMarkers = Just "-*"+ , themeOrderedList = dull Ansi.Magenta+ , themeBlockQuote = dull Ansi.Green+ , themeDefinitionTerm = dull Ansi.Blue+ , themeDefinitionList = dull Ansi.Magenta+ , themeTableHeader = dull Ansi.Blue+ , themeTableSeparator = dull Ansi.Magenta+ , themeEmph = dull Ansi.Green+ , themeStrong = dull Ansi.Red <> bold+ , themeCode = dull Ansi.White <> ondull Ansi.Black+ , themeLinkText = dull Ansi.Green+ , themeLinkTarget = dull Ansi.Cyan <> underline+ , themeStrikeout = ondull Ansi.Red+ , themeQuoted = dull Ansi.Green+ , themeMath = dull Ansi.Green+ , themeImageText = dull Ansi.Green+ , themeImageTarget = dull Ansi.Cyan <> underline+ , themeSyntaxHighlighting = Just defaultSyntaxHighlighting } where dull c = Just $ Style [Ansi.SetColor Ansi.Foreground Ansi.Dull c]@@ -157,9 +168,6 @@ Ansi.Magenta -> "Magenta" Ansi.Cyan -> "Cyan" Ansi.White -> "White")- where- capitalize "" = ""- capitalize (x : xs) = toUpper x : xs nameForSGR (Ansi.SetUnderlining Ansi.SingleUnderline) = Just "underline" @@ -186,6 +194,88 @@ ] ++ [Ansi.SetUnderlining u | u <- [minBound .. maxBound]] ++ [Ansi.SetConsoleIntensity c | c <- [minBound .. maxBound]]+++--------------------------------------------------------------------------------+newtype SyntaxHighlighting = SyntaxHighlighting+ { unSyntaxHighlighting :: M.Map String Style+ } deriving (Monoid, Show, A.ToJSON)+++--------------------------------------------------------------------------------+instance A.FromJSON SyntaxHighlighting where+ parseJSON val = do+ styleMap <- A.parseJSON val+ forM_ (M.keys styleMap) $ \k -> case nameToTokenType k of+ Just _ -> return ()+ Nothing -> fail $ "Unknown token type: " ++ show k+ return (SyntaxHighlighting styleMap)+++--------------------------------------------------------------------------------+defaultSyntaxHighlighting :: SyntaxHighlighting+defaultSyntaxHighlighting = mkSyntaxHighlighting+ [ (Kate.KeywordTok, dull Ansi.Yellow)+ , (Kate.ControlFlowTok, dull Ansi.Yellow)++ , (Kate.DataTypeTok, dull Ansi.Green)++ , (Kate.DecValTok, dull Ansi.Red)+ , (Kate.BaseNTok, dull Ansi.Red)+ , (Kate.FloatTok, dull Ansi.Red)+ , (Kate.ConstantTok, dull Ansi.Red)+ , (Kate.CharTok, dull Ansi.Red)+ , (Kate.SpecialCharTok, dull Ansi.Red)+ , (Kate.StringTok, dull Ansi.Red)+ , (Kate.VerbatimStringTok, dull Ansi.Red)+ , (Kate.SpecialStringTok, dull Ansi.Red)++ , (Kate.CommentTok, dull Ansi.Blue)+ , (Kate.DocumentationTok, dull Ansi.Blue)+ , (Kate.AnnotationTok, dull Ansi.Blue)+ , (Kate.CommentVarTok, dull Ansi.Blue)++ , (Kate.ImportTok, dull Ansi.Cyan)+ , (Kate.OperatorTok, dull Ansi.Cyan)+ , (Kate.FunctionTok, dull Ansi.Cyan)+ , (Kate.PreprocessorTok, dull Ansi.Cyan)+ ]+ where+ dull c = Style [Ansi.SetColor Ansi.Foreground Ansi.Dull c]++ mkSyntaxHighlighting ls = SyntaxHighlighting $+ M.fromList [(nameForTokenType tt, s) | (tt, s) <- ls]+++--------------------------------------------------------------------------------+nameForTokenType :: Kate.TokenType -> String+nameForTokenType =+ unCapitalize . dropTok . show+ where+ unCapitalize (x : xs) = toLower x : xs+ unCapitalize xs = xs++ dropTok str+ | "Tok" `isSuffixOf` str = take (length str - 3) str+ | otherwise = str+++--------------------------------------------------------------------------------+nameToTokenType :: String -> Maybe Kate.TokenType+nameToTokenType = readMaybe . capitalize . (++ "Tok")+++--------------------------------------------------------------------------------+capitalize :: String -> String+capitalize "" = ""+capitalize (x : xs) = toUpper x : xs+++--------------------------------------------------------------------------------+syntaxHighlight :: Theme -> Kate.TokenType -> Maybe Style+syntaxHighlight theme tokenType = do+ sh <- themeSyntaxHighlighting theme+ M.lookup (nameForTokenType tokenType) (unSyntaxHighlighting sh) --------------------------------------------------------------------------------