summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJasperVanDerJeugt <>2016-10-17 11:54:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-10-17 11:54:00 (GMT)
commit7f24bff9f5b58b23d75030e34c8379882e2b874d (patch)
tree133640efa99235747f2137738731034c11062ede
parent2455fb4fc58d6755c1e1f13846795e9e8d98602e (diff)
version 0.3.0.00.3.0.0
-rw-r--r--CHANGELOG.md4
-rw-r--r--patat.cabal4
-rw-r--r--src/Patat/Presentation/Display.hs53
-rw-r--r--src/Patat/Presentation/Display/CodeBlock.hs79
-rw-r--r--src/Patat/Presentation/Interactive.hs10
-rw-r--r--src/Patat/Theme.hs232
6 files changed, 275 insertions, 107 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index f4a2b14..b41d315 100644
--- 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
index d5f450e..5874b0c 100644
--- 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 @@ Executable patat
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 @@ Executable patat
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
index cdbd49e..942794b 100644
--- a/src/Patat/Presentation/Display.hs
+++ b/src/Patat/Presentation/Display.hs
@@ -9,23 +9,24 @@ module Patat.Presentation.Display
--------------------------------------------------------------------------------
-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 @@ displayPresentation Presentation {..} = do
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 @@ prettyBlock theme@Theme {..} (Pandoc.Header i _ inlines) =
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
index 0000000..4888166
--- /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
index 2ff5fd5..226a715 100644
--- a/src/Patat/Presentation/Interactive.hs
+++ b/src/Patat/Presentation/Interactive.hs
@@ -83,18 +83,18 @@ updatePresentation cmd presentation = case cmd of
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
index e3aeb17..c46c7f5 100644
--- 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 @@ instance Monoid Theme where
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 @@ nameForSGR (Ansi.SetColor layer intensity color) = Just $
Ansi.Magenta -> "Magenta"
Ansi.Cyan -> "Cyan"
Ansi.White -> "White")
- where
- capitalize "" = ""
- capitalize (x : xs) = toUpper x : xs
nameForSGR (Ansi.SetUnderlining Ansi.SingleUnderline) = Just "underline"
@@ -189,4 +197,86 @@ sgrsByName = M.fromList
--------------------------------------------------------------------------------
+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)
+
+
+--------------------------------------------------------------------------------
$(A.deriveJSON A.dropPrefixOptions ''Theme)