packages feed

publish 2.1.0 → 2.1.3

raw patch · 15 files changed

+1049/−968 lines, 15 files

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright © 2016-2019 Operational Dynamics and Others+Copyright © 2016-2020 Athae Eredh Siniath and Others  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"),
publish.cabal view
@@ -1,30 +1,27 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2.+-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: 001dfdaebed2195690eab746f62b3674eb4439f4f1bec491329118c1033da4bc+-- hash: 42641db30d6bd630e51fd42caac6877e1ed00681f0b775b2cd8e1f3665cf40bb  name:           publish-version:        2.1.0+version:        2.1.3 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>+                <https://github.com/aesiniath/publish/blob/master/README.markdown README>                 on GitHub.-                .-                The main program, @render@, is available via a Docker image at-                <https://hub.docker.com/r/oprdyn/publish-render docker.io/oprdyn/publish-render:latest> category:       Text stability:      experimental-homepage:       https://github.com/oprdyn/publish#readme-bug-reports:    https://github.com/oprdyn/publish/issues-author:         Andrew Cowie <andrew@operationaldynamics.com>-maintainer:     Andrew Cowie <andrew@operationaldynamics.com>-copyright:      © 2016-2019 Operational Dynamics and Others+homepage:       https://github.com/aesiniath/publish#readme+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 license:        MIT license-file:   LICENSE tested-with:    GHC == 8.6@@ -32,7 +29,7 @@  source-repository head   type: git-  location: https://github.com/oprdyn/publish+  location: https://github.com/aesiniath/publish  executable format   main-is: FormatMain.hs
src/Environment.hs view
@@ -1,29 +1,29 @@ module Environment-(-      Env(..)-    , initial-    , Bookfile(..)-)+  ( Env (..),+    initial,+    Bookfile (..),+  ) where  import System.Posix.Directory (getWorkingDirectory)  data Env = Env-    { startingDirectoryFrom :: FilePath-    , intermediateFilenamesFrom :: [FilePath]-    , masterFilenameFrom :: FilePath-    , resultFilenameFrom :: FilePath-    , tempDirectoryFrom :: FilePath-    }+  { startingDirectoryFrom :: FilePath,+    intermediateFilenamesFrom :: [FilePath],+    masterFilenameFrom :: FilePath,+    resultFilenameFrom :: FilePath,+    tempDirectoryFrom :: FilePath+  }  initial :: IO Env initial = do-    cwd <- getWorkingDirectory-    return (Env cwd [] "/dev/null" "/dev/null" "/dev/null")+  cwd <- getWorkingDirectory+  return (Env cwd [] "/dev/null" "/dev/null" "/dev/null")  data Bookfile = Bookfile-    { versionFrom :: Int-    , preamblesFrom :: [FilePath]-    , fragmentsFrom :: [FilePath]-    , trailersFrom :: [FilePath]-    } deriving (Show, Eq)+  { versionFrom :: Int,+    preamblesFrom :: [FilePath],+    fragmentsFrom :: [FilePath],+    trailersFrom :: [FilePath]+  }+  deriving (Show, Eq)
src/FormatDocument.hs view
@@ -2,53 +2,59 @@ {-# LANGUAGE ScopedTypeVariables #-}  module FormatDocument-    ( program-    , loadFragment-    , markdownToPandoc-    )+  ( 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 System.IO (withFile, IOMode(..))-import System.Directory (getFileSize, renameFile)-import Text.Pandoc (runIOorExplode, readMarkdown, def-    , ReaderOptions(readerExtensions), pandocExtensions, disableExtension-    , Extension(..), Pandoc, Extensions)- import PandocToMarkdown+import System.Directory (getFileSize, renameFile)+import System.IO (IOMode (..), withFile)+import Text.Pandoc+  ( Extension (..),+    Extensions,+    Pandoc,+    ReaderOptions (readerExtensions),+    def,+    disableExtension,+    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@@ -56,45 +62,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+        case mode of+          Inplace -> liftIO $ do             withFile result WriteMode $ \handle ->-                hWrite handle contents'+              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'+              then error "Zero content, not overwriting"+              else renameFile result file+          Console -> liftIO $ do+            hWrite stdout contents'
src/FormatMain.hs view
@@ -1,29 +1,45 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}  module Main where  import Core.Program import Core.Text- import FormatDocument (program) +#ifdef __GHCIDE__ version :: Version+version = "0"+#else+version :: Version version = $(fromPackage)+#endif  main :: IO () main = do-    context <- configure version None (simple-        [ Option "inplace" (Just 'i') Empty [quote|+  context <-+    configure+      version+      None+      ( simple+          [ Option+              "inplace"+              (Just 'i')+              Empty+              [quote|             Overwrite the original file with the reformatted version. WARNING             This tool is experimental. You should ensure you have a safe copy             of your original (ie, add it to Git's index) before running with             this option enabled.-          |]-        , Argument "document" [quote|+          |],+            Argument+              "document"+              [quote|             The file containing the markdown to be reformatted           |]-        ])+          ]+      ) -    executeWith context program+  executeWith context program
src/LatexPreamble.hs view
@@ -1,17 +1,21 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}  module LatexPreamble-    ( preamble-    , beginning-    , ending-    )+  ( preamble,+    beginning,+    ending,+  ) where +import Core.Program.Metadata import Core.Text  preamble :: Rope-preamble = [quote|+preamble =+  [quote| \documentclass[12pt,a4paper,oneside,openany]{memoir}  %@@ -91,8 +95,17 @@  |] +#ifdef __GHCIDE__+version :: Version+version = "0"+#else+version :: Version+version = $(fromPackage)+#endif+ beginning :: Rope-beginning = [quote|+beginning =+  [quote|  % % Output from Skylighting.styleToLaTeX@@ -146,11 +159,14 @@ \usepackage[normalem]{ulem} \pdfstringdefDisableCommands{\renewcommand{\sout}{}} -\begin{document} |]-+    <> "\\hypersetup{pdfproducer={Markdown and Latex rendered via Publish "+    <> intoRope (versionNumberFrom version)+    <> "},pdfcreator={lualatex}}\n"+    <> "\\begin{document}\n"  ending :: Rope-ending = [quote|+ending =+  [quote| \end{document} |]
src/PandocToMarkdown.hs view
@@ -1,31 +1,40 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveAnyClass #-}  module PandocToMarkdown-    ( pandocToMarkdown-    , NotSafe(..)-    , Rectangle(..)-    , rectanglerize-    , combineRectangles-    , buildRow-    , widthOf-    , heightOf-    , tableToMarkdown-    )+  ( pandocToMarkdown,+    NotSafe (..),+    Rectangle (..),+    rectanglerize,+    combineRectangles,+    buildRow,+    widthOf,+    heightOf,+    tableToMarkdown,+  ) where  import Control.DeepSeq (NFData)+import Core.System.Base import Core.Text-import Core.System import Data.Foldable (foldl')-import Data.Monoid (Monoid(..))-import Data.Semigroup (Semigroup(..)) import Data.List (intersperse)+import qualified Data.Text as T (Text, null) import GHC.Generics (Generic)-import Text.Pandoc (Pandoc(..), Block(..), Inline(..), Attr, Format(..)-    , ListAttributes, Alignment(..), TableCell, MathType(..), QuoteType(..))+import Text.Pandoc+  ( Alignment (..),+    Attr,+    Block (..),+    Format (..),+    Inline (..),+    ListAttributes,+    MathType (..),+    Pandoc (..),+    QuoteType (..),+    TableCell,+  ) import Text.Pandoc.Shared (orderedListMarkers)  __WIDTH__ :: Int@@ -33,35 +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+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+  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@@ -71,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@@ -83,47 +94,44 @@ -} 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+  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 -> 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-     rows :: Block -> [Rope]     rows = breakLines . convertBlock (margin - 2) @@ -131,61 +139,64 @@ bulletlistToMarkdown = listToMarkdown (repeat "-   ")  orderedlistToMarkdown :: Int -> ListAttributes -> [[Block]] -> Rope-orderedlistToMarkdown margin (num,style,delim) blockss =-    listToMarkdown (intoMarkers (num,style,delim)) margin blockss+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 :: 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-+    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+  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.--}+    {-+    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-+    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")+      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@@ -199,12 +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@@ -218,79 +227,75 @@ 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)) <> "}"-+  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 ::+  [Inline] ->+  [Alignment] ->+  [Double] ->+  [TableCell] ->+  [[TableCell]] ->+  Rope tableToMarkdown _ alignments relatives headers rows =-    mconcat (intersperse "\n"-        [ wrapperLine-        , header-        , underlineHeaders-        , body-        , wrapperLine-        ]) <> "\n"+  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+      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-+       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-+    rowToMarkdown =+      buildRow sizes . fmap convert+        . zipWith3+          (\size align (block : _) -> (size, align, block))+          sizes+          alignments     underlineHeaders :: Rope     underlineHeaders =-        foldl' (<>) emptyRope . intersperse " "+      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")--+        . 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+  deriving (Show)  instance Exception NotSafe  data Rectangle = Rectangle Int Int [Rope]-    deriving (Eq, Show, Generic, NFData)+  deriving (Eq, Show, Generic, NFData)  widthOf :: Rectangle -> Int widthOf (Rectangle size _ _) = size@@ -302,172 +307,146 @@ rowsFrom (Rectangle _ _ texts) = texts  instance Semigroup Rectangle where-    (<>) = combineRectangles+  (<>) = combineRectangles  instance Monoid Rectangle where-    mempty = Rectangle 0 0 []+  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 ' ')+  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+        | 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+  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-+  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))+  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+  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+  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+  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 &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 :: T.Text -> Rope stringToMarkdown =-    mconcat . intersperse "\\ " . breakPieces isNonBreaking . intoRope+  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+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++uriToMarkdown :: T.Text -> Rope uriToMarkdown url =-  let-    target = intoRope url-  in-    "<" <> target <> ">"+  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+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  -- is there more to this?-mathToMarkdown :: MathType -> String -> Rope+mathToMarkdown :: MathType -> T.Text -> Rope mathToMarkdown (InlineMath) math = "$" <> intoRope math <> "$" mathToMarkdown (DisplayMath) math = "$$" <> intoRope math <> "$$"  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/ParseBookfile.hs view
@@ -2,12 +2,11 @@  import Control.Monad import Data.Void+import Environment (Bookfile (..)) import Text.Megaparsec import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L -import Environment (Bookfile(..))- -- use String, since we need FilePaths which are type aliases over String anyway. type Parser = Parsec Void String @@ -16,47 +15,48 @@  parseMagicLine :: Parser Int parseMagicLine = do-    void (char '%') <?> "first line to begin with % character"-    void spaceChar <?> "a space character"-    void (string "publish")-    void spaceChar <?> "a space character"-    void (char 'v') <?> "the character v and then a number"-    v <- L.decimal <?> "the bookfile schema version number"-    unless (v == __VERSION__) (fail ("currently recognized bookfile schema version is v" ++ show __VERSION__))-    void newline-    return v+  void (char '%') <?> "first line to begin with % character"+  void spaceChar <?> "a space character"+  void (string "publish")+  void spaceChar <?> "a space character"+  void (char 'v') <?> "the character v and then a number"+  v <- L.decimal <?> "the bookfile schema version number"+  unless (v == __VERSION__) (fail ("currently recognized bookfile schema version is v" ++ show __VERSION__))+  void newline+  return v  parseBeginLine :: Parser () parseBeginLine = try $ label "begin marker" $ do-    void (string "% begin")-    void newline+  void (string "% begin")+  void newline  parseFileLine :: Parser FilePath parseFileLine = do-    notFollowedBy (char '%')-    file <- takeWhile1P (Just "line containing a filename") (/= '\n')-    return file+  notFollowedBy (char '%')+  file <- takeWhile1P (Just "line containing a filename") (/= '\n')+  return file  parseEndLine :: Parser () parseEndLine = try $ label "end marker" $ do-    void (string "% end")-    void newline+  void (string "% end")+  void newline  parseBlank :: Parser () parseBlank = do-    void (hidden (many newline))+  void (hidden (many newline))  parseBookfile :: Parser Bookfile parseBookfile = do-    version <- parseMagicLine-    preambles <- many (parseBlank *> parseFileLine <* parseBlank)-    parseBeginLine-    fragments <- many (parseBlank *> parseFileLine <* parseBlank)-    parseEndLine-    trailers <- many (parseBlank *> parseFileLine <* parseBlank)-    return Bookfile-        { versionFrom = version-        , preamblesFrom = preambles-        , fragmentsFrom = fragments-        , trailersFrom = trailers-        }+  version <- parseMagicLine+  preambles <- many (parseBlank *> parseFileLine <* parseBlank)+  parseBeginLine+  fragments <- many (parseBlank *> parseFileLine <* parseBlank)+  parseEndLine+  trailers <- many (parseBlank *> parseFileLine <* parseBlank)+  return+    Bookfile+      { versionFrom = version,+        preamblesFrom = preambles,+        fragmentsFrom = fragments,+        trailersFrom = trailers+      }
src/RenderDocument.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}  module RenderDocument-    ( program-    )+  ( program,+  ) where  import Control.Monad (filterM, forM_, forever, void)@@ -15,98 +15,109 @@ import qualified Data.List as List (dropWhileEnd, null) import Data.Maybe (isJust) import qualified Data.Text.IO as T-import System.Directory (doesFileExist, doesDirectoryExist-    , copyFileWithMetadata)-import System.Exit (ExitCode(..))-import System.FilePath.Posix (takeBaseName, takeExtension-    , replaceExtension, splitFileName, replaceDirectory)-import System.IO (withFile, IOMode(WriteMode), hPutStrLn)-import System.IO.Error (userError, IOError)-import System.Posix.Directory (changeWorkingDirectory)-import System.Posix.Temp (mkdtemp)-import System.Posix.User (getEffectiveUserID, getEffectiveGroupID)-import Text.Megaparsec (runParser, errorBundlePretty)-import Text.Pandoc (runIOorExplode, readMarkdown, writeLaTeX, def-    , readerExtensions, readerColumns, pandocExtensions-    , writerTopLevelDivision, TopLevelDivision(TopLevelSection))--import Environment (Env(..), Bookfile(..))-import LatexPreamble (preamble, beginning, ending)+import Environment (Bookfile (..), Env (..)) import LatexOutputReader (parseOutputForError)+import LatexPreamble (beginning, ending, preamble) import ParseBookfile (parseBookfile)+import System.Directory+  ( copyFileWithMetadata,+    doesDirectoryExist,+    doesFileExist,+    renameFile,+  )+import System.Exit (ExitCode (..))+import System.FilePath.Posix+  ( 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),+    def,+    pandocExtensions,+    readMarkdown,+    readerColumns,+    readerExtensions,+    runIOorExplode,+    writeLaTeX,+    writerTopLevelDivision,+  ) import Utilities (ensureDirectory, execProcess, ifNewer, isNewer)  data Mode = Once | Cycle  program :: Program Env () program = do-    params <- getCommandLine-    mode <- extractMode params--    event "Identify .book file"-    bookfile <- extractBookFile params+  params <- getCommandLine+  mode <- extractMode params -    case mode of-        Once -> do-            -- normal operation, single pass-            void (renderDocument mode bookfile)-        Cycle -> do-            -- use inotify to rebuild on changes-            forever (renderDocument mode bookfile >>= waitForChange)+  event "Identify .book file"+  bookfile <- extractBookFile params +  case mode of+    Once -> do+      -- normal operation, single pass+      void (renderDocument mode bookfile)+    Cycle -> do+      -- use inotify to rebuild on changes+      forever (renderDocument mode bookfile >>= waitForChange)  renderDocument :: Mode -> FilePath -> Program Env [FilePath] renderDocument mode file = do-    event "Read .book file"-    book <- processBookFile file--    event "Setup temporary directory"-    setupTargetFile file-    setupPreambleFile-    validatePreamble book+  event "Read .book file"+  book <- processBookFile file -    let preambles = preamblesFrom book-    let fragments = fragmentsFrom book-    let trailers  = trailersFrom book+  event "Setup temporary directory"+  setupTargetFile file+  setupPreambleFile+  validatePreamble book -    event "Convert preamble fragments and begin marker to LaTeX"-    mapM_ processFragment preambles-    setupBeginningFile+  let preambles = preamblesFrom book+  let fragments = fragmentsFrom book+  let trailers = trailersFrom book -    event "Convert document fragments to LaTeX"-    mapM_ processFragment fragments+  event "Convert preamble fragments and begin marker to LaTeX"+  mapM_ processFragment preambles+  setupBeginningFile -    event "Convert end marker and trailing fragments to LaTeX"-    setupEndingFile-    mapM_ processFragment trailers+  event "Convert document fragments to LaTeX"+  mapM_ processFragment fragments -    event "Write intermediate LaTeX file"-    produceResult+  event "Convert end marker and trailing fragments to LaTeX"+  setupEndingFile+  mapM_ processFragment trailers -    event "Render document to PDF"-    catch-        (do-            renderPDF-            copyHere-        )-        (\(e :: ExitCode) -> case mode of-            Once -> throw e-            Cycle -> return ()-        )+  event "Write intermediate LaTeX file"+  produceResult -    -- question: original lists or filtered ones?-    return (file : preambles ++ fragments)+  event "Render document to PDF"+  catch+    ( do+        renderPDF+        copyHere+    )+    ( \(e :: ExitCode) -> case mode of+        Once -> throw e+        Cycle -> return ()+    ) +  -- question: original lists or filtered ones?+  return (file : preambles ++ fragments ++ trailers)  extractMode :: Parameters -> Program Env Mode extractMode params =-  let-    mode = case lookupOptionFlag "watch" params of-        Just False  -> error "Invalid State"-        Just True   -> Cycle-        Nothing     -> Once-  in-    return mode+  let mode = case lookupOptionFlag "watch" params of+        Just False -> error "Invalid State"+        Just True -> Cycle+        Nothing -> Once+   in return mode  {- For the situation where the .book file is in a location other than '.'@@ -115,88 +126,87 @@ -} extractBookFile :: Parameters -> Program Env FilePath extractBookFile params =-  let-    (relative,bookfile) = case lookupArgument "bookfile" params of+  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+   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"-     trim :: String -> String     trim = List.dropWhileEnd isSpace  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@@ -205,86 +215,86 @@ -} 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@@ -292,16 +302,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.@@ -322,39 +332,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+        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+              parsed <- readMarkdown readingOptions contents+              writeLaTeX writingOptions parsed              withFile target WriteMode $ \handle -> do-                T.hPutStrLn handle latex-                T.hPutStr handle "\n"+              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@@ -362,19 +371,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@@ -383,126 +392,125 @@ -} convertImage :: FilePath -> Program Env () convertImage file = do-    env <- getApplicationState-    let tmpdir = tempDirectoryFrom env-        target = tmpdir ++ "/" ++ replaceExtension file ".pdf"--        rsvgConvert =-            [ "rsvg-convert"-            , "--format=pdf"-            , "--output=" ++ target-            , file-            ]+  env <- getApplicationState+  let tmpdir = tempDirectoryFrom env+      target = tmpdir ++ "/" ++ replaceExtension file ".pdf"+      buffer = target ++ "-tmp"+      rsvgConvert =+        [ "rsvg-convert",+          "--format=pdf",+          "--output=" ++ buffer,+          file+        ] -    ifNewer file target $ do-        debugS "target" target-        (exit,out,err) <- do-            ensureDirectory target-            execProcess rsvgConvert+  ifNewer file target $ do+    debugS "target" target+    (exit, out, err) <- do+      ensureDirectory target+      execProcess rsvgConvert -        case exit of-            ExitFailure _ ->  do-                event "Image processing failed"-                debug "stderr" (intoRope err)-                debug "stdout" (intoRope out)-                throw exit-            ExitSuccess -> return ()+    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--    let master = masterFilenameFrom env-        tmpdir = tempDirectoryFrom env--    user <- getUserID+  env <- getApplicationState -    params <- getCommandLine-    let command = case lookupOptionValue "docker" params of-            Just image  ->-                [ "docker"-                , "run"-                , "--rm=true"-                , "--volume=" ++ tmpdir ++ ":" ++ tmpdir-                , "--user=" ++ user-                , image-                , "latexmk"-                ]-            Nothing ->-                [ "latexmk"-                ]+  let master = masterFilenameFrom env+      tmpdir = tempDirectoryFrom env -        options =-                [ "-xelatex"-                , "-output-directory=" ++ tmpdir-                , "-interaction=nonstopmode"-                , "-halt-on-error"-                , "-file-line-error"-                , "-cd"-                , master-                ]+  user <- getUserID -        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
@@ -1,49 +1,77 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}  module Main where  import Core.Program import Core.Text--import RenderDocument (program) import Environment (initial)+import RenderDocument (program) +#ifdef __GHCIDE__ version :: Version+version = "0"+#else+version :: Version version = $(fromPackage)+#endif  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 "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
src/Utilities.hs view
@@ -1,13 +1,13 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE LambdaCase #-}  module Utilities-    ( ensureDirectory-    , execProcess-    , ifNewer-    , isNewer-    )+  ( ensureDirectory,+    execProcess,+    ifNewer,+    isNewer,+  ) where  import Chrono.Compat (convertToUTC)@@ -16,11 +16,15 @@ import Core.System import Core.Text import qualified Data.List as List (intercalate)-import System.Directory (doesDirectoryExist, doesFileExist, createDirectoryIfMissing-    , getModificationTime)-import System.Exit (ExitCode(..))+import System.Directory+  ( createDirectoryIfMissing,+    doesDirectoryExist,+    doesFileExist,+    getModificationTime,+  )+import System.Exit (ExitCode (..)) import System.FilePath.Posix (takeDirectory)-import System.Process.Typed (proc, readProcess, setStdin, closed)+import System.Process.Typed (closed, proc, readProcess, setStdin)  {- Some source files live in subdirectories. Replicate that directory@@ -28,12 +32,11 @@ -} ensureDirectory :: FilePath -> Program t () ensureDirectory target =-  let-     subdir = takeDirectory target-  in liftIO $ do-    probe <- doesDirectoryExist subdir-    when (not probe) $ do-        createDirectoryIfMissing True subdir+  let subdir = takeDirectory target+   in liftIO $ do+        probe <- doesDirectoryExist subdir+        when (not probe) $ do+          createDirectoryIfMissing True subdir  {- Thin wrapper around **typed-process**'s `readProcess` so that the command@@ -45,46 +48,44 @@ -} execProcess :: [String] -> Program t (ExitCode, Rope, Rope) execProcess [] = error "No command provided"-execProcess (cmd:args) =-  let-    task = proc cmd args-    task' = setStdin closed task-    command = List.intercalate " " (cmd:args)-  in do-    debugS "command" command--    (exit, out, err) <- liftIO $ do-        readProcess task'--    return (exit, intoRope out, intoRope err)--{-|-If the source file is newer than the target file, then run an action. For-example, if you want to install a file but only do so if the file has been-rebuilt, then you could do this:+execProcess (cmd : args) =+  let task = proc cmd args+      task' = setStdin closed task+      command = List.intercalate " " (cmd : args)+   in do+        debugS "command" command -@-copyFileIfNewer :: 'FilePath' -> 'FilePath' -> 'Program' τ ()-copyFileIfNewer source target = do-    'ifNewer' source target $ do-        'liftIO' ('copyFileWithMetadata' source target)-@+        (exit, out, err) <- liftIO $ do+          readProcess task' -This is basically a build system in a box, although the usual caveats-about the brittleness of timestamps apply.+        return (exit, intoRope out, intoRope err) -TODO this could potentially move to the **unbeliever** library--}+-- |+-- If the source file is newer than the target file, then run an action. For+-- example, if you want to install a file but only do so if the file has been+-- rebuilt, then you could do this:+--+-- @+-- copyFileIfNewer :: 'FilePath' -> 'FilePath' -> 'Program' τ ()+-- copyFileIfNewer source target = do+--     'ifNewer' source target $ do+--         'liftIO' ('copyFileWithMetadata' source target)+-- @+--+-- This is basically a build system in a box, although the usual caveats+-- about the brittleness of timestamps apply.+--+-- TODO this could potentially move to the **unbeliever** library ifNewer :: FilePath -> FilePath -> Program t () -> Program t () ifNewer source target program = do-    changed <- isNewer source target-    when changed $ do-        program+  changed <- isNewer source target+  when changed $ do+    program  isNewer :: FilePath -> FilePath -> Program t Bool isNewer source target = liftIO $ do-    time1 <- getModificationTime source-    time2 <- doesFileExist target >>= \case-        True  -> getModificationTime target-        False -> return (convertToUTC 0)        -- the epoch-    return (time1 > time2)+  time1 <- getModificationTime source+  time2 <- doesFileExist target >>= \case+    True -> getModificationTime target+    False -> return (convertToUTC 0) -- the epoch+  return (time1 > time2)
tests/CheckBookfileParser.hs view
@@ -3,74 +3,84 @@ {-# LANGUAGE ScopedTypeVariables #-}  module CheckBookfileParser-    ( checkBookfileParser-    )+  ( checkBookfileParser,+  ) where  import Core.Text+import Environment (Bookfile (..))+import ParseBookfile import Test.Hspec import Text.Megaparsec -import Environment (Bookfile(..))-import ParseBookfile- checkBookfileParser :: Spec checkBookfileParser = do-    describe "Parse bookfile format" $ do-        it "Correctly parses a complete first line" $ do-            parseMaybe parseMagicLine "% publish v2\n" `shouldBe` Just 2-        it "Errors if first line has incorrect syntax" $ do-            parseMaybe parseMagicLine "%\n" `shouldBe` Nothing-            parseMaybe parseMagicLine "%publish\n" `shouldBe` Nothing-            parseMaybe parseMagicLine "% publish\n" `shouldBe` Nothing-            parseMaybe parseMagicLine "% publish \n" `shouldBe` Nothing-            parseMaybe parseMagicLine "% publish v\n" `shouldBe` Nothing-            parseMaybe parseMagicLine "% publish  v2\n" `shouldBe` Nothing-            parseMaybe parseMagicLine "% publish v1\n" `shouldBe` Nothing-            parseMaybe parseMagicLine "% publish v2 asdf\n" `shouldBe` Nothing+  describe "Parse bookfile format" $ do+    it "Correctly parses a complete first line" $ do+      parseMaybe parseMagicLine "% publish v2\n" `shouldBe` Just 2+    it "Errors if first line has incorrect syntax" $ do+      parseMaybe parseMagicLine "%\n" `shouldBe` Nothing+      parseMaybe parseMagicLine "%publish\n" `shouldBe` Nothing+      parseMaybe parseMagicLine "% publish\n" `shouldBe` Nothing+      parseMaybe parseMagicLine "% publish \n" `shouldBe` Nothing+      parseMaybe parseMagicLine "% publish v\n" `shouldBe` Nothing+      parseMaybe parseMagicLine "% publish  v2\n" `shouldBe` Nothing+      parseMaybe parseMagicLine "% publish v1\n" `shouldBe` Nothing+      parseMaybe parseMagicLine "% publish v2 asdf\n" `shouldBe` Nothing -        it "Correctly parses a preamble line" $ do-            parseMaybe parseFileLine "preamble.latex" `shouldBe` Just "preamble.latex"-        it "Parses two filenames in a list" $ do-            parseMaybe (many (parseFileLine <* parseBlank)) "one.markdown\ntwo.markdown"-                `shouldBe` Just (["one.markdown", "two.markdown"] :: [FilePath])+    it "Correctly parses a preamble line" $ do+      parseMaybe parseFileLine "preamble.latex" `shouldBe` Just "preamble.latex"+    it "Parses two filenames in a list" $ do+      parseMaybe (many (parseFileLine <* parseBlank)) "one.markdown\ntwo.markdown"+        `shouldBe` Just (["one.markdown", "two.markdown"] :: [FilePath]) -        it "Parses two filenames with a blank line between them" $ do-            parseMaybe (many (parseFileLine <* parseBlank)) [quote|+    it "Parses two filenames with a blank line between them" $ do+      parseMaybe+        (many (parseFileLine <* parseBlank))+        [quote| one.markdown  two.markdown             |]-                `shouldBe` Just (["one.markdown", "two.markdown"] :: [FilePath])+        `shouldBe` Just (["one.markdown", "two.markdown"] :: [FilePath]) -        it "Correctly parses a begin end end pragmas" $ do-            parseMaybe parseBeginLine "% begin\n" `shouldBe` Just ()-            parseMaybe parseEndLine "% end\n" `shouldBe` Just ()+    it "Correctly parses a begin end end pragmas" $ do+      parseMaybe parseBeginLine "% begin\n" `shouldBe` Just ()+      parseMaybe parseEndLine "% end\n" `shouldBe` Just () -        it "Correctly parses a complete bookfile" $ do-            parseMaybe parseBookfile [quote|+    it "Correctly parses a complete bookfile" $ do+      parseMaybe+        parseBookfile+        [quote| % publish v2 preamble.latex % begin Introduction.markdown Conclusion.markdown % end-            |] `shouldBe` Just (Bookfile 2 ["preamble.latex"] ["Introduction.markdown", "Conclusion.markdown"] [])+            |]+        `shouldBe` Just (Bookfile 2 ["preamble.latex"] ["Introduction.markdown", "Conclusion.markdown"] []) -        it "Correctly parses a complete bookfile with no preamble" $ do-            parseMaybe parseBookfile [quote|+    it "Correctly parses a complete bookfile with no preamble" $ do+      parseMaybe+        parseBookfile+        [quote| % publish v2 % begin Introduction.markdown Conclusion.markdown % end-            |] `shouldBe` Just (Bookfile 2 [] ["Introduction.markdown", "Conclusion.markdown"] [])+            |]+        `shouldBe` Just (Bookfile 2 [] ["Introduction.markdown", "Conclusion.markdown"] []) -        it "Correctly parses a complete bookfile with trailing fragments" $ do-            parseMaybe parseBookfile [quote|+    it "Correctly parses a complete bookfile with trailing fragments" $ do+      parseMaybe+        parseBookfile+        [quote| % publish v2 % begin Introduction.markdown % end Conclusion.markdown-            |] `shouldBe` Just (Bookfile 2 [] ["Introduction.markdown"] ["Conclusion.markdown"])+            |]+        `shouldBe` Just (Bookfile 2 [] ["Introduction.markdown"] ["Conclusion.markdown"])
tests/CheckTableProperties.hs view
@@ -3,116 +3,138 @@ {-# LANGUAGE ScopedTypeVariables #-}  module CheckTableProperties-    ( checkTableProperties-    )+  ( checkTableProperties,+  ) where -import Core.Text import Control.DeepSeq (force) import Control.Exception (evaluate)-import Test.Hspec-+import Core.Text import FormatDocument (markdownToPandoc)-import PandocToMarkdown (NotSafe, Rectangle(..), rectanglerize-    , combineRectangles, buildRow, pandocToMarkdown, heightOf-    , tableToMarkdown)-import Text.Pandoc (Block(..), Inline(..), Alignment(..))+import PandocToMarkdown+  ( NotSafe,+    Rectangle (..),+    buildRow,+    combineRectangles,+    heightOf,+    pandocToMarkdown,+    rectanglerize,+    tableToMarkdown,+  )+import Test.Hspec+import Text.Pandoc (Alignment (..), Block (..), Inline (..))  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  "-                ]+  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 "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+    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     "+            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++    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              "+            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++    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 "+            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 "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|+    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                   ----------------------- ----------------------- -----------------------@@ -120,17 +142,18 @@ -----------------------------------------------------------------------             |] -        it "A minimal complete example reformats properly" $-          let-            table = [quote|+    it "A minimal complete example reformats properly" $+      let table =+            [quote| | First | Second | Third | |------:|:----:|---------| |   1  |  2  |  3   |             |]-          in do+       in do             doc <- markdownToPandoc table             let result = pandocToMarkdown doc-            result `shouldBe` [quote|+            result+              `shouldBe` [quote| --------------------------------------------          First     Second     Third          -------------- -------------- --------------
tests/CompareFragments.hs view
@@ -1,45 +1,44 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}  module CompareFragments-    ( checkByComparingFragments-    )+  ( checkByComparingFragments,+  ) where  import Core.Text import qualified Data.Text.IO as T-import Test.Hspec hiding (context)- import FormatDocument (markdownToPandoc) import PandocToMarkdown (pandocToMarkdown)+import Test.Hspec hiding (context) -fragments :: [(String,FilePath)]+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"),+    ("multiline table", "tests/fragments/MultilineTable.markdown"),+    ("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+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
@@ -1,18 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} -import Test.Hspec- import CheckBookfileParser import CheckTableProperties-import Core.System import CompareFragments+import Core.System+import Test.Hspec  main :: IO () main = do-    finally (hspec suite) (putStrLn ".")+  finally (hspec suite) (putStrLn ".")  suite :: Spec suite = do-    checkTableProperties-    checkByComparingFragments-    checkBookfileParser+  checkTableProperties+  checkByComparingFragments+  checkBookfileParser