{-# 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 Commonmark.Extensions.Smart
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 { Cm b a -> a
unCm :: a }
  deriving (Int -> Cm b a -> ShowS
[Cm b a] -> ShowS
Cm b a -> String
(Int -> Cm b a -> ShowS)
-> (Cm b a -> String) -> ([Cm b a] -> ShowS) -> Show (Cm b a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall b a. Show a => Int -> Cm b a -> ShowS
forall b a. Show a => [Cm b a] -> ShowS
forall b a. Show a => Cm b a -> String
showList :: [Cm b a] -> ShowS
$cshowList :: forall b a. Show a => [Cm b a] -> ShowS
show :: Cm b a -> String
$cshow :: forall b a. Show a => Cm b a -> String
showsPrec :: Int -> Cm b a -> ShowS
$cshowsPrec :: forall b a. Show a => Int -> Cm b a -> ShowS
Show, b -> Cm b a -> Cm b a
NonEmpty (Cm b a) -> Cm b a
Cm b a -> Cm b a -> Cm b a
(Cm b a -> Cm b a -> Cm b a)
-> (NonEmpty (Cm b a) -> Cm b a)
-> (forall b. Integral b => b -> Cm b a -> Cm b a)
-> Semigroup (Cm b a)
forall b. Integral b => b -> Cm b a -> Cm b a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall b a. Semigroup a => NonEmpty (Cm b a) -> Cm b a
forall b a. Semigroup a => Cm b a -> Cm b a -> Cm b a
forall b a b. (Semigroup a, Integral b) => b -> Cm b a -> Cm b a
stimes :: b -> Cm b a -> Cm b a
$cstimes :: forall b a b. (Semigroup a, Integral b) => b -> Cm b a -> Cm b a
sconcat :: NonEmpty (Cm b a) -> Cm b a
$csconcat :: forall b a. Semigroup a => NonEmpty (Cm b a) -> Cm b a
<> :: Cm b a -> Cm b a -> Cm b a
$c<> :: forall b a. Semigroup a => Cm b a -> Cm b a -> Cm b a
Semigroup, Semigroup (Cm b a)
Cm b a
Semigroup (Cm b a) =>
Cm b a
-> (Cm b a -> Cm b a -> Cm b a)
-> ([Cm b a] -> Cm b a)
-> Monoid (Cm b a)
[Cm b a] -> Cm b a
Cm b a -> Cm b a -> Cm b a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall b a. Monoid a => Semigroup (Cm b a)
forall b a. Monoid a => Cm b a
forall b a. Monoid a => [Cm b a] -> Cm b a
forall b a. Monoid a => Cm b a -> Cm b a -> Cm b a
mconcat :: [Cm b a] -> Cm b a
$cmconcat :: forall b a. Monoid a => [Cm b a] -> Cm b a
mappend :: Cm b a -> Cm b a -> Cm b a
$cmappend :: forall b a. Monoid a => Cm b a -> Cm b a -> Cm b a
mempty :: Cm b a
$cmempty :: forall b a. Monoid a => Cm b a
$cp1Monoid :: forall b a. Monoid a => Semigroup (Cm b a)
Monoid)

instance Functor (Cm b) where
  fmap :: (a -> b) -> Cm b a -> Cm b b
fmap f :: a -> b
f (Cm x :: a
x) = b -> Cm b b
forall b a. a -> Cm b a
Cm (a -> b
f a
x)

instance Rangeable (Cm b B.Inlines) => IsInline (Cm b B.Inlines) where
  lineBreak :: Cm b Inlines
lineBreak = Inlines -> Cm b Inlines
forall b a. a -> Cm b a
Cm Inlines
B.linebreak
  softBreak :: Cm b Inlines
softBreak = Inlines -> Cm b Inlines
forall b a. a -> Cm b a
Cm Inlines
B.softbreak
  str :: Text -> Cm b Inlines
str t :: Text
t = Inlines -> Cm b Inlines
forall b a. a -> Cm b a
Cm (Inlines -> Cm b Inlines) -> Inlines -> Cm b Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inlines
B.text Text
t
  entity :: Text -> Cm b Inlines
entity t :: Text
t
    | Text -> Bool
illegalCodePoint Text
t = Inlines -> Cm b Inlines
forall b a. a -> Cm b a
Cm (Inlines -> Cm b Inlines) -> Inlines -> Cm b Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inlines
B.str "\xFFFD"
    | Bool
otherwise = Inlines -> Cm b Inlines
forall b a. a -> Cm b a
Cm (Inlines -> Cm b Inlines) -> Inlines -> Cm b Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inlines
B.str (Text -> Inlines) -> Text -> Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
t (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
lookupEntity (Int -> Text -> Text
T.drop 1 Text
t)
  escapedChar :: Char -> Cm b Inlines
escapedChar c :: Char
c = Inlines -> Cm b Inlines
forall b a. a -> Cm b a
Cm (Inlines -> Cm b Inlines) -> Inlines -> Cm b Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inlines
B.str (Text -> Inlines) -> Text -> Inlines
forall a b. (a -> b) -> a -> b
$ Char -> Text
T.singleton Char
c
  emph :: Cm b Inlines -> Cm b Inlines
emph ils :: Cm b Inlines
ils = Inlines -> Inlines
B.emph (Inlines -> Inlines) -> Cm b Inlines -> Cm b Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cm b Inlines
ils
  strong :: Cm b Inlines -> Cm b Inlines
strong ils :: Cm b Inlines
ils = Inlines -> Inlines
B.strong (Inlines -> Inlines) -> Cm b Inlines -> Cm b Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cm b Inlines
ils
  link :: Text -> Text -> Cm b Inlines -> Cm b Inlines
link target :: Text
target title :: Text
title ils :: Cm b Inlines
ils = Text -> Text -> Inlines -> Inlines
B.link Text
target Text
title (Inlines -> Inlines) -> Cm b Inlines -> Cm b Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cm b Inlines
ils
  image :: Text -> Text -> Cm b Inlines -> Cm b Inlines
image target :: Text
target title :: Text
title ils :: Cm b Inlines
ils = Text -> Text -> Inlines -> Inlines
B.image Text
target Text
title (Inlines -> Inlines) -> Cm b Inlines -> Cm b Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cm b Inlines
ils
  code :: Text -> Cm b Inlines
code t :: Text
t = Inlines -> Cm b Inlines
forall b a. a -> Cm b a
Cm (Inlines -> Cm b Inlines) -> Inlines -> Cm b Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inlines
B.code Text
t
  rawInline :: Format -> Text -> Cm b Inlines
rawInline (C.Format f :: Text
f) t :: Text
t = Inlines -> Cm b Inlines
forall b a. a -> Cm b a
Cm (Inlines -> Cm b Inlines) -> Inlines -> Cm b Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Inlines
B.rawInline Text
f Text
t

instance Rangeable (Cm () B.Inlines) where
  ranged :: SourceRange -> Cm () Inlines -> Cm () Inlines
ranged _r :: SourceRange
_r x :: Cm () Inlines
x = Cm () Inlines
x

instance Rangeable (Cm SourceRange B.Inlines) where
  ranged :: SourceRange -> Cm SourceRange Inlines -> Cm SourceRange Inlines
ranged r :: SourceRange
r = Attributes -> Cm SourceRange Inlines -> Cm SourceRange Inlines
forall a. HasAttributes a => Attributes -> a -> a
addAttributes [("data-pos", String -> Text
T.pack (SourceRange -> String
forall a. Show a => a -> String
show SourceRange
r))]

instance Walkable Inline b => ToPlainText (Cm a b) where
  toPlainText :: Cm a b -> Text
toPlainText = b -> Text
forall a. Walkable Inline a => a -> Text
stringify (b -> Text) -> (Cm a b -> b) -> Cm a b -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inline -> Inline) -> b -> b
forall a b. Walkable a b => (a -> a) -> b -> b
walk Inline -> Inline
unemoji (b -> b) -> (Cm a b -> b) -> Cm a b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cm a b -> b
forall b a. Cm b a -> a
unCm

unemoji :: Inline -> Inline
unemoji :: Inline -> Inline
unemoji (Span ("",["emoji"],[("data-emoji",alias :: Text
alias)]) _)
          = Text -> Inline
Str (":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
alias Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ":")
unemoji x :: Inline
x = Inline
x

instance (Rangeable (Cm a B.Inlines),
          Rangeable (Cm a B.Blocks))
      => IsBlock (Cm a B.Inlines) (Cm a B.Blocks) where
  paragraph :: Cm a Inlines -> Cm a Blocks
paragraph ils :: Cm a Inlines
ils = Blocks -> Cm a Blocks
forall b a. a -> Cm b a
Cm (Blocks -> Cm a Blocks) -> Blocks -> Cm a Blocks
forall a b. (a -> b) -> a -> b
$ Inlines -> Blocks
B.para (Inlines -> Blocks) -> Inlines -> Blocks
forall a b. (a -> b) -> a -> b
$ Cm a Inlines -> Inlines
forall b a. Cm b a -> a
unCm Cm a Inlines
ils
  plain :: Cm a Inlines -> Cm a Blocks
plain ils :: Cm a Inlines
ils = Blocks -> Cm a Blocks
forall b a. a -> Cm b a
Cm (Blocks -> Cm a Blocks) -> Blocks -> Cm a Blocks
forall a b. (a -> b) -> a -> b
$ Inlines -> Blocks
B.plain (Inlines -> Blocks) -> Inlines -> Blocks
forall a b. (a -> b) -> a -> b
$ Cm a Inlines -> Inlines
forall b a. Cm b a -> a
unCm Cm a Inlines
ils
  thematicBreak :: Cm a Blocks
thematicBreak = Blocks -> Cm a Blocks
forall b a. a -> Cm b a
Cm Blocks
B.horizontalRule
  blockQuote :: Cm a Blocks -> Cm a Blocks
blockQuote bs :: Cm a Blocks
bs = Blocks -> Blocks
B.blockQuote (Blocks -> Blocks) -> Cm a Blocks -> Cm a Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cm a Blocks
bs
  codeBlock :: Text -> Text -> Cm a Blocks
codeBlock info :: Text
info t :: Text
t =
    Blocks -> Cm a Blocks
forall b a. a -> Cm b a
Cm (Blocks -> Cm a Blocks) -> Blocks -> Cm a Blocks
forall a b. (a -> b) -> a -> b
$ Attr -> Text -> Blocks
B.codeBlockWith Attr
forall a. (Text, [Text], [a])
attr (Text -> Blocks) -> Text -> Blocks
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
t (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripSuffix "\n" Text
t
    where attr :: (Text, [Text], [a])
attr = ("", [Text
lang | Bool -> Bool
not (Text -> Bool
T.null Text
lang)], [])
          lang :: Text
lang = (Char -> Bool) -> Text -> Text
T.takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) Text
info
  heading :: Int -> Cm a Inlines -> Cm a Blocks
heading level :: Int
level ils :: Cm a Inlines
ils = Blocks -> Cm a Blocks
forall b a. a -> Cm b a
Cm (Blocks -> Cm a Blocks) -> Blocks -> Cm a Blocks
forall a b. (a -> b) -> a -> b
$ Int -> Inlines -> Blocks
B.header Int
level (Inlines -> Blocks) -> Inlines -> Blocks
forall a b. (a -> b) -> a -> b
$ Cm a Inlines -> Inlines
forall b a. Cm b a -> a
unCm Cm a Inlines
ils
  rawBlock :: Format -> Text -> Cm a Blocks
rawBlock (C.Format f :: Text
f) t :: Text
t = Blocks -> Cm a Blocks
forall b a. a -> Cm b a
Cm (Blocks -> Cm a Blocks) -> Blocks -> Cm a Blocks
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Blocks
B.rawBlock Text
f Text
t
  referenceLinkDefinition :: Text -> (Text, Text) -> Cm a Blocks
referenceLinkDefinition _ _ = Blocks -> Cm a Blocks
forall b a. a -> Cm b a
Cm Blocks
forall a. Monoid a => a
mempty
  list :: ListType -> ListSpacing -> [Cm a Blocks] -> Cm a Blocks
list (C.BulletList _) lSpacing :: ListSpacing
lSpacing items :: [Cm a Blocks]
items =
    Blocks -> Cm a Blocks
forall b a. a -> Cm b a
Cm (Blocks -> Cm a Blocks)
-> ([Cm a Blocks] -> Blocks) -> [Cm a Blocks] -> Cm a Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Blocks] -> Blocks
B.bulletList ([Blocks] -> Blocks)
-> ([Cm a Blocks] -> [Blocks]) -> [Cm a Blocks] -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListSpacing -> [Blocks] -> [Blocks]
handleSpacing ListSpacing
lSpacing ([Blocks] -> [Blocks])
-> ([Cm a Blocks] -> [Blocks]) -> [Cm a Blocks] -> [Blocks]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cm a Blocks -> Blocks) -> [Cm a Blocks] -> [Blocks]
forall a b. (a -> b) -> [a] -> [b]
map Cm a Blocks -> Blocks
forall b a. Cm b a -> a
unCm ([Cm a Blocks] -> Cm a Blocks) -> [Cm a Blocks] -> Cm a Blocks
forall a b. (a -> b) -> a -> b
$ [Cm a Blocks]
items
  list (C.OrderedList startnum :: Int
startnum enumtype :: EnumeratorType
enumtype delimtype :: DelimiterType
delimtype) lSpacing :: ListSpacing
lSpacing items :: [Cm a Blocks]
items =
    Blocks -> Cm a Blocks
forall b a. a -> Cm b a
Cm (Blocks -> Cm a Blocks)
-> ([Cm a Blocks] -> Blocks) -> [Cm a Blocks] -> Cm a Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListAttributes -> [Blocks] -> Blocks
B.orderedListWith ListAttributes
attr ([Blocks] -> Blocks)
-> ([Cm a Blocks] -> [Blocks]) -> [Cm a Blocks] -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListSpacing -> [Blocks] -> [Blocks]
handleSpacing ListSpacing
lSpacing ([Blocks] -> [Blocks])
-> ([Cm a Blocks] -> [Blocks]) -> [Cm a Blocks] -> [Blocks]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cm a Blocks -> Blocks) -> [Cm a Blocks] -> [Blocks]
forall a b. (a -> b) -> [a] -> [b]
map Cm a Blocks -> Blocks
forall b a. Cm b a -> a
unCm ([Cm a Blocks] -> Cm a Blocks) -> [Cm a Blocks] -> Cm a Blocks
forall a b. (a -> b) -> a -> b
$ [Cm a Blocks]
items
    where sty :: ListNumberStyle
sty = case EnumeratorType
enumtype of
                  C.Decimal    -> ListNumberStyle
B.Decimal
                  C.UpperAlpha -> ListNumberStyle
B.UpperAlpha
                  C.LowerAlpha -> ListNumberStyle
B.LowerAlpha
                  C.UpperRoman -> ListNumberStyle
B.UpperRoman
                  C.LowerRoman -> ListNumberStyle
B.LowerRoman
          delim :: ListNumberDelim
delim = case DelimiterType
delimtype of
                    C.Period    -> ListNumberDelim
B.Period
                    C.OneParen  -> ListNumberDelim
B.OneParen
                    C.TwoParens -> ListNumberDelim
B.TwoParens
          attr :: ListAttributes
attr = (Int
startnum, ListNumberStyle
sty, ListNumberDelim
delim)

instance Rangeable (Cm () B.Blocks) where
  ranged :: SourceRange -> Cm () Blocks -> Cm () Blocks
ranged _r :: SourceRange
_r x :: Cm () Blocks
x = Cm () Blocks
x

instance Rangeable (Cm SourceRange B.Blocks) where
  ranged :: SourceRange -> Cm SourceRange Blocks -> Cm SourceRange Blocks
ranged r :: SourceRange
r x :: Cm SourceRange Blocks
x = Attr -> Blocks -> Blocks
B.divWith ("",[],[("data-pos",String -> Text
T.pack (SourceRange -> String
forall a. Show a => a -> String
show SourceRange
r))]) (Blocks -> Blocks)
-> Cm SourceRange Blocks -> Cm SourceRange Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cm SourceRange Blocks
x

instance HasMath (Cm b B.Inlines) where
  inlineMath :: Text -> Cm b Inlines
inlineMath t :: Text
t = Inlines -> Cm b Inlines
forall b a. a -> Cm b a
Cm (Inlines -> Cm b Inlines) -> Inlines -> Cm b Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inlines
B.math Text
t
  displayMath :: Text -> Cm b Inlines
displayMath t :: Text
t = Inlines -> Cm b Inlines
forall b a. a -> Cm b a
Cm (Inlines -> Cm b Inlines) -> Inlines -> Cm b Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inlines
B.displayMath Text
t

instance Rangeable (Cm b B.Inlines) => HasQuoted (Cm b B.Inlines) where
  singleQuoted :: Cm b Inlines -> Cm b Inlines
singleQuoted x :: Cm b Inlines
x = Inlines -> Inlines
B.singleQuoted (Inlines -> Inlines) -> Cm b Inlines -> Cm b Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cm b Inlines
x
  doubleQuoted :: Cm b Inlines -> Cm b Inlines
doubleQuoted x :: Cm b Inlines
x = Inlines -> Inlines
B.doubleQuoted (Inlines -> Inlines) -> Cm b Inlines -> Cm b Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cm b Inlines
x

instance HasEmoji (Cm b B.Inlines) where
  emoji :: Text -> Text -> Cm b Inlines
emoji kw :: Text
kw t :: Text
t = Inlines -> Cm b Inlines
forall b a. a -> Cm b a
Cm (Inlines -> Cm b Inlines) -> Inlines -> Cm b Inlines
forall a b. (a -> b) -> a -> b
$ Attr -> Inlines -> Inlines
B.spanWith ("",["emoji"],[("data-emoji",Text
kw)])
                  (Inlines -> Inlines) -> Inlines -> Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inlines
B.text Text
t

instance HasPipeTable (Cm a B.Inlines) (Cm a B.Blocks) where
  pipeTable :: [ColAlignment] -> [Cm a Inlines] -> [[Cm a Inlines]] -> Cm a Blocks
pipeTable aligns :: [ColAlignment]
aligns headerCells :: [Cm a Inlines]
headerCells rows :: [[Cm a Inlines]]
rows =
    Blocks -> Cm a Blocks
forall b a. a -> Cm b a
Cm (Blocks -> Cm a Blocks) -> Blocks -> Cm a Blocks
forall a b. (a -> b) -> a -> b
$ Caption
-> [ColSpec] -> TableHead -> [TableBody] -> TableFoot -> Blocks
B.table Caption
B.emptyCaption [ColSpec]
colspecs
           (Attr -> [Row] -> TableHead
TableHead Attr
nullAttr ([Cm a Inlines] -> [Row]
forall b. [Cm b Inlines] -> [Row]
toHeaderRow [Cm a Inlines]
headerCells))
           [Attr -> RowHeadColumns -> [Row] -> [Row] -> TableBody
TableBody Attr
nullAttr 0 [] ([Row] -> TableBody) -> [Row] -> TableBody
forall a b. (a -> b) -> a -> b
$ ([Cm a Inlines] -> Row) -> [[Cm a Inlines]] -> [Row]
forall a b. (a -> b) -> [a] -> [b]
map [Cm a Inlines] -> Row
forall b. [Cm b Inlines] -> Row
toRow [[Cm a Inlines]]
rows]
           (Attr -> [Row] -> TableFoot
TableFoot Attr
nullAttr [])
    where
     toHeaderRow :: [Cm b Inlines] -> [Row]
toHeaderRow cells :: [Cm b Inlines]
cells
       | [Cm b Inlines] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cm b Inlines]
cells  = []
       | Bool
otherwise   = [[Cm b Inlines] -> Row
forall b. [Cm b Inlines] -> Row
toRow [Cm b Inlines]
cells]
     toRow :: [Cm b Inlines] -> Row
toRow = Attr -> [Cell] -> Row
Row Attr
nullAttr ([Cell] -> Row)
-> ([Cm b Inlines] -> [Cell]) -> [Cm b Inlines] -> Row
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cm b Inlines -> Cell) -> [Cm b Inlines] -> [Cell]
forall a b. (a -> b) -> [a] -> [b]
map (Blocks -> Cell
B.simpleCell (Blocks -> Cell)
-> (Cm b Inlines -> Blocks) -> Cm b Inlines -> Cell
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inlines -> Blocks
B.plain (Inlines -> Blocks)
-> (Cm b Inlines -> Inlines) -> Cm b Inlines -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cm b Inlines -> Inlines
forall b a. Cm b a -> a
unCm)
     toPandocAlignment :: ColAlignment -> Alignment
toPandocAlignment LeftAlignedCol = Alignment
AlignLeft
     toPandocAlignment CenterAlignedCol = Alignment
AlignCenter
     toPandocAlignment RightAlignedCol = Alignment
AlignRight
     toPandocAlignment DefaultAlignedCol = Alignment
AlignDefault
     colspecs :: [ColSpec]
colspecs = (ColAlignment -> ColSpec) -> [ColAlignment] -> [ColSpec]
forall a b. (a -> b) -> [a] -> [b]
map (\al :: ColAlignment
al -> (ColAlignment -> Alignment
toPandocAlignment ColAlignment
al, ColWidth
ColWidthDefault))
                 [ColAlignment]
aligns

instance (Rangeable (Cm a B.Inlines), Rangeable (Cm a B.Blocks))
  => HasDefinitionList (Cm a B.Inlines) (Cm a B.Blocks) where
  definitionList :: ListSpacing -> [(Cm a Inlines, [Cm a Blocks])] -> Cm a Blocks
definitionList _ items :: [(Cm a Inlines, [Cm a Blocks])]
items =
    Blocks -> Cm a Blocks
forall b a. a -> Cm b a
Cm (Blocks -> Cm a Blocks) -> Blocks -> Cm a Blocks
forall a b. (a -> b) -> a -> b
$ [(Inlines, [Blocks])] -> Blocks
B.definitionList ([(Inlines, [Blocks])] -> Blocks)
-> [(Inlines, [Blocks])] -> Blocks
forall a b. (a -> b) -> a -> b
$ ((Cm a Inlines, [Cm a Blocks]) -> (Inlines, [Blocks]))
-> [(Cm a Inlines, [Cm a Blocks])] -> [(Inlines, [Blocks])]
forall a b. (a -> b) -> [a] -> [b]
map (Cm a Inlines, [Cm a Blocks]) -> (Inlines, [Blocks])
forall a b. Coercible a b => a -> b
coerce [(Cm a Inlines, [Cm a Blocks])]
items

instance (Rangeable (Cm a B.Inlines), Rangeable (Cm a B.Blocks))
  => HasTaskList (Cm a B.Inlines) (Cm a B.Blocks) where
  taskList :: ListType -> ListSpacing -> [(Bool, Cm a Blocks)] -> Cm a Blocks
taskList _ spacing :: ListSpacing
spacing items :: [(Bool, Cm a Blocks)]
items =
    Blocks -> Cm a Blocks
forall b a. a -> Cm b a
Cm (Blocks -> Cm a Blocks) -> Blocks -> Cm a Blocks
forall a b. (a -> b) -> a -> b
$ [Blocks] -> Blocks
B.bulletList ([Blocks] -> Blocks) -> [Blocks] -> Blocks
forall a b. (a -> b) -> a -> b
$ ListSpacing -> [Blocks] -> [Blocks]
handleSpacing ListSpacing
spacing ([Blocks] -> [Blocks]) -> [Blocks] -> [Blocks]
forall a b. (a -> b) -> a -> b
$ ((Bool, Cm a Blocks) -> Blocks)
-> [(Bool, Cm a Blocks)] -> [Blocks]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, Cm a Blocks) -> Blocks
forall a. (Bool, Cm a Blocks) -> Blocks
toTaskListItem [(Bool, Cm a Blocks)]
items

handleSpacing :: ListSpacing -> [B.Blocks] -> [B.Blocks]
handleSpacing :: ListSpacing -> [Blocks] -> [Blocks]
handleSpacing TightList = (Blocks -> Blocks) -> [Blocks] -> [Blocks]
forall a b. (a -> b) -> [a] -> [b]
map ([Block] -> Blocks
forall a. [a] -> Many a
B.fromList ([Block] -> Blocks) -> (Blocks -> [Block]) -> Blocks -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block -> Block) -> [Block] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map Block -> Block
paraToPlain ([Block] -> [Block]) -> (Blocks -> [Block]) -> Blocks -> [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocks -> [Block]
forall a. Many a -> [a]
B.toList)
handleSpacing LooseList = [Blocks] -> [Blocks]
forall a. a -> a
id

paraToPlain :: Block -> Block
paraToPlain :: Block -> Block
paraToPlain (Para xs :: [Inline]
xs) = [Inline] -> Block
Plain [Inline]
xs
paraToPlain x :: Block
x = Block
x

toTaskListItem :: (Bool, Cm a B.Blocks) -> B.Blocks
toTaskListItem :: (Bool, Cm a Blocks) -> Blocks
toTaskListItem (checked :: Bool
checked, item :: Cm a Blocks
item) = [Block] -> Blocks
forall a. [a] -> Many a
B.fromList ([Block] -> Blocks) -> [Block] -> Blocks
forall a b. (a -> b) -> a -> b
$
  case Blocks -> [Block]
forall a. Many a -> [a]
B.toList (Blocks -> [Block]) -> Blocks -> [Block]
forall a b. (a -> b) -> a -> b
$ Cm a Blocks -> Blocks
forall a b. Coercible a b => a -> b
coerce Cm a Blocks
item of
    (Plain ils :: [Inline]
ils : rest :: [Block]
rest) -> [Inline] -> Block
Plain (Inline
checkbox Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: Inline
Space Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline]
ils) Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
rest
    (Para  ils :: [Inline]
ils : rest :: [Block]
rest) -> [Inline] -> Block
Plain (Inline
checkbox Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: Inline
Space Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline]
ils) Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
rest
    bs :: [Block]
bs                 -> [Inline] -> Block
Plain [Inline
checkbox] Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
bs
    where checkbox :: Inline
checkbox = Text -> Inline
Str (if Bool
checked then "\9746" else "\9744")

instance Rangeable (Cm a B.Blocks)
  => HasDiv (Cm a B.Blocks) where
  div_ :: Cm a Blocks -> Cm a Blocks
div_ bs :: Cm a Blocks
bs = Attr -> Blocks -> Blocks
B.divWith Attr
nullAttr (Blocks -> Blocks) -> Cm a Blocks -> Cm a Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cm a Blocks
bs

instance HasStrikethrough (Cm a B.Inlines) where
  strikethrough :: Cm a Inlines -> Cm a Inlines
strikethrough ils :: Cm a Inlines
ils = Inlines -> Inlines
B.strikeout (Inlines -> Inlines) -> Cm a Inlines -> Cm a Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cm a Inlines
ils

instance HasSuperscript (Cm a B.Inlines) where
  superscript :: Cm a Inlines -> Cm a Inlines
superscript ils :: Cm a Inlines
ils = Inlines -> Inlines
B.superscript (Inlines -> Inlines) -> Cm a Inlines -> Cm a Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cm a Inlines
ils

instance HasSubscript (Cm a B.Inlines) where
  subscript :: Cm a Inlines -> Cm a Inlines
subscript ils :: Cm a Inlines
ils = Inlines -> Inlines
B.subscript (Inlines -> Inlines) -> Cm a Inlines -> Cm a Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cm a Inlines
ils

instance Rangeable (Cm a B.Inlines) => HasSpan (Cm a B.Inlines) where
  spanWith :: Attributes -> Cm a Inlines -> Cm a Inlines
spanWith attrs :: Attributes
attrs ils :: Cm a Inlines
ils =
    Attr -> Inlines -> Inlines
B.spanWith (Attributes -> Attr -> Attr
addToPandocAttr Attributes
attrs Attr
nullAttr) (Inlines -> Inlines) -> Cm a Inlines -> Cm a Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cm a Inlines
ils

instance HasAttributes (Cm a B.Blocks) where
  addAttributes :: Attributes -> Cm a Blocks -> Cm a Blocks
addAttributes attrs :: Attributes
attrs b :: Cm a Blocks
b = (Block -> Block) -> Blocks -> Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Attributes -> Block -> Block
addBlockAttrs Attributes
attrs) (Blocks -> Blocks) -> Cm a Blocks -> Cm a Blocks
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cm a Blocks
b

instance HasAttributes (Cm a B.Inlines) where
  addAttributes :: Attributes -> Cm a Inlines -> Cm a Inlines
addAttributes attrs :: Attributes
attrs il :: Cm a Inlines
il = (Inline -> Inline) -> Inlines -> Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Attributes -> Inline -> Inline
addInlineAttrs Attributes
attrs) (Inlines -> Inlines) -> Cm a Inlines -> Cm a Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cm a Inlines
il

addBlockAttrs :: [(T.Text, T.Text)] -> Block -> Block
addBlockAttrs :: Attributes -> Block -> Block
addBlockAttrs attrs :: Attributes
attrs (Header n :: Int
n curattrs :: Attr
curattrs ils :: [Inline]
ils) =
  Int -> Attr -> [Inline] -> Block
Header Int
n (Attributes -> Attr -> Attr
addToPandocAttr Attributes
attrs Attr
curattrs) [Inline]
ils
addBlockAttrs attrs :: Attributes
attrs (CodeBlock curattrs :: Attr
curattrs s :: Text
s) =
  Attr -> Text -> Block
CodeBlock (Attributes -> Attr -> Attr
addToPandocAttr Attributes
attrs Attr
curattrs) Text
s
addBlockAttrs attrs :: Attributes
attrs (Table curattrs :: Attr
curattrs capt :: Caption
capt colspecs :: [ColSpec]
colspecs thead :: TableHead
thead tbody :: [TableBody]
tbody tfoot :: TableFoot
tfoot) =
  Attr
-> Caption
-> [ColSpec]
-> TableHead
-> [TableBody]
-> TableFoot
-> Block
Table (Attributes -> Attr -> Attr
addToPandocAttr Attributes
attrs Attr
curattrs) Caption
capt [ColSpec]
colspecs TableHead
thead [TableBody]
tbody TableFoot
tfoot
addBlockAttrs attrs :: Attributes
attrs (Div curattrs :: Attr
curattrs bs :: [Block]
bs) =
  Attr -> [Block] -> Block
Div (Attributes -> Attr -> Attr
addToPandocAttr Attributes
attrs Attr
curattrs) [Block]
bs
addBlockAttrs attrs :: Attributes
attrs x :: Block
x =
  Attr -> [Block] -> Block
Div (Attributes -> Attr -> Attr
addToPandocAttr Attributes
attrs Attr
nullAttr) [Block
x]

addInlineAttrs :: [(T.Text, T.Text)] -> Inline -> Inline
addInlineAttrs :: Attributes -> Inline -> Inline
addInlineAttrs attrs :: Attributes
attrs (Link curattrs :: Attr
curattrs ils :: [Inline]
ils target :: (Text, Text)
target) =
  Attr -> [Inline] -> (Text, Text) -> Inline
Link (Attributes -> Attr -> Attr
addToPandocAttr Attributes
attrs Attr
curattrs) [Inline]
ils (Text, Text)
target
addInlineAttrs attrs :: Attributes
attrs (Image curattrs :: Attr
curattrs ils :: [Inline]
ils target :: (Text, Text)
target) =
  Attr -> [Inline] -> (Text, Text) -> Inline
Image (Attributes -> Attr -> Attr
addToPandocAttr Attributes
attrs Attr
curattrs) [Inline]
ils (Text, Text)
target
addInlineAttrs attrs :: Attributes
attrs (Span curattrs :: Attr
curattrs ils :: [Inline]
ils) =
  Attr -> [Inline] -> Inline
Span (Attributes -> Attr -> Attr
addToPandocAttr Attributes
attrs Attr
curattrs) [Inline]
ils
addInlineAttrs attrs :: Attributes
attrs (Code curattrs :: Attr
curattrs s :: Text
s) =
  Attr -> Text -> Inline
Code (Attributes -> Attr -> Attr
addToPandocAttr Attributes
attrs Attr
curattrs) Text
s
addInlineAttrs attrs :: Attributes
attrs x :: Inline
x =
  Attr -> [Inline] -> Inline
Span (Attributes -> Attr -> Attr
addToPandocAttr Attributes
attrs Attr
nullAttr) [Inline
x]

addToPandocAttr :: Attributes -> Attr -> Attr
addToPandocAttr :: Attributes -> Attr -> Attr
addToPandocAttr attrs :: Attributes
attrs attr :: Attr
attr = ((Text, Text) -> Attr -> Attr) -> Attr -> Attributes -> Attr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Text, Text) -> Attr -> Attr
forall a b.
(Eq a, IsString a) =>
(a, b) -> (b, [b], [(a, b)]) -> (b, [b], [(a, b)])
go Attr
attr Attributes
attrs
 where
  go :: (a, b) -> (b, [b], [(a, b)]) -> (b, [b], [(a, b)])
go ("id", v :: b
v) (_, cls :: [b]
cls, kvs :: [(a, b)]
kvs) = (b
v, [b]
cls, [(a, b)]
kvs)
  go ("class", v :: b
v) (ident :: b
ident, cls :: [b]
cls, kvs :: [(a, b)]
kvs) = (b
ident, b
vb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
cls, [(a, b)]
kvs)
  go (k :: a
k, v :: b
v) (ident :: b
ident, cls :: [b]
cls, kvs :: [(a, b)]
kvs) = (b
ident, [b]
cls, (a
k,b
v)(a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
:[(a, b)]
kvs)

instance (Rangeable (Cm a B.Inlines), Rangeable (Cm a B.Blocks))
     => HasFootnote (Cm a B.Inlines) (Cm a B.Blocks) where
  footnote :: Int -> Text -> Cm a Blocks -> Cm a Blocks
footnote _num :: Int
_num _lab :: Text
_lab _x :: Cm a Blocks
_x = Cm a Blocks
forall a. Monoid a => a
mempty
  footnoteList :: [Cm a Blocks] -> Cm a Blocks
footnoteList _xs :: [Cm a Blocks]
_xs = Cm a Blocks
forall a. Monoid a => a
mempty
  footnoteRef :: Text -> Text -> Cm a Blocks -> Cm a Inlines
footnoteRef _num :: Text
_num _lab :: Text
_lab contents :: Cm a Blocks
contents = Blocks -> Inlines
B.note (Blocks -> Inlines) -> Cm a Blocks -> Cm a Inlines
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cm a Blocks
contents

illegalCodePoint :: T.Text -> Bool
illegalCodePoint :: Text -> Bool
illegalCodePoint t :: Text
t =
  "&#" Text -> Text -> Bool
`T.isPrefixOf` Text
t Bool -> Bool -> Bool
&&
  let t' :: Text
t' = Int -> Text -> Text
T.drop 2 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=';') Text
t
      badvalue :: (Integer, Text) -> Bool
badvalue (n :: Integer
n, r :: Text
r) = Bool -> Bool
not (Text -> Bool
T.null Text
r) Bool -> Bool -> Bool
||
                        Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 1 Bool -> Bool -> Bool
||
                        Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> (0x10FFFF :: Integer)
  in
  case Text -> Maybe (Char, Text)
T.uncons Text
t' of
       Nothing -> Bool
True
       Just (x :: Char
x, rest :: Text
rest)
         | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'x' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'X'
           -> (String -> Bool)
-> ((Integer, Text) -> Bool)
-> Either String (Integer, Text)
-> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
True) (Integer, Text) -> Bool
badvalue (Reader Integer
forall a. Integral a => Reader a
TR.hexadecimal Text
rest)
         | Bool
otherwise
           -> (String -> Bool)
-> ((Integer, Text) -> Bool)
-> Either String (Integer, Text)
-> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
True) (Integer, Text) -> Bool
badvalue (Reader Integer
forall a. Integral a => Reader a
TR.decimal Text
t')

stringify :: Walkable Inline a => a -> T.Text
stringify :: a -> Text
stringify = (Inline -> Text) -> a -> Text
forall a b c. (Walkable a b, Monoid c) => (a -> c) -> b -> c
query Inline -> Text
go (a -> Text) -> (a -> a) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inline -> Inline) -> a -> a
forall a b. Walkable a b => (a -> a) -> b -> b
walk (Inline -> Inline
deNote (Inline -> Inline) -> (Inline -> Inline) -> Inline -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inline -> Inline
deQuote)
  where go :: Inline -> T.Text
        go :: Inline -> Text
go Space                                         = " "
        go SoftBreak                                     = " "
        go (Str x :: Text
x)                                       = Text
x
        go (Code _ x :: Text
x)                                    = Text
x
        go (Math _ x :: Text
x)                                    = Text
x
        go (RawInline (B.Format "html") t :: Text
t)
           | "<br" Text -> Text -> Bool
`T.isPrefixOf` Text
t                      = " "
        go LineBreak                                     = " "
        go _                                             = Text
forall a. Monoid a => a
mempty

deNote :: Inline -> Inline
deNote :: Inline -> Inline
deNote (Note _) = Text -> Inline
Str ""
deNote x :: Inline
x        = Inline
x

deQuote :: Inline -> Inline
deQuote :: Inline -> Inline
deQuote (Quoted SingleQuote xs :: [Inline]
xs) =
  Attr -> [Inline] -> Inline
Span ("",[],[]) (Text -> Inline
Str "\8216" Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline]
xs [Inline] -> [Inline] -> [Inline]
forall a. [a] -> [a] -> [a]
++ [Text -> Inline
Str "\8217"])
deQuote (Quoted DoubleQuote xs :: [Inline]
xs) =
  Attr -> [Inline] -> Inline
Span ("",[],[]) (Text -> Inline
Str "\8220" Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline]
xs [Inline] -> [Inline] -> [Inline]
forall a. [a] -> [a] -> [a]
++ [Text -> Inline
Str "\8221"])
deQuote x :: Inline
x = Inline
x