diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/patat.cabal b/patat.cabal --- a/patat.cabal +++ b/patat.cabal @@ -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 diff --git a/src/Patat/Presentation/Display.hs b/src/Patat/Presentation/Display.hs --- a/src/Patat/Presentation/Display.hs +++ b/src/Patat/Presentation/Display.hs @@ -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 diff --git a/src/Patat/Presentation/Display/CodeBlock.hs b/src/Patat/Presentation/Display/CodeBlock.hs new file mode 100644 --- /dev/null +++ b/src/Patat/Presentation/Display/CodeBlock.hs @@ -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) ' ') <> " " diff --git a/src/Patat/Presentation/Interactive.hs b/src/Patat/Presentation/Interactive.hs --- a/src/Patat/Presentation/Interactive.hs +++ b/src/Patat/Presentation/Interactive.hs @@ -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} diff --git a/src/Patat/Theme.hs b/src/Patat/Theme.hs --- a/src/Patat/Theme.hs +++ b/src/Patat/Theme.hs @@ -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) --------------------------------------------------------------------------------