diff --git a/CHANGELOG.md b/CHANGELOG.md --- 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 --- 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 @@ - [Fragmented slides](#fragmented-slides) - [Theming](#theming) - [Syntax Highlighting](#syntax-highlighting) + - [Pandoc Extensions](#pandoc-extensions) - [Trivia](#trivia) Installation @@ -53,9 +54,9 @@ ### Pre-built-packages -There is a pre-built package available for Debian: - -- +- Debian: +- Ubuntu: +- openSUSE: ### From source @@ -406,6 +407,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: + + + +`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 --- /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 --- 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 @@ 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 @@ 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 @@ 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 --- a/src/Main.hs +++ b/src/Main.hs @@ -178,7 +178,7 @@ 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 --- 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 @@ 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 @@ , psIncrementalLists :: !(Maybe Bool) , psAutoAdvanceDelay :: !(Maybe (A.FlexibleNum Int)) , psSlideLevel :: !(Maybe Int) + , psPandocExtensions :: !(Maybe ExtensionList) } deriving (Show) @@ -57,6 +67,7 @@ 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 @@ , 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 @@ , 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 @@ -------------------------------------------------------------------------------- -$(A.deriveJSON A.dropPrefixOptions ''PresentationSettings) +$(A.deriveFromJSON A.dropPrefixOptions ''PresentationSettings) diff --git a/src/Patat/Presentation/Read.hs b/src/Patat/Presentation/Read.hs --- a/src/Patat/Presentation/Read.hs +++ b/src/Patat/Presentation/Read.hs @@ -16,9 +16,9 @@ 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 @@ -------------------------------------------------------------------------------- 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,21 +53,31 @@ -------------------------------------------------------------------------------- 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 :: FilePath -> PresentationSettings -> Pandoc.Pandoc @@ -83,21 +95,22 @@ -- 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