Support pandoc 2

.circleci/config.yml

@@ -0,0 +1,28 @@
+version: 2
+jobs:
+  build:
+    docker:
+      - image: 'fpco/stack-build:latest'
+    steps:
+      - checkout
+      - restore_cache:
+          key: 'v1-patat-{{ arch }}-{{ .Branch }}'
+      - run:
+          name: 'Update cabal indices'
+          command: 'cabal update'
+      - run:
+          # We set jobs to 1 here because that prevents Out-Of-Memory exceptions
+          # while compiling dependencies.
+          name: 'Install dependencies'
+          command: '.circleci/tickle.sh cabal install --only-dependencies --jobs=1'
+      - run:
+          name: 'Build and install'
+          command: 'cabal install --flags="patat-make-man"'
+      - run:
+          name: 'Run tests'
+          command: 'make test'
+      - save_cache:
+          key: 'v1-patat-{{ arch }}-{{ .Branch }}-{{ .Revision }}'
+          paths:
+            - '~/.cabal'
+            - '~/.ghc'

.circleci/tickle.sh

@@ -0,0 +1,24 @@
+#!/bin/bash
+set -o nounset -o errexit -o pipefail
+
+function tickle() {
+    while [ true ]; do
+        echo "[$(date +%H:%M:%S)] Tickling..."
+        sleep 60
+    done
+}
+
+echo "Forking tickle process..."
+tickle &
+TICKLE_PID=$!
+
+echo "Forking build process..."
+eval $@ &
+BUILD_PID=$!
+
+echo "Waiting for build thread ($BUILD_PID)..."
+wait $BUILD_PID
+
+echo "Killing tickle thread ($TICKLE_PID)..."
+kill $TICKLE_PID
+echo "All done!"

.travis.yml

@@ -1,15 +0,0 @@
-language: haskell
-ghc: '8.0.2'
-sudo: false
-env:
-  global:
-    # Travis seems to fail at setting this correctly.
-    - PATH: "$HOME/.cabal/bin:$PATH"
-cache:
-  directories:
-    - '$HOME/.cabal'
-    - '$HOME/.ghc'
-install:
-  - cabal install
-script:
-  - make test

Makefile

@@ -1,21 +1,11 @@
-# The minor version is passed to the build.  This is used to do some CPP to
-# solve incompatibilities.
-PANDOC_MINOR_VERSION=$(shell ghc-pkg latest pandoc | sed 's/.*-//' | cut -d. -f2)
-
 # We use `?=` to set SOURCE_DATE_EPOCH only if it is not present.  Unfortunately
 # we can't use `git --date=unix` since only very recent git versions support
 # that, so we need to make a round trip through `date`.
 SOURCE_DATE_EPOCH?=$(shell date '+%s' \
 					   --date="$(shell git log -1 --format=%cd --date=rfc)")
 
-# Prettify the date.
-SOURCE_DATE=$(shell env LC_ALL=C date --utc '+%B %d, %Y' -d "@${SOURCE_DATE_EPOCH}")
-
-extra/patat.1: README.md extra/make-man
-	SOURCE_DATE="$(SOURCE_DATE)" ./extra/make-man >$@
-
-extra/make-man: extra/make-man.hs
-	ghc -DPANDOC_MINOR_VERSION=${PANDOC_MINOR_VERSION} -Wall -o $@ $<
+extra/patat.1: README.md
+	SOURCE_DATE_EPOCH="$(SOURCE_DATE_EPOCH)" patat-make-man >$@
 
 extra/patat.bash-completion:
 	patat --bash-completion-script patat >$@

extra/make-man.hs

@@ -1,16 +1,20 @@
 -- | This script generates a man page for patat.
-{-# LANGUAGE CPP #-}
+{-# 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
-import qualified Text.Pandoc.Walk    as Pandoc
-import           Prelude
 
 getVersion :: IO String
 getVersion =
@@ -18,12 +22,20 @@ getVersion =
     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.walk $ \inline -> case inline of
+removeLinks = Pandoc.bottomUp $ \inline -> case inline of
     Pandoc.Link _ inlines _ -> Pandoc.Emph inlines
     _                       -> inline
 
-type Sections = [(Int, String, [Pandoc.Block])]
+type Sections = [(Int, T.Text, [Pandoc.Block])]
 
 toSections :: Int -> [Pandoc.Block] -> Sections
 toSections level = go
@@ -35,16 +47,19 @@ toSections level = go
             let (section, cont) = break (isJust . toSectionHeader) xs in
             (l, title, section) : go cont
 
-    toSectionHeader :: Pandoc.Block -> Maybe (Int, String)
+    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]
-        return (l, Pandoc.writeMarkdown Pandoc.def doc)
+            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 title] : blocks
+    Pandoc.Header level ("", [], []) [Pandoc.Str $ T.unpack title] : blocks
 
 reorganizeSections :: Pandoc.Pandoc -> Pandoc.Pandoc
 reorganizeSections (Pandoc.Pandoc meta0 blocks0) =
@@ -80,21 +95,22 @@ reorganizeSections (Pandoc.Pandoc meta0 blocks0) =
         [section | section@(_, n, _) <- sections, name == n]
 
 main :: IO ()
-main = do
-    Encoding.setLocaleEncoding Encoding.utf8
-    Right pandoc0  <- Pandoc.readMarkdown Pandoc.def <$> readFile "README.md"
-    Right template <- Pandoc.getDefaultTemplate Nothing "man"
+main = Pandoc.runIOorExplode $ do
+    liftIO $ Encoding.setLocaleEncoding Encoding.utf8
 
-    version <- getVersion
-    date    <- getEnv "SOURCE_DATE"
+    let readerOptions = Pandoc.def
+            { Pandoc.readerExtensions = Pandoc.pandocExtensions
+            }
 
-    let writerOptions = Pandoc.def {
-#if PANDOC_MINOR_VERSION >= 19
-              Pandoc.writerTemplate   = Just template
-#else
-              Pandoc.writerStandalone = True
-            , Pandoc.writerTemplate   = template
-#endif
+    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")
@@ -105,6 +121,7 @@ main = do
             }
 
     let pandoc1 = reorganizeSections $ removeLinks pandoc0
-
-    putStr $ Pandoc.writeMan writerOptions pandoc1
-    IO.hPutStrLn IO.stderr "Wrote man page."
+    txt <- Pandoc.writeMan writerOptions pandoc1
+    liftIO $ do
+        T.putStr txt
+        IO.hPutStrLn IO.stderr "Wrote man page."

patat.cabal

@@ -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.5,
+    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

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,7 +32,7 @@ import qualified Text.Pandoc.Extended        as Pandoc
 --------------------------------------------------------------------------------
 readPresentation :: FilePath -> IO (Either String Presentation)
 readPresentation filePath = runExceptT $ do
-    src    <- liftIO $ readFile filePath
+    src    <- liftIO $ T.readFile filePath
     reader <- case readExtension ext of
         Nothing -> throwError $ "Unknown file extension: " ++ show ext
         Just x  -> return x
@@ -51,18 +51,47 @@ readPresentation filePath = runExceptT $ do
 
 --------------------------------------------------------------------------------
 readExtension
-    :: String -> Maybe (String -> Either Pandoc.PandocError Pandoc.Pandoc)
+    :: String -> Maybe (T.Text -> 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
+    ".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 = 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
+        { Pandoc.readerExtensions =
+            Pandoc.extensionsFromList exts <> Pandoc.readerExtensions opts
         }
 
 
@@ -83,21 +112,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

stack.yaml

@@ -1,9 +1,11 @@
-resolver: nightly-2017-06-14
+resolver: nightly-2017-11-20
 install-ghc: true
 packages:
 - '.'
-flags: {}
+flags:
+  patat:
+    patat-make-man: true
 extra-package-dbs: []
-extra-deps:
-- 'aeson-1.2.0.0'
-- 'optparse-applicative-0.14.0.0'
+extra-deps: []
+# - 'aeson-1.2.0.0'
+# - 'optparse-applicative-0.14.0.0'