{-# LANGUAGE LambdaCase #-}
{-# 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 qualified Text.Pandoc.Builder as B
import Text.Pandoc.Definition (Attr)
import qualified Text.Pandoc.Walk as W

elPandocAttr ::
  DomBuilder t m =>
  -- | Element name
  Text ->
  -- | Pandoc attribute object. TODO: Use a sensible type.
  Attr ->
  -- | Child widget
  m a ->
  m a
elPandocAttr :: Text -> Attr -> m a -> m a
elPandocAttr Text
name = Text -> Map Text Text -> m a -> m a
forall t (m :: * -> *) a.
DomBuilder t m =>
Text -> Map Text Text -> m a -> m a
elAttr Text
name (Map Text Text -> m a -> m a)
-> (Attr -> Map Text Text) -> Attr -> m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text Text -> Map Text Text
forall k. Map k Text -> Map k Text
sansEmptyAttrs (Map Text Text -> Map Text Text)
-> (Attr -> Map Text Text) -> Attr -> Map Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attr -> Map Text Text
renderAttr

sansEmptyAttrs :: Map k Text -> Map k Text
sansEmptyAttrs :: Map k Text -> Map k Text
sansEmptyAttrs = (Text -> Bool) -> Map k Text -> Map k Text
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null)

renderAttr ::
  -- | Pandoc attribute object. TODO: Use a sensible type.
  Attr ->
  Map Text Text
renderAttr :: Attr -> Map Text Text
renderAttr (Text
identifier, [Text]
classes, [(Text, Text)]
attrs) =
  Index (Map Text Text)
"id" Index (Map Text Text) -> IxValue (Map Text Text) -> Map Text Text
forall m. (At m, Monoid m) => Index m -> IxValue m -> m
=: Text
IxValue (Map Text Text)
identifier
    Map Text Text -> Map Text Text -> Map Text Text
forall a. Semigroup a => a -> a -> a
<> Index (Map Text Text)
"class" Index (Map Text Text) -> IxValue (Map Text Text) -> Map Text Text
forall m. (At m, Monoid m) => Index m -> IxValue m -> m
=: [Text] -> Text
T.unwords [Text]
classes
    Map Text Text -> Map Text Text -> Map Text Text
forall a. Semigroup a => a -> a -> a
<> [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Text)]
attrs

addClass ::
  -- | The class to add
  Text ->
  -- | Pandoc attribute object. TODO: Use a sensible type.
  Attr ->
  Attr
addClass :: Text -> Attr -> Attr
addClass Text
c (Text
identifier, [Text]
classes, [(Text, Text)]
attrs) = (Text
identifier, Text
c Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
classes, [(Text, Text)]
attrs)

headerElement :: Int -> Text
headerElement :: Int -> Text
headerElement Int
level = case Int
level of
  Int
1 -> Text
"h1"
  Int
2 -> Text
"h2"
  Int
3 -> Text
"h3"
  Int
4 -> Text
"h4"
  Int
5 -> Text
"h5"
  Int
6 -> Text
"h6"
  Int
_ -> [Char] -> Text
forall a. HasCallStack => [Char] -> a
error [Char]
"bad header level"

-- | Convert Pandoc AST inlines to raw text.
plainify :: [B.Inline] -> Text
plainify :: [Inline] -> Text
plainify = (Inline -> Text) -> [Inline] -> Text
forall a b c. (Walkable a b, Monoid c) => (a -> c) -> b -> c
W.query ((Inline -> Text) -> [Inline] -> Text)
-> (Inline -> Text) -> [Inline] -> Text
forall a b. (a -> b) -> a -> b
$ \case
  B.Str Text
x -> Text
x
  B.Code Attr
_attr Text
x -> Text
x
  Inline
B.Space -> Text
" "
  Inline
B.SoftBreak -> Text
" "
  Inline
B.LineBreak -> Text
" "
  B.RawInline Format
_fmt Text
s -> Text
s
  B.Math MathType
_mathTyp Text
s -> Text
s
  -- Ignore the rest of AST nodes, as they are recursively defined in terms of
  -- `Inline` which `W.query` will traverse again.
  Inline
_ -> Text
""