version 0.3.0.00.3.0.0

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)