version 0.6.0.00.6.0.0

7 files changed, 319 insertions, 46 deletions

diff --git a/CHANGELOG.md b/CHANGELOG.md
index aac2a95..237212f 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,9 @@
 # Changelog
 
+- 0.6.0.0 (2017-12-19)
+    * Make pandoc extensions customizable in the configuration
+    * Bump `pandoc` to 2.0
+
 - 0.5.2.2 (2017-06-14)
     * Add `network-uri` dependency to fix travis build
 
diff --git a/README.md b/README.md
index 2b6f7f3..1bd10ae 100644
--- a/README.md
+++ b/README.md
@@ -1,7 +1,7 @@
 patat
 =====
 
-[![Build Status](https://img.shields.io/travis/jaspervdj/patat.svg)](https://travis-ci.org/jaspervdj/patat) [![Hackage](https://img.shields.io/hackage/v/patat.svg)](https://hackage.haskell.org/package/patat) [![GitHub tag](https://img.shields.io/github/tag/jaspervdj/patat.svg)]()
+[![Build Status](https://img.shields.io/circleci/project/github/jaspervdj/patat.svg)](https://circleci.com/gh/jaspervdj/patat) [![Hackage](https://img.shields.io/hackage/v/patat.svg)](https://hackage.haskell.org/package/patat) [![GitHub tag](https://img.shields.io/github/tag/jaspervdj/patat.svg)]()
 
 `patat` (**P**resentations **A**top **T**he **A**NSI **T**erminal) is a small
 tool that allows you to show presentations using only an ANSI terminal.  It does
@@ -46,6 +46,7 @@ Table of Contents
     -   [Fragmented slides](#fragmented-slides)
     -   [Theming](#theming)
     -   [Syntax Highlighting](#syntax-highlighting)
+    -   [Pandoc Extensions](#pandoc-extensions)
 -   [Trivia](#trivia)
 
 Installation
@@ -53,9 +54,9 @@ Installation
 
 ### Pre-built-packages
 
-There is a pre-built package available for Debian:
-
-- <https://packages.debian.org/unstable/patat>
+- Debian: <https://packages.debian.org/unstable/patat>
+- Ubuntu: <https://packages.ubuntu.com/artful/patat>
+- openSUSE: <https://build.opensuse.org/package/show/openSUSE:Factory:ARM/patat>
 
 ### From source
 
@@ -407,6 +408,44 @@ an obvious way.
 
 [this list]: https://hackage.haskell.org/package/highlighting-kate-0.6.3/docs/Text-Highlighting-Kate-Types.html#t:TokenType
 
+### Pandoc Extensions
+
+Pandoc comes with a fair number of extensions on top of markdown:
+
+    <https://hackage.haskell.org/package/pandoc-2.0.5/docs/Text-Pandoc-Extensions.html>
+
+`patat` enables a number of them by default, but this is also customizable.
+
+In order to enable an additional extensions, e.g. `autolink_bare_uris`, add it
+to the `pandocExtensions` field in the YAML metadata:
+
+    ---
+    patat:
+      pandocExtensions:
+        - patat_extensions
+        - autolink_bare_uris
+    ...
+
+    Document content...
+
+The `patat_extensions` in the above snippet refers to the default set of
+extensions enabled by `patat`.  If you want to disable those and only use a
+select few extensions, simply leave it out and choose your own:
+
+    ---
+    patat:
+      pandocExtensions:
+        - autolink_bare_uris
+        - emoji
+    ...
+
+    ...
+
+    Document content...
+
+If you don't want to enable any extensions, simply set `pandocExtensions` to the
+empty list `[]`.
+
 Trivia
 ------
 
diff --git a/extra/make-man.hs b/extra/make-man.hs
new file mode 100644
index 0000000..58cb00d
--- /dev/null
+++ b/extra/make-man.hs
@@ -0,0 +1,127 @@
+-- | This script generates a man page for patat.
+{-# LANGUAGE OverloadedStrings #-}
+import           Control.Applicative ((<$>))
+import           Control.Exception   (throw)
+import           Control.Monad       (guard)
+import           Control.Monad.Trans (liftIO)
+import           Data.Char           (isSpace, toLower)
+import           Data.List           (isPrefixOf)
+import           Data.Maybe          (isJust)
+import qualified Data.Text           as T
+import qualified Data.Text.IO        as T
+import qualified GHC.IO.Encoding     as Encoding
+import           Prelude
+import           System.Environment  (getEnv)
+import qualified System.IO           as IO
+import qualified Data.Time as Time
+import qualified Text.Pandoc         as Pandoc
+
+getVersion :: IO String
+getVersion =
+    dropWhile isSpace . drop 1 . dropWhile (/= ':') . head .
+    filter (\l -> "version:" `isPrefixOf` map toLower l) .
+    map (dropWhile isSpace) . lines <$> readFile "patat.cabal"
+
+getPrettySourceDate :: IO String
+getPrettySourceDate = do
+    epoch <- getEnv "SOURCE_DATE_EPOCH"
+    utc   <- Time.parseTimeM True locale "%s" epoch :: IO Time.UTCTime
+    return $ Time.formatTime locale "%B %d, %Y" utc
+  where
+    locale = Time.defaultTimeLocale
+
+removeLinks :: Pandoc.Pandoc -> Pandoc.Pandoc
+removeLinks = Pandoc.bottomUp $ \inline -> case inline of
+    Pandoc.Link _ inlines _ -> Pandoc.Emph inlines
+    _                       -> inline
+
+type Sections = [(Int, T.Text, [Pandoc.Block])]
+
+toSections :: Int -> [Pandoc.Block] -> Sections
+toSections level = go
+  where
+    go []       = []
+    go (h : xs) = case toSectionHeader h of
+        Nothing         -> go xs
+        Just (l, title) ->
+            let (section, cont) = break (isJust . toSectionHeader) xs in
+            (l, title, section) : go cont
+
+    toSectionHeader :: Pandoc.Block -> Maybe (Int, T.Text)
+    toSectionHeader (Pandoc.Header l _ inlines) = do
+        guard (l <= level)
+        let doc = Pandoc.Pandoc Pandoc.nullMeta [Pandoc.Plain inlines]
+            txt = case Pandoc.runPure (Pandoc.writeMarkdown Pandoc.def doc) of
+                    Left err -> throw err  -- Bad!
+                    Right x  -> x
+        return (l, txt)
+    toSectionHeader _ = Nothing
+
+fromSections :: Sections -> [Pandoc.Block]
+fromSections = concatMap $ \(level, title, blocks) ->
+    Pandoc.Header level ("", [], []) [Pandoc.Str $ T.unpack title] : blocks
+
+reorganizeSections :: Pandoc.Pandoc -> Pandoc.Pandoc
+reorganizeSections (Pandoc.Pandoc meta0 blocks0) =
+    let sections0 = toSections 2 blocks0 in
+    Pandoc.Pandoc meta0 $ fromSections $
+        [ (1, "NAME", nameSection)
+        ] ++
+        [ (1, "SYNOPSIS", s)
+        | (_, _, s) <- lookupSection "Running" sections0
+        ] ++
+        [ (1, "DESCRIPTION", [])
+        ] ++
+            [ (2, n, s)
+            | (_, n, s) <- lookupSection "Controls" sections0
+            ] ++
+            [ (2, n, s)
+            | (_, n, s) <- lookupSection "Input format" sections0
+            ] ++
+            [ (2, n, s)
+            | (_, n, s) <- lookupSection "Configuration" sections0
+            ] ++
+        [ (1, "OPTIONS", s)
+        | (_, _, s) <- lookupSection "Options" sections0
+        ] ++
+        [ (1, "SEE ALSO", seeAlsoSection)
+        ]
+  where
+    nameSection    = mkPara "patat - Presentations Atop The ANSI Terminal"
+    seeAlsoSection = mkPara "pandoc(1)"
+    mkPara str     = [Pandoc.Para [Pandoc.Str str]]
+
+    lookupSection name sections =
+        [section | section@(_, n, _) <- sections, name == n]
+
+main :: IO ()
+main = Pandoc.runIOorExplode $ do
+    liftIO $ Encoding.setLocaleEncoding Encoding.utf8
+
+    let readerOptions = Pandoc.def
+            { Pandoc.readerExtensions = Pandoc.pandocExtensions
+            }
+
+    source   <- liftIO $ T.readFile "README.md"
+    pandoc0  <- Pandoc.readMarkdown readerOptions source
+    template <- Pandoc.getDefaultTemplate "man"
+
+    version <- liftIO getVersion
+    date    <- liftIO getPrettySourceDate
+
+    let writerOptions = Pandoc.def
+            { Pandoc.writerTemplate   = Just template
+            , Pandoc.writerVariables  =
+                [ ("author",  "Jasper Van der Jeugt")
+                , ("title",   "patat manual")
+                , ("date",    date)
+                , ("footer",  "patat v" ++ version)
+                , ("section", "1")
+                ]
+            }
+
+    let pandoc1 = reorganizeSections $ removeLinks pandoc0
+    txt <- Pandoc.writeMan writerOptions pandoc1
+    liftIO $ do
+        T.putStr txt
+        IO.hPutStrLn IO.stderr "Wrote man page."
diff --git a/patat.cabal b/patat.cabal
index 5422b1a..dc67ccd 100644
--- a/patat.cabal
+++ b/patat.cabal
@@ -1,5 +1,5 @@
 Name:                patat
-Version:             0.5.2.2
+Version:             0.6.0.0
 Synopsis:            Terminal-based presentations using Pandoc
 Description:         Terminal-based presentations using Pandoc
 License:             GPL-2
@@ -20,6 +20,11 @@ Source-repository head
   Type:     git
   Location: git://github.com/jaspervdj/patat.git
 
+Flag patat-make-man
+  Description: Build the executable to generate the man page
+  Default:     False
+  Manual:      True
+
 Executable patat
   Main-is:           Main.hs
   Ghc-options:       -Wall -threaded -rtsopts "-with-rtsopts=-N"
@@ -27,23 +32,23 @@ Executable patat
   Default-language:  Haskell2010
 
   Build-depends:
-    aeson                >= 0.9  && < 1.3,
-    ansi-terminal        >= 0.6  && < 0.7,
-    ansi-wl-pprint       >= 0.6  && < 0.7,
-    base                 >= 4.6  && < 4.10,
-    bytestring           >= 0.10 && < 0.11,
-    containers           >= 0.5  && < 0.6,
-    directory            >= 1.2  && < 1.4,
-    filepath             >= 1.4  && < 1.5,
-    mtl                  >= 2.2  && < 2.3,
-    optparse-applicative >= 0.12 && < 0.15,
-    pandoc               >= 1.16 && < 1.20,
-    skylighting          >= 0.1  && < 0.4,
-    terminal-size        >= 0.3  && < 0.4,
-    text                 >= 1.2  && < 1.3,
-    time                 >= 1.4  && < 1.8,
-    unordered-containers >= 0.2  && < 0.3,
-    yaml                 >= 0.7  && < 0.9,
+    aeson                >= 0.9   && < 1.3,
+    ansi-terminal        >= 0.6   && < 0.7,
+    ansi-wl-pprint       >= 0.6   && < 0.7,
+    base                 >= 4.6   && < 4.11,
+    bytestring           >= 0.10  && < 0.11,
+    containers           >= 0.5   && < 0.6,
+    directory            >= 1.2   && < 1.4,
+    filepath             >= 1.4   && < 1.5,
+    mtl                  >= 2.2   && < 2.3,
+    optparse-applicative >= 0.12  && < 0.15,
+    pandoc               >= 2.0.4 && < 2.1,
+    skylighting          >= 0.1   && < 0.6,
+    terminal-size        >= 0.3   && < 0.4,
+    text                 >= 1.2   && < 1.3,
+    time                 >= 1.4   && < 1.9,
+    unordered-containers >= 0.2   && < 0.3,
+    yaml                 >= 0.7   && < 0.9,
     -- We don't even depend on these packages but they can break cabal install
     -- because of the conflicting 'Network.URI' module.
     network-uri >= 2.6,
@@ -64,4 +69,23 @@ Executable patat
     Patat.Presentation.Read
     Patat.PrettyPrint
     Patat.Theme
+    Paths_patat
     Text.Pandoc.Extended
+
+Executable patat-make-man
+  Main-is:          make-man.hs
+  Ghc-options:      -Wall
+  Hs-source-dirs:   extra
+  Default-language: Haskell2010
+
+  If flag(patat-make-man)
+    Buildable: True
+  Else
+    Buildable: False
+
+  Build-depends:
+    base   >= 4.6  && < 4.11,
+    mtl    >= 2.2  && < 2.3,
+    pandoc >= 2.0  && < 2.1,
+    text   >= 1.2  && < 1.3,
+    time   >= 1.6  && < 1.9
diff --git a/src/Main.hs b/src/Main.hs
index 2073453..3ba00c6 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -178,7 +178,7 @@ main = do
 watcher :: Chan.Chan PresentationCommand -> FilePath -> UTCTime -> IO a
 watcher chan filePath mtime0 = do
     -- The extra exists check helps because some editors temporarily make the
-    -- file dissapear while writing.
+    -- file disappear while writing.
     exists <- doesFileExist filePath
     mtime1 <- if exists then getModificationTime filePath else return mtime0
 
diff --git a/src/Patat/Presentation/Internal.hs b/src/Patat/Presentation/Internal.hs
index c253f13..3ed7ac0 100644
--- a/src/Patat/Presentation/Internal.hs
+++ b/src/Patat/Presentation/Internal.hs
@@ -1,10 +1,15 @@
 --------------------------------------------------------------------------------
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE TemplateHaskell            #-}
 module Patat.Presentation.Internal
     ( Presentation (..)
     , PresentationSettings (..)
     , defaultPresentationSettings
+
+    , ExtensionList (..)
+    , defaultExtensionList
+
     , Slide (..)
     , Fragment (..)
     , Index
@@ -21,11 +26,15 @@ module Patat.Presentation.Internal
 import           Control.Monad          (mplus)
 import qualified Data.Aeson.Extended    as A
 import qualified Data.Aeson.TH.Extended as A
+import qualified Data.Foldable          as Foldable
+import           Data.List              (intercalate)
 import           Data.Maybe             (listToMaybe)
 import           Data.Monoid            (Monoid (..), (<>))
+import qualified Data.Text              as T
 import qualified Patat.Theme            as Theme
-import qualified Text.Pandoc            as Pandoc
 import           Prelude
+import qualified Text.Pandoc            as Pandoc
+import           Text.Read              (readMaybe)
 
 
 --------------------------------------------------------------------------------
@@ -50,6 +59,7 @@ data PresentationSettings = PresentationSettings
     , psIncrementalLists :: !(Maybe Bool)
     , psAutoAdvanceDelay :: !(Maybe (A.FlexibleNum Int))
     , psSlideLevel       :: !(Maybe Int)
+    , psPandocExtensions :: !(Maybe ExtensionList)
     } deriving (Show)
 
 
@@ -57,6 +67,7 @@ data PresentationSettings = PresentationSettings
 instance Monoid PresentationSettings where
     mempty      = PresentationSettings
                     Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+                    Nothing
     mappend l r = PresentationSettings
         { psRows             = psRows             l `mplus` psRows             r
         , psColumns          = psColumns          l `mplus` psColumns          r
@@ -65,6 +76,7 @@ instance Monoid PresentationSettings where
         , psIncrementalLists = psIncrementalLists l `mplus` psIncrementalLists r
         , psAutoAdvanceDelay = psAutoAdvanceDelay l `mplus` psAutoAdvanceDelay r
         , psSlideLevel       = psSlideLevel       l `mplus` psSlideLevel       r
+        , psPandocExtensions = psPandocExtensions l `mplus` psPandocExtensions r
         }
 
 
@@ -78,10 +90,64 @@ defaultPresentationSettings = PresentationSettings
     , psIncrementalLists = Nothing
     , psAutoAdvanceDelay = Nothing
     , psSlideLevel       = Nothing
+    , psPandocExtensions = Nothing
     }
 
 
 --------------------------------------------------------------------------------
+newtype ExtensionList = ExtensionList {unExtensionList :: Pandoc.Extensions}
+    deriving (Show)
+
+
+--------------------------------------------------------------------------------
+instance A.FromJSON ExtensionList where
+    parseJSON = A.withArray "FromJSON ExtensionList" $
+        fmap (ExtensionList . mconcat) . mapM parseExt . Foldable.toList
+      where
+        parseExt = A.withText "FromJSON ExtensionList" $ \txt -> case txt of
+            -- Our default extensions
+            "patat_extensions" -> return (unExtensionList defaultExtensionList)
+
+            -- Individuals
+            _ -> case readMaybe ("Ext_" ++ T.unpack txt) of
+                Just e  -> return $ Pandoc.extensionsFromList [e]
+                Nothing -> fail $
+                    "Unknown extension: " ++ show txt ++
+                    ", known extensions are: " ++
+                    intercalate ", "
+                        [ show (drop 4 (show e))
+                        | e <- [minBound .. maxBound] :: [Pandoc.Extension]
+                        ]
+
+
+--------------------------------------------------------------------------------
+defaultExtensionList :: ExtensionList
+defaultExtensionList = ExtensionList $
+    Pandoc.readerExtensions Pandoc.def <> Pandoc.extensionsFromList
+    [ Pandoc.Ext_yaml_metadata_block
+    , Pandoc.Ext_table_captions
+    , Pandoc.Ext_simple_tables
+    , Pandoc.Ext_multiline_tables
+    , Pandoc.Ext_grid_tables
+    , Pandoc.Ext_pipe_tables
+    , Pandoc.Ext_raw_html
+    , Pandoc.Ext_tex_math_dollars
+    , Pandoc.Ext_fenced_code_blocks
+    , Pandoc.Ext_fenced_code_attributes
+    , Pandoc.Ext_backtick_code_blocks
+    , Pandoc.Ext_inline_code_attributes
+    , Pandoc.Ext_fancy_lists
+    , Pandoc.Ext_four_space_rule
+    , Pandoc.Ext_definition_lists
+    , Pandoc.Ext_compact_definition_lists
+    , Pandoc.Ext_example_lists
+    , Pandoc.Ext_strikeout
+    , Pandoc.Ext_superscript
+    , Pandoc.Ext_subscript
+    ]
+
+
+--------------------------------------------------------------------------------
 data Slide
     = ContentSlide [Fragment]
     | TitleSlide   Pandoc.Block
@@ -126,4 +192,4 @@ getActiveFragment presentation = do
 
 
 --------------------------------------------------------------------------------
-$(A.deriveJSON A.dropPrefixOptions ''PresentationSettings)
+$(A.deriveFromJSON A.dropPrefixOptions ''PresentationSettings)
diff --git a/src/Patat/Presentation/Read.hs b/src/Patat/Presentation/Read.hs
index 92bce07..07bc72e 100644
--- a/src/Patat/Presentation/Read.hs
+++ b/src/Patat/Presentation/Read.hs
@@ -16,9 +16,9 @@ import qualified Data.ByteString             as B
 import qualified Data.HashMap.Strict         as HMS
 import           Data.Maybe                  (fromMaybe)
 import           Data.Monoid                 (mempty, (<>))
-import qualified Data.Set                    as Set
 import qualified Data.Text                   as T
 import qualified Data.Text.Encoding          as T
+import qualified Data.Text.IO                as T
 import qualified Data.Yaml                   as Yaml
 import           Patat.Presentation.Fragment
 import           Patat.Presentation.Internal
@@ -32,18 +32,20 @@ import qualified Text.Pandoc.Extended        as Pandoc
 --------------------------------------------------------------------------------
 readPresentation :: FilePath -> IO (Either String Presentation)
 readPresentation filePath = runExceptT $ do
-    src    <- liftIO $ readFile filePath
-    reader <- case readExtension ext of
+    -- We need to read the settings first.
+    src          <- liftIO $ T.readFile filePath
+    homeSettings <- ExceptT readHomeSettings
+    metaSettings <- ExceptT $ return $ readMetaSettings src
+    let settings = metaSettings <> homeSettings <> defaultPresentationSettings
+
+    let pexts = fromMaybe defaultExtensionList (psPandocExtensions settings)
+    reader <- case readExtension pexts ext of
         Nothing -> throwError $ "Unknown file extension: " ++ show ext
         Just x  -> return x
     doc    <- case reader src of
         Left  e -> throwError $ "Could not parse document: " ++ show e
         Right x -> return x
 
-    homeSettings <- ExceptT readHomeSettings
-    metaSettings <- ExceptT $ return $ readMetaSettings src
-    let settings = metaSettings <> homeSettings <> defaultPresentationSettings
-
     ExceptT $ return $ pandocToPresentation filePath settings doc
   where
     ext = takeExtension filePath
@@ -51,20 +53,30 @@ readPresentation filePath = runExceptT $ do
 
 --------------------------------------------------------------------------------
 readExtension
-    :: String -> Maybe (String -> Either Pandoc.PandocError Pandoc.Pandoc)
-readExtension fileExt = case fileExt of
-    ".md"  -> Just $ Pandoc.readMarkdown Pandoc.def
-    ".lhs" -> Just $ Pandoc.readMarkdown lhsOpts
-    ""     -> Just $ Pandoc.readMarkdown Pandoc.def
-    ".org" -> Just $ Pandoc.readOrg Pandoc.def
+    :: ExtensionList -> String
+    -> Maybe (T.Text -> Either Pandoc.PandocError Pandoc.Pandoc)
+readExtension (ExtensionList extensions) fileExt = case fileExt of
+    ".md"  -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
+    ".lhs" -> Just $ Pandoc.runPure . Pandoc.readMarkdown lhsOpts
+    ""     -> Just $ Pandoc.runPure . Pandoc.readMarkdown readerOpts
+    ".org" -> Just $ Pandoc.runPure . Pandoc.readOrg      readerOpts
     _      -> Nothing
 
   where
-    lhsOpts = Pandoc.def
-        { Pandoc.readerExtensions = Set.insert Pandoc.Ext_literate_haskell
-            (Pandoc.readerExtensions Pandoc.def)
+    readerOpts = Pandoc.def
+        { Pandoc.readerExtensions =
+            extensions <> absolutelyRequiredExtensions
         }
 
+    lhsOpts = readerOpts
+        { Pandoc.readerExtensions =
+            Pandoc.readerExtensions readerOpts <>
+            Pandoc.extensionsFromList [Pandoc.Ext_literate_haskell]
+        }
+
+    absolutelyRequiredExtensions =
+        Pandoc.extensionsFromList [Pandoc.Ext_yaml_metadata_block]
+
 
 --------------------------------------------------------------------------------
 pandocToPresentation
@@ -83,21 +95,22 @@ pandocToPresentation pFilePath pSettings pandoc@(Pandoc.Pandoc meta _) = do
 -- avoids the problems caused by pandoc involving rendering Markdown.  This
 -- should only be used for settings though, not things like title / authors
 -- since those /can/ contain markdown.
-parseMetadataBlock :: String -> Maybe A.Value
+parseMetadataBlock :: T.Text -> Maybe A.Value
 parseMetadataBlock src = do
     block <- mbBlock
-    Yaml.decode $! T.encodeUtf8 $! T.pack block
+    Yaml.decode $! T.encodeUtf8 block
   where
-    mbBlock = case lines src of
+    mbBlock :: Maybe T.Text
+    mbBlock = case T.lines src of
         ("---" : ls) -> case break (`elem` ["---", "..."]) ls of
             (_,     [])      -> Nothing
-            (block, (_ : _)) -> Just (unlines block)
+            (block, (_ : _)) -> Just (T.unlines block)
         _            -> Nothing
 
 
 --------------------------------------------------------------------------------
 -- | Read settings from the metadata block in the Pandoc document.
-readMetaSettings :: String -> Either String PresentationSettings
+readMetaSettings :: T.Text -> Either String PresentationSettings
 readMetaSettings src = fromMaybe (Right mempty) $ do
     A.Object obj <- parseMetadataBlock src
     val          <- HMS.lookup "patat" obj