reflex-dom-pandoc 0.2.0.0 → 0.4.0.0

raw patch · 9 files changed

+112/−73 lines, 9 filesdep ~skylightingPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: skylighting

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• README.md +1/−1
• reflex-dom-pandoc.cabal +2/−2
• src/Reflex/Dom/Pandoc/Document.hs +50/−39
• src/Reflex/Dom/Pandoc/Footnotes.hs +22/−15
• src/Reflex/Dom/Pandoc/PandocRaw.hs +3/−2
• src/Reflex/Dom/Pandoc/SyntaxHighlighting.hs +9/−7
• src/Reflex/Dom/Pandoc/URILink.hs +9/−5
• src/Reflex/Dom/Pandoc/Util.hs +5/−2

@@ -1,5 +1,16 @@ # Change Log for reflex-dom-pandoc +## 0.4.0.0++- Fix task list checkbox styling margins by using Semantic UI checkbox.+- Add a wrapping div with class "pandoc" for user styling of elements+- Make unicode quote characters less heavy+- Require pure Haskell skylighting+- Remove empty HTML attributes (#6)+- Fancy lists (#7)+- Make `LineBreak` generate `<br>`+- Footnote misalignment on Firefox (#9)+ ## 0.2.0.0  Initial public release

@@ -11,4 +11,4 @@  ## Hacking -To develop in reflex-dom-pandoc, follow neuron's README: https://github.com/srid/neuron#developing-on-reflex-dom-pandoc+To develop in reflex-dom-pandoc, follow neuron's README: <https://github.com/srid/neuron/blob/master/CONTRIBUTING.md#hacking-on-pandocs-html-layout>

@@ -1,7 +1,7 @@ cabal-version: 2.2  name:           reflex-dom-pandoc-version:        0.2.0.0+version:        0.4.0.0 synopsis:       Render Pandoc documents to HTML using reflex-dom description:    Please see the README on GitHub at <https://github.com/srid/reflex-dom-pandoc> homepage:       https://github.com/srid/reflex-dom-pandoc#readme@@ -46,7 +46,7 @@     , pandoc-types >= 0.21     , reflex-dom-core     , safe-    , skylighting+    , skylighting >= 0.9     , text     , time     , ref-tf

@@ -28,14 +28,13 @@ import Control.Monad.Reader import Data.Bool import qualified Data.Map as Map-import Data.Maybe-import Data.Traversable (for)+import qualified Data.Text as T import Reflex.Dom.Core hiding (Link, Space, mapAccum) import Reflex.Dom.Pandoc.Footnotes import Reflex.Dom.Pandoc.PandocRaw import Reflex.Dom.Pandoc.SyntaxHighlighting (elCodeHighlighted) import Reflex.Dom.Pandoc.URILink-import Reflex.Dom.Pandoc.Util (elPandocAttr, headerElement, renderAttr)+import Reflex.Dom.Pandoc.Util (elPandocAttr, headerElement, renderAttr, sansEmptyAttrs) import Text.Pandoc.Definition  -- | Like `DomBuilder` but with a capability to render pandoc raw content.@@ -57,9 +56,10 @@ -- | Convert Markdown to HTML elPandoc :: forall t m a. (PandocBuilder t m, Monoid a) => Config t m a -> Pandoc -> m a elPandoc cfg doc@(Pandoc _meta blocks) = do-  let fs = getFootnotes doc-  x <- flip runReaderT fs $ renderBlocks cfg blocks-  fmap (x <>) $ renderFootnotes (sansFootnotes . renderBlocks cfg) fs+  divClass "pandoc" $ do+    let fs = queryFootnotes doc+    x <- flip runReaderT fs $ renderBlocks cfg blocks+    fmap (x <>) $ renderFootnotes (sansFootnotes . renderBlocks cfg) fs  -- | Render list of Pandoc inlines elPandocInlines :: PandocBuilder t m => [Inline] -> m ()@@ -70,8 +70,8 @@ elPandocBlocks = void . sansFootnotes . renderBlocks defaultConfig  mapAccum :: (Monoid b, Applicative f) => (a -> f b) -> [a] -> f b-mapAccum f xs =-  fmap mconcat $ for xs f+mapAccum f =+  fmap mconcat . traverse f  renderBlocks :: (PandocBuilder t m, Monoid a) => Config t m a -> [Block] -> ReaderT Footnotes m a renderBlocks cfg =@@ -97,18 +97,20 @@     elPandocRaw fmt x >> pure mempty   BlockQuote xs ->     el "blockquote" $ renderBlocks cfg xs-  OrderedList _lattr xss ->-    -- TODO: Implement list attributes.-    el "ol" $ do+  OrderedList (idx, style, _delim) xss ->+    -- delimStyle is not supported in HTML or in Semantic UI+    elAttr "ol" (listStyle style <> startFrom idx) $ do       flip mapAccum xss $ \xs -> do         el "li" $ renderBlocks cfg xs   BulletList xss ->     el "ul" $ flip mapAccum xss $ \xs -> el "li" $ renderBlocks cfg xs   DefinitionList defs ->-    el "dl" $ flip mapAccum defs $ \(term, descList) -> do-      x <- el "dt" $ renderInlines cfg term-      fmap (x <>) $ flip mapAccum descList $ \desc ->-        el "dd" $ renderBlocks cfg desc+    el "dl" $+      flip mapAccum defs $ \(term, descList) -> do+        x <- el "dt" $ renderInlines cfg term+        fmap (x <>) $+          flip mapAccum descList $ \desc ->+            el "dd" $ renderBlocks cfg desc   Header level attr xs ->     elPandocAttr (headerElement level) attr $ do       renderInlines cfg xs@@ -122,29 +124,39 @@           el "tr" $ do             flip mapAccum cells $ \(Cell _ _ _ _ blks) ->               el "th" $ renderBlocks cfg blks-      fmap (x <>) $ flip mapAccum tbodys $ \(TableBody _ _ _ rows) ->-        el "tbody" $ do-          flip mapAccum rows $ \(Row _ cells) ->-            el "tr" $ do-              flip mapAccum cells $ \(Cell _ _ _ _ blks) ->-                el "td" $ renderBlocks cfg blks+      fmap (x <>) $+        flip mapAccum tbodys $ \(TableBody _ _ _ rows) ->+          el "tbody" $ do+            flip mapAccum rows $ \(Row _ cells) ->+              el "tr" $ do+                flip mapAccum cells $ \(Cell _ _ _ _ blks) ->+                  el "td" $ renderBlocks cfg blks   Div attr xs ->     elPandocAttr "div" attr $       renderBlocks cfg xs   Null ->     blank >> pure mempty   where-    checkboxEl checked =-      void $-        elAttr-          "input"-          ( mconcat $ catMaybes $-              [ Just $ "type" =: "checkbox",-                Just $ "disabled" =: "True",-                bool Nothing (Just $ "checked" =: "True") checked-              ]-          )-          blank+    checkboxEl checked = do+      let attrs =+            ( mconcat $+                [ "type" =: "checkbox",+                  "disabled" =: "True",+                  bool mempty ("checked" =: "True") checked+                ]+            )+          invisibleChar = "\8206"+      divClass "ui disabled fitted checkbox" $ do+        void $ elAttr "input" attrs blank+        -- Semantic UI requires a non-empty label element+        el "label" $ text invisibleChar+    startFrom idx = bool mempty ("start" =: (T.pack $ show idx)) (idx /= 1)+    listStyle = \case+      LowerRoman -> "type" =: "i"+      UpperRoman -> "type" =: "I"+      LowerAlpha -> "type" =: "a"+      UpperAlpha -> "type" =: "A"+      _ -> mempty  renderInlines :: (PandocBuilder t m, Monoid a) => Config t m a -> [Inline] -> ReaderT Footnotes m a renderInlines cfg =@@ -182,7 +194,7 @@   SoftBreak ->     text " " >> pure mempty   LineBreak ->-    text "\n" >> pure mempty+    el "br" blank >> pure mempty   RawInline fmt x ->     elPandocRaw fmt x >> pure mempty   Math mathType s -> do@@ -195,7 +207,7 @@     pure mempty   inline@(Link attr xs (lUrl, lTitle)) -> do     let defaultRender = do-          let attr' = renderAttr attr <> ("href" =: lUrl <> "title" =: lTitle)+          let attr' = sansEmptyAttrs $ renderAttr attr <> ("href" =: lUrl <> "title" =: lTitle)           elAttr "a" attr' $ renderInlines cfg xs     case uriLinkFromInline inline of       Just uriLink -> do@@ -204,11 +216,11 @@       Nothing ->         defaultRender   Image attr xs (iUrl, iTitle) -> do-    let attr' = renderAttr attr <> ("src" =: iUrl <> "title" =: iTitle)+    let attr' = sansEmptyAttrs $ renderAttr attr <> ("src" =: iUrl <> "title" =: iTitle)     elAttr "img" attr' $ renderInlines cfg xs   Note xs -> do     fs :: Footnotes <- ask-    case Map.lookup (Footnote xs) fs of+    case Map.lookup (mkFootnote xs) fs of       Nothing ->         -- No footnote in the global map (this means that the user has         -- defined a footnote inside a footnote); just put the whole thing in@@ -216,11 +228,10 @@         elClass "aside" "footnote-inline" $ renderBlocks cfg xs       Just idx ->         renderFootnoteRef idx >> pure mempty-  -- el "aside" $ renderBlocks xs   Span attr xs ->     elPandocAttr "span" attr $       renderInlines cfg xs   where     inQuotes w = \case-      SingleQuote -> text "❛" >> w <* text "❜"-      DoubleQuote -> text "❝" >> w <* text "❞"+      SingleQuote -> text "‘" >> w <* text "’"+      DoubleQuote -> text "“" >> w <* text "”"

@@ -7,8 +7,8 @@  import Control.Monad.Reader import Data.List (nub, sortOn)-import qualified Data.Map as Map import Data.Map (Map)+import qualified Data.Map as Map import qualified Data.Text as T import Reflex.Dom.Core hiding (Link, Space) import Text.Pandoc.Definition@@ -19,19 +19,26 @@  type Footnotes = Map Footnote Int -getFootnotes :: Pandoc -> Footnotes-getFootnotes =+-- | Make a footnote from the Pandoc `Note` node's block elements+mkFootnote :: [Block] -> Footnote+mkFootnote blocks =+  Footnote blocks++-- | Traverse the Pandoc document accumulating any footnotes+queryFootnotes :: Pandoc -> Footnotes+queryFootnotes =   buildFootnotes     . query       ( \case-          Note s -> [Footnote s]+          Note xs -> [mkFootnote xs]           _ -> []       )   where     buildFootnotes :: [Footnote] -> Footnotes     buildFootnotes fs =-      Map.fromList $ flip fmap (zip (nub fs) [1 ..]) $ \(fn, idx) ->-        (fn, idx)+      Map.fromList $+        flip fmap (zip (nub fs) [1 ..]) $ \(fn, idx) ->+          (fn, idx)  renderFootnotes :: (DomBuilder t m, Monoid a) => ([Block] -> m a) -> Footnotes -> m a renderFootnotes render footnotes = do@@ -39,19 +46,19 @@     then pure mempty     else do       elAttr "div" ("id" =: "footnotes") $ do-        el "ol" $ fmap mconcat $ forM (sortOn snd $ Map.toList footnotes) $ \(Footnote blks, idx) -> do-          el "li" $ do-            -- We discard any footnotes inside footnotes-            elAttr "a" ("name" =: ("fn" <> T.pack (show idx))) blank-            x <- render blks-            -- FIXME: This should appear inline if the footnote is a single paragraph.-            elAttr "a" ("href" =: ("#fnref" <> T.pack (show idx))) $ text "↩︎"-            pure x+        el "ol" $+          fmap mconcat $+            forM (sortOn snd $ Map.toList footnotes) $ \(Footnote blks, idx) -> do+              elAttr "li" ("id" =: ("fn" <> T.pack (show idx))) $ do+                x <- render blks+                -- FIXME: This should appear inline if the footnote is a single paragraph.+                elAttr "a" ("href" =: ("#fnref" <> T.pack (show idx))) $ text "↩︎"+                pure x  renderFootnoteRef :: DomBuilder t m => Int -> m () renderFootnoteRef idx = do   elClass "sup" "footnote-ref" $ do-    elAttr "a" ("name" =: ("fnref" <> T.pack (show idx)) <> "href" =: ("#fn" <> T.pack (show idx))) $ do+    elAttr "a" ("id" =: ("fnref" <> T.pack (show idx)) <> "href" =: ("#fn" <> T.pack (show idx))) $ do       text $ T.pack $ show idx  sansFootnotes :: DomBuilder t m => ReaderT Footnotes m a -> m a

@@ -67,5 +67,6 @@  instance PandocRaw m => PandocRaw (PostBuildT t m) where   type PandocRawConstraints (PostBuildT t m) = PandocRawConstraints m-  elPandocRaw f s = PostBuildT $ ReaderT $ \_ ->-    elPandocRaw f s+  elPandocRaw f s = PostBuildT $+    ReaderT $ \_ ->+      elPandocRaw f s

@@ -24,15 +24,17 @@   case tokenizeForOneOfLang langClasses x of     Nothing -> do       divClass "pandoc-code nosyntax" $ do-        el "pre" $ elPandocAttr "code" attr $-          text x+        el "pre" $+          elPandocAttr "code" attr $+            text x     Just lines ->       divClass "pandoc-code highlighted" $ do-        el "pre" $ elPandocAttr "code" attr $ do-          forM_ lines $ \line -> do-            forM_ line $ \(tokType, tok) ->-              elClass "span" (tokenClass tokType) $ text tok-            text "\n"+        el "pre" $+          elPandocAttr "code" attr $ do+            forM_ lines $ \line -> do+              forM_ line $ \(tokType, tok) ->+                elClass "span" (tokenClass tokType) $ text tok+              text "\n"   where     tokenizeForOneOfLang langs s = do       syntax <- msum (fmap (`S.lookupSyntax` S.defaultSyntaxMap) langs)

@@ -3,24 +3,28 @@  module Reflex.Dom.Pandoc.URILink where +import Control.Monad (guard) import Data.Maybe-import Data.Text (Text) import Text.Pandoc.Definition import qualified Text.Pandoc.Walk as W import Text.URI (URI, mkURI) --- | A Pandoc Link node with a valid URI and a simple (unformatted) link text.+-- | A Pandoc Link node with a valid URI data URILink = URILink-  { _uriLink_linkText :: Text,+  { -- | This is set to Nothing for autolinks+    _uriLink_inner :: Maybe [Inline],     _uriLink_uri :: URI   }   deriving (Eq, Show, Ord)  uriLinkFromInline :: Inline -> Maybe URILink uriLinkFromInline = \case-  Link _attr [Str linkText] (url, _title) -> do+  Link _attr inlines (url, _title) -> do     uri <- mkURI url-    pure $ URILink linkText uri+    let inner = do+          guard $ inlines /= [Str url]+          pure inlines+    pure $ URILink inner uri   _ ->     Nothing 

@@ -18,15 +18,18 @@   -- | Child widget   m a ->   m a-elPandocAttr name = elAttr name . renderAttr+elPandocAttr name = elAttr name . sansEmptyAttrs . renderAttr +sansEmptyAttrs :: Map k Text -> Map k Text+sansEmptyAttrs = Map.filter (not . T.null)+ renderAttr ::   -- | Pandoc attribute object. TODO: Use a sensible type.   Attr ->   Map Text Text renderAttr (identifier, classes, attrs) =   "id" =: identifier-    <> "class" =: (T.unwords classes)+    <> "class" =: T.unwords classes     <> Map.fromList attrs  addClass ::