commonmark-pandoc (empty) → 0.1.0.0
raw patch · 6 files changed
+341/−0 lines, 6 filesdep +basedep +commonmarkdep +commonmark-extensionssetup-changed
Dependencies added: base, commonmark, commonmark-extensions, containers, pandoc-types, semigroups, text
Files
- LICENSE +30/−0
- README.md +5/−0
- Setup.hs +2/−0
- changelog.md +3/−0
- commonmark-pandoc.cabal +42/−0
- src/Commonmark/Pandoc.hs +259/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,5 @@+# commonmark-pandoc++This package provides typeclass instances for parsing+commonmark directly into the `Pandoc` AST.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ changelog.md view
@@ -0,0 +1,3 @@+# Changelog for commonmark-pandoc++## Unreleased changes
+ commonmark-pandoc.cabal view
@@ -0,0 +1,42 @@+name: commonmark-pandoc+version: 0.1.0.0+synopsis: Bridge between commonmark and pandoc AST.+description: This library provides typeclasses for rendering+ commonmark to Pandoc types.+category: Text+homepage: https://github.com/jgm/commonmark-hs+bug-reports: https://github.com/jgm/commonmark-hs/issues+author: John MacFarlane+maintainer: jgm@berkeley.edu+copyright: 2018-2020 John MacFarlane+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ changelog.md+ README.md++source-repository head+ type: git+ location: https://github.com/jgm/commonmark-hs++library+ hs-source-dirs:+ src+ build-depends:+ base >=4.7 && <5+ , commonmark >= 0.1 && < 0.2+ , commonmark-extensions >= 0.1 && < 0.2+ , pandoc-types >= 1.21 && < 1.22+ , text+ , containers+ if !impl(ghc >= 8.0)+ build-depends: semigroups == 0.18.*+ if impl(ghc >= 8.8)+ ghc-options: -fwrite-ide-info -hiedir=.hie+ exposed-modules:+ Commonmark.Pandoc+ ghc-options: -Wall -fno-warn-unused-do-bind+ default-language: Haskell2010
+ src/Commonmark/Pandoc.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Commonmark.Pandoc+ ( Cm(..)+ )++where++import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import qualified Data.Text.Read as TR+import Text.Pandoc.Definition+import Text.Pandoc.Walk+import qualified Text.Pandoc.Builder as B+import Commonmark.Types as C+import Commonmark.Entity (lookupEntity)+import Commonmark.Extensions.Math+import Commonmark.Extensions.Emoji+import Commonmark.Extensions.PipeTable+import Commonmark.Extensions.Strikethrough+import Commonmark.Extensions.Superscript+import Commonmark.Extensions.Subscript+import Commonmark.Extensions.DefinitionList+import Commonmark.Extensions.Attributes+import Commonmark.Extensions.Footnote+import Commonmark.Extensions.TaskList+import Data.Char (isSpace)+import Data.Coerce (coerce)+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup, (<>))+#endif++newtype Cm b a = Cm { unCm :: a }+ deriving (Show, Semigroup, Monoid)++instance Functor (Cm b) where+ fmap f (Cm x) = Cm (f x)++instance Rangeable (Cm b B.Inlines) => IsInline (Cm b B.Inlines) where+ lineBreak = Cm B.linebreak+ softBreak = Cm B.softbreak+ str t = Cm $ B.text t+ entity t+ | illegalCodePoint t = Cm $ B.str "\xFFFD"+ | otherwise = Cm $ B.str $ fromMaybe t $ lookupEntity (T.drop 1 t)+ escapedChar c = Cm $ B.str $ T.singleton c+ emph ils = B.emph <$> ils+ strong ils = B.strong <$> ils+ link target title ils = B.link target title <$> ils+ image target title ils = B.image target title <$> ils+ code t = Cm $ B.code t+ rawInline (C.Format f) t = Cm $ B.rawInline f t++instance Rangeable (Cm () B.Inlines) where+ ranged _r x = x++instance Rangeable (Cm SourceRange B.Inlines) where+ ranged r = addAttributes [("data-pos", T.pack (show r))]++instance Walkable Inline b => ToPlainText (Cm a b) where+ toPlainText = stringify . walk unemoji . unCm++unemoji :: Inline -> Inline+unemoji (Span ("",["emoji"],[("data-emoji",alias)]) _)+ = Str (":" <> alias <> ":")+unemoji x = x++instance (Rangeable (Cm a B.Inlines),+ Rangeable (Cm a B.Blocks))+ => IsBlock (Cm a B.Inlines) (Cm a B.Blocks) where+ paragraph ils = Cm $ B.para $ unCm ils+ plain ils = Cm $ B.plain $ unCm ils+ thematicBreak = Cm B.horizontalRule+ blockQuote bs = B.blockQuote <$> bs+ codeBlock info t =+ Cm $ B.codeBlockWith attr $ fromMaybe t $ T.stripSuffix "\n" t+ where attr = ("", [lang | not (T.null lang)], [])+ lang = T.takeWhile (not . isSpace) info+ heading level ils = Cm $ B.header level $ unCm ils+ rawBlock (C.Format f) t = Cm $ B.rawBlock f t+ referenceLinkDefinition _ _ = Cm mempty+ list (C.BulletList _) lSpacing items =+ Cm . B.bulletList . handleSpacing lSpacing . map unCm $ items+ list (C.OrderedList startnum enumtype delimtype) lSpacing items =+ Cm . B.orderedListWith attr . handleSpacing lSpacing . map unCm $ items+ where sty = case enumtype of+ C.Decimal -> B.Decimal+ C.UpperAlpha -> B.UpperAlpha+ C.LowerAlpha -> B.LowerAlpha+ C.UpperRoman -> B.UpperRoman+ C.LowerRoman -> B.LowerRoman+ delim = case delimtype of+ C.Period -> B.Period+ C.OneParen -> B.OneParen+ C.TwoParens -> B.TwoParens+ attr = (startnum, sty, delim)++instance Rangeable (Cm () B.Blocks) where+ ranged _r x = x++instance Rangeable (Cm SourceRange B.Blocks) where+ ranged r x = B.divWith ("",[],[("data-pos",T.pack (show r))]) <$> x++instance HasMath (Cm b B.Inlines) where+ inlineMath t = Cm $ B.math t+ displayMath t = Cm $ B.displayMath t++instance HasEmoji (Cm b B.Inlines) where+ emoji kw t = Cm $ B.spanWith ("",["emoji"],[("data-emoji",kw)])+ $ B.text t++instance HasPipeTable (Cm a B.Inlines) (Cm a B.Blocks) where+ pipeTable aligns headerCells rows =+ Cm $ B.table B.emptyCaption colspecs+ (TableHead nullAttr (toHeaderRow headerCells))+ [TableBody nullAttr 0 [] $ map toRow rows]+ (TableFoot nullAttr [])+ where+ toHeaderRow cells+ | null cells = []+ | otherwise = [toRow cells]+ toRow = Row nullAttr . map (B.simpleCell . B.plain . unCm)+ toPandocAlignment LeftAlignedCol = AlignLeft+ toPandocAlignment CenterAlignedCol = AlignCenter+ toPandocAlignment RightAlignedCol = AlignRight+ toPandocAlignment DefaultAlignedCol = AlignDefault+ colspecs = map (\al -> (toPandocAlignment al, ColWidthDefault))+ aligns++instance (Rangeable (Cm a B.Inlines), Rangeable (Cm a B.Blocks))+ => HasDefinitionList (Cm a B.Inlines) (Cm a B.Blocks) where+ definitionList _ items =+ Cm $ B.definitionList $ map coerce items++instance (Rangeable (Cm a B.Inlines), Rangeable (Cm a B.Blocks))+ => HasTaskList (Cm a B.Inlines) (Cm a B.Blocks) where+ taskList _ spacing items =+ Cm $ B.bulletList $ handleSpacing spacing $ map toTaskListItem items++handleSpacing :: ListSpacing -> [B.Blocks] -> [B.Blocks]+handleSpacing TightList = map (B.fromList . map paraToPlain . B.toList)+handleSpacing LooseList = id++paraToPlain :: Block -> Block+paraToPlain (Para xs) = Plain xs+paraToPlain x = x++toTaskListItem :: (Bool, Cm a B.Blocks) -> B.Blocks+toTaskListItem (checked, item) = B.fromList $+ case B.toList $ coerce item of+ (Plain ils : rest) -> Plain (checkbox : Space : ils) : rest+ (Para ils : rest) -> Plain (checkbox : Space : ils) : rest+ bs -> Plain [checkbox] : bs+ where checkbox = Str (if checked then "\9746" else "\9744")++instance Rangeable (Cm a B.Blocks)+ => HasDiv (Cm a B.Blocks) where+ div_ bs = B.divWith nullAttr <$> bs++instance HasStrikethrough (Cm a B.Inlines) where+ strikethrough ils = B.strikeout <$> ils++instance HasSuperscript (Cm a B.Inlines) where+ superscript ils = B.superscript <$> ils++instance HasSubscript (Cm a B.Inlines) where+ subscript ils = B.subscript <$> ils++instance Rangeable (Cm a B.Inlines) => HasSpan (Cm a B.Inlines) where+ spanWith attrs ils =+ B.spanWith (addToPandocAttr attrs nullAttr) <$> ils++instance HasAttributes (Cm a B.Blocks) where+ addAttributes attrs b = fmap (addBlockAttrs attrs) <$> b++instance HasAttributes (Cm a B.Inlines) where+ addAttributes attrs il = fmap (addInlineAttrs attrs) <$> il++addBlockAttrs :: [(T.Text, T.Text)] -> Block -> Block+addBlockAttrs attrs (Header n curattrs ils) =+ Header n (addToPandocAttr attrs curattrs) ils+addBlockAttrs attrs (CodeBlock curattrs s) =+ CodeBlock (addToPandocAttr attrs curattrs) s+addBlockAttrs attrs (Div curattrs bs) =+ Div (addToPandocAttr attrs curattrs) bs+addBlockAttrs attrs x =+ Div (addToPandocAttr attrs nullAttr) [x]++addInlineAttrs :: [(T.Text, T.Text)] -> Inline -> Inline+addInlineAttrs attrs (Link curattrs ils target) =+ Link (addToPandocAttr attrs curattrs) ils target+addInlineAttrs attrs (Image curattrs ils target) =+ Image (addToPandocAttr attrs curattrs) ils target+addInlineAttrs attrs (Span curattrs ils) =+ Span (addToPandocAttr attrs curattrs) ils+addInlineAttrs attrs (Code curattrs s) =+ Code (addToPandocAttr attrs curattrs) s+addInlineAttrs attrs x =+ Span (addToPandocAttr attrs nullAttr) [x]++addToPandocAttr :: Attributes -> Attr -> Attr+addToPandocAttr attrs attr = foldr go attr attrs+ where+ go ("id", v) (_, cls, kvs) = (v, cls, kvs)+ go ("class", v) (ident, cls, kvs) = (ident, v:cls, kvs)+ go (k, v) (ident, cls, kvs) = (ident, cls, (k,v):kvs)++instance (Rangeable (Cm a B.Inlines), Rangeable (Cm a B.Blocks))+ => HasFootnote (Cm a B.Inlines) (Cm a B.Blocks) where+ footnote _num _lab _x = mempty+ footnoteList _xs = mempty+ footnoteRef _num _lab contents = B.note <$> contents++illegalCodePoint :: T.Text -> Bool+illegalCodePoint t =+ "&#" `T.isPrefixOf` t &&+ let t' = T.drop 2 $ T.filter (/=';') t+ badvalue (n, r) = not (T.null r) ||+ n < 1 ||+ n > (0x10FFFF :: Integer)+ in+ case T.uncons t' of+ Nothing -> True+ Just (x, rest)+ | x == 'x' || x == 'X'+ -> either (const True) badvalue (TR.hexadecimal rest)+ | otherwise+ -> either (const True) badvalue (TR.decimal t')++stringify :: Walkable Inline a => a -> T.Text+stringify = query go . walk (deNote . deQuote)+ where go :: Inline -> T.Text+ go Space = " "+ go SoftBreak = " "+ go (Str x) = x+ go (Code _ x) = x+ go (Math _ x) = x+ go (RawInline (B.Format "html") t)+ | "<br" `T.isPrefixOf` t = " "+ go LineBreak = " "+ go _ = mempty++deNote :: Inline -> Inline+deNote (Note _) = Str ""+deNote x = x++deQuote :: Inline -> Inline+deQuote (Quoted SingleQuote xs) =+ Span ("",[],[]) (Str "\8216" : xs ++ [Str "\8217"])+deQuote (Quoted DoubleQuote xs) =+ Span ("",[],[]) (Str "\8220" : xs ++ [Str "\8221"])+deQuote x = x