patat 0.1.0.0 → 0.2.0.0
raw patch · 13 files changed
+666/−224 lines, 13 filesdep +aesondep +bytestringdep +text
Dependencies added: aeson, bytestring, text, yaml
Files
- CHANGELOG.md +6/−0
- patat.cabal +9/−2
- src/Data/Aeson/Extended.hs +22/−0
- src/Data/Aeson/TH/Extended.hs +21/−0
- src/Main.hs +1/−1
- src/Patat/Presentation.hs +4/−1
- src/Patat/Presentation/Display.hs +142/−97
- src/Patat/Presentation/Display/Table.hs +39/−25
- src/Patat/Presentation/Internal.hs +46/−2
- src/Patat/Presentation/Read.hs +59/−18
- src/Patat/PrettyPrint.hs +93/−75
- src/Patat/Theme.hs +192/−0
- src/Text/Pandoc/Extended.hs +32/−3
CHANGELOG.md view
@@ -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.
patat.cabal view
@@ -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
+ src/Data/Aeson/Extended.hs view
@@ -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
+ src/Data/Aeson/TH/Extended.hs view
@@ -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
src/Main.hs view
@@ -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
src/Patat/Presentation.hs view
@@ -1,5 +1,8 @@ module Patat.Presentation- ( Presentation (..)+ ( PresentationSettings (..)+ , defaultPresentationSettings++ , Presentation (..) , readPresentation , displayPresentation , dumpPresentation
src/Patat/Presentation/Display.hs view
@@ -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 <> "\"")
src/Patat/Presentation/Display/Table.hs view
@@ -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
src/Patat/Presentation/Internal.hs view
@@ -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)
src/Patat/Presentation/Read.hs view
@@ -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 --------------------------------------------------------------------------------
src/Patat/PrettyPrint.hs view
@@ -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 --------------------------------------------------------------------------------
+ src/Patat/Theme.hs view
@@ -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)
src/Text/Pandoc/Extended.hs view
@@ -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