{-# LANGUAGE RecordWildCards #-}

module Heist.Extra.Splices.Pandoc.Ctx (
  RenderCtx (..),
  mkRenderCtx,
  emptyRenderCtx,
  rewriteClass,
  ctxSansCustomSplicing,
  concatSpliceFunc,
) where

import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import Heist qualified as H
import Heist.Extra.Splices.Pandoc.Attr (concatAttr)
import Heist.Interpreted qualified as HI
import Text.Pandoc.Builder qualified as B
import Text.XmlHtml qualified as X

{- | The configuration context under which we must render a `Pandoc` document
 using the given Heist template.
-}
data RenderCtx = RenderCtx
  { -- The XML node which contains individual AST rendering definitions
    -- This corresponds to pandoc.tpl
    RenderCtx -> Maybe Node
rootNode :: Maybe X.Node
  , -- Attributes for a given AST node.
    RenderCtx -> Block -> Attr
bAttr :: B.Block -> B.Attr
  , RenderCtx -> Inline -> Attr
iAttr :: B.Inline -> B.Attr
  , -- Class attribute rewrite rules
    RenderCtx -> Map Text Text
classMap :: Map Text Text
  , -- Custom render functions for AST nodes.
    RenderCtx -> Block -> Maybe (Splice Identity)
blockSplice :: B.Block -> Maybe (HI.Splice Identity)
  , RenderCtx -> Inline -> Maybe (Splice Identity)
inlineSplice :: B.Inline -> Maybe (HI.Splice Identity)
  }

mkRenderCtx ::
  (Monad m) =>
  Map Text Text ->
  (RenderCtx -> B.Block -> Maybe (HI.Splice Identity)) ->
  (RenderCtx -> B.Inline -> Maybe (HI.Splice Identity)) ->
  H.HeistT Identity m RenderCtx
mkRenderCtx :: forall (m :: Type -> Type).
Monad m =>
Map Text Text
-> (RenderCtx -> Block -> Maybe (Splice Identity))
-> (RenderCtx -> Inline -> Maybe (Splice Identity))
-> HeistT Identity m RenderCtx
mkRenderCtx Map Text Text
classMap RenderCtx -> Block -> Maybe (Splice Identity)
bS RenderCtx -> Inline -> Maybe (Splice Identity)
iS = do
  Node
node <- HeistT Identity m Node
forall (m :: Type -> Type) (n :: Type -> Type).
Monad m =>
HeistT n m Node
H.getParamNode
  RenderCtx -> HeistT Identity m RenderCtx
forall a. a -> HeistT Identity m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (RenderCtx -> HeistT Identity m RenderCtx)
-> RenderCtx -> HeistT Identity m RenderCtx
forall a b. (a -> b) -> a -> b
$
    Node
-> Map Text Text
-> (RenderCtx -> Block -> Maybe (Splice Identity))
-> (RenderCtx -> Inline -> Maybe (Splice Identity))
-> RenderCtx
mkRenderCtxWith
      Node
node
      Map Text Text
classMap
      RenderCtx -> Block -> Maybe (Splice Identity)
bS
      RenderCtx -> Inline -> Maybe (Splice Identity)
iS

mkRenderCtxWith ::
  X.Node ->
  -- | How to replace classes in Div and Span nodes.
  Map Text Text ->
  -- | Custom handling of AST block nodes
  (RenderCtx -> B.Block -> Maybe (HI.Splice Identity)) ->
  -- | Custom handling of AST inline nodes
  (RenderCtx -> B.Inline -> Maybe (HI.Splice Identity)) ->
  RenderCtx
mkRenderCtxWith :: Node
-> Map Text Text
-> (RenderCtx -> Block -> Maybe (Splice Identity))
-> (RenderCtx -> Inline -> Maybe (Splice Identity))
-> RenderCtx
mkRenderCtxWith Node
node Map Text Text
classMap RenderCtx -> Block -> Maybe (Splice Identity)
bS RenderCtx -> Inline -> Maybe (Splice Identity)
iS = do
  let ctx :: RenderCtx
ctx =
        Maybe Node
-> (Block -> Attr)
-> (Inline -> Attr)
-> Map Text Text
-> (Block -> Maybe (Splice Identity))
-> (Inline -> Maybe (Splice Identity))
-> RenderCtx
RenderCtx
          (Node -> Maybe Node
forall a. a -> Maybe a
Just Node
node)
          (Node -> Block -> Attr
blockLookupAttr Node
node)
          (Node -> Inline -> Attr
inlineLookupAttr Node
node)
          Map Text Text
classMap
          (RenderCtx -> Block -> Maybe (Splice Identity)
bS RenderCtx
ctx)
          (RenderCtx -> Inline -> Maybe (Splice Identity)
iS RenderCtx
ctx)
   in RenderCtx
ctx

emptyRenderCtx :: RenderCtx
emptyRenderCtx :: RenderCtx
emptyRenderCtx =
  Maybe Node
-> (Block -> Attr)
-> (Inline -> Attr)
-> Map Text Text
-> (Block -> Maybe (Splice Identity))
-> (Inline -> Maybe (Splice Identity))
-> RenderCtx
RenderCtx Maybe Node
forall a. Maybe a
Nothing (Attr -> Block -> Attr
forall a b. a -> b -> a
const Attr
B.nullAttr) (Attr -> Inline -> Attr
forall a b. a -> b -> a
const Attr
B.nullAttr) Map Text Text
forall a. Monoid a => a
mempty (Maybe (Splice Identity) -> Block -> Maybe (Splice Identity)
forall a b. a -> b -> a
const Maybe (Splice Identity)
forall a. Maybe a
Nothing) (Maybe (Splice Identity) -> Inline -> Maybe (Splice Identity)
forall a b. a -> b -> a
const Maybe (Splice Identity)
forall a. Maybe a
Nothing)

-- | Strip any custom splicing out of the given render context
ctxSansCustomSplicing :: RenderCtx -> RenderCtx
ctxSansCustomSplicing :: RenderCtx -> RenderCtx
ctxSansCustomSplicing RenderCtx
ctx =
  RenderCtx
ctx
    { blockSplice = const Nothing
    , inlineSplice = const Nothing
    }

concatSpliceFunc :: Alternative f => (t -> f a) -> (t -> f a) -> t -> f a
concatSpliceFunc :: forall (f :: Type -> Type) t a.
Alternative f =>
(t -> f a) -> (t -> f a) -> t -> f a
concatSpliceFunc t -> f a
f t -> f a
g t
x =
  [f a] -> f a
forall (t :: Type -> Type) (f :: Type -> Type) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
    [ t -> f a
f t
x
    , t -> f a
g t
x
    ]

rewriteClass :: RenderCtx -> B.Attr -> B.Attr
rewriteClass :: RenderCtx -> Attr -> Attr
rewriteClass RenderCtx {Maybe Node
Map Text Text
Inline -> Maybe (Splice Identity)
Inline -> Attr
Block -> Maybe (Splice Identity)
Block -> Attr
rootNode :: RenderCtx -> Maybe Node
bAttr :: RenderCtx -> Block -> Attr
iAttr :: RenderCtx -> Inline -> Attr
classMap :: RenderCtx -> Map Text Text
blockSplice :: RenderCtx -> Block -> Maybe (Splice Identity)
inlineSplice :: RenderCtx -> Inline -> Maybe (Splice Identity)
rootNode :: Maybe Node
bAttr :: Block -> Attr
iAttr :: Inline -> Attr
classMap :: Map Text Text
blockSplice :: Block -> Maybe (Splice Identity)
inlineSplice :: Inline -> Maybe (Splice Identity)
..} (Text
id', [Text]
classes, [(Text, Text)]
attr) =
  (Text
id', Map Text Text -> Text -> Text
forall a. Ord a => Map a a -> a -> a
rewrite Map Text Text
classMap (Text -> Text) -> [Text] -> [Text]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
classes, [(Text, Text)]
attr)
  where
    rewrite :: Ord a => Map a a -> a -> a
    rewrite :: forall a. Ord a => Map a a -> a -> a
rewrite Map a a
rules a
x =
      a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
x (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ a -> Map a a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
x Map a a
rules

blockLookupAttr :: X.Node -> B.Block -> B.Attr
blockLookupAttr :: Node -> Block -> Attr
blockLookupAttr Node
node = \case
  B.Para {} -> Node -> Text -> Attr
childTagAttr Node
node Text
"Para"
  B.BulletList {} -> Node -> Text -> Attr
childTagAttr Node
node Text
"BulletList"
  B.OrderedList {} -> Node -> Text -> Attr
childTagAttr Node
node Text
"OrderedList"
  B.CodeBlock {} -> Node -> Text -> Attr
childTagAttr Node
node Text
"CodeBlock"
  B.BlockQuote {} -> Node -> Text -> Attr
childTagAttr Node
node Text
"BlockQuote"
  Block
_ -> Attr
B.nullAttr

inlineLookupAttr :: X.Node -> B.Inline -> B.Attr
inlineLookupAttr :: Node -> Inline -> Attr
inlineLookupAttr Node
node = \case
  B.Code {} -> Node -> Text -> Attr
childTagAttr Node
node Text
"Code"
  B.Note [Block]
_ ->
    Node -> Text -> Attr
childTagAttr Node
node Text
"Note"
  B.Link Attr
_ [Inline]
_ (Text
url, Text
_) ->
    Attr -> Maybe Attr -> Attr
forall a. a -> Maybe a -> a
fromMaybe Attr
B.nullAttr (Maybe Attr -> Attr) -> Maybe Attr -> Attr
forall a b. (a -> b) -> a -> b
$ do
      Node
link <- Text -> Node -> Maybe Node
X.childElementTag Text
"PandocLink" Node
node
      let innerTag :: Text
innerTag = if Text
"://" Text -> Text -> Bool
`T.isInfixOf` Text
url then Text
"External" else Text
"Internal"
      Attr -> Maybe Attr
forall a. a -> Maybe a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Attr -> Maybe Attr) -> Attr -> Maybe Attr
forall a b. (a -> b) -> a -> b
$ Node -> Attr
attrFromNode Node
link Attr -> Attr -> Attr
`concatAttr` Node -> Text -> Attr
childTagAttr Node
link Text
innerTag
  Inline
_ -> Attr
B.nullAttr

childTagAttr :: X.Node -> Text -> B.Attr
childTagAttr :: Node -> Text -> Attr
childTagAttr Node
x Text
name =
  Attr -> (Node -> Attr) -> Maybe Node -> Attr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Attr
B.nullAttr Node -> Attr
attrFromNode (Maybe Node -> Attr) -> Maybe Node -> Attr
forall a b. (a -> b) -> a -> b
$ Text -> Node -> Maybe Node
X.childElementTag Text
name Node
x

attrFromNode :: X.Node -> B.Attr
attrFromNode :: Node -> Attr
attrFromNode Node
node =
  let mClass :: [Text]
mClass = [Text] -> (Text -> [Text]) -> Maybe Text -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Text]
forall a. Monoid a => a
mempty Text -> [Text]
forall t. IsText t "words" => t -> [t]
words (Maybe Text -> [Text]) -> Maybe Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Node -> Maybe Text
X.getAttribute Text
"class" Node
node
      id' :: Text
id' = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Node -> Maybe Text
X.getAttribute Text
"id" Node
node
      attrs :: [(Text, Text)]
attrs = ((Text, Text) -> Bool) -> [(Text, Text)] -> [(Text, Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"class") (Text -> Bool) -> ((Text, Text) -> Text) -> (Text, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst) ([(Text, Text)] -> [(Text, Text)])
-> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ Node -> [(Text, Text)]
X.elementAttrs Node
node
   in (Text
id', [Text]
mClass, [(Text, Text)]
attrs)