From bebe94a4d07f5334e550ccef119b11adbf1ce664 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 19 Dec 2017 15:56:53 +0100 Subject: [PATCH] Support pandoc 2 --- .circleci/config.yml | 28 +++++++++++++++ .circleci/tickle.sh | 24 +++++++++++++ .travis.yml | 15 -------- Makefile | 14 ++------ extra/make-man.hs | 65 +++++++++++++++++++++------------- patat.cabal | 58 +++++++++++++++++++++--------- src/Patat/Presentation/Read.hs | 60 +++++++++++++++++++++++-------- stack.yaml | 12 ++++--- 8 files changed, 188 insertions(+), 88 deletions(-) create mode 100644 .circleci/config.yml create mode 100755 .circleci/tickle.sh delete mode 100644 .travis.yml diff --git a/.circleci/config.yml b/.circleci/config.yml new file mode 100644 index 0000000..e2bec66 --- /dev/null +++ b/.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' diff --git a/.circleci/tickle.sh b/.circleci/tickle.sh new file mode 100755 index 0000000..195c29c --- /dev/null +++ b/.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!" diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index ace2844..0000000 --- a/.travis.yml +++ /dev/null @@ -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 diff --git a/Makefile b/Makefile index 4e44db2..d8513a5 100644 --- a/Makefile +++ b/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 >$@ diff --git a/extra/make-man.hs b/extra/make-man.hs index 78c01f8..58cb00d 100644 --- a/extra/make-man.hs +++ b/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." diff --git a/patat.cabal b/patat.cabal index 5422b1a..bad3454 100644 --- a/patat.cabal +++ b/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 diff --git a/src/Patat/Presentation/Read.hs b/src/Patat/Presentation/Read.hs index 92bce07..b77fd6c 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,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 diff --git a/stack.yaml b/stack.yaml index 9c9debe..b85231e 100644 --- a/stack.yaml +++ b/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'