diff --git a/publish.cabal b/publish.cabal --- a/publish.cabal +++ b/publish.cabal @@ -1,83 +1,113 @@ cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.31.1. --- --- see: https://github.com/sol/hpack --- --- hash: 41c25ce1051d93b85743e4f7cc0fd8b69bae4d522b04c60eea9cb5624fd5ae98 +name: publish +version: 0.4.4 +license: BSD3 +license-file: LICENCE +copyright: © 2016-2019 Operational Dynamics Consulting Pty Ltd, and Others +maintainer: Andrew Cowie +author: Andrew Cowie +stability: experimental +tested-with: ghc ==8.6 +homepage: https://github.com/oprdyn/publish#readme +bug-reports: https://github.com/oprdyn/publish/issues +synopsis: Publishing tools for papers, books, and presentations +description: + Tools for rendering markdown-centric documents into PDFs. + . + A description of this package, a list of features, and some background + to its design is contained in the + + on GitHub. + . + The main program, @render@, is available via a Docker image at + +category: Text +build-type: Simple -name: publish -version: 0.3.2 -synopsis: Publishing tools for papers, books, and presentations -description: Tools for rendering markdown-centric documents into PDFs. - . - A description of this package, a list of features, and some background - to its design is contained in the - - on GitHub. - . - The main program, @render@, is available via a Docker image at - -category: Text -stability: experimental -author: Andrew Cowie -maintainer: Andrew Cowie -copyright: © 2016-2019 Operational Dynamics Consulting Pty Ltd, and Others -license: BSD3 -license-file: LICENCE -tested-with: GHC == 8.4 -build-type: Simple +source-repository head + type: git + location: https://github.com/oprdyn/publish executable format - main-is: FormatMain.hs - other-modules: - FormatDocument - hs-source-dirs: - src - ghc-options: -threaded -Wall -Wwarn -fwarn-tabs - build-depends: - base >=4.11 && <5 - , bytestring - , chronologique - , directory - , filepath - , hinotify - , pandoc - , pandoc-types - , template-haskell - , text - , typed-process - , unbeliever >=0.8.0 - , unix - , unordered-containers - default-language: Haskell2010 + main-is: FormatMain.hs + hs-source-dirs: src + other-modules: + FormatDocument + PandocToMarkdown + default-language: Haskell2010 + ghc-options: -threaded -Wall -Wwarn -fwarn-tabs + build-depends: + base >=4.11 && <5, + bytestring >=0.10.8.2 && <0.11, + chronologique >=0.3.1.1 && <0.4, + deepseq >=1.4.4.0 && <1.5, + directory >=1.3.3.0 && <1.4, + filepath >=1.4.2.1 && <1.5, + hinotify ==0.4.*, + pandoc ==2.5.*, + pandoc-types >=1.17.5.4 && <1.18, + template-haskell >=2.14.0.0 && <2.15, + text >=1.2.3.1 && <1.3, + typed-process >=0.2.4.0 && <0.3, + unbeliever >=0.9.3.2 && <0.10, + unix >=2.7.2.2 && <2.8, + unordered-containers >=0.2.9.0 && <0.3 executable render - main-is: RenderMain.hs - other-modules: - RenderDocument - Environment - LatexPreamble - NotifyChanges - OutputParser - Paths_publish - Utilities - hs-source-dirs: - src - ghc-options: -threaded -Wall -Wwarn -fwarn-tabs - build-depends: - base >=4.11 && <5 - , bytestring - , chronologique - , directory - , filepath - , hinotify - , pandoc - , pandoc-types - , template-haskell - , text - , typed-process - , unbeliever >=0.8.0 - , unix - , unordered-containers - default-language: Haskell2010 + main-is: RenderMain.hs + hs-source-dirs: src + other-modules: + Environment + LatexPreamble + NotifyChanges + OutputParser + PandocToMarkdown + RenderDocument + Utilities + default-language: Haskell2010 + ghc-options: -threaded -Wall -Wwarn -fwarn-tabs + build-depends: + base >=4.11 && <5, + bytestring >=0.10.8.2 && <0.11, + chronologique >=0.3.1.1 && <0.4, + deepseq >=1.4.4.0 && <1.5, + directory >=1.3.3.0 && <1.4, + filepath >=1.4.2.1 && <1.5, + hinotify ==0.4.*, + pandoc ==2.5.*, + pandoc-types >=1.17.5.4 && <1.18, + template-haskell >=2.14.0.0 && <2.15, + text >=1.2.3.1 && <1.3, + typed-process >=0.2.4.0 && <0.3, + unbeliever >=0.9.3.2 && <0.10, + unix >=2.7.2.2 && <2.8, + unordered-containers >=0.2.9.0 && <0.3 + +test-suite check + type: exitcode-stdio-1.0 + main-is: TestSuite.hs + hs-source-dirs: src tests + other-modules: + CheckTableProperties + CompareFragments + FormatDocument + PandocToMarkdown + default-language: Haskell2010 + ghc-options: -threaded -Wall -Wwarn -fwarn-tabs -threaded + build-depends: + base >=4.11 && <5, + bytestring >=0.10.8.2 && <0.11, + chronologique >=0.3.1.1 && <0.4, + deepseq >=1.4.4.0 && <1.5, + directory >=1.3.3.0 && <1.4, + filepath >=1.4.2.1 && <1.5, + hinotify ==0.4.*, + hspec >=2.6.1 && <2.7, + pandoc ==2.5.*, + pandoc-types >=1.17.5.4 && <1.18, + template-haskell >=2.14.0.0 && <2.15, + text >=1.2.3.1 && <1.3, + typed-process >=0.2.4.0 && <0.3, + unbeliever >=0.9.3.2 && <0.10, + unix >=2.7.2.2 && <2.8, + unordered-containers >=0.2.9.0 && <0.3 diff --git a/src/FormatDocument.hs b/src/FormatDocument.hs --- a/src/FormatDocument.hs +++ b/src/FormatDocument.hs @@ -3,16 +3,24 @@ module FormatDocument ( program + , loadFragment + , markdownToPandoc ) where import Core.Program import Core.System +import Core.Text + +import qualified Data.Text as T (Text) import qualified Data.Text.IO as T -import Text.Pandoc (runIOorExplode, readMarkdown, writeMarkdown, def - , readerExtensions, pandocExtensions, writerExtensions, writerColumns - , writerSetextHeaders, writerWrapText, WrapOption(WrapAuto), Pandoc) +import System.IO (withFile, IOMode(..)) +import Text.Pandoc (runIOorExplode, readMarkdown, def + , ReaderOptions(readerExtensions), pandocExtensions, disableExtension + , Extension(..), Pandoc, Extensions) +import PandocToMarkdown + program :: Program None () program = do event "Identify document fragment" @@ -36,29 +44,38 @@ loadFragment :: FilePath -> Program None Pandoc loadFragment file = + liftIO $ do + contents <- T.readFile file + markdownToPandoc contents + +-- +-- Unlike the render use case, here we suppress certain +-- options which mess up the ASCII form of the source documents +-- +markdownToPandoc :: T.Text -> IO Pandoc +markdownToPandoc contents = let + disableFrom :: Extensions -> [Extension] -> Extensions + disableFrom extensions list = foldr disableExtension extensions list + readingOptions = def - { readerExtensions = pandocExtensions + { readerExtensions = disableFrom pandocExtensions + [ Ext_implicit_figures + , Ext_shortcut_reference_links + , Ext_smart + ] } - in - liftIO $ do - contents <- T.readFile file - runIOorExplode $ do - readMarkdown readingOptions contents + in do + runIOorExplode $ do + readMarkdown readingOptions contents writeResult :: FilePath -> Pandoc -> Program None () writeResult file doc = let result = file ++ "-tmp" - writingOptions = def - { writerExtensions = pandocExtensions - , writerWrapText = WrapAuto - , writerColumns = 75 - , writerSetextHeaders = True - } + contents' = pandocToMarkdown doc in liftIO $ do - contents' <- runIOorExplode $ do - writeMarkdown writingOptions doc - T.writeFile result contents' + withFile result WriteMode $ \handle -> + hWrite handle contents' diff --git a/src/LatexPreamble.hs b/src/LatexPreamble.hs --- a/src/LatexPreamble.hs +++ b/src/LatexPreamble.hs @@ -90,6 +90,56 @@ \setsubsecheadstyle{\normalsize\sffamily\bfseries} \setsubsubsecheadstyle{\normalsize\rmfamily\itshape} +% +% Output from Skylighting.styleToLaTeX +% + +\usepackage{color} +\usepackage{fancyvrb} +\newcommand{\VerbBar}{|} +\newcommand{\VERB}{\Verb[commandchars=\\\{\}]} +\DefineVerbatimEnvironment{Highlighting}{Verbatim}{commandchars=\\\{\}} +% Add ',fontsize=\small' for more characters per line +\usepackage{framed} +\definecolor{shadecolor}{RGB}{248,248,248} +\newenvironment{Shaded}{\begin{snugshade}}{\end{snugshade}} +\newcommand{\AlertTok}[1]{\textcolor[rgb]{0.94,0.16,0.16}{#1}} +\newcommand{\AnnotationTok}[1]{\textcolor[rgb]{0.56,0.35,0.01}{\textbf{\textit{#1}}}} +\newcommand{\AttributeTok}[1]{\textcolor[rgb]{0.77,0.63,0.00}{#1}} +\newcommand{\BaseNTok}[1]{\textcolor[rgb]{0.00,0.00,0.81}{#1}} +\newcommand{\BuiltInTok}[1]{#1} +\newcommand{\CharTok}[1]{\textcolor[rgb]{0.31,0.60,0.02}{#1}} +\newcommand{\CommentTok}[1]{\textcolor[rgb]{0.56,0.35,0.01}{\textit{#1}}} +\newcommand{\CommentVarTok}[1]{\textcolor[rgb]{0.56,0.35,0.01}{\textbf{\textit{#1}}}} +\newcommand{\ConstantTok}[1]{\textcolor[rgb]{0.00,0.00,0.00}{#1}} +\newcommand{\ControlFlowTok}[1]{\textcolor[rgb]{0.13,0.29,0.53}{\textbf{#1}}} +\newcommand{\DataTypeTok}[1]{\textcolor[rgb]{0.13,0.29,0.53}{#1}} +\newcommand{\DecValTok}[1]{\textcolor[rgb]{0.00,0.00,0.81}{#1}} +\newcommand{\DocumentationTok}[1]{\textcolor[rgb]{0.56,0.35,0.01}{\textbf{\textit{#1}}}} +\newcommand{\ErrorTok}[1]{\textcolor[rgb]{0.64,0.00,0.00}{\textbf{#1}}} +\newcommand{\ExtensionTok}[1]{#1} +\newcommand{\FloatTok}[1]{\textcolor[rgb]{0.00,0.00,0.81}{#1}} +\newcommand{\FunctionTok}[1]{\textcolor[rgb]{0.00,0.00,0.00}{#1}} +\newcommand{\ImportTok}[1]{#1} +\newcommand{\InformationTok}[1]{\textcolor[rgb]{0.56,0.35,0.01}{\textbf{\textit{#1}}}} +\newcommand{\KeywordTok}[1]{\textcolor[rgb]{0.13,0.29,0.53}{\textbf{#1}}} +\newcommand{\NormalTok}[1]{#1} +\newcommand{\OperatorTok}[1]{\textcolor[rgb]{0.81,0.36,0.00}{\textbf{#1}}} +\newcommand{\OtherTok}[1]{\textcolor[rgb]{0.56,0.35,0.01}{#1}} +\newcommand{\PreprocessorTok}[1]{\textcolor[rgb]{0.56,0.35,0.01}{\textit{#1}}} +\newcommand{\RegionMarkerTok}[1]{#1} +\newcommand{\SpecialCharTok}[1]{\textcolor[rgb]{0.00,0.00,0.00}{#1}} +\newcommand{\SpecialStringTok}[1]{\textcolor[rgb]{0.31,0.60,0.02}{#1}} +\newcommand{\StringTok}[1]{\textcolor[rgb]{0.31,0.60,0.02}{#1}} +\newcommand{\VariableTok}[1]{\textcolor[rgb]{0.00,0.00,0.00}{#1}} +\newcommand{\VerbatimStringTok}[1]{\textcolor[rgb]{0.31,0.60,0.02}{#1}} +\newcommand{\WarningTok}[1]{\textcolor[rgb]{0.56,0.35,0.01}{\textbf{\textit{#1}}}} + +\usepackage[normalem]{ulem} +% avoid problems with \sout in headers with hyperref: +\pdfstringdefDisableCommands{\renewcommand{\sout}{}} + + \begin{document} |] diff --git a/src/PandocToMarkdown.hs b/src/PandocToMarkdown.hs new file mode 100644 --- /dev/null +++ b/src/PandocToMarkdown.hs @@ -0,0 +1,473 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + +module PandocToMarkdown + ( pandocToMarkdown + , NotSafe(..) + , Rectangle(..) + , rectanglerize + , combineRectangles + , buildRow + , widthOf + , heightOf + , tableToMarkdown + ) +where + +import Control.DeepSeq (NFData) +import Core.Text +import Core.System +import Data.Foldable (foldl') +import Data.Monoid (Monoid(..)) +import Data.Semigroup (Semigroup(..)) +import Data.List (intersperse) +import GHC.Generics (Generic) +import Text.Pandoc (Pandoc(..), Block(..), Inline(..), Attr, Format(..) + , ListAttributes, Alignment(..), TableCell, MathType(..), QuoteType(..)) +import Text.Pandoc.Shared (orderedListMarkers) + +__WIDTH__ :: Int +__WIDTH__ = 78 + +pandocToMarkdown :: Pandoc -> Rope +pandocToMarkdown (Pandoc _ 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 :: 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 + +{- +This does **not** emit a newline at the end. The intersperse happening in +`blocksToMarkdown` will terminate the line, but you won't get a blank line +between blocks as is the convention everywhere else (this was critical when +lists were nested in tight lists). +-} +plaintextToMarkdown :: Int -> [Inline] -> Rope +plaintextToMarkdown margin inlines = + wrap' margin (inlinesToMarkdown inlines) + +{- +Everything was great until we had to figure out how to deal with line +breaks aka
, represented in Markdown by [' ',' ']. We do this by +replacing the line break Inline with \x2028. This character, U+2028 LS, is +the Line Separator character. It's one of those symbols up in General +Punctuation that no one ever uses. So we use it as a sentinel internally +here; first we break on those, and then we wrap the results. +-} +paragraphToMarkdown :: Int -> [Inline] -> Rope +paragraphToMarkdown margin inlines = + wrap' margin (inlinesToMarkdown inlines) <> "\n" + +wrap' :: Int -> Rope -> Rope +wrap' margin = + 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" + +codeToMarkdown :: Attr -> String -> Rope +codeToMarkdown attr literal = + 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" + where + prefix inlines = "| " <> inlinesToMarkdown inlines + +quoteToMarkdown :: Int -> [Block] -> Rope +quoteToMarkdown margin blocks = + foldl' (\text block -> text <> prefix block) emptyRope blocks + where + prefix :: Block -> Rope + prefix = foldl' (\text line -> text <> "> " <> line <> "\n") emptyRope . rows + + rows :: Block -> [Rope] + rows = breakLines . convertBlock (margin - 2) + +bulletlistToMarkdown :: Int -> [[Block]] -> Rope +bulletlistToMarkdown = listToMarkdown (repeat "- ") + +orderedlistToMarkdown :: Int -> ListAttributes -> [[Block]] -> Rope +orderedlistToMarkdown margin (num,style,delim) 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 + where + handleDefinition :: ([Inline],[[Block]]) -> Rope + handleDefinition (term,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 + where + pairs = zip markers items + + listitem :: Rope -> [Block] -> Rope + listitem _ [] = emptyRope + listitem marker blocks = indent marker blocks + +{- +Tricky. Tight lists are represented by Plain, whereas more widely spaced +lists are represented by Para. A complex block (specifically a nested +list!) will handle its own spacing. This seems fragile. +-} + spacer :: [Block] -> Rope + spacer [] = emptyRope + spacer (block:_) = case block of + Plain _ -> emptyRope + Para _ -> "\n" + _ -> emptyRope -- ie nested list + + indent :: Rope -> [Block] -> Rope + indent marker = + 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") + +{- +In Pandoc flavoured Markdown,
are recognized as valid Markdown via +the `native_divs` extension. We turn that off, in favour of the +`fenced_divs` extension, three (or more) colons + + ::: {#identifier .class key=value} + Content + ::: + +-} +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" + +-- special case for (notably) code blocks where a single class doesn't need braces. +fencedAttributesToMarkdown :: Attr -> Rope +fencedAttributesToMarkdown ("", [], []) = emptyRope +fencedAttributesToMarkdown ("", [single], []) = intoRope single +fencedAttributesToMarkdown (identifier, [], []) = " " <> attributesToMarkdown (identifier, [], []) +fencedAttributesToMarkdown (identifier, classes, pairs) = " " <> attributesToMarkdown (identifier, classes, pairs) + +-- present attributes, used by both fenced blocks and inline spans +attributesToMarkdown :: Attr -> Rope +attributesToMarkdown ("", [], []) = emptyRope +attributesToMarkdown (identifier, [], []) = "{#" <> intoRope identifier <> "}" +attributesToMarkdown (identifier, classes, pairs) = + let + i = if 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" + 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") + + + +data NotSafe = NotSafe String + deriving Show + +instance Exception NotSafe + +data Rectangle = Rectangle Int Int [Rope] + deriving (Eq, Show, Generic, NFData) + +widthOf :: Rectangle -> Int +widthOf (Rectangle size _ _) = size + +heightOf :: Rectangle -> Int +heightOf (Rectangle _ height _) = height + +rowsFrom :: Rectangle -> [Rope] +rowsFrom (Rectangle _ _ texts) = texts + +instance Semigroup Rectangle where + (<>) = combineRectangles + +instance Monoid Rectangle where + mempty = Rectangle 0 0 [] + +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 + +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 + +ensureWidth :: Int -> Rectangle -> Rectangle +ensureWidth request rect = + if widthOf rect < request + then rectanglerize request AlignLeft (foldl' (<>) emptyRope (rowsFrom rect)) + else rect + + +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)) + +vertical :: Char -> [Rectangle] -> Rectangle +vertical ch rects = + let + height = maximum (fmap heightOf rects) + border = replicate height (intoRope [ch]) + in + Rectangle 1 height border + +---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- + +inlinesToMarkdown :: [Inline] -> Rope +inlinesToMarkdown 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 string -> stringToMarkdown string + 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 string -> mathToMarkdown mode string + -- 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 +seems to be how it describes an escaped space in Markdown. So scan for these +and replace the escaped space on output. +-} +stringToMarkdown :: String -> Rope +stringToMarkdown = + mconcat . intersperse "\\ " . breakPieces isNonBreaking . intoRope + where + isNonBreaking c = c == '\x00a0' + +imageToMarkdown :: Attr -> [Inline] -> (String,String) -> Rope +imageToMarkdown attr inlines (url,title) = + let + alt = inlinesToMarkdown inlines + target = case title of + [] -> intoRope url + _ -> intoRope url <> " \"" <> intoRope title <> "\"" + in + "![" <> alt <> "](" <> target <> ")" <> attributesToMarkdown attr + +uriToMarkdown :: String -> Rope +uriToMarkdown url = + let + target = intoRope url + in + "<" <> target <> ">" + +linkToMarkdown :: Attr -> [Inline] -> (String,String) -> Rope +linkToMarkdown attr inlines (url,title) = + let + text = inlinesToMarkdown inlines + target = case title of + [] -> intoRope url + _ -> intoRope url <> " \"" <> intoRope title <> "\"" + in + "[" <> text <> "](" <> target <> ")" <> attributesToMarkdown attr + +-- is there more to this? +mathToMarkdown :: MathType -> String -> Rope +mathToMarkdown (InlineMath) math = "$" <> intoRope math <> "$" +mathToMarkdown (DisplayMath) math = "$$" <> intoRope math <> "$$" + +smallcapsToMarkdown :: [Inline] -> Rope +smallcapsToMarkdown inlines = + let + text = inlinesToMarkdown inlines + in + "[" <> text <> "]{.smallcaps}" + +spanToMarkdown :: Attr -> [Inline] -> Rope +spanToMarkdown attr inlines = + let + text = inlinesToMarkdown inlines + in + "[" <> text <> "]" <> attributesToMarkdown attr diff --git a/src/RenderDocument.hs b/src/RenderDocument.hs --- a/src/RenderDocument.hs +++ b/src/RenderDocument.hs @@ -26,8 +26,8 @@ import System.Posix.Temp (mkdtemp) import System.Posix.User (getEffectiveUserID, getEffectiveGroupID) import Text.Pandoc (runIOorExplode, readMarkdown, writeLaTeX, def - , readerExtensions, pandocExtensions, writerTopLevelDivision - , TopLevelDivision(TopLevelChapter)) + , readerExtensions, readerColumns, pandocExtensions + , writerTopLevelDivision, TopLevelDivision(TopLevelChapter)) import Environment (Env(..)) import NotifyChanges (waitForChange) @@ -122,26 +122,32 @@ let start = startingDirectoryFrom env let dotfile = start ++ "/.target" - tmpdir <- 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 - ) + 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" - params <- getCommandLine first <- case lookupOptionFlag "builtin-preamble" params of Nothing -> return [] Just True -> do @@ -200,7 +206,9 @@ -- 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 @@ -224,9 +232,14 @@ convertMarkdown :: FilePath -> Program Env () convertMarkdown file = let - readingOptions = def { readerExtensions = pandocExtensions } + readingOptions = def + { readerExtensions = pandocExtensions + , readerColumns = 75 + } - writingOptions = def { writerTopLevelDivision = TopLevelChapter } + writingOptions = def + { writerTopLevelDivision = TopLevelChapter + } in do env <- getApplicationState diff --git a/src/RenderMain.hs b/src/RenderMain.hs --- a/src/RenderMain.hs +++ b/src/RenderMain.hs @@ -28,6 +28,11 @@ Watch all sources listed in the bookfile and re-run the rendering engine if changes are detected. |] + , 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| Run the specified Docker image in a container, mount the target directory into it as a volume, and do the build there. This allows diff --git a/src/Utilities.hs b/src/Utilities.hs --- a/src/Utilities.hs +++ b/src/Utilities.hs @@ -16,8 +16,8 @@ import Core.System import Core.Text import qualified Data.List as List (intercalate) -import System.Directory (doesDirectoryExist, doesFileExist, createDirectory - , getModificationTime, copyFileWithMetadata) +import System.Directory (doesDirectoryExist, doesFileExist, createDirectoryIfMissing + , getModificationTime) import System.Exit (ExitCode(..)) import System.FilePath.Posix (takeDirectory) import System.Process.Typed (proc, readProcess, setStdin, closed) @@ -33,7 +33,7 @@ in liftIO $ do probe <- doesDirectoryExist subdir when (not probe) $ do - createDirectory subdir + createDirectoryIfMissing True subdir {- Thin wrapper around **typed-process**'s `readProcess` so that the command diff --git a/tests/CheckTableProperties.hs b/tests/CheckTableProperties.hs new file mode 100644 --- /dev/null +++ b/tests/CheckTableProperties.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module CheckTableProperties + ( checkTableProperties + ) +where + +import Core.Text +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Test.Hspec + +import FormatDocument (markdownToPandoc) +import PandocToMarkdown (NotSafe, Rectangle(..), rectanglerize + , combineRectangles, buildRow, pandocToMarkdown, heightOf + , tableToMarkdown) +import Text.Pandoc (Block(..), Inline(..), Alignment(..)) + +notsafe :: Selector NotSafe +notsafe = const True + +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| +| First | Second | Third | +|------:|:----:|---------| +| 1 | 2 | 3 | + |] + in do + doc <- markdownToPandoc table + let result = pandocToMarkdown doc + result `shouldBe` [quote| +-------------------------------------------- + First Second Third +-------------- -------------- -------------- + 1 2 3 +-------------------------------------------- + |] diff --git a/tests/CompareFragments.hs b/tests/CompareFragments.hs new file mode 100644 --- /dev/null +++ b/tests/CompareFragments.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module CompareFragments + ( checkByComparingFragments + ) +where + +import Core.Text +import qualified Data.Text.IO as T +import Test.Hspec hiding (context) + +import FormatDocument (markdownToPandoc) +import PandocToMarkdown (pandocToMarkdown) + +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") + ] + +checkByComparingFragments :: Spec +checkByComparingFragments = + 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 diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs new file mode 100644 --- /dev/null +++ b/tests/TestSuite.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Test.Hspec + +import Core.System +import CheckTableProperties +import CompareFragments + +main :: IO () +main = do + finally (hspec suite) (putStrLn ".") + +suite :: Spec +suite = do + checkTableProperties + checkByComparingFragments