publish 2.1.5 → 2.1.6
raw patch · 7 files changed
+772/−879 lines, 7 filesdep −hinotifydep ~core-programdep ~core-textdep ~pandoc
Dependencies removed: hinotify
Dependency ranges changed: core-program, core-text, pandoc, pandoc-types
Files
- publish.cabal +16/−19
- src/FormatDocument.hs +54/−56
- src/PandocToMarkdown.hs +221/−258
- src/RenderDocument.hs +334/−330
- src/RenderMain.hs +42/−42
- tests/CheckTableProperties.hs +81/−149
- tests/CompareFragments.hs +24/−25
publish.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: c35d54fad6892dcaef7d0d6f267b9349e9a21788945c513b64d884539ce9494d+-- hash: aef6f603b6208e83923b38b0844890f9251c6b38c650d7bb264a4e66083493ad name: publish-version: 2.1.5+version: 2.1.6 synopsis: Publishing tools for papers, books, and presentations description: Tools for rendering markdown-centric documents into PDFs. .@@ -21,10 +21,10 @@ bug-reports: https://github.com/aesiniath/publish/issues author: Andrew Cowie <istathar@gmail.com> maintainer: Andrew Cowie <istathar@gmail.com>-copyright: © 2016-2020 Athae Eredh Siniath and Others+copyright: © 2016-2021 Athae Eredh Siniath and Others license: MIT license-file: LICENSE-tested-with: GHC == 8.8+tested-with: GHC == 8.10 build-type: Simple source-repository head@@ -44,15 +44,14 @@ , bytestring , chronologique , core-data- , core-program >=0.2.2.3- , core-text >=0.2.2.3+ , core-program >=0.2.7+ , core-text >=0.3.0 , deepseq , directory , filepath- , hinotify , megaparsec- , pandoc- , pandoc-types+ , pandoc >=2.11+ , pandoc-types >=1.22 , template-haskell , text , typed-process@@ -78,15 +77,14 @@ , bytestring , chronologique , core-data- , core-program >=0.2.2.3- , core-text >=0.2.2.3+ , core-program >=0.2.7+ , core-text >=0.3.0 , deepseq , directory , filepath- , hinotify , megaparsec- , pandoc- , pandoc-types+ , pandoc >=2.11+ , pandoc-types >=1.22 , template-haskell , text , typed-process@@ -114,16 +112,15 @@ , bytestring , chronologique , core-data- , core-program >=0.2.2.3- , core-text >=0.2.2.3+ , core-program >=0.2.7+ , core-text >=0.3.0 , deepseq , directory , filepath- , hinotify , hspec , megaparsec- , pandoc- , pandoc-types+ , pandoc >=2.11+ , pandoc-types >=1.22 , template-haskell , text , typed-process
src/FormatDocument.hs view
@@ -1,12 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module FormatDocument- ( program,+module FormatDocument (+ program, loadFragment, markdownToPandoc,- )-where+) where import Core.Program import Core.System@@ -15,9 +14,8 @@ import qualified Data.Text.IO as T import PandocToMarkdown import System.Directory (getFileSize, renameFile)-import System.IO (IOMode (..), withFile)-import Text.Pandoc- ( Extension (..),+import Text.Pandoc (+ Extension (..), Extensions, Pandoc, ReaderOptions (readerExtensions),@@ -26,35 +24,35 @@ pandocExtensions, readMarkdown, runIOorExplode,- )+ ) program :: Program None () program = do- event "Identify document fragment"- file <- getFragmentName+ event "Identify document fragment"+ file <- getFragmentName - event "Load to Pandoc internal representation"- parsed <- loadFragment file+ event "Load to Pandoc internal representation"+ parsed <- loadFragment file - event "Write to Markdown format"- writeResult file parsed+ event "Write to Markdown format"+ writeResult file parsed - event "Complete"+ event "Complete" getFragmentName :: Program None FilePath getFragmentName = do- params <- getCommandLine+ params <- getCommandLine - let fragment = case lookupArgument "document" params of- Nothing -> error "invalid"- Just file -> file- return fragment+ let fragment = case lookupArgument "document" params of+ Nothing -> error "invalid"+ Just file -> file+ return fragment loadFragment :: FilePath -> Program None Pandoc loadFragment file =- liftIO $ do- contents <- T.readFile file- markdownToPandoc contents+ liftIO $ do+ contents <- T.readFile file+ markdownToPandoc contents -- -- Unlike the render use case, here we suppress certain@@ -62,44 +60,44 @@ -- markdownToPandoc :: T.Text -> IO Pandoc markdownToPandoc contents =- let disableFrom :: Extensions -> [Extension] -> Extensions- disableFrom extensions list = foldr disableExtension extensions list- readingOptions =- def- { readerExtensions =- disableFrom- pandocExtensions- [ Ext_implicit_figures,- Ext_shortcut_reference_links,- Ext_smart- ]- }- in do- runIOorExplode $ do- readMarkdown readingOptions contents+ let disableFrom :: Extensions -> [Extension] -> Extensions+ disableFrom extensions list = foldr disableExtension extensions list+ readingOptions =+ def+ { readerExtensions =+ disableFrom+ pandocExtensions+ [ Ext_implicit_figures+ , Ext_shortcut_reference_links+ , Ext_smart+ ]+ }+ in do+ runIOorExplode $ do+ readMarkdown readingOptions contents data Inplace = Inplace | Console writeResult :: FilePath -> Pandoc -> Program None () writeResult file doc =- let contents' = pandocToMarkdown doc- result = file ++ "~tmp"- in do- params <- getCommandLine+ let contents' = pandocToMarkdown doc+ result = file ++ "~tmp"+ in do+ params <- getCommandLine - let mode = case lookupOptionFlag "inplace" params of- Just False -> error "Invalid State"- Just True -> Inplace- Nothing -> Console+ let mode = case lookupOptionFlag "inplace" params of+ Just False -> error "Invalid State"+ Just True -> Inplace+ Nothing -> Console - case mode of- Inplace -> liftIO $ do- withFile result WriteMode $ \handle ->- hWrite handle contents'+ case mode of+ Inplace -> liftIO $ do+ withFile result WriteMode $ \handle ->+ hWrite handle contents' - size <- getFileSize result- if size == 0- then error "Zero content, not overwriting"- else renameFile result file- Console -> liftIO $ do- hWrite stdout contents'+ size <- getFileSize result+ if size == 0+ then error "Zero content, not overwriting"+ else renameFile result file+ Console -> liftIO $ do+ hWrite stdout contents'
src/PandocToMarkdown.hs view
@@ -3,38 +3,38 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module PandocToMarkdown- ( pandocToMarkdown,+module PandocToMarkdown (+ pandocToMarkdown, NotSafe (..),- Rectangle (..),- rectanglerize,- combineRectangles,- buildRow,- widthOf,- heightOf, tableToMarkdown,- )-where+) where -import Control.DeepSeq (NFData) import Core.System.Base import Core.Text import Data.Foldable (foldl') import Data.List (intersperse) import qualified Data.Text as T (Text, null)-import GHC.Generics (Generic)-import Text.Pandoc- ( Alignment (..),+import Text.Pandoc (+ Alignment (..), Attr, Block (..),+ Caption (..),+ Cell (..),+ ColSpan (..),+ ColSpec,+ ColWidth (..), Format (..), Inline (..), ListAttributes, MathType (..), Pandoc (..), QuoteType (..),- TableCell,- )+ Row (..),+ RowSpan (..),+ TableBody (..),+ TableFoot (..),+ TableHead (..),+ ) import Text.Pandoc.Shared (orderedListMarkers) __WIDTH__ :: Int@@ -42,37 +42,37 @@ pandocToMarkdown :: Pandoc -> Rope pandocToMarkdown (Pandoc _ blocks) =- blocksToMarkdown __WIDTH__ blocks+ blocksToMarkdown __WIDTH__ blocks blocksToMarkdown :: Int -> [Block] -> Rope blocksToMarkdown _ [] = emptyRope blocksToMarkdown margin (block1 : blocks) =- convertBlock margin block1- <> foldl'- (\text block -> text <> "\n" <> convertBlock margin block)- emptyRope- blocks+ convertBlock margin block1+ <> foldl'+ (\text block -> text <> "\n" <> convertBlock margin block)+ emptyRope+ blocks convertBlock :: Int -> Block -> Rope convertBlock margin block =- let msg = "Unfinished block: " ++ show block -- FIXME- in case block of- Plain inlines -> plaintextToMarkdown margin inlines- Para inlines -> paragraphToMarkdown margin inlines- Header level _ inlines -> headingToMarkdown level inlines- Null -> emptyRope- RawBlock (Format "tex") string -> intoRope string <> "\n"- RawBlock (Format "html") string -> intoRope string <> "\n"- RawBlock _ _ -> error msg- CodeBlock attr string -> codeToMarkdown attr string- LineBlock list -> poemToMarkdown list- BlockQuote blocks -> quoteToMarkdown margin blocks- BulletList blockss -> bulletlistToMarkdown margin blockss- OrderedList attrs blockss -> orderedlistToMarkdown margin attrs blockss- DefinitionList blockss -> definitionlistToMarkdown margin blockss- HorizontalRule -> "---\n"- Table caption alignments relatives headers rows -> tableToMarkdown caption alignments relatives headers rows- Div attr blocks -> divToMarkdown margin attr blocks+ let msg = "Unfinished block: " ++ show block -- FIXME+ in case block of+ Plain inlines -> plaintextToMarkdown margin inlines+ Para inlines -> paragraphToMarkdown margin inlines+ Header level _ inlines -> headingToMarkdown level inlines+ Null -> emptyRope+ RawBlock (Format "tex") string -> intoRope string <> "\n"+ RawBlock (Format "html") string -> intoRope string <> "\n"+ RawBlock _ _ -> error msg+ CodeBlock attr string -> codeToMarkdown attr string+ LineBlock list -> poemToMarkdown list+ BlockQuote blocks -> quoteToMarkdown margin blocks+ BulletList blockss -> bulletlistToMarkdown margin blockss+ OrderedList attrs blockss -> orderedlistToMarkdown margin attrs blockss+ DefinitionList blockss -> definitionlistToMarkdown margin blockss+ HorizontalRule -> "---\n"+ Table attr caption alignments header rows footer -> tableToMarkdown attr caption alignments header rows footer+ Div attr blocks -> divToMarkdown margin attr blocks {- This does **not** emit a newline at the end. The intersperse happening in@@ -82,7 +82,7 @@ -} plaintextToMarkdown :: Int -> [Inline] -> Rope plaintextToMarkdown margin inlines =- wrap' margin (inlinesToMarkdown inlines)+ wrap' margin (inlinesToMarkdown inlines) {- Everything was great until we had to figure out how to deal with line@@ -94,41 +94,41 @@ -} paragraphToMarkdown :: Int -> [Inline] -> Rope paragraphToMarkdown margin inlines =- wrap' margin (inlinesToMarkdown inlines) <> "\n"+ wrap' margin (inlinesToMarkdown inlines) <> "\n" wrap' :: Int -> Rope -> Rope wrap' margin =- mconcat . intersperse " \n" . fmap (wrap margin) . breakPieces isLineSeparator+ mconcat . intersperse " \n" . fmap (wrap margin) . breakPieces isLineSeparator where isLineSeparator = (== '\x2028') headingToMarkdown :: Int -> [Inline] -> Rope headingToMarkdown level inlines =- let text = inlinesToMarkdown inlines- in case level of- 1 -> text <> "\n" <> underline '=' text <> "\n"- 2 -> text <> "\n" <> underline '-' text <> "\n"- n -> intoRope (replicate n '#') <> " " <> text <> "\n"+ let text = inlinesToMarkdown inlines+ in case level of+ 1 -> text <> "\n" <> underline '=' text <> "\n"+ 2 -> text <> "\n" <> underline '-' text <> "\n"+ n -> intoRope (replicate n '#') <> " " <> text <> "\n" codeToMarkdown :: Attr -> T.Text -> Rope codeToMarkdown attr literal =- let body = intoRope literal- lang = fencedAttributesToMarkdown attr- in "```" <> lang <> "\n"- <> body- <> "\n"- <> "```"- <> "\n"+ let body = intoRope literal+ lang = fencedAttributesToMarkdown attr+ in "```" <> lang <> "\n"+ <> body+ <> "\n"+ <> "```"+ <> "\n" poemToMarkdown :: [[Inline]] -> Rope poemToMarkdown list =- mconcat (intersperse "\n" (fmap prefix list)) <> "\n"+ mconcat (intersperse "\n" (fmap prefix list)) <> "\n" where prefix inlines = "| " <> inlinesToMarkdown inlines quoteToMarkdown :: Int -> [Block] -> Rope quoteToMarkdown margin blocks =- foldl' (\text block -> text <> prefix block) emptyRope blocks+ foldl' (\text block -> text <> prefix block) emptyRope blocks where prefix :: Block -> Rope prefix = foldl' (\text line -> text <> "> " <> line <> "\n") emptyRope . rows@@ -140,36 +140,36 @@ orderedlistToMarkdown :: Int -> ListAttributes -> [[Block]] -> Rope orderedlistToMarkdown margin (num, style, delim) blockss =- listToMarkdown (intoMarkers (num, style, delim)) margin blockss+ listToMarkdown (intoMarkers (num, style, delim)) margin blockss where intoMarkers = fmap pad . fmap intoRope . orderedListMarkers pad text = text <> if widthRope text > 2 then " " else " " definitionlistToMarkdown :: Int -> [([Inline], [[Block]])] -> Rope definitionlistToMarkdown margin definitions =- case definitions of- [] -> emptyRope- (definition1 : definitionN) ->- handleDefinition definition1- <> foldl'- (\text definition -> text <> "\n" <> handleDefinition definition)- emptyRope- definitionN+ case definitions of+ [] -> emptyRope+ (definition1 : definitionN) ->+ handleDefinition definition1+ <> foldl'+ (\text definition -> text <> "\n" <> handleDefinition definition)+ emptyRope+ definitionN where handleDefinition :: ([Inline], [[Block]]) -> Rope handleDefinition (term, blockss) =- inlinesToMarkdown term <> "\n\n" <> listToMarkdown (repeat ": ") margin blockss+ inlinesToMarkdown term <> "\n\n" <> listToMarkdown (repeat ": ") margin blockss listToMarkdown :: [Rope] -> Int -> [[Block]] -> Rope listToMarkdown markers margin items =- case pairs of- [] -> emptyRope- ((marker1, blocks1) : pairsN) ->- listitem marker1 blocks1- <> foldl'- (\text (markerN, blocksN) -> text <> spacer blocksN <> listitem markerN blocksN)- emptyRope- pairsN+ case pairs of+ [] -> emptyRope+ ((marker1, blocks1) : pairsN) ->+ listitem marker1 blocks1+ <> foldl'+ (\text (markerN, blocksN) -> text <> spacer blocksN <> listitem markerN blocksN)+ emptyRope+ pairsN where pairs = zip markers items listitem :: Rope -> [Block] -> Rope@@ -183,20 +183,20 @@ spacer :: [Block] -> Rope spacer [] = emptyRope spacer (block : _) = case block of- Plain _ -> emptyRope- Para _ -> "\n"- _ -> emptyRope -- ie nested list+ Plain _ -> emptyRope+ Para _ -> "\n"+ _ -> emptyRope -- ie nested list indent :: Rope -> [Block] -> Rope indent marker =- snd . foldl' (f marker) (True, emptyRope) . breakLines . blocksToMarkdown (margin - 4)+ snd . foldl' (f marker) (True, emptyRope) . breakLines . blocksToMarkdown (margin - 4) f :: Rope -> (Bool, Rope) -> Rope -> (Bool, Rope) f marker (first, text) line- | nullRope line =- (False, text <> "\n") -- don't indent lines that should be blank- | otherwise =- if first- then (False, text <> marker <> line <> "\n")- else (False, text <> " " <> line <> "\n")+ | nullRope line =+ (False, text <> "\n") -- don't indent lines that should be blank+ | otherwise =+ if first+ then (False, text <> marker <> line <> "\n")+ else (False, text <> " " <> line <> "\n") {- In Pandoc flavoured Markdown, <div> are recognized as valid Markdown via@@ -210,10 +210,10 @@ -} divToMarkdown :: Int -> Attr -> [Block] -> Rope divToMarkdown margin attr blocks =- let first = ":::" <> fencedAttributesToMarkdown attr- trail = ":::"- content = mconcat . intersperse "\n" . fmap (convertBlock margin)- in first <> "\n" <> content blocks <> trail <> "\n"+ let first = ":::" <> fencedAttributesToMarkdown attr+ trail = ":::"+ content = mconcat . intersperse "\n" . fmap (convertBlock margin)+ in first <> "\n" <> content blocks <> trail <> "\n" -- special case for (notably) code blocks where a single class doesn't need braces. fencedAttributesToMarkdown :: Attr -> Rope@@ -227,180 +227,143 @@ attributesToMarkdown ("", [], []) = emptyRope attributesToMarkdown (identifier, [], []) = "{#" <> intoRope identifier <> "}" attributesToMarkdown (identifier, classes, pairs) =- let i =- if T.null identifier- then emptyRope- else "#" <> intoRope identifier <> " "- cs = fmap (\c -> "." <> intoRope c) classes- ps = fmap (\(k, v) -> intoRope k <> "=" <> intoRope v) pairs- in "{" <> i <> mconcat (intersperse " " (cs ++ ps)) <> "}"+ let i =+ if T.null identifier+ then emptyRope+ else "#" <> intoRope identifier <> " "+ cs = fmap (\c -> "." <> intoRope c) classes+ ps = fmap (\(k, v) -> intoRope k <> "=" <> intoRope v) pairs+ in "{" <> i <> mconcat (intersperse " " (cs ++ ps)) <> "}" tableToMarkdown ::- [Inline] ->- [Alignment] ->- [Double] ->- [TableCell] ->- [[TableCell]] ->- Rope-tableToMarkdown _ alignments relatives headers rows =- mconcat- ( intersperse- "\n"- [ wrapperLine,- header,- underlineHeaders,- body,- wrapperLine- ]- )- <> "\n"+ Attr ->+ Caption ->+ [ColSpec] ->+ TableHead ->+ [TableBody] ->+ TableFoot ->+ Rope+tableToMarkdown _ _ alignments thead tbodys _ =+ mconcat+ ( intersperse+ "\n"+ [ headerline+ , betweenline+ , bodylines+ ]+ )+ <> "\n" where- header = rowToMarkdown headers- bodylines = fmap rowToMarkdown rows- body = mconcat (intersperse "\n\n" bodylines)- sizes :: [Int]- sizes =- let total = fromIntegral __WIDTH__- -- there's a weird thing where sometimes (in pipe tables?) the- -- value of relative is 0. If that happens, pick a value.- -- TODO Better heuristic? Because, this will break if cell too wide.- f x- | x == 0.0 = 14- | otherwise = floor (total * x)- in fmap (fromInteger . f) relatives- overall = sum sizes + (length headers) - 1- wrapperLine = intoRope (replicate overall '-')- rowToMarkdown :: [TableCell] -> Rope- rowToMarkdown =- buildRow sizes . fmap convert- . zipWith3- (\size align (block : _) -> (size, align, block))- sizes- alignments- underlineHeaders :: Rope- underlineHeaders =- foldl' (<>) emptyRope . intersperse " "- . fmap (\size -> intoRope (replicate size '-'))- . take (length headers)- $ sizes- convert :: (Int, Alignment, Block) -> Rectangle- convert (size, align, Plain inlines) =- rectanglerize size align (plaintextToMarkdown size inlines)- convert (_, _, _) =- impureThrow (NotSafe "Incorrect Block type encountered")+ colonChar = singletonRope ':'+ dashChar = singletonRope '-'+ pipeChar = singletonRope '|'+ spaceChar = singletonRope ' '+ newlineChar = singletonRope '\n' -data NotSafe = NotSafe String- deriving (Show)+ surround :: Rope -> Rope -> Rope+ surround char text = char <> text <> char -instance Exception NotSafe+ headerline = headerToMarkdown thead -data Rectangle = Rectangle Int Int [Rope]- deriving (Eq, Show, Generic, NFData)+ betweenline =+ surround pipeChar . foldl' (<>) emptyRope+ . intersperse pipeChar+ . fmap columnToMarkdown+ $ alignments -widthOf :: Rectangle -> Int-widthOf (Rectangle size _ _) = size+ bodylines = bodiesToMarkdown tbodys -heightOf :: Rectangle -> Int-heightOf (Rectangle _ height _) = height+ headerToMarkdown :: TableHead -> Rope+ headerToMarkdown (TableHead _ [row]) = rowToMarkdown row+ headerToMarkdown _ = impureThrow (NotSafe "What do we do with this TableHead?") -rowsFrom :: Rectangle -> [Rope]-rowsFrom (Rectangle _ _ texts) = texts+ columnToMarkdown :: (Alignment, ColWidth) -> Rope+ columnToMarkdown (align, col) =+ let total = fromIntegral __WIDTH__+ begin = case align of+ AlignLeft -> colonChar+ AlignCenter -> colonChar+ _ -> dashChar -instance Semigroup Rectangle where- (<>) = combineRectangles+ num = case col of+ ColWidth x -> floor (total * x) - 2+ ColWidthDefault -> 6+ middle = mconcat (replicate num dashChar) -instance Monoid Rectangle where- mempty = Rectangle 0 0 []+ end = case align of+ AlignRight -> colonChar+ AlignCenter -> colonChar+ _ -> dashChar+ in begin <> middle <> end -rectanglerize :: Int -> Alignment -> Rope -> Rectangle-rectanglerize size align text =- let ls = breakLines (wrap size text)- fix l- | widthRope l < size =- let padding = size - widthRope l- (left, remain) = divMod padding 2- right = left + remain- in case align of- AlignCenter -> intoRope (replicate left ' ') <> l <> intoRope (replicate right ' ')- AlignRight -> intoRope (replicate padding ' ') <> l- AlignLeft -> l <> intoRope (replicate padding ' ')- AlignDefault -> l <> intoRope (replicate padding ' ')- | widthRope l == size = case align of- AlignRight -> impureThrow (NotSafe "Column width insufficient to show alignment")- _ -> l- | otherwise = impureThrow (NotSafe "Line wider than permitted size")- result = foldr (\l acc -> fix l : acc) [] ls- in Rectangle size (length result) result+ bodiesToMarkdown :: [TableBody] -> Rope+ bodiesToMarkdown = mconcat . intersperse newlineChar . fmap bodyToMarkdown -combineRectangles :: Rectangle -> Rectangle -> Rectangle-combineRectangles rect1@(Rectangle size1 height1 _) rect2@(Rectangle size2 height2 _) =- let target = max height1 height2- extra1 = target - height1- extra2 = target - height2- padRows :: Int -> Rectangle -> [Rope]- padRows count (Rectangle size _ texts) =- let texts' = texts ++ replicate count (intoRope (replicate size ' '))- in texts'- texts1' = padRows extra1 rect1- texts2' = padRows extra2 rect2- pairs = zip texts1' texts2'- result = foldr (\(text1, text2) texts -> text1 <> text2 : texts) [] pairs- in Rectangle (size1 + size2) target result+ bodyToMarkdown :: TableBody -> Rope+ bodyToMarkdown (TableBody _ _ _ rows) =+ foldl' (<>) emptyRope+ . intersperse newlineChar+ . fmap rowToMarkdown+ $ rows -ensureWidth :: Int -> Rectangle -> Rectangle-ensureWidth request rect =- if widthOf rect < request- then rectanglerize request AlignLeft (foldl' (<>) emptyRope (rowsFrom rect))- else rect+ rowToMarkdown :: Row -> Rope+ rowToMarkdown (Row _ cells) =+ surround pipeChar . foldl' (<>) emptyRope+ . intersperse pipeChar+ . fmap (surround spaceChar . cellToMarkdown)+ $ cells -buildRow :: [Int] -> [Rectangle] -> Rope-buildRow cellWidths rects =- let pairs = zip cellWidths rects- rects' = fmap (\(desired, rect) -> ensureWidth desired rect) pairs- wall = vertical ' ' rects'- result = foldl' (<>) mempty . intersperse wall $ rects'- in foldl' (<>) emptyRope (intersperse "\n" (rowsFrom result))+ cellToMarkdown :: Cell -> Rope+ cellToMarkdown (Cell _ _ (RowSpan 1) (ColSpan 1) [block]) =+ convert block+ cellToMarkdown _ =+ impureThrow (NotSafe "Multiple Blocks encountered") -vertical :: Char -> [Rectangle] -> Rectangle-vertical ch rects =- let height = maximum (fmap heightOf rects)- border = replicate height (intoRope [ch])- in Rectangle 1 height border+ convert :: Block -> Rope+ convert (Plain inlines) =+ plaintextToMarkdown 100000 inlines+ convert _ =+ impureThrow (NotSafe "Incorrect Block type encountered") +data NotSafe = NotSafe String+ deriving (Show)++instance Exception NotSafe+ ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- inlinesToMarkdown :: [Inline] -> Rope inlinesToMarkdown inlines =- foldl' (\text inline -> appendRope (convertInline inline) text) emptyRope inlines+ foldl' (\text inline -> appendRope (convertInline inline) text) emptyRope inlines convertInline :: Inline -> Rope convertInline inline =- let msg = "Unfinished inline: " ++ show inline- in case inline of- Space -> " "- Str text -> stringToMarkdown text- Emph inlines -> "_" <> inlinesToMarkdown inlines <> "_"- Strong inlines -> "**" <> inlinesToMarkdown inlines <> "**"- SoftBreak -> " "- LineBreak -> "\x2028"- Image attr inlines target -> imageToMarkdown attr inlines target- Code _ string -> "`" <> intoRope string <> "`"- RawInline (Format "tex") string -> intoRope string- RawInline (Format "html") string -> intoRope string- RawInline _ _ -> error msg- Link ("", ["uri"], []) _ (url, _) -> uriToMarkdown url- Link attr inlines target -> linkToMarkdown attr inlines target- Strikeout inlines -> "~~" <> inlinesToMarkdown inlines <> "~~"- Math mode text -> mathToMarkdown mode text- -- then things start getting weird- SmallCaps inlines -> smallcapsToMarkdown inlines- Subscript inlines -> "~" <> inlinesToMarkdown inlines <> "~"- Superscript inlines -> "^" <> inlinesToMarkdown inlines <> "^"- Span attr inlines -> spanToMarkdown attr inlines- -- I don't know what the point of these ones are- Quoted SingleQuote inlines -> "'" <> inlinesToMarkdown inlines <> "'"- Quoted DoubleQuote inlines -> "\"" <> inlinesToMarkdown inlines <> "\""- _ -> error msg+ let msg = "Unfinished inline: " ++ show inline+ in case inline of+ Space -> " "+ Str text -> stringToMarkdown text+ Emph inlines -> "_" <> inlinesToMarkdown inlines <> "_"+ Strong inlines -> "**" <> inlinesToMarkdown inlines <> "**"+ SoftBreak -> " "+ LineBreak -> "\x2028"+ Image attr inlines target -> imageToMarkdown attr inlines target+ Code _ string -> "`" <> intoRope string <> "`"+ RawInline (Format "tex") string -> intoRope string+ RawInline (Format "html") string -> intoRope string+ RawInline _ _ -> error msg+ Link ("", ["uri"], []) _ (url, _) -> uriToMarkdown url+ Link attr inlines target -> linkToMarkdown attr inlines target+ Strikeout inlines -> "~~" <> inlinesToMarkdown inlines <> "~~"+ Math mode text -> mathToMarkdown mode text+ -- then things start getting weird+ SmallCaps inlines -> smallcapsToMarkdown inlines+ Subscript inlines -> "~" <> inlinesToMarkdown inlines <> "~"+ Superscript inlines -> "^" <> inlinesToMarkdown inlines <> "^"+ Span attr inlines -> spanToMarkdown attr inlines+ -- I don't know what the point of these ones are+ Quoted SingleQuote inlines -> "'" <> inlinesToMarkdown inlines <> "'"+ Quoted DoubleQuote inlines -> "\"" <> inlinesToMarkdown inlines <> "\""+ _ -> error msg {- Pandoc uses U+00A0 aka ASCII 160 aka to mark a non-breaking space, which@@ -409,32 +372,32 @@ -} stringToMarkdown :: T.Text -> Rope stringToMarkdown =- mconcat . intersperse "\\ " . breakPieces isNonBreaking . intoRope+ mconcat . intersperse "\\ " . breakPieces isNonBreaking . intoRope where isNonBreaking c = c == '\x00a0' imageToMarkdown :: Attr -> [Inline] -> (T.Text, T.Text) -> Rope imageToMarkdown attr inlines (url, title) =- let alt = inlinesToMarkdown inlines- target =- if T.null title- then intoRope url- else intoRope url <> " \"" <> intoRope title <> "\""- in "![" <> alt <> "](" <> target <> ")" <> attributesToMarkdown attr+ let alt = inlinesToMarkdown inlines+ target =+ if T.null title+ then intoRope url+ else intoRope url <> " \"" <> intoRope title <> "\""+ in "![" <> alt <> "](" <> target <> ")" <> attributesToMarkdown attr uriToMarkdown :: T.Text -> Rope uriToMarkdown url =- let target = intoRope url- in "<" <> target <> ">"+ let target = intoRope url+ in "<" <> target <> ">" linkToMarkdown :: Attr -> [Inline] -> (T.Text, T.Text) -> Rope linkToMarkdown attr inlines (url, title) =- let text = inlinesToMarkdown inlines- target =- if T.null title- then intoRope url- else intoRope url <> " \"" <> intoRope title <> "\""- in "[" <> text <> "](" <> target <> ")" <> attributesToMarkdown attr+ let text = inlinesToMarkdown inlines+ target =+ if T.null title+ then intoRope url+ else intoRope url <> " \"" <> intoRope title <> "\""+ in "[" <> text <> "](" <> target <> ")" <> attributesToMarkdown attr -- is there more to this? mathToMarkdown :: MathType -> T.Text -> Rope@@ -443,10 +406,10 @@ smallcapsToMarkdown :: [Inline] -> Rope smallcapsToMarkdown inlines =- let text = inlinesToMarkdown inlines- in "[" <> text <> "]{.smallcaps}"+ let text = inlinesToMarkdown inlines+ in "[" <> text <> "]{.smallcaps}" spanToMarkdown :: Attr -> [Inline] -> Rope spanToMarkdown attr inlines =- let text = inlinesToMarkdown inlines- in "[" <> text <> "]" <> attributesToMarkdown attr+ let text = inlinesToMarkdown inlines+ in "[" <> text <> "]" <> attributesToMarkdown attr
src/RenderDocument.hs view
@@ -2,10 +2,9 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} -module RenderDocument- ( program,- )-where+module RenderDocument (+ program,+) where import Control.Monad (filterM, forM_, forever, void) import Core.Data@@ -20,28 +19,28 @@ import LatexOutputReader (parseOutputForError) import LatexPreamble (beginning, ending, preamble) import ParseBookfile (parseBookfile)-import System.Directory- ( copyFileWithMetadata,+import System.Directory (+ copyFileWithMetadata, doesDirectoryExist, doesFileExist, renameFile,- )+ ) import System.Exit (ExitCode (..))-import System.FilePath.Posix- ( dropExtension,+import System.FilePath.Posix (+ dropExtension, replaceDirectory, replaceExtension, splitFileName, takeBaseName, takeExtension,- )+ ) import System.IO (hPutStrLn) import System.Posix.Directory (changeWorkingDirectory) import System.Posix.Temp (mkdtemp) import System.Posix.User (getEffectiveGroupID, getEffectiveUserID) import Text.Megaparsec (errorBundlePretty, runParser)-import Text.Pandoc- ( TopLevelDivision (TopLevelSection),+import Text.Pandoc (+ TopLevelDivision (TopLevelSection), def, pandocExtensions, readMarkdown,@@ -50,7 +49,7 @@ runIOorExplode, writeLaTeX, writerTopLevelDivision,- )+ ) import Utilities (ensureDirectory, execProcess, ifNewer, isNewer) data Mode = Once | Cycle@@ -59,62 +58,63 @@ program :: Program Env () program = do- params <- getCommandLine- (mode, copy) <- extractMode params+ params <- getCommandLine+ (mode, copy) <- extractMode params - event "Identify .book file"- bookfile <- extractBookFile params+ event "Identify .book file"+ bookfile <- extractBookFile params - case mode of- Once -> do- -- normal operation, single pass- void (renderDocument (mode, copy) bookfile)- Cycle -> do- -- use inotify to rebuild on changes- forever (renderDocument (mode, copy) bookfile >>= waitForChange)+ case mode of+ Once -> do+ -- normal operation, single pass+ void (renderDocument (mode, copy) bookfile)+ Cycle -> do+ -- use inotify to rebuild on changes+ forever (renderDocument (mode, copy) bookfile >>= waitForChange) renderDocument :: (Mode, Copy) -> FilePath -> Program Env [FilePath] renderDocument (mode, copy) file = do- event "Read .book file"- book <- processBookFile file+ resetTimer+ event "Read .book file"+ book <- processBookFile file - event "Setup temporary directory"- setupTargetFile file- setupPreambleFile- validatePreamble book+ event "Setup temporary directory"+ setupTargetFile file+ setupPreambleFile+ validatePreamble book - let preambles = preamblesFrom book- let fragments = fragmentsFrom book- let trailers = trailersFrom book+ let preambles = preamblesFrom book+ let fragments = fragmentsFrom book+ let trailers = trailersFrom book - event "Convert preamble fragments and begin marker to LaTeX"- mapM_ processFragment preambles- setupBeginningFile+ event "Convert preamble fragments and begin marker to LaTeX"+ mapM_ processFragment preambles+ setupBeginningFile - event "Convert document fragments to LaTeX"- mapM_ processFragment fragments+ event "Convert document fragments to LaTeX"+ mapM_ processFragment fragments - event "Convert end marker and trailing fragments to LaTeX"- setupEndingFile- mapM_ processFragment trailers+ event "Convert end marker and trailing fragments to LaTeX"+ setupEndingFile+ mapM_ processFragment trailers - event "Write intermediate LaTeX file"- produceResult+ event "Write intermediate LaTeX file"+ produceResult - event "Render document to PDF"- catch- ( do- renderPDF- case copy of- InstallPdf -> copyHere- NoCopyPdf -> return ()- )- ( \(e :: ExitCode) -> case mode of- Once -> throw e- Cycle -> return ()- )+ event "Render document to PDF"+ catch+ ( do+ renderPDF+ case copy of+ InstallPdf -> copyHere+ NoCopyPdf -> return ()+ )+ ( \(e :: ExitCode) -> case mode of+ Once -> throw e+ Cycle -> return ()+ ) - return (uniqueList file preambles fragments trailers)+ return (uniqueList file preambles fragments trailers) -- -- Quickly reduce the fragment names to a unique list so we don't waste@@ -122,20 +122,20 @@ -- uniqueList :: FilePath -> [FilePath] -> [FilePath] -> [FilePath] -> [FilePath] uniqueList file preambles fragments trailers =- let files = insertElement file (intoSet trailers <> (intoSet preambles <> intoSet fragments))- in fromSet files+ let files = insertElement file (intoSet trailers <> (intoSet preambles <> intoSet fragments))+ in fromSet files extractMode :: Parameters -> Program Env (Mode, Copy) extractMode params =- let mode = case lookupOptionFlag "watch" params of- Just False -> error "Invalid State"- Just True -> Cycle- Nothing -> Once- copy = case lookupOptionFlag "no-copy" params of- Just False -> error "Invalid State"- Just True -> NoCopyPdf- Nothing -> InstallPdf- in return (mode, copy)+ let mode = case lookupOptionFlag "watch" params of+ Just False -> error "Invalid State"+ Just True -> Cycle+ Nothing -> Once+ copy = case lookupOptionFlag "no-copy" params of+ Just False -> error "Invalid State"+ Just True -> NoCopyPdf+ Nothing -> InstallPdf+ in return (mode, copy) {- For the situation where the .book file is in a location other than '.'@@ -144,63 +144,63 @@ -} extractBookFile :: Parameters -> Program Env FilePath extractBookFile params =- let (relative, bookfile) = case lookupArgument "bookfile" params of- Nothing -> error "invalid"- Just file -> splitFileName file- in do- debugS "relative" relative- debugS "bookfile" bookfile- probe <- liftIO $ do- changeWorkingDirectory relative- doesFileExist bookfile- case probe of- True -> return bookfile- False -> do- write ("error: specified .book file \"" <> intoRope bookfile <> "\" not found.")- throw (userError "no such file")+ let (relative, bookfile) = case lookupArgument "bookfile" params of+ Nothing -> error "invalid"+ Just file -> splitFileName file+ in do+ debugS "relative" relative+ debugS "bookfile" bookfile+ probe <- liftIO $ do+ changeWorkingDirectory relative+ doesFileExist bookfile+ case probe of+ True -> return bookfile+ False -> do+ write ("error: specified .book file \"" <> intoRope bookfile <> "\" not found.")+ throw (userError "no such file") setupTargetFile :: FilePath -> Program Env () setupTargetFile file = do- env <- getApplicationState- let start = startingDirectoryFrom env- let dotfile = start ++ "/.target"+ env <- getApplicationState+ let start = startingDirectoryFrom env+ let dotfile = start ++ "/.target" - params <- getCommandLine- tmpdir <- case lookupOptionValue "temp" params of- Just dir -> do- -- Append a slash so that /tmp/booga is taken as a directory.- -- Otherwise, you end up ensuring /tmp exists.- ensureDirectory (dir ++ "/")- return dir- Nothing ->- liftIO $- catch- ( do- dir' <- readFile dotfile- let dir = trim dir'- probe <- doesDirectoryExist dir- if probe- then return dir- else throw boom- )- ( \(_ :: IOError) -> do- dir <- mkdtemp "/tmp/publish-"- writeFile dotfile (dir ++ "\n")- return dir- )- debugS "tmpdir" tmpdir+ params <- getCommandLine+ tmpdir <- case lookupOptionValue "temp" params of+ Just dir -> do+ -- Append a slash so that /tmp/booga is taken as a directory.+ -- Otherwise, you end up ensuring /tmp exists.+ ensureDirectory (dir ++ "/")+ return dir+ Nothing ->+ liftIO $+ catch+ ( do+ dir' <- readFile dotfile+ let dir = trim dir'+ probe <- doesDirectoryExist dir+ if probe+ then return dir+ else throw boom+ )+ ( \(_ :: IOError) -> do+ dir <- mkdtemp "/tmp/publish-"+ writeFile dotfile (dir ++ "\n")+ return dir+ )+ debugS "tmpdir" tmpdir - let master = tmpdir ++ "/" ++ base ++ ".tex"- result = tmpdir ++ "/" ++ base ++ ".pdf"+ let master = tmpdir ++ "/" ++ base ++ ".tex"+ result = tmpdir ++ "/" ++ base ++ ".pdf" - let env' =- env- { intermediateFilenamesFrom = [],- masterFilenameFrom = master,- resultFilenameFrom = result,- tempDirectoryFrom = tmpdir- }- setApplicationState env'+ let env' =+ env+ { intermediateFilenamesFrom = []+ , masterFilenameFrom = master+ , resultFilenameFrom = result+ , tempDirectoryFrom = tmpdir+ }+ setApplicationState env' where base = takeBaseName file -- "/directory/file.ext" -> "file" boom = userError "Temp dir no longer present"@@ -209,22 +209,23 @@ setupPreambleFile :: Program Env () setupPreambleFile = do- env <- getApplicationState- let tmpdir = tempDirectoryFrom env+ env <- getApplicationState+ let tmpdir = tempDirectoryFrom env - params <- getCommandLine- first <- case lookupOptionFlag "builtin-preamble" params of- Nothing -> return []- Just True -> do- let name = "00_Preamble.latex"- let target = tmpdir ++ "/" ++ name- liftIO $ withFile target WriteMode $ \handle -> do- hWrite handle preamble- return [name]- Just _ -> invalid+ params <- getCommandLine+ first <- case lookupOptionFlag "builtin-preamble" params of+ Nothing -> return []+ Just True -> do+ let name = "00_Preamble.latex"+ let target = tmpdir ++ "/" ++ name+ liftIO $+ withFile target WriteMode $ \handle -> do+ hWrite handle preamble+ return [name]+ Just _ -> invalid - let env' = env {intermediateFilenamesFrom = first}- setApplicationState env'+ let env' = env{intermediateFilenamesFrom = first}+ setApplicationState env' {- This could do a lot more; checking to see if \documentclass is present, for@@ -233,86 +234,88 @@ -} validatePreamble :: Bookfile -> Program Env () validatePreamble book = do- params <- getCommandLine- let preambles = preamblesFrom book- let builtin = isJust (lookupOptionFlag "builtin-preamble" params)+ params <- getCommandLine+ let preambles = preamblesFrom book+ let builtin = isJust (lookupOptionFlag "builtin-preamble" params) - if List.null preambles && not builtin- then do- write "error: no preamble\n"- let msg :: Rope =- [quote|+ if List.null preambles && not builtin+ then do+ write "error: no preamble\n"+ let msg :: Rope =+ [quote| You need to either a) put the name of the file including the LaTeX preamble for your document in the .book file between the "% publish" and "% begin" lines, or b) specify the --builtin-preamble option on the command-line when running this program. |]- writeR msg- terminate 2- else return ()+ writeR msg+ terminate 2+ else return () setupBeginningFile :: Program Env () setupBeginningFile = do- env <- getApplicationState- let tmpdir = tempDirectoryFrom env- files = intermediateFilenamesFrom env+ env <- getApplicationState+ let tmpdir = tempDirectoryFrom env+ files = intermediateFilenamesFrom env - file <- do- let name = "99_Beginning.latex"- let target = tmpdir ++ "/" ++ name- liftIO $ withFile target WriteMode $ \handle -> do- hWrite handle beginning- return name+ file <- do+ let name = "99_Beginning.latex"+ let target = tmpdir ++ "/" ++ name+ liftIO $+ withFile target WriteMode $ \handle -> do+ hWrite handle beginning+ return name - let env' = env {intermediateFilenamesFrom = file : files}- setApplicationState env'+ let env' = env{intermediateFilenamesFrom = file : files}+ setApplicationState env' setupEndingFile :: Program Env () setupEndingFile = do- env <- getApplicationState- let tmpdir = tempDirectoryFrom env- files = intermediateFilenamesFrom env+ env <- getApplicationState+ let tmpdir = tempDirectoryFrom env+ files = intermediateFilenamesFrom env - file <- do- let name = "ZZ_Ending.latex"- let target = tmpdir ++ "/" ++ name- liftIO $ withFile target WriteMode $ \handle -> do- hWrite handle ending- return name+ file <- do+ let name = "ZZ_Ending.latex"+ let target = tmpdir ++ "/" ++ name+ liftIO $+ withFile target WriteMode $ \handle -> do+ hWrite handle ending+ return name - let env' = env {intermediateFilenamesFrom = file : files}- setApplicationState env'+ let env' = env{intermediateFilenamesFrom = file : files}+ setApplicationState env' processBookFile :: FilePath -> Program Env Bookfile processBookFile file = do- contents <- liftIO (readFile file)+ contents <- liftIO (readFile file) - let result = runParser parseBookfile file contents- bookfile <- case result of- Left err -> do- write (intoRope (errorBundlePretty err))- terminate 1- Right value -> return value+ let result = runParser parseBookfile file contents+ bookfile <- case result of+ Left err -> do+ write (intoRope (errorBundlePretty err))+ terminate 1+ Right value -> return value - list1 <- filterM skipNotFound (preamblesFrom bookfile)- debugS "preambles" (length list1)+ list1 <- filterM skipNotFound (preamblesFrom bookfile)+ debugS "preambles" (length list1) - list2 <- filterM skipNotFound (fragmentsFrom bookfile)- debugS "fragments" (length list2)+ list2 <- filterM skipNotFound (fragmentsFrom bookfile)+ debugS "fragments" (length list2) - list3 <- filterM skipNotFound (trailersFrom bookfile)- debugS "trailers" (length list3)+ list3 <- filterM skipNotFound (trailersFrom bookfile)+ debugS "trailers" (length list3) - return bookfile {preamblesFrom = list1, fragmentsFrom = list2, trailersFrom = list3}+ return bookfile{preamblesFrom = list1, fragmentsFrom = list2, trailersFrom = list3} where skipNotFound :: FilePath -> Program t Bool skipNotFound fragment = do- probe <- liftIO (doesFileExist fragment)- case probe of- True -> return True- False -> do- write ("warning: Fragment \"" <> intoRope fragment <> "\" not found, skipping")- return False+ probe <- liftIO (doesFileExist fragment)+ case probe of+ True -> return True+ False -> do+ write ("warning: Fragment \"" <> intoRope fragment <> "\" not found, skipping")+ return False {- Which kind of file is it? Dispatch to the appropriate reader switching on@@ -320,16 +323,16 @@ -} processFragment :: FilePath -> Program Env () processFragment file = do- debugS "source" file+ debugS "source" file - -- Read the fragment, process it if Markdown then run it out to LaTeX.- case takeExtension file of- ".markdown" -> convertMarkdown file- ".md" -> convertMarkdown file- ".latex" -> passthroughLaTeX file- ".tex" -> passthroughLaTeX file- ".svg" -> convertImage file- _ -> passthroughImage file+ -- Read the fragment, process it if Markdown then run it out to LaTeX.+ case takeExtension file of+ ".markdown" -> convertMarkdown file+ ".md" -> convertMarkdown file+ ".latex" -> passthroughLaTeX file+ ".tex" -> passthroughLaTeX file+ ".svg" -> convertImage file+ _ -> passthroughImage file {- Convert Markdown to LaTeX. This is where we "call" Pandoc.@@ -350,38 +353,38 @@ -} convertMarkdown :: FilePath -> Program Env () convertMarkdown file =- let readingOptions =- def- { readerExtensions = pandocExtensions,- readerColumns = 75- }- writingOptions =- def- { writerTopLevelDivision = TopLevelSection- }- in do- env <- getApplicationState- let tmpdir = tempDirectoryFrom env- file' = replaceExtension file ".latex"- target = tmpdir ++ "/" ++ file'- files = intermediateFilenamesFrom env+ let readingOptions =+ def+ { readerExtensions = pandocExtensions+ , readerColumns = 75+ }+ writingOptions =+ def+ { writerTopLevelDivision = TopLevelSection+ }+ in do+ env <- getApplicationState+ let tmpdir = tempDirectoryFrom env+ file' = replaceExtension file ".latex"+ target = tmpdir ++ "/" ++ file'+ files = intermediateFilenamesFrom env - ensureDirectory target- ifNewer file target $ do- debugS "target" target- liftIO $ do- contents <- T.readFile file+ ensureDirectory target+ ifNewer file target $ do+ debugS "target" target+ liftIO $ do+ contents <- T.readFile file - latex <- runIOorExplode $ do- parsed <- readMarkdown readingOptions contents- writeLaTeX writingOptions parsed+ latex <- runIOorExplode $ do+ parsed <- readMarkdown readingOptions contents+ writeLaTeX writingOptions parsed - withFile target WriteMode $ \handle -> do- T.hPutStrLn handle latex- T.hPutStr handle "\n"+ withFile target WriteMode $ \handle -> do+ T.hPutStrLn handle latex+ T.hPutStr handle "\n" - let env' = env {intermediateFilenamesFrom = file' : files}- setApplicationState env'+ let env' = env{intermediateFilenamesFrom = file' : files}+ setApplicationState env' {- If a source fragment is already LaTeX, simply copy it through to@@ -389,19 +392,19 @@ -} passthroughLaTeX :: FilePath -> Program Env () passthroughLaTeX file = do- env <- getApplicationState- let tmpdir = tempDirectoryFrom env- target = tmpdir ++ "/" ++ file- files = intermediateFilenamesFrom env+ env <- getApplicationState+ let tmpdir = tempDirectoryFrom env+ target = tmpdir ++ "/" ++ file+ files = intermediateFilenamesFrom env - ensureDirectory target- ifNewer file target $ do- debugS "target" target- liftIO $ do- copyFileWithMetadata file target+ ensureDirectory target+ ifNewer file target $ do+ debugS "target" target+ liftIO $ do+ copyFileWithMetadata file target - let env' = env {intermediateFilenamesFrom = file : files}- setApplicationState env'+ let env' = env{intermediateFilenamesFrom = file : files}+ setApplicationState env' {- Images in SVG format need to be converted to PDF to be able to be@@ -410,126 +413,127 @@ -} convertImage :: FilePath -> Program Env () convertImage file = do- env <- getApplicationState- let tmpdir = tempDirectoryFrom env- basepath = dropExtension file- target = tmpdir ++ "/" ++ basepath ++ ".pdf"- buffer = tmpdir ++ "/" ++ basepath ++ "~tmp.pdf"- inkscape =- [ "inkscape",- "--export-type=pdf",- "--export-filename=" ++ buffer,- file- ]+ env <- getApplicationState+ let tmpdir = tempDirectoryFrom env+ basepath = dropExtension file+ target = tmpdir ++ "/" ++ basepath ++ ".pdf"+ buffer = tmpdir ++ "/" ++ basepath ++ "~tmp.pdf"+ inkscape =+ [ "inkscape"+ , "--export-type=pdf"+ , "--export-filename=" ++ buffer+ , file+ ] - ifNewer file target $ do- debugS "target" target- (exit, out, err) <- do- ensureDirectory target- execProcess inkscape+ ifNewer file target $ do+ debugS "target" target+ (exit, out, err) <- do+ ensureDirectory target+ execProcess inkscape - case exit of- ExitFailure _ -> do- event "Image processing failed"- debug "stderr" (intoRope err)- debug "stdout" (intoRope out)- write ("error: Unable to convert " <> intoRope file <> " from SVG to PDF")- throw exit- ExitSuccess -> liftIO $ do- renameFile buffer target+ case exit of+ ExitFailure _ -> do+ event "Image processing failed"+ debug "stderr" (intoRope err)+ debug "stdout" (intoRope out)+ write ("error: Unable to convert " <> intoRope file <> " from SVG to PDF")+ throw exit+ ExitSuccess -> liftIO $ do+ renameFile buffer target passthroughImage :: FilePath -> Program Env () passthroughImage file = do- env <- getApplicationState- let tmpdir = tempDirectoryFrom env- target = tmpdir ++ "/" ++ file+ env <- getApplicationState+ let tmpdir = tempDirectoryFrom env+ target = tmpdir ++ "/" ++ file - ensureDirectory target- ifNewer file target $ do- debugS "target" target- liftIO $ do- copyFileWithMetadata file target+ ensureDirectory target+ ifNewer file target $ do+ debugS "target" target+ liftIO $ do+ copyFileWithMetadata file target {- Finish up by writing the intermediate "master" file. -} produceResult :: Program Env () produceResult = do- env <- getApplicationState- let master = masterFilenameFrom env- files = intermediateFilenamesFrom env+ env <- getApplicationState+ let master = masterFilenameFrom env+ files = intermediateFilenamesFrom env - debugS "master" master- liftIO $ withFile master WriteMode $ \handle -> do- hPutStrLn handle ("\\RequirePackage{import}")- forM_ (reverse files) $ \file -> do- let (path, name) = splitFileName file- hPutStrLn handle ("\\subimport{" ++ path ++ "}{" ++ name ++ "}")+ debugS "master" master+ liftIO $+ withFile master WriteMode $ \handle -> do+ hPutStrLn handle ("\\RequirePackage{import}")+ forM_ (reverse files) $ \file -> do+ let (path, name) = splitFileName file+ hPutStrLn handle ("\\subimport{" ++ path ++ "}{" ++ name ++ "}") getUserID :: Program a String getUserID = liftIO $ do- uid <- getEffectiveUserID- gid <- getEffectiveGroupID- return (show uid ++ ":" ++ show gid)+ uid <- getEffectiveUserID+ gid <- getEffectiveGroupID+ return (show uid ++ ":" ++ show gid) renderPDF :: Program Env () renderPDF = do- env <- getApplicationState+ env <- getApplicationState - let master = masterFilenameFrom env- tmpdir = tempDirectoryFrom env+ let master = masterFilenameFrom env+ tmpdir = tempDirectoryFrom env - user <- getUserID+ user <- getUserID - params <- getCommandLine- let command = case lookupOptionValue "docker" params of- Just image ->- [ "docker",- "run",- "--rm=true",- "--volume=" ++ tmpdir ++ ":" ++ tmpdir,- "--user=" ++ user,- image,- "latexmk"- ]- Nothing ->- [ "latexmk"- ]- options =- [ "-lualatex",- "-output-directory=" ++ tmpdir,- "-interaction=nonstopmode",- "-halt-on-error",- "-file-line-error",- "-cd",- master- ]- latexmk = command ++ options+ params <- getCommandLine+ let command = case lookupOptionValue "docker" params of+ Just image ->+ [ "docker"+ , "run"+ , "--rm=true"+ , "--volume=" ++ tmpdir ++ ":" ++ tmpdir+ , "--user=" ++ user+ , image+ , "latexmk"+ ]+ Nothing ->+ [ "latexmk"+ ]+ options =+ [ "-lualatex"+ , "-output-directory=" ++ tmpdir+ , "-interaction=nonstopmode"+ , "-halt-on-error"+ , "-file-line-error"+ , "-cd"+ , master+ ]+ latexmk = command ++ options - (exit, out, err) <- execProcess latexmk- case exit of- ExitFailure _ -> do- event "Render failed"- debug "stderr" (intoRope err)- debug "stdout" (intoRope out)- write (parseOutputForError tmpdir out)- throw exit- ExitSuccess -> return ()+ (exit, out, err) <- execProcess latexmk+ case exit of+ ExitFailure _ -> do+ event "Render failed"+ debug "stderr" (intoRope err)+ debug "stdout" (intoRope out)+ write (parseOutputForError tmpdir out)+ throw exit+ ExitSuccess -> return () copyHere :: Program Env () copyHere = do- env <- getApplicationState- let result = resultFilenameFrom env- start = startingDirectoryFrom env- final = replaceDirectory result start -- ie ./Book.pdf- changed <- isNewer result final- case changed of- True -> do- event "Copy resultant PDF to starting directory"- debugS "result" result- debugS "final" final- liftIO $ do- copyFileWithMetadata result final- event "Complete"- False -> do- event "Result unchanged"+ env <- getApplicationState+ let result = resultFilenameFrom env+ start = startingDirectoryFrom env+ final = replaceDirectory result start -- ie ./Book.pdf+ changed <- isNewer result final+ case changed of+ True -> do+ event "Copy resultant PDF to starting directory"+ debugS "result" result+ debugS "final" final+ liftIO $ do+ copyFileWithMetadata result final+ event "Complete"+ False -> do+ event "Result unchanged"
src/RenderMain.hs view
@@ -20,67 +20,67 @@ main :: IO () main = do- env <- initial- context <-- configure- version- env- ( simple- [ Option- "builtin-preamble"- (Just 'p')- Empty- [quote|+ env <- initial+ context <-+ configure+ version+ env+ ( simple+ [ Option+ "builtin-preamble"+ (Just 'p')+ Empty+ [quote| Wrap a built-in LaTeX preamble (and ending) around your supplied source fragments. Most documents will put their own custom preamble as the first fragment in the .book file, but for getting started a suitable default can be employed via this option.- |],- Option- "watch"- Nothing- Empty- [quote|+ |]+ , Option+ "watch"+ Nothing+ Empty+ [quote| Watch all sources listed in the bookfile and re-run the rendering engine if changes are detected.- |],- Option- "no-copy"- Nothing- Empty- [quote|+ |]+ , Option+ "no-copy"+ Nothing+ Empty+ [quote| Should the resultant PDF be copied to this directory? Of course it should, so the default is true. Select this if you want to leave the file in /tmp.- |],- Option- "temp"- Nothing- (Value "TMPDIR")- [quote|+ |]+ , Option+ "temp"+ Nothing+ (Value "TMPDIR")+ [quote| The working location for assembling converted fragments and caching intermediate results between runs. By default, a temporary directory will be created in /tmp.- |],- Option- "docker"- Nothing- (Value "IMAGE")- [quote|+ |]+ , Option+ "docker"+ Nothing+ (Value "IMAGE")+ [quote| Run the specified Docker image in a container, mount the target directory into it as a volume, and do the build there. This allows you to have all of the LaTeX dependencies separate from the machine you are editing on.- |],- Argument- "bookfile"- [quote|+ |]+ , Argument+ "bookfile"+ [quote| The file containing the list of fragments making up this book. If the argument is specified as "Hobbit.book" then "Hobbit" will be used as the basename for the final output .pdf file. |]- ]- )+ ]+ ) - executeWith context program+ executeWith context program
tests/CheckTableProperties.hs view
@@ -2,161 +2,93 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} -module CheckTableProperties- ( checkTableProperties,- )-where+module CheckTableProperties (+ checkTableProperties,+) where -import Control.DeepSeq (force)-import Control.Exception (evaluate) import Core.Text-import FormatDocument (markdownToPandoc)-import PandocToMarkdown- ( NotSafe,- Rectangle (..),- buildRow,- combineRectangles,- heightOf,- pandocToMarkdown,- rectanglerize,+import PandocToMarkdown ( tableToMarkdown,- )+ ) import Test.Hspec-import Text.Pandoc (Alignment (..), Block (..), Inline (..))--notsafe :: Selector NotSafe-notsafe = const True+import Text.Pandoc checkTableProperties :: Spec checkTableProperties = do- describe "Table rendering code" $ do- it "Making wrapped text into rectangles" $- rectanglerize 6 AlignLeft "First Name"- `shouldBe` Rectangle- 6- 2- [ "First ",- "Name "- ]-- it "Rectanglerizing a block with too long lines should throw" $- (evaluate . force) (rectanglerize 7 AlignLeft "Borough of Kensington") `shouldThrow` notsafe-- it "Two rectangles of equal size combine" $- let rect1 = rectanglerize 8 AlignLeft "This is a test"- rect2 = rectanglerize 8 AlignLeft "Ode to Joy"- result = combineRectangles rect1 rect2- in do- heightOf rect1 `shouldBe` 2- heightOf rect2 `shouldBe` 2- heightOf result `shouldBe` 2- result- `shouldBe` Rectangle- 16- 2- [ "This is Ode to ",- "a test Joy "- ]-- it "Two rectangles of unequal size combine (1)" $- let -- 1234567890- rect1 = rectanglerize 10 AlignLeft "Emergency Broadcast System"- rect2 = rectanglerize 10 AlignLeft "Ode to Joy is nice"- result = combineRectangles rect1 rect2- in do- heightOf rect1 `shouldBe` 3- heightOf rect2 `shouldBe` 2- heightOf result `shouldBe` 3- result- `shouldBe` Rectangle- 20- 3- [ "Emergency Ode to Joy",- "Broadcast is nice ",- "System "- ]-- it "Two rectangles of unequal size combine (2)" $- let -- 1234567890- rect3 = rectanglerize 10 AlignLeft "This is an emergency"- rect4 = rectanglerize 10 AlignLeft "Ode to Joy is nice piece that lots play"- result = combineRectangles rect3 rect4- in do- heightOf rect3 `shouldBe` 2- heightOf rect4 `shouldBe` 4- heightOf result `shouldBe` 4- result- `shouldBe` Rectangle- 20- 4- [ "This is anOde to Joy",- "emergency is nice ",- " piece that",- " lots play "- ]-- it "Given several cells, builds a row" $- let cell1 =- Rectangle- 10- 3- [ "This is an",- "emergency ",- "no problem"- ]- cell2 =- Rectangle- 10- 4- [ "Ode to Joy",- "is nice ",- "piece that",- "lots play "- ]- result = buildRow [10, 10] [cell1, cell2]- in do- result- `shouldBe` "This is an Ode to Joy\n"- <> "emergency is nice \n"- <> "no problem piece that\n"- <> " lots play "-- it "Header rows format" $- let result =- tableToMarkdown- []- [AlignLeft, AlignLeft, AlignLeft]- [0.3, 0.3, 0.3]- [ [Plain [Str "First"]],- [Plain [Str "Second"]],- [Plain [Str "Third"]]- ]- []- in do- result- `shouldBe` [quote|-------------------------------------------------------------------------First Second Third ------------------------ ----------------------- ------------------------------------------------------------------------------------------------- |]-- it "A minimal complete example reformats properly" $- let table =- [quote|+ describe "Table rendering code" $ do+ it "Header rows format" $+ let result =+ tableToMarkdown+ ("", [], [])+ ( Caption+ Nothing+ []+ )+ [ (AlignRight, ColWidthDefault)+ , (AlignCenter, ColWidthDefault)+ , (AlignDefault, ColWidth 0.5)+ ]+ ( TableHead+ ("", [], [])+ [ Row+ ("", [], [])+ [ Cell+ ("", [], [])+ AlignDefault+ (RowSpan 1)+ (ColSpan 1)+ [Plain [Str "First"]]+ , Cell+ ("", [], [])+ AlignDefault+ (RowSpan 1)+ (ColSpan 1)+ [Plain [Str "Second"]]+ , Cell+ ("", [], [])+ AlignDefault+ (RowSpan 1)+ (ColSpan 1)+ [Plain [Str "Third"]]+ ]+ ]+ )+ [ ( TableBody+ ("", [], [])+ (RowHeadColumns 0)+ []+ [ Row+ ("", [], [])+ [ Cell+ ("", [], [])+ AlignDefault+ (RowSpan 1)+ (ColSpan 1)+ [Plain [Str "1"]]+ , Cell+ ("", [], [])+ AlignDefault+ (RowSpan 1)+ (ColSpan 1)+ [Plain [Str "2"]]+ , Cell+ ("", [], [])+ AlignDefault+ (RowSpan 1)+ (ColSpan 1)+ [Plain [Str "3"]]+ ]+ ]+ )+ ]+ ( TableFoot+ ("", [], [])+ []+ )+ in do+ result+ `shouldBe` [quote| | First | Second | Third |-|------:|:----:|---------|-| 1 | 2 | 3 |- |]- in do- doc <- markdownToPandoc table- let result = pandocToMarkdown doc- result- `shouldBe` [quote|---------------------------------------------- First Second Third --------------- -------------- --------------- 1 2 3 ---------------------------------------------+|-------:|:------:|---------------------------------------|+| 1 | 2 | 3 | |]
tests/CompareFragments.hs view
@@ -2,10 +2,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module CompareFragments- ( checkByComparingFragments,- )-where+module CompareFragments (+ checkByComparingFragments,+) where import Core.Text import qualified Data.Text.IO as T@@ -15,30 +14,30 @@ fragments :: [(String, FilePath)] fragments =- [ ("headings", "tests/fragments/Headings.markdown"),- ("paragraphs", "tests/fragments/Paragraphs.markdown"),- ("code blocks", "tests/fragments/CodeBlocks.markdown"),- ("div blocks", "tests/fragments/DivBlocks.markdown"),- ("LaTeX blocks", "tests/fragments/LatexBlocks.markdown"),- ("HTML blocks", "tests/fragments/HtmlBlocks.markdown"),- ("poem passage", "tests/fragments/Poetry.markdown"),- ("blockquotes", "tests/fragments/Blockquotes.markdown"),- ("bullet list", "tests/fragments/BulletList.markdown"),- ("ordered list", "tests/fragments/OrderedList.markdown"),- ("definition list", "tests/fragments/DefinitionList.markdown"),- ("multiline table", "tests/fragments/MultilineTable.markdown"),- ("weird inlines", "tests/fragments/WeirdInlines.markdown")- ]+ [ ("headings", "tests/fragments/Headings.markdown")+ , ("paragraphs", "tests/fragments/Paragraphs.markdown")+ , ("code blocks", "tests/fragments/CodeBlocks.markdown")+ , ("div blocks", "tests/fragments/DivBlocks.markdown")+ , ("LaTeX blocks", "tests/fragments/LatexBlocks.markdown")+ , ("HTML blocks", "tests/fragments/HtmlBlocks.markdown")+ , ("poem passage", "tests/fragments/Poetry.markdown")+ , ("blockquotes", "tests/fragments/Blockquotes.markdown")+ , ("bullet list", "tests/fragments/BulletList.markdown")+ , ("ordered list", "tests/fragments/OrderedList.markdown")+ , ("definition list", "tests/fragments/DefinitionList.markdown")+ , ("pipe table", "tests/fragments/PipeTable.md")+ , ("weird inlines", "tests/fragments/WeirdInlines.markdown")+ ] checkByComparingFragments :: Spec checkByComparingFragments =- describe "Compare fragments" $ do- sequence_ (map compareFragment fragments)+ describe "Compare fragments" $ do+ sequence_ (map compareFragment fragments) compareFragment :: (String, FilePath) -> SpecWith () compareFragment (label, file) =- it ("Formats " ++ label ++ " correctly") $ do- original <- T.readFile file- doc <- markdownToPandoc original- let text = pandocToMarkdown doc- fromRope text `shouldBe` original+ it ("Formats " ++ label ++ " correctly") $ do+ original <- T.readFile file+ doc <- markdownToPandoc original+ let text = pandocToMarkdown doc+ fromRope text `shouldBe` original