content: {-# LANGUAGE ExtendedDefaultRules       #-}
  {-# LANGUAGE FlexibleContexts           #-}
  {-# LANGUAGE FlexibleInstances          #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE MultiParamTypeClasses      #-}
  {-# LANGUAGE OverloadedStrings          #-}
  {-# LANGUAGE UndecidableInstances       #-}
  {-# LANGUAGE MonoLocalBinds             #-}
  
  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.Wikilinks
  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.Alerts
  import Commonmark.Extensions.Smart
  import Data.Char (isSpace)
  import Data.Coerce (coerce)
  
  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 = addAttributes [("data-pos", T.pack (show r))]
  
  instance HasMath (Cm b B.Inlines) where
    inlineMath t = Cm $ B.math t
    displayMath t = Cm $ B.displayMath t
  
  instance Rangeable (Cm b B.Inlines) => HasQuoted (Cm b B.Inlines) where
    singleQuoted x = B.singleQuoted <$> x
    doubleQuoted x = B.doubleQuoted <$> x
  
  instance HasEmoji (Cm b B.Inlines) where
    emoji kw t = Cm $ B.spanWith ("",["emoji"],[("data-emoji",kw)])
                    $ B.text t
  
  instance HasWikilinks (Cm b B.Inlines) where
    wikilink t il = Cm $ B.linkWith (mempty, ["wikilink"], mempty) t "" $ unCm il
  
  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))
    => HasAlerts (Cm a B.Inlines) (Cm a B.Blocks) where
    alert alertType bs =
      Cm $ B.divWith ("",[T.toLower $ alertName alertType],[])
         $ B.divWith ("",["title"],[])
             (B.para (B.str (alertName alertType)))
           <> coerce bs
  
  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) -> Para  (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 (Table curattrs capt colspecs thead tbody tfoot) =
    Table (addToPandocAttr attrs curattrs) capt colspecs thead tbody tfoot
  addBlockAttrs attrs (Div curattrs bs) =
    Div (addToPandocAttr attrs curattrs) bs
  addBlockAttrs attrs x = -- add wrapper="1" if we needed to add a Div
    Div (addToPandocAttr (("wrapper","1"):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 = -- add wrapper="1" if we needed to add a Span
    Span (addToPandocAttr (("wrapper","1"):attrs) nullAttr) [x]
  
  addToPandocAttr :: Attributes -> Attr -> Attr
  -- avoid adding spurious extra data-pos to wrapper div (#159):
  addToPandocAttr [("data-pos", _)] attrs@(_,_,("wrapper","1"):_)  = attrs
  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 . walk deNote <$> 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
  