reflex-dom-pandoc 0.6.0.0 → 1.0.0.0

raw patch · 8 files changed

+230/−178 lines, 8 filesdep −claydep −modern-uriPVP ok

version bump matches the API change (PVP)

Dependencies removed: clay, modern-uri

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−1
• reflex-dom-pandoc.cabal +2/−7
• src/Reflex/Dom/Pandoc.hs +0/−1
• src/Reflex/Dom/Pandoc/Document.hs +80/−62
• src/Reflex/Dom/Pandoc/PandocRaw.hs +0/−72
• src/Reflex/Dom/Pandoc/Raw.hs +119/−0
• src/Reflex/Dom/Pandoc/URILink.hs +0/−35
• src/Reflex/Dom/Pandoc/Util.hs +17/−0

@@ -1,5 +1,17 @@ # Change Log for reflex-dom-pandoc +## 1.0.0.0++- Drop `URILink` and simplify link render configuration (#11)+- Get rid of `PandocRaw` complexity (pass raw node render as a function) (#13)+  - But leave it available as an exposed module for explicit user use.+- Pass attributes to link renderer (#13)+- Remove hardcoded semantic UI CSS classes on `<table>` and `<input>` (checkbox) elements+- Remove the wrapper "div"+- Allow configuring how to render code blocks (eg: without syntax highlighting)+- Render img element alt attribute (#12)+- Apply attributes for `<table>`+ ## 0.6.0.0  - Hide footnote references from search engine results (#10)@@ -18,4 +30,3 @@ ## 0.2.0.0  Initial public release-

@@ -1,7 +1,7 @@ cabal-version: 2.2  name:           reflex-dom-pandoc-version:        0.6.0.0+version:        1.0.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@@ -22,13 +22,11 @@ library   exposed-modules:       Reflex.Dom.Pandoc-      Reflex.Dom.Pandoc.PandocRaw       Reflex.Dom.Pandoc.Document-      Reflex.Dom.Pandoc.URILink       Reflex.Dom.Pandoc.SyntaxHighlighting-  other-modules:       Reflex.Dom.Pandoc.Footnotes       Reflex.Dom.Pandoc.Util+      Reflex.Dom.Pandoc.Raw   hs-source-dirs:       src   ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates@@ -37,7 +35,6 @@     , base >=4.7 && <5     , binary     , bytestring-    , clay     , containers     , data-default     , lens@@ -52,6 +49,4 @@     , ref-tf     , reflex     , constraints-    , modern-uri   default-language: Haskell2010-

@@ -4,4 +4,3 @@ where  import Reflex.Dom.Pandoc.Document as X-import Reflex.Dom.Pandoc.PandocRaw as X

@@ -2,8 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralisedNewtypeDeriving #-}-{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}@@ -16,68 +14,84 @@   ( elPandoc,     elPandocInlines,     elPandocBlocks,-    PandocBuilder,-    PandocRaw (..),-    URILink (..),     Config (..),+    PandocRawNode (..),     defaultConfig,   ) where -import Control.Monad+import Control.Monad (guard, void) import Control.Monad.Reader-import Data.Bool+  ( MonadReader (ask),+    MonadTrans (lift),+    ReaderT (runReaderT),+  )+import Data.Bool (bool) import qualified Data.Map as Map+import Data.Map.Strict (Map)+import Data.Text (Text) 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.Raw (PandocRawNode (..), elPandocRawNodeSafe) import Reflex.Dom.Pandoc.SyntaxHighlighting (elCodeHighlighted)-import Reflex.Dom.Pandoc.URILink-import Reflex.Dom.Pandoc.Util (elPandocAttr, headerElement, renderAttr, sansEmptyAttrs)+import Reflex.Dom.Pandoc.Util (elPandocAttr, headerElement, plainify, renderAttr, sansEmptyAttrs) import Text.Pandoc.Definition --- | Like `DomBuilder` but with a capability to render pandoc raw content.-type PandocBuilder t m =-  ( DomBuilder t m,-    PandocRaw m,-    PandocRawConstraints m-  )- data Config t m a = Config   { -- | Custom link renderer.-    _config_renderURILink :: m a -> URILink -> m a+    _config_renderLink ::+      m a ->+      -- Link URL+      Text ->+      -- Link attributes, including "title"+      Map Text Text ->+      -- Inner body of the link. Nothing if same as URL (i.e., an autolink)+      Maybe [Inline] ->+      m a,+    -- | How to render code blocks+    _config_renderCode ::+      m () ->+      Attr ->+      Text ->+      m (),+    -- | How to render raw nodes+    _config_renderRaw ::+      PandocRawNode ->+      m a   } -defaultConfig :: Monad m => Config t m ()+defaultConfig :: DomBuilder t m => Config t m () defaultConfig =-  Config $ \f _ -> f >> pure ()+  Config+    (\f _ _ _ -> f >> pure ())+    (\f _ _ -> f)+    elPandocRawNodeSafe  -- | Convert Markdown to HTML-elPandoc :: forall t m a. (PandocBuilder t m, Monoid a) => Config t m a -> Pandoc -> m a+elPandoc :: forall t m a. (DomBuilder t m, Monoid a) => Config t m a -> Pandoc -> m a elPandoc cfg doc@(Pandoc _meta blocks) = do-  divClass "pandoc" $ do-    let fs = queryFootnotes doc-    x <- flip runReaderT fs $ renderBlocks cfg blocks-    fmap (x <>) $ renderFootnotes (sansFootnotes . renderBlocks cfg) fs+  let fs = queryFootnotes doc+  x <- flip runReaderT fs $ renderBlocks cfg blocks+  (x <>) <$> renderFootnotes (sansFootnotes . renderBlocks cfg) fs  -- | Render list of Pandoc inlines-elPandocInlines :: PandocBuilder t m => [Inline] -> m ()+elPandocInlines :: DomBuilder t m => [Inline] -> m () elPandocInlines = void . sansFootnotes . renderInlines defaultConfig  -- | Render list of Pandoc Blocks-elPandocBlocks :: PandocBuilder t m => [Block] -> m ()+elPandocBlocks :: DomBuilder t m => [Block] -> m () elPandocBlocks = void . sansFootnotes . renderBlocks defaultConfig  mapAccum :: (Monoid b, Applicative f) => (a -> f b) -> [a] -> f b mapAccum f =   fmap mconcat . traverse f -renderBlocks :: (PandocBuilder t m, Monoid a) => Config t m a -> [Block] -> ReaderT Footnotes m a+renderBlocks :: (DomBuilder t m, Monoid a) => Config t m a -> [Block] -> ReaderT Footnotes m a renderBlocks cfg =   mapAccum $ renderBlock cfg -renderBlock :: (PandocBuilder t m, Monoid a) => Config t m a -> Block -> ReaderT Footnotes m a+renderBlock :: (DomBuilder t m, Monoid a) => Config t m a -> Block -> ReaderT Footnotes m a renderBlock cfg = \case   -- Pandoc parses github tasklist as this structure.   Plain (Str "☐" : Space : is) -> checkboxEl False >> renderInlines cfg is@@ -91,10 +105,11 @@   LineBlock xss ->     flip mapAccum xss $ \xs -> do       renderInlines cfg xs <* text "\n"-  CodeBlock attr x ->-    elCodeHighlighted attr x >> pure mempty+  CodeBlock attr x -> do+    lift $ _config_renderCode cfg (elCodeHighlighted attr x) attr x+    pure mempty   RawBlock fmt x ->-    elPandocRaw fmt x >> pure mempty+    lift $ _config_renderRaw cfg (PandocRawNode_Block fmt x) >> pure mempty   BlockQuote xs ->     el "blockquote" $ renderBlocks cfg xs   OrderedList (idx, style, _delim) xss ->@@ -116,9 +131,9 @@       renderInlines cfg xs   HorizontalRule ->     el "hr" blank >> pure mempty-  Table _attr _captions _colSpec (TableHead _ hrows) tbodys _tfoot -> do-    -- TODO: Rendering is basic, and needs to handle with all attributes of the AST-    elClass "table" "ui celled table" $ do+  Table attr _captions _colSpec (TableHead _ hrows) tbodys _tfoot -> do+    -- TODO: Apply captions, colSpec, etc.+    elPandocAttr "table" attr $ do       x <- el "thead" $ do         flip mapAccum hrows $ \(Row _ cells) -> do           el "tr" $ do@@ -139,18 +154,13 @@   where     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)+            mconcat $+              [ "type" =: "checkbox",+                "disabled" =: "True",+                bool mempty ("checked" =: "True") checked+              ]+      void $ elAttr "input" attrs blank+    startFrom idx = bool mempty ("start" =: T.pack (show idx)) (idx /= 1)     listStyle = \case       LowerRoman -> "type" =: "i"       UpperRoman -> "type" =: "I"@@ -158,11 +168,11 @@       UpperAlpha -> "type" =: "A"       _ -> mempty -renderInlines :: (PandocBuilder t m, Monoid a) => Config t m a -> [Inline] -> ReaderT Footnotes m a+renderInlines :: (DomBuilder t m, Monoid a) => Config t m a -> [Inline] -> ReaderT Footnotes m a renderInlines cfg =   mapAccum $ renderInline cfg -renderInline :: (PandocBuilder t m, Monoid a) => Config t m a -> Inline -> ReaderT Footnotes m a+renderInline :: (DomBuilder t m, Monoid a) => Config t m a -> Inline -> ReaderT Footnotes m a renderInline cfg = \case   Str x ->     text x >> pure mempty@@ -196,7 +206,7 @@   LineBreak ->     el "br" blank >> pure mempty   RawInline fmt x ->-    elPandocRaw fmt x >> pure mempty+    lift $ _config_renderRaw cfg (PandocRawNode_Inline fmt x) >> pure mempty   Math mathType s -> do     -- http://docs.mathjax.org/en/latest/basic/mathematics.html#tex-and-latex-input     case mathType of@@ -205,19 +215,24 @@       DisplayMath ->         elClass "span" "math display" $ text "$$" >> text s >> text "$$"     pure mempty-  inline@(Link attr xs (lUrl, lTitle)) -> do-    let defaultRender = do-          let attr' = sansEmptyAttrs $ renderAttr attr <> ("href" =: lUrl <> "title" =: lTitle)+  Link attr xs (lUrl, lTitle) -> do+    let attrMap = renderAttr attr+        defaultRender = do+          let attr' = sansEmptyAttrs $ attrMap <> "href" =: lUrl <> "title" =: lTitle           elAttr "a" attr' $ renderInlines cfg xs-    case uriLinkFromInline inline of-      Just uriLink -> do-        fns <- ask-        lift $ _config_renderURILink cfg (flip runReaderT fns defaultRender) uriLink-      Nothing ->-        defaultRender-  Image attr xs (iUrl, iTitle) -> do-    let attr' = sansEmptyAttrs $ renderAttr attr <> ("src" =: iUrl <> "title" =: iTitle)-    elAttr "img" attr' $ renderInlines cfg xs+    fns <- ask+    let minner = do+          guard $ xs /= [Str lUrl]+          pure xs+    lift $+      _config_renderLink+        cfg+        (runReaderT defaultRender fns)+        lUrl+        (attrMap <> "title" =: lTitle)+        minner+  Image attr xs target -> do+    elAttr "img" (imageAttrs attr xs target) blank >> pure mempty   Note xs -> do     fs :: Footnotes <- ask     case Map.lookup (mkFootnote xs) fs of@@ -235,3 +250,6 @@     inQuotes w = \case       SingleQuote -> text "‘" >> w <* text "’"       DoubleQuote -> text "“" >> w <* text "”"+    -- Pandoc stores Img's alt text as [Inline]+    imageAttrs attr imgInlines (iUrl, iTitle) =+      sansEmptyAttrs $ renderAttr attr <> ("src" =: iUrl <> "title" =: iTitle <> "alt" =: plainify imgInlines)

@@ -1,72 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}--module Reflex.Dom.Pandoc.PandocRaw-  ( PandocRaw (..),-    elPandocRawSafe,-  )-where--import Control.Monad.Fix (MonadFix)-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Reader (ReaderT (..), lift)-import Control.Monad.Ref (MonadRef, Ref)-import Control.Monad.State (modify)-import Data.Constraint-import Data.Text (Text)-import Data.Text.Encoding (encodeUtf8Builder)-import GHC.IORef-import Reflex.Dom.Core hiding (Link, Space)-import Reflex.Host.Class-import Text.Pandoc.Definition---- | Class to define how to render pandoc raw nodes-class PandocRaw m where-  -- | The constraints required to render-  type PandocRawConstraints m :: Constraint--  -- | Render a raw content of the given format-  -- TODO: Distinguish between inline vs block-  elPandocRaw :: PandocRawConstraints m => Format -> Text -> m ()---- | In a static builder, we accept whatever raw html that comes through.-instance PandocRaw (StaticDomBuilderT t m) where-  type-    PandocRawConstraints (StaticDomBuilderT t m) =-      ( Reflex t,-        Monad m,-        Ref m ~ IORef,-        MonadIO m,-        MonadHold t m,-        MonadFix m,-        MonadRef m,-        Adjustable t m,-        PerformEvent t m,-        MonadReflexCreateTrigger t m-      )-  elPandocRaw f@(Format format) s =-    case format of-      x-        | x `elem` ["html", "html4", "html5"] ->-          StaticDomBuilderT $ lift $ modify $ (:) $ fmap encodeUtf8Builder $ current $ constDyn s-      _ ->-        elPandocRawSafe f s--elPandocRawSafe :: DomBuilder t m => Format -> Text -> m ()-elPandocRawSafe (Format format) s =-  elClass "pre" ("pandoc-raw " <> format) $ text s--instance PandocRaw m => PandocRaw (ReaderT a m) where-  type PandocRawConstraints (ReaderT a m) = PandocRawConstraints m-  elPandocRaw f s = ReaderT $ \_ -> elPandocRaw f s--instance PandocRaw m => PandocRaw (PostBuildT t m) where-  type PandocRawConstraints (PostBuildT t m) = PandocRawConstraints m-  elPandocRaw f s = PostBuildT $-    ReaderT $ \_ ->-      elPandocRaw f s

@@ -0,0 +1,119 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++-- | This module exists primarily so as to provide an alternative to+-- `elDynHtml'` that works with the static builder. `elRawHtml` is pretty much+-- what you typically need; and if you are on GHCJS, you should define how it+-- will behave via writing instances for `PandocRaw`.+module Reflex.Dom.Pandoc.Raw+  ( RawBuilder,+    elRawHtml,+    PandocRawNode (..),+    elPandocRawNodeSafe,+    PandocRaw (..),+  )+where++import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Reader (ReaderT (..), lift)+import Control.Monad.Ref (MonadRef, Ref)+import Control.Monad.State (modify)+import Data.Constraint (Constraint)+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8Builder)+import GHC.IORef (IORef)+import Reflex.Dom.Core hiding (Link, Space)+import Reflex.Host.Class (MonadReflexCreateTrigger)+import Text.Pandoc.Definition (Format (..))++type RawBuilder m = (PandocRaw m, PandocRawConstraints m)++elRawHtml :: (RawBuilder m) => Text -> m ()+elRawHtml =+  elPandocRaw . PandocRawNode_Block "html"++_elRawHtmlExample :: IO ()+_elRawHtmlExample = do+  _ <- renderStatic $ do+    text "some <Text/> before"+    elRawHtml "<b>hello</b> world"+    text "some <Text/> after"+  pure ()++data PandocRawNode+  = PandocRawNode_Block Format Text+  | PandocRawNode_Inline Format Text+  deriving (Eq, Show)++elPandocRawNodeSafe :: DomBuilder t m => PandocRawNode -> m ()+elPandocRawNodeSafe = \case+  PandocRawNode_Block fmt s ->+    elPandocRawSafe "div" fmt s+  PandocRawNode_Inline fmt s ->+    elPandocRawSafe "span" fmt s++-- | Class to define how to render pandoc raw nodes+class PandocRaw m where+  -- | The constraints required to render+  type PandocRawConstraints m :: Constraint++  -- | Render a raw content of the given format+  elPandocRaw :: PandocRawConstraints m => PandocRawNode -> m ()++-- | In a static builder, we accept whatever raw html that comes through.+--+-- Non-html formats are rendered as-is.+instance PandocRaw (StaticDomBuilderT t m) where+  type+    PandocRawConstraints (StaticDomBuilderT t m) =+      ( Reflex t,+        Monad m,+        Ref m ~ IORef,+        MonadIO m,+        MonadHold t m,+        MonadFix m,+        MonadRef m,+        Adjustable t m,+        PerformEvent t m,+        MonadReflexCreateTrigger t m+      )+  elPandocRaw = \case+    PandocRawNode_Block "html" s ->+      elPandocRawHtmlStatic s+    PandocRawNode_Inline "html" s ->+      elPandocRawHtmlStatic s+    x ->+      elPandocRawNodeSafe x++elPandocRawHtmlStatic :: (Monad m, Reflex t) => Text -> StaticDomBuilderT t m ()+elPandocRawHtmlStatic s =+  let html = encodeUtf8Builder <$> current (constDyn s)+   in StaticDomBuilderT $+        lift $+          modify $ (:) html++elPandocRawSafe :: DomBuilder t m => Text -> Format -> Text -> m ()+elPandocRawSafe e (Format fmt) s =+  elClass e ("pandoc-raw-" <> fmt <> "-block") $ text s++instance PandocRaw m => PandocRaw (ReaderT a m) where+  type PandocRawConstraints (ReaderT a m) = PandocRawConstraints m+  elPandocRaw x = ReaderT $ \_ -> elPandocRaw x++instance PandocRaw m => PandocRaw (PostBuildT t m) where+  type PandocRawConstraints (PostBuildT t m) = PandocRawConstraints m+  elPandocRaw x = PostBuildT $+    ReaderT $ \_ ->+      elPandocRaw x++instance PandocRaw m => PandocRaw (HydratableT m) where+  type PandocRawConstraints (HydratableT m) = PandocRawConstraints m+  elPandocRaw x = HydratableT $ elPandocRaw x

@@ -1,35 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Reflex.Dom.Pandoc.URILink where--import Control.Monad (guard)-import Data.Maybe-import Text.Pandoc.Definition-import qualified Text.Pandoc.Walk as W-import Text.URI (URI, mkURI)---- | A Pandoc Link node with a valid URI-data URILink = URILink-  { -- | 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 inlines (url, _title) -> do-    uri <- mkURI url-    let inner = do-          guard $ inlines /= [Str url]-          pure inlines-    pure $ URILink inner uri-  _ ->-    Nothing--queryURILinks :: Pandoc -> [URILink]-queryURILinks = W.query go-  where-    go :: Inline -> [URILink]-    go = maybeToList . uriLinkFromInline

@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}  module Reflex.Dom.Pandoc.Util where@@ -7,7 +8,9 @@ import Data.Text (Text) import qualified Data.Text as T import Reflex.Dom.Core+import qualified Text.Pandoc.Builder as B import Text.Pandoc.Definition (Attr)+import qualified Text.Pandoc.Walk as W  elPandocAttr ::   DomBuilder t m =>@@ -49,3 +52,17 @@   5 -> "h5"   6 -> "h6"   _ -> error "bad header level"++-- | Convert Pandoc AST inlines to raw text.+plainify :: [B.Inline] -> Text+plainify = W.query $ \case+  B.Str x -> x+  B.Code _attr x -> x+  B.Space -> " "+  B.SoftBreak -> " "+  B.LineBreak -> " "+  B.RawInline _fmt s -> s+  B.Math _mathTyp s -> s+  -- Ignore the rest of AST nodes, as they are recursively defined in terms of+  -- `Inline` which `W.query` will traverse again.+  _ -> ""