summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJasperVanDerJeugt <>2016-10-13 12:30:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-10-13 12:30:00 (GMT)
commit2455fb4fc58d6755c1e1f13846795e9e8d98602e (patch)
treefda79c3e1436b3b09fe45ab5f8b481103a7597b3
parenta7c0d1bec9548480b27275432aa916d8ff53493b (diff)
version 0.2.0.00.2.0.0
-rw-r--r--CHANGELOG.md6
-rw-r--r--patat.cabal11
-rw-r--r--src/Data/Aeson/Extended.hs22
-rw-r--r--src/Data/Aeson/TH/Extended.hs21
-rw-r--r--src/Main.hs2
-rw-r--r--src/Patat/Presentation.hs5
-rw-r--r--src/Patat/Presentation/Display.hs241
-rw-r--r--src/Patat/Presentation/Display/Table.hs64
-rw-r--r--src/Patat/Presentation/Internal.hs48
-rw-r--r--src/Patat/Presentation/Read.hs81
-rw-r--r--src/Patat/PrettyPrint.hs168
-rw-r--r--src/Patat/Theme.hs192
-rw-r--r--src/Text/Pandoc/Extended.hs35
13 files changed, 669 insertions, 227 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 9b45b5e..f4a2b14 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,4 +1,10 @@
# Changelog
+- 0.2.0.0 (2016-10-13)
+ * Add theming support.
+ * Fix links display.
+ * Add support for wrapping.
+ * Allow org mode as input format.
+
- 0.1.0.0 (2016-10-02)
* Upload first version from hotel wifi in Kalaw.
diff --git a/patat.cabal b/patat.cabal
index 792060d..d5f450e 100644
--- a/patat.cabal
+++ b/patat.cabal
@@ -1,5 +1,5 @@
Name: patat
-Version: 0.1.0.0
+Version: 0.2.0.0
Synopsis: Terminal-based presentations using Pandoc
Description: Terminal-based presentations using Pandoc
License: GPL-2
@@ -24,9 +24,11 @@ Executable patat
Default-language: Haskell2010
Build-depends:
+ aeson >= 0.11 && < 1.1,
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.3,
filepath >= 1.4 && < 1.5,
@@ -34,9 +36,13 @@ Executable patat
optparse-applicative >= 0.12 && < 0.14,
pandoc >= 1.17 && < 1.18,
terminal-size >= 0.3 && < 0.4,
- time >= 1.4 && < 1.7
+ text >= 1.2 && < 1.3,
+ time >= 1.4 && < 1.7,
+ yaml >= 0.7 && < 0.9
Other-modules:
+ Data.Aeson.Extended
+ Data.Aeson.TH.Extended
Data.Data.Extended
Patat.Presentation
Patat.Presentation.Display
@@ -45,4 +51,5 @@ Executable patat
Patat.Presentation.Internal
Patat.Presentation.Read
Patat.PrettyPrint
+ Patat.Theme
Text.Pandoc.Extended
diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs
new file mode 100644
index 0000000..9b95cec
--- /dev/null
+++ b/src/Data/Aeson/Extended.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Data.Aeson.Extended
+ ( module Data.Aeson
+
+ , FlexibleNum (..)
+ ) where
+
+import Control.Applicative ((<$>))
+import Data.Aeson
+import qualified Data.Text as T
+import Text.Read (readMaybe)
+import Prelude
+
+-- | This can be parsed from a JSON string in addition to a JSON number.
+newtype FlexibleNum a = FlexibleNum {unFlexibleNum :: a}
+ deriving (Show, ToJSON)
+
+instance (FromJSON a, Read a) => FromJSON (FlexibleNum a) where
+ parseJSON (String str) = case readMaybe (T.unpack str) of
+ Nothing -> fail $ "Could not parse " ++ T.unpack str ++ " as a number"
+ Just x -> return (FlexibleNum x)
+ parseJSON val = FlexibleNum <$> parseJSON val
diff --git a/src/Data/Aeson/TH/Extended.hs b/src/Data/Aeson/TH/Extended.hs
new file mode 100644
index 0000000..0fa5487
--- /dev/null
+++ b/src/Data/Aeson/TH/Extended.hs
@@ -0,0 +1,21 @@
+--------------------------------------------------------------------------------
+module Data.Aeson.TH.Extended
+ ( module Data.Aeson.TH
+ , dropPrefixOptions
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.Aeson.TH
+import Data.Char (isUpper, toLower)
+
+
+--------------------------------------------------------------------------------
+dropPrefixOptions :: Options
+dropPrefixOptions = defaultOptions
+ { fieldLabelModifier = dropPrefix
+ }
+ where
+ dropPrefix str = case break isUpper str of
+ (_, (y : ys)) -> toLower y : ys
+ _ -> str
diff --git a/src/Main.hs b/src/Main.hs
index 2278478..4394835 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -96,7 +96,7 @@ assertAnsiFeatures = do
--------------------------------------------------------------------------------
main :: IO ()
main = do
- options <- OA.execParser parserInfo
+ options <- OA.customExecParser (OA.prefs OA.showHelpOnError) parserInfo
errOrPres <- readPresentation (oFilePath options)
pres <- either (errorAndExit . return) return errOrPres
diff --git a/src/Patat/Presentation.hs b/src/Patat/Presentation.hs
index 9addefb..bf6c2b3 100644
--- a/src/Patat/Presentation.hs
+++ b/src/Patat/Presentation.hs
@@ -1,5 +1,8 @@
module Patat.Presentation
- ( Presentation (..)
+ ( PresentationSettings (..)
+ , defaultPresentationSettings
+
+ , Presentation (..)
, readPresentation
, displayPresentation
, dumpPresentation
diff --git a/src/Patat/Presentation/Display.hs b/src/Patat/Presentation/Display.hs
index 50b9e05..cdbd49e 100644
--- a/src/Patat/Presentation/Display.hs
+++ b/src/Patat/Presentation/Display.hs
@@ -9,13 +9,20 @@ module Patat.Presentation.Display
--------------------------------------------------------------------------------
+import Control.Applicative ((<$>))
+import Control.Monad (mplus)
+import qualified Data.Aeson.Extended as A
import Data.Data.Extended (grecQ)
import Data.List (intersperse)
+import Data.Maybe (fromMaybe)
import Data.Monoid (mconcat, mempty, (<>))
+import qualified Data.Text as T
import Patat.Presentation.Display.Table
import Patat.Presentation.Internal
import Patat.PrettyPrint ((<$$>), (<+>))
import qualified Patat.PrettyPrint as PP
+import Patat.Theme (Theme (..))
+import qualified Patat.Theme as Theme
import qualified System.Console.ANSI as Ansi
import qualified System.Console.Terminal.Size as Terminal
import qualified Text.Pandoc.Extended as Pandoc
@@ -30,14 +37,22 @@ displayPresentation Presentation {..} = do
-- Get terminal width/title
mbWindow <- Terminal.size
- let termWidth = maybe 72 Terminal.width mbWindow
- termHeight = maybe 24 Terminal.height mbWindow
- title = PP.toString (prettyInlines pTitle)
+ let columns = fromMaybe 72 $
+ (A.unFlexibleNum <$> psColumns pSettings) `mplus`
+ (Terminal.width <$> mbWindow)
+ rows = fromMaybe 24 $
+ (A.unFlexibleNum <$> psRows pSettings) `mplus`
+ (Terminal.height <$> mbWindow)
+
+ let settings = pSettings {psColumns = Just $ A.FlexibleNum columns}
+ theme = fromMaybe Theme.defaultTheme (psTheme settings)
+ title = PP.toString (prettyInlines theme pTitle)
titleWidth = length title
- titleOffset = (termWidth - titleWidth) `div` 2
+ titleOffset = (columns - titleWidth) `div` 2
+ borders = themed (themeBorders theme)
Ansi.setCursorColumn titleOffset
- PP.putDoc $ PP.dullyellow $ PP.string title
+ PP.putDoc $ borders $ PP.string title
putStrLn ""
putStrLn ""
@@ -45,50 +60,61 @@ displayPresentation Presentation {..} = do
[] -> mempty
(s : _) -> s
- PP.putDoc $ prettySlide slide
+ PP.putDoc $ withWrapSettings settings $ prettySlide theme slide
putStrLn ""
let active = show (pActiveSlide + 1) ++ " / " ++ show (length pSlides)
activeWidth = length active
- Ansi.setCursorPosition (termHeight - 2) 0
- PP.putDoc $ " " <> PP.dullyellow (prettyInlines pAuthor)
- Ansi.setCursorColumn (termWidth - activeWidth - 1)
- PP.putDoc $ PP.dullyellow $ PP.string active
+ Ansi.setCursorPosition (rows - 2) 0
+ PP.putDoc $ " " <> borders (prettyInlines theme pAuthor)
+ Ansi.setCursorColumn (columns - activeWidth - 1)
+ PP.putDoc $ borders $ PP.string active
putStrLn ""
--------------------------------------------------------------------------------
dumpPresentation :: Presentation -> IO ()
-dumpPresentation =
- PP.putDoc . PP.vcat . intersperse "----------" . map prettySlide . pSlides
+dumpPresentation pres =
+ let theme = fromMaybe Theme.defaultTheme (psTheme $ pSettings pres) in
+ PP.putDoc $ withWrapSettings (pSettings pres) $
+ PP.vcat $ intersperse "----------" $
+ map (prettySlide theme) $ pSlides pres
--------------------------------------------------------------------------------
-prettySlide :: Slide -> PP.Doc
-prettySlide slide@(Slide blocks) =
- prettyBlocks blocks <>
- case prettyReferences slide of
+withWrapSettings :: PresentationSettings -> PP.Doc -> PP.Doc
+withWrapSettings ps = case (psWrap ps, psColumns ps) of
+ (Just True, Just (A.FlexibleNum col)) -> PP.wrapAt (Just col)
+ _ -> id
+
+
+--------------------------------------------------------------------------------
+prettySlide :: Theme -> Slide -> PP.Doc
+prettySlide theme slide@(Slide blocks) =
+ prettyBlocks theme blocks <>
+ case prettyReferences theme slide of
[] -> mempty
- refs -> PP.newline <> PP.vcat refs
+ refs -> PP.hardline <> PP.vcat refs
--------------------------------------------------------------------------------
-prettyBlock :: Pandoc.Block -> PP.Doc
+prettyBlock :: Theme -> Pandoc.Block -> PP.Doc
-prettyBlock (Pandoc.Plain inlines) = prettyInlines inlines
+prettyBlock theme (Pandoc.Plain inlines) = prettyInlines theme inlines
-prettyBlock (Pandoc.Para inlines) = prettyInlines inlines <> PP.newline
+prettyBlock theme (Pandoc.Para inlines) =
+ prettyInlines theme inlines <> PP.hardline
-prettyBlock (Pandoc.Header i _ inlines) =
- PP.dullblue (PP.string (replicate i '#') <+> prettyInlines inlines) <>
- PP.newline
+prettyBlock theme@Theme {..} (Pandoc.Header i _ inlines) =
+ themed themeHeader (PP.string (replicate i '#') <+> prettyInlines theme inlines) <>
+ PP.hardline
-prettyBlock (Pandoc.CodeBlock _ txt) = PP.vcat
+prettyBlock Theme {..} (Pandoc.CodeBlock _ txt) = PP.vcat
[ let ind = PP.NotTrimmable " " in
- PP.indent ind ind $ PP.ondullblack $ PP.dullwhite $ PP.string line
+ PP.indent ind ind $ themed themeCodeBlock $ PP.string line
| line <- blockified txt
- ] <> PP.newline
+ ] <> PP.hardline
where
blockified str =
let ls = lines str
@@ -96,21 +122,32 @@ prettyBlock (Pandoc.CodeBlock _ txt) = PP.vcat
extend l = " " ++ l ++ replicate (longest - length l) ' ' ++ " " in
map extend $ [""] ++ ls ++ [""]
-prettyBlock (Pandoc.BulletList bss) = PP.vcat
+prettyBlock theme (Pandoc.BulletList bss) = PP.vcat
[ PP.indent
- (PP.NotTrimmable $ PP.dullmagenta " - ")
+ (PP.NotTrimmable $ themed (themeBulletList theme) prefix)
(PP.Trimmable " ")
- (prettyBlocks bs)
+ (prettyBlocks theme' bs)
| bs <- bss
- ] <> PP.newline
-
-prettyBlock (Pandoc.OrderedList _ bss) = PP.vcat
+ ] <> PP.hardline
+ where
+ prefix = " " <> PP.string [marker] <> " "
+ marker = case T.unpack <$> themeBulletListMarkers theme of
+ Just (x : _) -> x
+ _ -> '-'
+
+ -- Cycle the markers.
+ theme' = theme
+ { themeBulletListMarkers =
+ (\ls -> T.drop 1 ls <> T.take 1 ls) <$> themeBulletListMarkers theme
+ }
+
+prettyBlock theme@Theme {..} (Pandoc.OrderedList _ bss) = PP.vcat
[ PP.indent
- (PP.NotTrimmable $ PP.dullmagenta $ PP.string prefix)
+ (PP.NotTrimmable $ themed themeOrderedList $ PP.string prefix)
(PP.Trimmable " ")
- (prettyBlocks bs)
+ (prettyBlocks theme bs)
| (prefix, bs) <- zip padded bss
- ] <> PP.newline
+ ] <> PP.hardline
where
padded = [n ++ replicate (4 - length n) ' ' | n <- numbers]
numbers =
@@ -118,107 +155,114 @@ prettyBlock (Pandoc.OrderedList _ bss) = PP.vcat
| i <- [1 .. length bss]
]
-prettyBlock (Pandoc.RawBlock _ t) = PP.string t <> PP.newline
+prettyBlock _theme (Pandoc.RawBlock _ t) = PP.string t <> PP.hardline
-prettyBlock Pandoc.HorizontalRule = "---"
+prettyBlock _theme Pandoc.HorizontalRule = "---"
-prettyBlock (Pandoc.BlockQuote bs) =
- let quote = PP.NotTrimmable (PP.dullgreen "> ") in
- PP.indent quote quote (prettyBlocks bs)
+prettyBlock theme@Theme {..} (Pandoc.BlockQuote bs) =
+ let quote = PP.NotTrimmable (themed themeBlockQuote "> ") in
+ PP.indent quote quote (prettyBlocks theme bs)
-prettyBlock (Pandoc.Table caption aligns _ headers rows) = prettyTable Table
- { tCaption = prettyInlines caption
- , tAligns = map align aligns
- , tHeaders = map prettyBlocks headers
- , tRows = map (map prettyBlocks) rows
- }
- where
- align Pandoc.AlignLeft = PP.AlignLeft
- align Pandoc.AlignCenter = PP.AlignCenter
- align Pandoc.AlignDefault = PP.AlignLeft
- align Pandoc.AlignRight = PP.AlignRight
-
-prettyBlock (Pandoc.Div _attrs blocks) = prettyBlocks blocks
-
-prettyBlock (Pandoc.DefinitionList terms) =
+prettyBlock theme@Theme {..} (Pandoc.DefinitionList terms) =
PP.vcat $ map prettyDefinition terms
where
prettyDefinition (term, definitions) =
- PP.dullblue (prettyInlines term) <$$> PP.newline <> PP.vcat
+ themed themeDefinitionTerm (prettyInlines theme term) <$$>
+ PP.hardline <> PP.vcat
[ PP.indent
- (PP.NotTrimmable (PP.dullmagenta ": "))
+ (PP.NotTrimmable (themed themeDefinitionList ": "))
(PP.Trimmable " ") $
- prettyBlocks (Pandoc.plainToPara definition)
+ prettyBlocks theme (Pandoc.plainToPara definition)
| definition <- definitions
]
-prettyBlock Pandoc.Null = mempty
+prettyBlock theme (Pandoc.Table caption aligns _ headers rows) =
+ PP.wrapAt Nothing $
+ prettyTable theme Table
+ { tCaption = prettyInlines theme caption
+ , tAligns = map align aligns
+ , tHeaders = map (prettyBlocks theme) headers
+ , tRows = map (map (prettyBlocks theme)) rows
+ }
+ where
+ align Pandoc.AlignLeft = PP.AlignLeft
+ align Pandoc.AlignCenter = PP.AlignCenter
+ align Pandoc.AlignDefault = PP.AlignLeft
+ align Pandoc.AlignRight = PP.AlignRight
+
+prettyBlock theme (Pandoc.Div _attrs blocks) = prettyBlocks theme blocks
+
+prettyBlock _theme Pandoc.Null = mempty
--------------------------------------------------------------------------------
-prettyBlocks :: [Pandoc.Block] -> PP.Doc
-prettyBlocks = PP.vcat . map prettyBlock
+prettyBlocks :: Theme -> [Pandoc.Block] -> PP.Doc
+prettyBlocks theme = PP.vcat . map (prettyBlock theme)
--------------------------------------------------------------------------------
-prettyInline :: Pandoc.Inline -> PP.Doc
+prettyInline :: Theme -> Pandoc.Inline -> PP.Doc
-prettyInline Pandoc.Space = PP.space
+prettyInline _theme Pandoc.Space = PP.space
-prettyInline (Pandoc.Str str) = PP.string str
+prettyInline _theme (Pandoc.Str str) = PP.string str
-prettyInline (Pandoc.Emph inlines) =
- PP.dullgreen $ prettyInlines inlines
+prettyInline theme@Theme {..} (Pandoc.Emph inlines) =
+ themed themeEmph $
+ prettyInlines theme inlines
-prettyInline (Pandoc.Strong inlines) =
- PP.dullred $ PP.bold $ prettyInlines inlines
+prettyInline theme@Theme {..} (Pandoc.Strong inlines) =
+ themed themeStrong $
+ prettyInlines theme inlines
-prettyInline (Pandoc.Code _ txt) =
- PP.ondullblack $ PP.dullwhite $ " " <> PP.string txt <> " "
+prettyInline Theme {..} (Pandoc.Code _ txt) =
+ themed themeCode $
+ " " <> PP.string txt <> " "
-prettyInline link@(Pandoc.Link _attrs text (target, _title))
+prettyInline theme@Theme {..} link@(Pandoc.Link _attrs text (target, _title))
| isReferenceLink link =
- "[" <> PP.dullcyan (prettyInlines text) <> "]"
+ "[" <> themed themeLinkText (prettyInlines theme text) <> "]"
| otherwise =
- "<" <> PP.dullcyan (PP.underline $ PP.string target) <> ">"
+ "<" <> themed themeLinkTarget (PP.string target) <> ">"
-prettyInline Pandoc.SoftBreak = PP.newline
+prettyInline _theme Pandoc.SoftBreak = PP.softline
-prettyInline Pandoc.LineBreak = PP.newline
+prettyInline _theme Pandoc.LineBreak = PP.hardline
-prettyInline (Pandoc.Strikeout t) =
- "~~" <> PP.ondullred (prettyInlines t) <> "~~"
+prettyInline theme@Theme {..} (Pandoc.Strikeout t) =
+ "~~" <> themed themeStrikeout (prettyInlines theme t) <> "~~"
-prettyInline (Pandoc.Quoted Pandoc.SingleQuote t) =
- "'" <> PP.dullgreen (prettyInlines t) <> "'"
-prettyInline (Pandoc.Quoted Pandoc.DoubleQuote t) =
- "'" <> PP.dullgreen (prettyInlines t) <> "'"
+prettyInline theme@Theme {..} (Pandoc.Quoted Pandoc.SingleQuote t) =
+ "'" <> themed themeQuoted (prettyInlines theme t) <> "'"
+prettyInline theme@Theme {..} (Pandoc.Quoted Pandoc.DoubleQuote t) =
+ "'" <> themed themeQuoted (prettyInlines theme t) <> "'"
-prettyInline (Pandoc.Math _ t) = PP.dullgreen (PP.string t)
+prettyInline Theme {..} (Pandoc.Math _ t) =
+ themed themeMath (PP.string t)
-prettyInline (Pandoc.Image _ _ (tit, src)) =
- "![" <> PP.dullgreen (PP.string tit) <> "](" <>
- PP.dullcyan (PP.underline (PP.string src)) <> ")"
+prettyInline theme@Theme {..} (Pandoc.Image _attrs text (target, _title)) =
+ "![" <> themed themeImageText (prettyInlines theme text) <> "](" <>
+ themed themeImageTarget (PP.string target) <> ")"
-- These elements aren't really supported.
-prettyInline (Pandoc.Cite _ t) = prettyInlines t
-prettyInline (Pandoc.Span _ t) = prettyInlines t
-prettyInline (Pandoc.RawInline _ t) = PP.string t
-prettyInline (Pandoc.Note t) = prettyBlocks t
-prettyInline (Pandoc.Superscript t) = prettyInlines t
-prettyInline (Pandoc.Subscript t) = prettyInlines t
-prettyInline (Pandoc.SmallCaps t) = prettyInlines t
+prettyInline theme (Pandoc.Cite _ t) = prettyInlines theme t
+prettyInline theme (Pandoc.Span _ t) = prettyInlines theme t
+prettyInline _theme (Pandoc.RawInline _ t) = PP.string t
+prettyInline theme (Pandoc.Note t) = prettyBlocks theme t
+prettyInline theme (Pandoc.Superscript t) = prettyInlines theme t
+prettyInline theme (Pandoc.Subscript t) = prettyInlines theme t
+prettyInline theme (Pandoc.SmallCaps t) = prettyInlines theme t
-- prettyInline unsupported = PP.ondullred $ PP.string $ show unsupported
--------------------------------------------------------------------------------
-prettyInlines :: [Pandoc.Inline] -> PP.Doc
-prettyInlines = mconcat . map prettyInline
+prettyInlines :: Theme -> [Pandoc.Inline] -> PP.Doc
+prettyInlines theme = mconcat . map (prettyInline theme)
--------------------------------------------------------------------------------
-prettyReferences :: Slide -> [PP.Doc]
-prettyReferences =
+prettyReferences :: Theme -> Slide -> [PP.Doc]
+prettyReferences theme@Theme {..} =
map prettyReference . getReferences . unSlide
where
getReferences :: [Pandoc.Block] -> [Pandoc.Inline]
@@ -226,9 +270,10 @@ prettyReferences =
prettyReference :: Pandoc.Inline -> PP.Doc
prettyReference (Pandoc.Link _attrs text (target, title)) =
- "[" <> PP.dullgreen (prettyInlines $ Pandoc.newlineToSpace text) <>
+ "[" <>
+ themed themeLinkText (prettyInlines theme $ Pandoc.newlineToSpace text) <>
"](" <>
- PP.dullcyan (PP.underline (PP.string target)) <>
+ themed themeLinkTarget (PP.string target) <>
(if null title
then mempty
else PP.space <> "\"" <> PP.string title <> "\"")
diff --git a/src/Patat/Presentation/Display/Table.hs b/src/Patat/Presentation/Display/Table.hs
index 181c55a..fee68c9 100644
--- a/src/Patat/Presentation/Display/Table.hs
+++ b/src/Patat/Presentation/Display/Table.hs
@@ -4,6 +4,8 @@
module Patat.Presentation.Display.Table
( Table (..)
, prettyTable
+
+ , themed
) where
@@ -12,6 +14,8 @@ import Data.List (intersperse, transpose)
import Data.Monoid (mconcat, mempty, (<>))
import Patat.PrettyPrint ((<$$>))
import qualified Patat.PrettyPrint as PP
+import Patat.Theme (Theme (..))
+import qualified Patat.Theme as Theme
import Prelude
@@ -26,25 +30,26 @@ data Table = Table
--------------------------------------------------------------------------------
prettyTable
- :: Table -> PP.Doc
-prettyTable Table {..} = PP.indent (PP.Trimmable " ") (PP.Trimmable " ") $
- lineIf (not isHeaderLess) (hcat2 headerHeight
- [ PP.dullblue (PP.align w a (vpad headerHeight header))
- | (w, a, header) <- zip3 columnWidths tAligns tHeaders
- ]) <>
- dashedHeaderSeparator columnWidths <$$>
- joinRows
- [ hcat2 rowHeight
- [ PP.align w a (vpad rowHeight cell)
- | (w, a, cell) <- zip3 columnWidths tAligns row
- ]
- | (rowHeight, row) <- zip rowHeights tRows
- ] <$$>
- lineIf isHeaderLess (dashedHeaderSeparator columnWidths) <>
- lineIf
- (not $ PP.null tCaption) (PP.newline <> "Table: " <> tCaption)
+ :: Theme -> Table -> PP.Doc
+prettyTable theme@Theme {..} Table {..} =
+ PP.indent (PP.Trimmable " ") (PP.Trimmable " ") $
+ lineIf (not isHeaderLess) (hcat2 headerHeight
+ [ themed themeTableHeader (PP.align w a (vpad headerHeight header))
+ | (w, a, header) <- zip3 columnWidths tAligns tHeaders
+ ]) <>
+ dashedHeaderSeparator theme columnWidths <$$>
+ joinRows
+ [ hcat2 rowHeight
+ [ PP.align w a (vpad rowHeight cell)
+ | (w, a, cell) <- zip3 columnWidths tAligns row
+ ]
+ | (rowHeight, row) <- zip rowHeights tRows
+ ] <$$>
+ lineIf isHeaderLess (dashedHeaderSeparator theme columnWidths) <>
+ lineIf
+ (not $ PP.null tCaption) (PP.hardline <> "Table: " <> tCaption)
where
- lineIf cond line = if cond then line <> PP.newline else mempty
+ lineIf cond line = if cond then line <> PP.hardline else mempty
joinRows
| all (all isSimpleCell) tRows = PP.vcat
@@ -67,7 +72,7 @@ prettyTable Table {..} = PP.indent (PP.Trimmable " ") (PP.Trimmable " ") $
vpad :: Int -> PP.Doc -> PP.Doc
vpad height doc =
let (actual, _) = PP.dimensions doc in
- doc <> mconcat (replicate (height - actual) PP.newline)
+ doc <> mconcat (replicate (height - actual) PP.hardline)
safeMax = foldr max 0
@@ -76,7 +81,7 @@ prettyTable Table {..} = PP.indent (PP.Trimmable " ") (PP.Trimmable " ") $
spaces2 :: Int -> PP.Doc
spaces2 rowHeight =
- mconcat $ intersperse PP.newline $
+ mconcat $ intersperse PP.hardline $
replicate rowHeight (PP.string " ")
@@ -86,8 +91,17 @@ isSimpleCell = (<= 1) . fst . PP.dimensions
--------------------------------------------------------------------------------
-dashedHeaderSeparator :: [Int] -> PP.Doc
-dashedHeaderSeparator columnWidths = mconcat $ intersperse (PP.string " ")
- [ PP.dullmagenta (PP.string (replicate w '-'))
- | w <- columnWidths
- ]
+dashedHeaderSeparator :: Theme -> [Int] -> PP.Doc
+dashedHeaderSeparator Theme {..} columnWidths =
+ mconcat $ intersperse (PP.string " ")
+ [ themed themeTableSeparator (PP.string (replicate w '-'))
+ | w <- columnWidths
+ ]
+
+
+--------------------------------------------------------------------------------
+-- | This does not really belong in the module.
+themed :: Maybe Theme.Style -> PP.Doc -> PP.Doc
+themed Nothing = id
+themed (Just (Theme.Style [])) = id
+themed (Just (Theme.Style codes)) = PP.ansi codes
diff --git a/src/Patat/Presentation/Internal.hs b/src/Patat/Presentation/Internal.hs
index 1780db3..f11c46b 100644
--- a/src/Patat/Presentation/Internal.hs
+++ b/src/Patat/Presentation/Internal.hs
@@ -1,14 +1,21 @@
--------------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
module Patat.Presentation.Internal
( Presentation (..)
+ , PresentationSettings (..)
+ , defaultPresentationSettings
, Slide (..)
) where
--------------------------------------------------------------------------------
-import Data.Monoid (Monoid)
-import qualified Text.Pandoc as Pandoc
+import Control.Monad (mplus)
+import qualified Data.Aeson.Extended as A
+import qualified Data.Aeson.TH.Extended as A
+import Data.Monoid (Monoid (..))
+import qualified Patat.Theme as Theme
+import qualified Text.Pandoc as Pandoc
import Prelude
@@ -17,11 +24,48 @@ data Presentation = Presentation
{ pFilePath :: !FilePath
, pTitle :: ![Pandoc.Inline]
, pAuthor :: ![Pandoc.Inline]
+ , pSettings :: !PresentationSettings
, pSlides :: [Slide]
, pActiveSlide :: !Int
} deriving (Show)
--------------------------------------------------------------------------------
+-- | These are patat-specific settings. That is where they differ from more
+-- general metadata (author, title...)
+data PresentationSettings = PresentationSettings
+ { psRows :: !(Maybe (A.FlexibleNum Int))
+ , psColumns :: !(Maybe (A.FlexibleNum Int))
+ , psWrap :: !(Maybe Bool)
+ , psTheme :: !(Maybe Theme.Theme)
+ } deriving (Show)
+
+
+--------------------------------------------------------------------------------
+instance Monoid PresentationSettings where
+ mempty = PresentationSettings Nothing Nothing Nothing Nothing
+ mappend l r = PresentationSettings
+ { psRows = psRows l `mplus` psRows r
+ , psColumns = psColumns l `mplus` psColumns r
+ , psWrap = psWrap l `mplus` psWrap r
+ , psTheme = psTheme l `mappend` psTheme r
+ }
+
+
+--------------------------------------------------------------------------------
+defaultPresentationSettings :: PresentationSettings
+defaultPresentationSettings = PresentationSettings
+ { psRows = Nothing
+ , psColumns = Nothing
+ , psWrap = Nothing
+ , psTheme = Just Theme.defaultTheme
+ }
+
+
+--------------------------------------------------------------------------------
newtype Slide = Slide {unSlide :: [Pandoc.Block]}
deriving (Monoid, Show)
+
+
+--------------------------------------------------------------------------------
+$(A.deriveJSON A.dropPrefixOptions ''PresentationSettings)
diff --git a/src/Patat/Presentation/Read.hs b/src/Patat/Presentation/Read.hs
index b74b417..c962632 100644
--- a/src/Patat/Presentation/Read.hs
+++ b/src/Patat/Presentation/Read.hs
@@ -1,4 +1,5 @@
-- | Read a presentation from disk.
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
module Patat.Presentation.Read
( readPresentation
@@ -6,27 +7,38 @@ module Patat.Presentation.Read
--------------------------------------------------------------------------------
+import Control.Monad.Except (ExceptT (..), runExceptT,
+ throwError)
+import Control.Monad.Trans (liftIO)
+import qualified Data.Aeson as A
+import qualified Data.ByteString as B
+import Data.Monoid (mempty, (<>))
import qualified Data.Set as Set
+import qualified Data.Yaml as Yaml
import Patat.Presentation.Internal
-import System.FilePath (takeExtension)
-import qualified Text.Pandoc as Pandoc
+import System.Directory (doesFileExist, getHomeDirectory)
+import System.FilePath (takeExtension, (</>))
import qualified Text.Pandoc.Error as Pandoc
+import qualified Text.Pandoc.Extended as Pandoc
+import Prelude
--------------------------------------------------------------------------------
readPresentation :: FilePath -> IO (Either String Presentation)
-readPresentation filePath = do
- src <- readFile filePath
- return $ do
- reader <- case readExtension ext of
- Nothing -> Left $ "Unknown extension: " ++ ext
- Just r -> Right r
-
- doc <- case reader src of
- Left err -> Left $ "Pandoc parsing error: " ++ show err
- Right x -> Right x
-
- pandocToPresentation filePath doc
+readPresentation filePath = runExceptT $ do
+ src <- liftIO $ readFile filePath
+ reader <- case readExtension ext of
+ Nothing -> throwError $ "Unknown file extension: " ++ show ext
+ Just x -> return x
+ doc@(Pandoc.Pandoc meta _) <- case reader src of
+ Left e -> throwError $ "Could not parse document: " ++ show e
+ Right x -> return x
+
+ homeSettings <- ExceptT readHomeSettings
+ metaSettings <- ExceptT $ return $ readMetaSettings meta
+ let settings = metaSettings <> homeSettings <> defaultPresentationSettings
+
+ ExceptT $ return $ pandocToPresentation filePath settings doc
where
ext = takeExtension filePath
@@ -38,6 +50,7 @@ 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
_ -> Nothing
where
@@ -49,16 +62,44 @@ readExtension fileExt = case fileExt of
--------------------------------------------------------------------------------
pandocToPresentation
- :: FilePath -> Pandoc.Pandoc -> Either String Presentation
-pandocToPresentation pFilePath pandoc@(Pandoc.Pandoc meta _) = do
- let pTitle = Pandoc.docTitle meta
- pSlides = pandocToSlides pandoc
- pActiveSlide = 0
- pAuthor = concat (Pandoc.docAuthors meta)
+ :: FilePath -> PresentationSettings -> Pandoc.Pandoc
+ -> Either String Presentation
+pandocToPresentation pFilePath pSettings pandoc@(Pandoc.Pandoc meta _) = do
+ let !pTitle = Pandoc.docTitle meta
+ !pSlides = pandocToSlides pandoc
+ !pActiveSlide = 0
+ !pAuthor = concat (Pandoc.docAuthors meta)
return Presentation {..}
--------------------------------------------------------------------------------
+-- | Read settings from the metadata block in the Pandoc document.
+readMetaSettings :: Pandoc.Meta -> Either String PresentationSettings
+readMetaSettings meta = case Pandoc.lookupMeta "patat" meta of
+ Nothing -> return mempty
+ Just val -> resultToEither $! A.fromJSON $! Pandoc.metaToJson val
+ where
+ resultToEither :: A.Result a -> Either String a
+ resultToEither (A.Success x) = Right x
+ resultToEither (A.Error e) = Left $!
+ "Error parsing patat settings from metadata: " ++ e
+
+
+--------------------------------------------------------------------------------
+-- | Read settings from "$HOME/.patat.yaml".
+readHomeSettings :: IO (Either String PresentationSettings)
+readHomeSettings = do
+ home <- getHomeDirectory
+ let path = home </> ".patat.yaml"
+ exists <- doesFileExist path
+ if not exists
+ then return (Right mempty)
+ else do
+ contents <- B.readFile path
+ return $! Yaml.decodeEither contents
+
+
+--------------------------------------------------------------------------------
-- | Split a pandoc document into slides. If the document contains horizonal
-- rules, we use those as slide delimiters. If there are no horizontal rules,
-- we split using h1 headers.
diff --git a/src/Patat/PrettyPrint.hs b/src/Patat/PrettyPrint.hs
index 59f2c6d..7b24b37 100644
--- a/src/Patat/PrettyPrint.hs
+++ b/src/Patat/PrettyPrint.hs
@@ -15,31 +15,22 @@ module Patat.PrettyPrint
, putDoc
, string
+ , text
, space
- , newline
+ , softline
+ , hardline
+
+ , wrapAt
, Trimmable (..)
, indent
+ , ansi
+
, (<+>)
, (<$$>)
, vcat
- , bold
- , underline
-
- , dullblack
- , dullred
- , dullgreen
- , dullyellow
- , dullblue
- , dullmagenta
- , dullcyan
- , dullwhite
-
- , ondullblack
- , ondullred
-
-- * Exotic combinators
, Alignment (..)
, align
@@ -50,12 +41,13 @@ module Patat.PrettyPrint
--------------------------------------------------------------------------------
import Control.Monad.Reader (asks, local)
import Control.Monad.RWS (RWS, runRWS)
-import Control.Monad.State (get, modify)
+import Control.Monad.State (get, gets, modify)
import Control.Monad.Writer (tell)
import Data.Foldable (Foldable)
import qualified Data.List as L
import Data.Monoid (Monoid, mconcat, mempty, (<>))
import Data.String (IsString (..))
+import qualified Data.Text as T
import Data.Traversable (Traversable, traverse)
import qualified System.Console.ANSI as Ansi
import qualified System.IO as IO
@@ -111,8 +103,14 @@ chunkLines chunks = case break (== NewlineChunk) chunks of
--------------------------------------------------------------------------------
data DocE
= String String
- | Space
- | Newline
+ | Softspace
+ | Hardspace
+ | Softline
+ | Hardline
+ | WrapAt
+ { wrapAtCol :: Maybe Int
+ , wrapDoc :: Doc
+ }
| Ansi
{ ansiCode :: [Ansi.SGR] -> [Ansi.SGR] -- ^ Modifies current codes.
, ansiDoc :: Doc
@@ -126,7 +124,7 @@ data DocE
--------------------------------------------------------------------------------
chunkToDocE :: Chunk -> DocE
-chunkToDocE NewlineChunk = Newline
+chunkToDocE NewlineChunk = Hardline
chunkToDocE (StringChunk codes str) = Ansi (\_ -> codes) (Doc [String str])
@@ -149,6 +147,7 @@ instance Show Doc where
data DocEnv = DocEnv
{ deCodes :: [Ansi.SGR] -- ^ Most recent ones first in the list
, deIndent :: LineBuffer -- ^ Don't need to store first-line indent
+ , deWrap :: Maybe Int -- ^ Wrap at columns
}
@@ -182,7 +181,7 @@ bufferToChunks = map trimmableToChunk . reverse . dropWhile isTrimmable
--------------------------------------------------------------------------------
docToChunks :: Doc -> Chunks
docToChunks doc0 =
- let env0 = DocEnv [] []
+ let env0 = DocEnv [] [] Nothing
((), b, cs) = runRWS (go $ unDoc doc0) env0 mempty in
optimizeChunks (cs <> bufferToChunks b)
where
@@ -195,18 +194,30 @@ docToChunks doc0 =
modify (NotTrimmable chunk :)
go docs
- go (Space : docs) = do
+ go (Softspace : docs) = do
+ hard <- softConversion Softspace docs
+ go (hard : docs)
+
+ go (Hardspace : docs) = do
chunk <- makeChunk " "
modify (NotTrimmable chunk :)
go docs
- go (Newline : docs) = do
+ go (Softline : docs) = do
+ hard <- softConversion Softline docs
+ go (hard : docs)
+
+ go (Hardline : docs) = do
buffer <- get
tell $ bufferToChunks buffer <> [NewlineChunk]
indentation <- asks deIndent
modify $ \_ -> if L.null docs then [] else indentation
go docs
+ go (WrapAt {..} : docs) = do
+ local (\env -> env {deWrap = wrapAtCol}) $ go (unDoc wrapDoc)
+ go docs
+
go (Ansi {..} : docs) = do
local (\env -> env {deCodes = ansiCode (deCodes env)}) $
go (unDoc ansiDoc)
@@ -223,6 +234,40 @@ docToChunks doc0 =
codes <- asks deCodes
return $ StringChunk codes str
+ -- Convert 'Softspace' or 'Softline' to 'Hardspace' or 'Hardline'
+ softConversion :: DocE -> [DocE] -> DocM DocE
+ softConversion soft docs = do
+ mbWrapCol <- asks deWrap
+ case mbWrapCol of
+ Nothing -> return hard
+ Just maxCol -> do
+ -- Slow.
+ currentLine <- gets (concatMap chunkToString . bufferToChunks)
+ let currentCol = length currentLine
+ case nextWordLength docs of
+ Nothing -> return hard
+ Just l
+ | currentCol + 1 + l <= maxCol -> return Hardspace
+ | otherwise -> return Hardline
+ where
+ hard = case soft of
+ Softspace -> Hardspace
+ Softline -> Hardline
+ _ -> soft
+
+ nextWordLength :: [DocE] -> Maybe Int
+ nextWordLength [] = Nothing
+ nextWordLength (String x : xs)
+ | L.null x = nextWordLength xs
+ | otherwise = Just (length x)
+ nextWordLength (Softspace : xs) = nextWordLength xs
+ nextWordLength (Hardspace : xs) = nextWordLength xs
+ nextWordLength (Softline : xs) = nextWordLength xs
+ nextWordLength (Hardline : _) = Nothing
+ nextWordLength (WrapAt {..} : xs) = nextWordLength (unDoc wrapDoc ++ xs)
+ nextWordLength (Ansi {..} : xs) = nextWordLength (unDoc ansiDoc ++ xs)
+ nextWordLength (Indent {..} : xs) = nextWordLength (unDoc indentDoc ++ xs)
+
--------------------------------------------------------------------------------
toString :: Doc -> String
@@ -263,13 +308,28 @@ string = mkDoc . String -- TODO (jaspervdj): Newline conversion
--------------------------------------------------------------------------------
+text :: T.Text -> Doc
+text = string . T.unpack
+
+
+--------------------------------------------------------------------------------
space :: Doc
-space = mkDoc Space
+space = mkDoc Softspace
+
+
+--------------------------------------------------------------------------------
+softline :: Doc
+softline = mkDoc Softline
--------------------------------------------------------------------------------
-newline :: Doc
-newline = mkDoc Newline
+hardline :: Doc
+hardline = mkDoc Hardline
+
+
+--------------------------------------------------------------------------------
+wrapAt :: Maybe Int -> Doc -> Doc
+wrapAt wrapAtCol wrapDoc = mkDoc WrapAt {..}
--------------------------------------------------------------------------------
@@ -282,6 +342,11 @@ indent firstLineDoc otherLinesDoc doc = mkDoc $ Indent
--------------------------------------------------------------------------------
+ansi :: [Ansi.SGR] -> Doc -> Doc
+ansi codes = mkDoc . Ansi (codes ++)
+
+
+--------------------------------------------------------------------------------
(<+>) :: Doc -> Doc -> Doc
x <+> y = x <> space <> y
infixr 6 <+>
@@ -289,60 +354,13 @@ infixr 6 <+>
--------------------------------------------------------------------------------
(<$$>) :: Doc -> Doc -> Doc
-x <$$> y = x <> newline <> y
+x <$$> y = x <> hardline <> y
infixr 5 <$$>
--------------------------------------------------------------------------------
vcat :: [Doc] -> Doc
-vcat = mconcat . L.intersperse newline
-
-
---------------------------------------------------------------------------------
-bold :: Doc -> Doc
-bold = mkDoc . Ansi
- (\codes -> Ansi.SetConsoleIntensity Ansi.BoldIntensity : codes)
-
-
---------------------------------------------------------------------------------
-underline :: Doc -> Doc
-underline = mkDoc . Ansi
- (\codes -> Ansi.SetUnderlining Ansi.SingleUnderline : codes)
-
-
---------------------------------------------------------------------------------
-dullcolor :: Ansi.Color -> Doc -> Doc
-dullcolor c = mkDoc . Ansi
- (\codes -> Ansi.SetColor Ansi.Foreground Ansi.Dull c : codes)
-
-
---------------------------------------------------------------------------------
-dullblack, dullred, dullgreen, dullyellow, dullblue, dullmagenta, dullcyan,
- dullwhite :: Doc -> Doc
-dullblack = dullcolor Ansi.Black
-dullred = dullcolor Ansi.Red
-dullgreen = dullcolor Ansi.Green
-dullyellow = dullcolor Ansi.Yellow
-dullblue = dullcolor Ansi.Blue
-dullmagenta = dullcolor Ansi.Magenta
-dullcyan = dullcolor Ansi.Cyan
-dullwhite = dullcolor Ansi.White
-
-
---------------------------------------------------------------------------------
-ondullcolor :: Ansi.Color -> Doc -> Doc
-ondullcolor c = mkDoc . Ansi
- (\codes -> Ansi.SetColor Ansi.Background Ansi.Dull c : codes)
-
-
---------------------------------------------------------------------------------
-ondullblack :: Doc -> Doc
-ondullblack = ondullcolor Ansi.Black
-
-
---------------------------------------------------------------------------------
-ondullred :: Doc -> Doc
-ondullred = ondullcolor Ansi.Red
+vcat = mconcat . L.intersperse hardline
--------------------------------------------------------------------------------
diff --git a/src/Patat/Theme.hs b/src/Patat/Theme.hs
new file mode 100644
index 0000000..e3aeb17
--- /dev/null
+++ b/src/Patat/Theme.hs
@@ -0,0 +1,192 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Patat.Theme
+ ( Theme (..)
+ , defaultTheme
+ , Style (..)
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Monad (mplus)
+import qualified Data.Aeson as A
+import qualified Data.Aeson.TH.Extended as A
+import Data.Char (toUpper)
+import Data.List (intercalate)
+import qualified Data.Map as M
+import Data.Maybe (mapMaybe, maybeToList)
+import Data.Monoid (Monoid (..), (<>))
+import qualified Data.Text as T
+import qualified System.Console.ANSI as Ansi
+import Prelude
+
+
+--------------------------------------------------------------------------------
+data Theme = Theme
+ { themeBorders :: !(Maybe Style)
+ , themeHeader :: !(Maybe Style)
+ , themeCodeBlock :: !(Maybe Style)
+ , themeBulletList :: !(Maybe Style)
+ , themeBulletListMarkers :: !(Maybe T.Text)
+ , themeOrderedList :: !(Maybe Style)
+ , themeBlockQuote :: !(Maybe Style)
+ , themeDefinitionTerm :: !(Maybe Style)
+ , themeDefinitionList :: !(Maybe Style)
+ , themeTableHeader :: !(Maybe Style)
+ , themeTableSeparator :: !(Maybe Style)
+ , themeEmph :: !(Maybe Style)
+ , themeStrong :: !(Maybe Style)
+ , themeCode :: !(Maybe Style)
+ , themeLinkText :: !(Maybe Style)
+ , themeLinkTarget :: !(Maybe Style)
+ , themeStrikeout :: !(Maybe Style)
+ , themeQuoted :: !(Maybe Style)
+ , themeMath :: !(Maybe Style)
+ , themeImageText :: !(Maybe Style)
+ , themeImageTarget :: !(Maybe Style)
+ } deriving (Show)
+
+
+--------------------------------------------------------------------------------
+instance Monoid Theme where
+ mempty = Theme
+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+ Nothing Nothing Nothing
+
+ mappend l r = Theme
+ { themeBorders = mplusOn themeBorders
+ , themeHeader = mplusOn themeHeader
+ , themeCodeBlock = mplusOn themeCodeBlock
+ , themeBulletList = mplusOn themeBulletList
+ , themeBulletListMarkers = mplusOn themeBulletListMarkers
+ , themeOrderedList = mplusOn themeOrderedList
+ , themeBlockQuote = mplusOn themeBlockQuote
+ , themeDefinitionTerm = mplusOn themeDefinitionTerm
+ , themeDefinitionList = mplusOn themeDefinitionList
+ , themeTableHeader = mplusOn themeTableHeader
+ , themeTableSeparator = mplusOn themeTableSeparator
+ , themeEmph = mplusOn themeEmph
+ , themeStrong = mplusOn themeStrong
+ , themeCode = mplusOn themeCode
+ , themeLinkText = mplusOn themeLinkText
+ , themeLinkTarget = mplusOn themeLinkTarget
+ , themeStrikeout = mplusOn themeStrikeout
+ , themeQuoted = mplusOn themeQuoted
+ , themeMath = mplusOn themeMath
+ , themeImageText = mplusOn themeImageText
+ , themeImageTarget = mplusOn themeImageTarget
+ }
+ where
+ mplusOn f = f l `mplus` f r
+
+
+--------------------------------------------------------------------------------
+defaultTheme :: Theme
+defaultTheme = Theme
+ { themeBorders = dull Ansi.Yellow
+ , themeHeader = dull Ansi.Blue
+ , themeCodeBlock = dull Ansi.White <> ondull Ansi.Black
+ , themeBulletList = dull Ansi.Magenta
+ , themeBulletListMarkers = Just "-*"
+ , themeOrderedList = dull Ansi.Magenta
+ , themeBlockQuote = dull Ansi.Green
+ , themeDefinitionTerm = dull Ansi.Blue
+ , themeDefinitionList = dull Ansi.Magenta
+ , themeTableHeader = dull Ansi.Blue
+ , themeTableSeparator = dull Ansi.Magenta
+ , themeEmph = dull Ansi.Green
+ , themeStrong = dull Ansi.Red <> bold
+ , themeCode = dull Ansi.White <> ondull Ansi.Black
+ , themeLinkText = dull Ansi.Green
+ , themeLinkTarget = dull Ansi.Cyan <> underline
+ , themeStrikeout = ondull Ansi.Red
+ , themeQuoted = dull Ansi.Green
+ , themeMath = dull Ansi.Green
+ , themeImageText = dull Ansi.Green
+ , themeImageTarget = dull Ansi.Cyan <> underline
+ }
+ where
+ dull c = Just $ Style [Ansi.SetColor Ansi.Foreground Ansi.Dull c]
+ ondull c = Just $ Style [Ansi.SetColor Ansi.Background Ansi.Dull c]
+ bold = Just $ Style [Ansi.SetConsoleIntensity Ansi.BoldIntensity]
+ underline = Just $ Style [Ansi.SetUnderlining Ansi.SingleUnderline]
+
+
+--------------------------------------------------------------------------------
+newtype Style = Style {unStyle :: [Ansi.SGR]}
+ deriving (Monoid, Show)
+
+
+--------------------------------------------------------------------------------
+instance A.ToJSON Style where
+ toJSON = A.toJSON . mapMaybe nameForSGR . unStyle
+
+
+--------------------------------------------------------------------------------
+instance A.FromJSON Style where
+ parseJSON val = do
+ names <- A.parseJSON val
+ sgrs <- mapM toSgr names
+ return $! Style sgrs
+ where
+ toSgr name = case M.lookup name sgrsByName of
+ Just sgr -> return sgr
+ Nothing -> fail $!
+ "Unknown style: " ++ show name ++ ". Known styles are: " ++
+ intercalate ", " (map show $ M.keys sgrsByName)
+
+
+--------------------------------------------------------------------------------
+nameForSGR :: Ansi.SGR -> Maybe String
+nameForSGR (Ansi.SetColor layer intensity color) = Just $
+ (\str -> case layer of
+ Ansi.Foreground -> str
+ Ansi.Background -> "on" ++ capitalize str) $
+ (case intensity of
+ Ansi.Dull -> "dull"
+ Ansi.Vivid -> "vivid") ++
+ (case color of
+ Ansi.Black -> "Black"
+ Ansi.Red -> "Red"
+ Ansi.Green -> "Green"
+ Ansi.Yellow -> "Yellow"
+ Ansi.Blue -> "Blue"
+ Ansi.Magenta -> "Magenta"
+ Ansi.Cyan -> "Cyan"
+ Ansi.White -> "White")
+ where
+ capitalize "" = ""
+ capitalize (x : xs) = toUpper x : xs
+
+nameForSGR (Ansi.SetUnderlining Ansi.SingleUnderline) = Just "underline"
+
+nameForSGR (Ansi.SetConsoleIntensity Ansi.BoldIntensity) = Just "bold"
+
+nameForSGR _ = Nothing
+
+
+--------------------------------------------------------------------------------
+sgrsByName :: M.Map String Ansi.SGR
+sgrsByName = M.fromList
+ [ (name, sgr)
+ | sgr <- knownSgrs
+ , name <- maybeToList (nameForSGR sgr)
+ ]
+ where
+ -- | It doesn't really matter if we generate "too much" SGRs here since
+ -- 'nameForSGR' will only pick the ones we support.
+ knownSgrs =
+ [ Ansi.SetColor l i c
+ | l <- [minBound .. maxBound]
+ , i <- [minBound .. maxBound]
+ , c <- [minBound .. maxBound]
+ ] ++
+ [Ansi.SetUnderlining u | u <- [minBound .. maxBound]] ++
+ [Ansi.SetConsoleIntensity c | c <- [minBound .. maxBound]]
+
+
+--------------------------------------------------------------------------------
+$(A.deriveJSON A.dropPrefixOptions ''Theme)
diff --git a/src/Text/Pandoc/Extended.hs b/src/Text/Pandoc/Extended.hs
index eb01245..ab139a9 100644
--- a/src/Text/Pandoc/Extended.hs
+++ b/src/Text/Pandoc/Extended.hs
@@ -1,21 +1,50 @@
-{-# LANGUAGE LambdaCase #-}
+--------------------------------------------------------------------------------
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
module Text.Pandoc.Extended
( module Text.Pandoc
, plainToPara
, newlineToSpace
+ , metaToJson
) where
-import Text.Pandoc
-import Data.Data.Extended (grecT)
+--------------------------------------------------------------------------------
+import qualified Data.Aeson as A
+import Data.Data.Extended (grecT)
+import qualified Data.Map as M
+import Data.Monoid (mempty)
+import Text.Pandoc
+import Prelude
+
+
+--------------------------------------------------------------------------------
plainToPara :: [Block] -> [Block]
plainToPara = map $ \case
Plain inlines -> Para inlines
block -> block
+
+--------------------------------------------------------------------------------
newlineToSpace :: [Inline] -> [Inline]
newlineToSpace = grecT $ \case
SoftBreak -> Space
LineBreak -> Space
inline -> inline
+
+
+--------------------------------------------------------------------------------
+-- | Convert Pandoc's internal metadata value format to JSON. This makes
+-- parsing some things a bit easier.
+metaToJson :: MetaValue -> A.Value
+metaToJson (MetaMap m) = A.toJSON $! M.map metaToJson m
+metaToJson (MetaList l) = A.toJSON $! map metaToJson l
+metaToJson (MetaBool b) = A.toJSON b
+metaToJson (MetaString s) = A.toJSON s
+metaToJson (MetaInlines i) =
+ let !t = writeMarkdown def (Pandoc mempty [Plain i]) :: String in
+ A.toJSON t
+metaToJson (MetaBlocks b) =
+ let !t = writeMarkdown def (Pandoc mempty b) :: String in
+ A.toJSON t