packages feed

publish 0.3.2 → 0.4.4

raw patch · 10 files changed

+905/−117 lines, 10 filesdep +deepseqdep +hspecdep ~bytestringdep ~chronologiquedep ~directory

Dependencies added: deepseq, hspec

Dependency ranges changed: bytestring, chronologique, directory, filepath, hinotify, pandoc, pandoc-types, template-haskell, text, typed-process, unbeliever, unix, unordered-containers

Files

publish.cabal view
@@ -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 <andrew@operationaldynamics.com>+author: Andrew Cowie <andrew@operationaldynamics.com>+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+    <https://github.com/oprdyn/publish/blob/master/README.markdown README>+    on GitHub.+    .+    The main program, @render@, is available via a Docker image at+    <https://cloud.docker.com/u/oprdyn/repository/docker/oprdyn/publish-render/general docker.io/oprdyn/publish-render:latest>+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-                <https://github.com/oprdyn/publish/blob/master/README.markdown README>-                on GitHub.-                .-                The main program, @render@, is available via a Docker image at-                <https://cloud.docker.com/u/oprdyn/repository/docker/oprdyn/publish-render/general docker.io/oprdyn/publish-render:latest>-category:       Text-stability:      experimental-author:         Andrew Cowie <andrew@operationaldynamics.com>-maintainer:     Andrew Cowie <andrew@operationaldynamics.com>-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
src/FormatDocument.hs view
@@ -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'
src/LatexPreamble.hs view
@@ -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} |]
+ src/PandocToMarkdown.hs view
@@ -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 <BR>, 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, <div> 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 &nbsp; 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
src/RenderDocument.hs view
@@ -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
src/RenderMain.hs view
@@ -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
src/Utilities.hs view
@@ -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
+ tests/CheckTableProperties.hs view
@@ -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             +--------------------------------------------+            |]
+ tests/CompareFragments.hs view
@@ -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
+ tests/TestSuite.hs view
@@ -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