diff --git a/CHANGELOG.md b/CHANGELOG.md --- 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 --- 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 @@ 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 @@ 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 @@ 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 --- /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 --- /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 --- a/src/Main.hs +++ b/src/Main.hs @@ -96,7 +96,7 @@ -------------------------------------------------------------------------------- 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 --- 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 --- a/src/Patat/Presentation/Display.hs +++ b/src/Patat/Presentation/Display.hs @@ -9,13 +9,20 @@ -------------------------------------------------------------------------------- +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 @@ -- 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 @@ [] -> 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 @@ 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 + ] <> PP.hardline + where + prefix = " " <> PP.string [marker] <> " " + marker = case T.unpack <$> themeBulletListMarkers theme of + Just (x : _) -> x + _ -> '-' -prettyBlock (Pandoc.OrderedList _ bss) = PP.vcat + -- 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 @@ | i <- [1 .. length bss] ] -prettyBlock (Pandoc.RawBlock _ t) = PP.string t <> PP.newline - -prettyBlock Pandoc.HorizontalRule = "---" - -prettyBlock (Pandoc.BlockQuote bs) = - let quote = PP.NotTrimmable (PP.dullgreen "> ") in - PP.indent quote quote (prettyBlocks bs) +prettyBlock _theme (Pandoc.RawBlock _ t) = PP.string t <> PP.hardline -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 _theme Pandoc.HorizontalRule = "---" -prettyBlock (Pandoc.Div _attrs blocks) = prettyBlocks blocks +prettyBlock theme@Theme {..} (Pandoc.BlockQuote bs) = + let quote = PP.NotTrimmable (themed themeBlockQuote "> ") in + PP.indent quote quote (prettyBlocks theme bs) -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 @@ 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 --- 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.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 @@ -------------------------------------------------------------------------------- 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 @@ 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 @@ spaces2 :: Int -> PP.Doc spaces2 rowHeight = - mconcat $ intersperse PP.newline $ + mconcat $ intersperse PP.hardline $ replicate rowHeight (PP.string " ") @@ -86,8 +91,17 @@ -------------------------------------------------------------------------------- -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 --- 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 @@ { 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 --- 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 @@ -------------------------------------------------------------------------------- +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 +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 - doc <- case reader src of - Left err -> Left $ "Pandoc parsing error: " ++ show err - Right x -> Right x + homeSettings <- ExceptT readHomeSettings + metaSettings <- ExceptT $ return $ readMetaSettings meta + let settings = metaSettings <> homeSettings <> defaultPresentationSettings - pandocToPresentation filePath doc + ExceptT $ return $ pandocToPresentation filePath settings doc where ext = takeExtension filePath @@ -38,6 +50,7 @@ ".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,13 +62,41 @@ -------------------------------------------------------------------------------- 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 -------------------------------------------------------------------------------- diff --git a/src/Patat/PrettyPrint.hs b/src/Patat/PrettyPrint.hs --- a/src/Patat/PrettyPrint.hs +++ b/src/Patat/PrettyPrint.hs @@ -15,31 +15,22 @@ , 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 @@ -------------------------------------------------------------------------------- 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 @@ -------------------------------------------------------------------------------- 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 @@ -------------------------------------------------------------------------------- chunkToDocE :: Chunk -> DocE -chunkToDocE NewlineChunk = Newline +chunkToDocE NewlineChunk = Hardline chunkToDocE (StringChunk codes str) = Ansi (\_ -> codes) (Doc [String str]) @@ -149,6 +147,7 @@ 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 @@ -------------------------------------------------------------------------------- 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 @@ 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,7 +234,41 @@ 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 toString = concat . map chunkToString . docToChunks @@ -263,16 +308,31 @@ -------------------------------------------------------------------------------- +text :: T.Text -> Doc +text = string . T.unpack + + +-------------------------------------------------------------------------------- space :: Doc -space = mkDoc Space +space = mkDoc Softspace -------------------------------------------------------------------------------- -newline :: Doc -newline = mkDoc Newline +softline :: Doc +softline = mkDoc Softline -------------------------------------------------------------------------------- +hardline :: Doc +hardline = mkDoc Hardline + + +-------------------------------------------------------------------------------- +wrapAt :: Maybe Int -> Doc -> Doc +wrapAt wrapAtCol wrapDoc = mkDoc WrapAt {..} + + +-------------------------------------------------------------------------------- indent :: Trimmable Doc -> Trimmable Doc -> Doc -> Doc indent firstLineDoc otherLinesDoc doc = mkDoc $ Indent { indentFirstLine = traverse docToChunks firstLineDoc @@ -282,6 +342,11 @@ -------------------------------------------------------------------------------- +ansi :: [Ansi.SGR] -> Doc -> Doc +ansi codes = mkDoc . Ansi (codes ++) + + +-------------------------------------------------------------------------------- (<+>) :: Doc -> Doc -> Doc x <+> y = x <> space <> y infixr 6 <+> @@ -289,60 +354,13 @@ -------------------------------------------------------------------------------- (<$$>) :: 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 --- /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 --- 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