packages feed

reflex-dom-pandoc (empty) → 0.2.0.0

raw patch · 10 files changed

+598/−0 lines, 10 filesdep +aesondep +basedep +binary

Dependencies added: aeson, base, binary, bytestring, clay, constraints, containers, data-default, lens, lens-aeson, modern-uri, mtl, pandoc-types, ref-tf, reflex, reflex-dom-core, safe, skylighting, text, time

Files

+ CHANGELOG.md view
@@ -0,0 +1,6 @@+# Change Log for reflex-dom-pandoc++## 0.2.0.0++Initial public release+
+ README.md view
@@ -0,0 +1,14 @@+# reflex-dom-pandoc++Render Pandoc documents to HTML using reflex-dom, in your reflex or Obelisk apps.++## Todo++Nearly all parts of the AST are rendered, except the following:++- [ ] Table is rendered only in basic fashion; but its attributes are not handled.+- [ ] `Citation` (Pandoc's `Cite` node)++## Hacking++To develop in reflex-dom-pandoc, follow neuron's README: https://github.com/srid/neuron#developing-on-reflex-dom-pandoc
+ reflex-dom-pandoc.cabal view
@@ -0,0 +1,57 @@+cabal-version: 2.2++name:           reflex-dom-pandoc+version:        0.2.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+bug-reports:    https://github.com/srid/reflex-dom-pandoc/issues+author:         Sridhar Ratnakumar+maintainer:     srid@srid.ca+copyright:      2019 Sridhar Ratnakumar+license:        BSD-3-Clause+build-type:     Simple+extra-source-files:+  README.md+  CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/srid/reflex-dom-pandoc++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+  hs-source-dirs:+      src+  ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates+  build-depends:+      aeson+    , base >=4.7 && <5+    , binary+    , bytestring+    , clay+    , containers+    , data-default+    , lens+    , lens-aeson+    , mtl+    , pandoc-types >= 0.21+    , reflex-dom-core+    , safe+    , skylighting+    , text+    , time+    , ref-tf+    , reflex+    , constraints+    , modern-uri+  default-language: Haskell2010+
+ src/Reflex/Dom/Pandoc.hs view
@@ -0,0 +1,7 @@+module Reflex.Dom.Pandoc+  ( module X,+  )+where++import Reflex.Dom.Pandoc.Document as X+import Reflex.Dom.Pandoc.PandocRaw as X
+ src/Reflex/Dom/Pandoc/Document.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Reflex.Dom.Pandoc.Document+  ( elPandoc,+    elPandocInlines,+    elPandocBlocks,+    PandocBuilder,+    PandocRaw (..),+    URILink (..),+    Config (..),+    defaultConfig,+  )+where++import Control.Monad+import Control.Monad.Reader+import Data.Bool+import qualified Data.Map as Map+import Data.Maybe+import Data.Traversable (for)+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 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+  }++defaultConfig :: Monad m => Config t m ()+defaultConfig =+  Config $ \f _ -> f >> pure ()++-- | 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++-- | Render list of Pandoc inlines+elPandocInlines :: PandocBuilder t m => [Inline] -> m ()+elPandocInlines = void . sansFootnotes . renderInlines defaultConfig++-- | Render list of Pandoc Blocks+elPandocBlocks :: PandocBuilder t m => [Block] -> m ()+elPandocBlocks = void . sansFootnotes . renderBlocks defaultConfig++mapAccum :: (Monoid b, Applicative f) => (a -> f b) -> [a] -> f b+mapAccum f xs =+  fmap mconcat $ for xs f++renderBlocks :: (PandocBuilder 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 cfg = \case+  -- Pandoc parses github tasklist as this structure.+  Plain (Str "☐" : Space : is) -> checkboxEl False >> renderInlines cfg is+  Plain (Str "☒" : Space : is) -> checkboxEl True >> renderInlines cfg is+  Para (Str "☐" : Space : is) -> checkboxEl False >> renderInlines cfg is+  Para (Str "☒" : Space : is) -> checkboxEl True >> renderInlines cfg is+  Plain xs ->+    renderInlines cfg xs+  Para xs ->+    el "p" $ renderInlines cfg xs+  LineBlock xss ->+    flip mapAccum xss $ \xs -> do+      renderInlines cfg xs <* text "\n"+  CodeBlock attr x ->+    elCodeHighlighted attr x >> pure mempty+  RawBlock fmt x ->+    elPandocRaw fmt x >> pure mempty+  BlockQuote xs ->+    el "blockquote" $ renderBlocks cfg xs+  OrderedList _lattr xss ->+    -- TODO: Implement list attributes.+    el "ol" $ 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+  Header level attr xs ->+    elPandocAttr (headerElement level) attr $ do+      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+      x <- el "thead" $ do+        flip mapAccum hrows $ \(Row _ cells) -> do+          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+  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++renderInlines :: (PandocBuilder 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 cfg = \case+  Str x ->+    text x >> pure mempty+  Emph xs ->+    el "em" $ renderInlines cfg xs+  Strong xs ->+    el "strong" $ renderInlines cfg xs+  Underline xs ->+    el "u" $ renderInlines cfg xs+  Strikeout xs ->+    el "strike" $ renderInlines cfg xs+  Superscript xs ->+    el "sup" $ renderInlines cfg xs+  Subscript xs ->+    el "sub" $ renderInlines cfg xs+  SmallCaps xs ->+    el "small" $ renderInlines cfg xs+  Quoted qt xs ->+    flip inQuotes qt $ renderInlines cfg xs+  Cite _ _ -> do+    el "pre" $ text "error[reflex-doc-pandoc]: Pandoc Cite is not handled"+    pure mempty+  Code attr x ->+    elPandocAttr "code" attr $ do+      text x+      pure mempty+  Space ->+    text " " >> pure mempty+  SoftBreak ->+    text " " >> pure mempty+  LineBreak ->+    text "\n" >> pure mempty+  RawInline fmt x ->+    elPandocRaw fmt x >> pure mempty+  Math mathType s -> do+    -- http://docs.mathjax.org/en/latest/basic/mathematics.html#tex-and-latex-input+    case mathType of+      InlineMath ->+        elClass "span" "math inline" $ text $ "\\(" <> s <> "\\)"+      DisplayMath ->+        elClass "span" "math display" $ text "$$" >> text s >> text "$$"+    pure mempty+  inline@(Link attr xs (lUrl, lTitle)) -> do+    let defaultRender = do+          let attr' = renderAttr attr <> ("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' = 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+      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+        -- aside.+        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 "❞"
+ src/Reflex/Dom/Pandoc/Footnotes.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Reflex.Dom.Pandoc.Footnotes where++import Control.Monad.Reader+import Data.List (nub, sortOn)+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Text as T+import Reflex.Dom.Core hiding (Link, Space)+import Text.Pandoc.Definition+import Text.Pandoc.Walk++newtype Footnote = Footnote {unFootnote :: [Block]}+  deriving (Eq, Show, Ord)++type Footnotes = Map Footnote Int++getFootnotes :: Pandoc -> Footnotes+getFootnotes =+  buildFootnotes+    . query+      ( \case+          Note s -> [Footnote s]+          _ -> []+      )+  where+    buildFootnotes :: [Footnote] -> Footnotes+    buildFootnotes fs =+      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+  if null footnotes+    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++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+      text $ T.pack $ show idx++sansFootnotes :: DomBuilder t m => ReaderT Footnotes m a -> m a+sansFootnotes = flip runReaderT mempty
+ src/Reflex/Dom/Pandoc/PandocRaw.hs view
@@ -0,0 +1,71 @@+{-# 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
+ src/Reflex/Dom/Pandoc/SyntaxHighlighting.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Reflex.Dom.Pandoc.SyntaxHighlighting where++import Control.Monad (forM_, msum)+import Data.Text (Text)+import Reflex.Dom.Core+import Reflex.Dom.Pandoc.Util (elPandocAttr)+import qualified Skylighting as S+import Text.Pandoc.Definition (Attr)+import Prelude hiding (lines)++elCodeHighlighted ::+  forall t m.+  DomBuilder t m =>+  -- | Pandoc attribute object. TODO: Use a sensible type.+  Attr ->+  -- | Code to highlight.+  Text ->+  m ()+elCodeHighlighted attr@(_, langClasses, _) x = do+  case tokenizeForOneOfLang langClasses x of+    Nothing -> do+      divClass "pandoc-code nosyntax" $ do+        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"+  where+    tokenizeForOneOfLang langs s = do+      syntax <- msum (fmap (`S.lookupSyntax` S.defaultSyntaxMap) langs)+      case S.tokenize tokenizerConfig syntax s of+        Left _ -> Nothing+        Right lines -> pure lines+    tokenizerConfig =+      S.TokenizerConfig+        { S.syntaxMap = S.defaultSyntaxMap,+          S.traceOutput = False+        }++tokenClass :: S.TokenType -> Text+tokenClass = \case+  S.KeywordTok -> "kw"+  S.DataTypeTok -> "dt"+  S.DecValTok -> "dv"+  S.BaseNTok -> "bn"+  S.FloatTok -> "fl"+  S.CharTok -> "ch"+  S.StringTok -> "st"+  S.CommentTok -> "co"+  S.OtherTok -> "ot"+  S.AlertTok -> "al"+  S.FunctionTok -> "fu"+  S.RegionMarkerTok -> "re"+  S.ErrorTok -> "er"+  S.ConstantTok -> "cn"+  S.SpecialCharTok -> "sc"+  S.VerbatimStringTok -> "vs"+  S.SpecialStringTok -> "ss"+  S.ImportTok -> "im"+  S.DocumentationTok -> "do"+  S.AnnotationTok -> "an"+  S.CommentVarTok -> "cv"+  S.VariableTok -> "va"+  S.ControlFlowTok -> "cf"+  S.OperatorTok -> "op"+  S.BuiltInTok -> "bu"+  S.ExtensionTok -> "ex"+  S.PreprocessorTok -> "pp"+  S.AttributeTok -> "at"+  S.InformationTok -> "in"+  S.WarningTok -> "wa"+  S.NormalTok -> ""
+ src/Reflex/Dom/Pandoc/URILink.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Reflex.Dom.Pandoc.URILink where++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.+data URILink = URILink+  { _uriLink_linkText :: Text,+    _uriLink_uri :: URI+  }+  deriving (Eq, Show, Ord)++uriLinkFromInline :: Inline -> Maybe URILink+uriLinkFromInline = \case+  Link _attr [Str linkText] (url, _title) -> do+    uri <- mkURI url+    pure $ URILink linkText uri+  _ ->+    Nothing++queryURILinks :: Pandoc -> [URILink]+queryURILinks = W.query go+  where+    go :: Inline -> [URILink]+    go = maybeToList . uriLinkFromInline
+ src/Reflex/Dom/Pandoc/Util.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}++module Reflex.Dom.Pandoc.Util where++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as T+import Reflex.Dom.Core+import Text.Pandoc.Definition (Attr)++elPandocAttr ::+  DomBuilder t m =>+  -- | Element name+  Text ->+  -- | Pandoc attribute object. TODO: Use a sensible type.+  Attr ->+  -- | Child widget+  m a ->+  m a+elPandocAttr name = elAttr name . renderAttr++renderAttr ::+  -- | Pandoc attribute object. TODO: Use a sensible type.+  Attr ->+  Map Text Text+renderAttr (identifier, classes, attrs) =+  "id" =: identifier+    <> "class" =: (T.unwords classes)+    <> Map.fromList attrs++addClass ::+  -- | The class to add+  Text ->+  -- | Pandoc attribute object. TODO: Use a sensible type.+  Attr ->+  Attr+addClass c (identifier, classes, attrs) = (identifier, c : classes, attrs)++headerElement :: Int -> Text+headerElement level = case level of+  1 -> "h1"+  2 -> "h2"+  3 -> "h3"+  4 -> "h4"+  5 -> "h5"+  6 -> "h6"+  _ -> error "bad header level"