Make pandoc extensions customizable

README.md

@@ -46,6 +46,7 @@ Table of Contents
     -   [Fragmented slides](#fragmented-slides)
     -   [Theming](#theming)
     -   [Syntax Highlighting](#syntax-highlighting)
+    -   [Pandoc Extensions](#pandoc-extensions)
 -   [Trivia](#trivia)
 
 Installation
@@ -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
 ------
 

patat.cabal

@@ -43,7 +43,7 @@ Executable patat
     mtl                  >= 2.2   && < 2.3,
     optparse-applicative >= 0.12  && < 0.15,
     pandoc               >= 2.0.4 && < 2.1,
-    skylighting          >= 0.1   && < 0.5,
+    skylighting          >= 0.1   && < 0.6,
     terminal-size        >= 0.3   && < 0.4,
     text                 >= 1.2   && < 1.3,
     time                 >= 1.4   && < 1.9,

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,9 +90,63 @@ 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]
@@ -126,4 +192,4 @@ getActiveFragment presentation = do
 
 
 --------------------------------------------------------------------------------
-$(A.deriveJSON A.dropPrefixOptions ''PresentationSettings)
+$(A.deriveFromJSON A.dropPrefixOptions ''PresentationSettings)

src/Patat/Presentation/Read.hs

@@ -32,18 +32,20 @@ import qualified Text.Pandoc.Extended        as Pandoc
 --------------------------------------------------------------------------------
 readPresentation :: FilePath -> IO (Either String Presentation)
 readPresentation filePath = runExceptT $ do
-    src    <- liftIO $ T.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,8 +53,9 @@ readPresentation filePath = runExceptT $ do
 
 --------------------------------------------------------------------------------
 readExtension
-    :: String -> Maybe (T.Text -> Either Pandoc.PandocError Pandoc.Pandoc)
-readExtension fileExt = case fileExt of
+    :: 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
@@ -60,40 +63,20 @@ readExtension fileExt = case fileExt of
     _      -> Nothing
 
   where
-    readerOpts = addExtensions Pandoc.def
-        [ 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
-        ]
-
-    lhsOpts = addExtensions readerOpts
-        [ Pandoc.Ext_literate_haskell
-        ]
-
-    addExtensions
-        :: Pandoc.ReaderOptions -> [Pandoc.Extension] -> Pandoc.ReaderOptions
-    addExtensions opts exts = opts
+    readerOpts = Pandoc.def
         { Pandoc.readerExtensions =
-            Pandoc.extensionsFromList exts <> Pandoc.readerExtensions opts
+            extensions <> absolutelyRequiredExtensions
         }
 
+    lhsOpts = readerOpts
+        { Pandoc.readerExtensions =
+            Pandoc.readerExtensions readerOpts <>
+            Pandoc.extensionsFromList [Pandoc.Ext_literate_haskell]
+        }
+
+    absolutelyRequiredExtensions =
+        Pandoc.extensionsFromList [Pandoc.Ext_yaml_metadata_block]
+
 
 --------------------------------------------------------------------------------
 pandocToPresentation

stack.yaml

@@ -1,4 +1,4 @@
-resolver: nightly-2017-11-20
+resolver: nightly-2017-12-14
 install-ghc: true
 packages:
 - '.'
@@ -6,6 +6,6 @@ flags:
   patat:
     patat-make-man: true
 extra-package-dbs: []
-extra-deps: []
-# - 'aeson-1.2.0.0'
-# - 'optparse-applicative-0.14.0.0'
+extra-deps:
+- 'ansi-terminal-0.6.3.1'
+- 'skylighting-0.5'

tests/extentions0.md

@@ -0,0 +1,9 @@
+---
+patat:
+  pandocExtensions:
+    - patat_extensions
+    - autolink_bare_uris
+    - emoji
+...
+
+Check out this example: http://example.com/ :smile:

tests/extentions0.md.dump

@@ -0,0 +1 @@
+Check out this example: <http://example.com/> 😄

tests/extentions1.md

@@ -0,0 +1,7 @@
+---
+patat:
+  pandocExtensions:
+    - emoji
+...
+
+The patat default ~~strikeout~~ is not enabled, but emojis are :smile:

tests/extentions1.md.dump

@@ -0,0 +1 @@
+The patat default ~~strikeout~~ is not enabled, but emojis are 😄