    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# OPTIONS_GHC -fsimpl-tick-factor=140 #-}

    module Typst.Show (applyShowRules) where

    import Data.Array ((!))
    import qualified Data.Map as M
    import Data.Sequence (Seq)
    import qualified Data.Sequence as Seq
    import Data.Text (Text)
    import qualified Data.Text as T
    import Text.Parsec (getState, updateState)
    import qualified Text.Regex.TDFA as TDFA
    import Typst.Regex (RE (..), makeLiteralRE)
    import Typst.Syntax
    import Typst.Types

    -- import Debug.Trace

    applyShowRules :: Monad m => Seq Content -> MP m (Seq Content)
    applyShowRules :: forall (m :: * -> *). Monad m => Seq Content -> MP m (Seq Content)
    applyShowRules Seq Content
    cs = do
      rules <- EvalState m -> [ShowRule]
    forall (m :: * -> *). EvalState m -> [ShowRule]
    evalShowRules (EvalState m -> [ShowRule])
    -> ParsecT [Markup] (EvalState m) m (EvalState m)
    -> ParsecT [Markup] (EvalState m) m [ShowRule]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ParsecT [Markup] (EvalState m) m (EvalState m)
    forall (m :: * -> *) s u. Monad m => ParsecT s u m u
    getState
      foldMap (tryShowRules rules) cs

    -- By experiment, it seems that show rules work this way:
    -- the first (i.e. most recently defined) one to match a given element
    -- are applied first.
    tryShowRules ::
      Monad m =>
      [ShowRule] ->
      Content ->
      MP m (Seq Content)
    tryShowRules :: forall (m :: * -> *).
    Monad m =>
    [ShowRule] -> Content -> MP m (Seq Content)
    tryShowRules (ShowRule
    r:[ShowRule]
    rest) e :: Content
    e@(Elt Identifier
    "text" Maybe SourcePos
    pos Map Identifier Val
    fields) =
      case Identifier -> Map Identifier Val -> Maybe Val
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup Identifier
    "body" Map Identifier Val
    fields of
        Just (VContent Seq Content
    cs) -> do
          cs' <- (Content -> ParsecT [Markup] (EvalState m) m (Seq Content))
    -> Seq Content -> ParsecT [Markup] (EvalState m) m (Seq Content)
    forall m a. Monoid m => (a -> m) -> Seq a -> m
    forall (t :: * -> *) m a.
    (Foldable t, Monoid m) =>
    (a -> m) -> t a -> m
    foldMap ([ShowRule]
    -> Content -> ParsecT [Markup] (EvalState m) m (Seq Content)
    forall (m :: * -> *).
    Monad m =>
    [ShowRule] -> Content -> MP m (Seq Content)
    tryShowRules (ShowRule
    rShowRule -> [ShowRule] -> [ShowRule]
    forall a. a -> [a] -> [a]
    :[ShowRule]
    rest)) Seq Content
    cs
          pure $ Seq.singleton $
            Elt "text" pos (M.insert "body" (VContent cs') fields)
        Maybe Val
    _ -> ShowRule
    -> Content -> ParsecT [Markup] (EvalState m) m (Seq Content)
    forall (m :: * -> *).
    Monad m =>
    ShowRule -> Content -> MP m (Seq Content)
    applyShowRule ShowRule
    r Content
    e ParsecT [Markup] (EvalState m) m (Seq Content)
    -> (Seq Content -> ParsecT [Markup] (EvalState m) m (Seq Content))
    -> ParsecT [Markup] (EvalState m) m (Seq Content)
    forall a b.
    ParsecT [Markup] (EvalState m) m a
    -> (a -> ParsecT [Markup] (EvalState m) m b)
    -> ParsecT [Markup] (EvalState m) m b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (Content -> ParsecT [Markup] (EvalState m) m (Seq Content))
    -> Seq Content -> ParsecT [Markup] (EvalState m) m (Seq Content)
    forall m a. Monoid m => (a -> m) -> Seq a -> m
    forall (t :: * -> *) m a.
    (Foldable t, Monoid m) =>
    (a -> m) -> t a -> m
    foldMap ([ShowRule]
    -> Content -> ParsecT [Markup] (EvalState m) m (Seq Content)
    forall (m :: * -> *).
    Monad m =>
    [ShowRule] -> Content -> MP m (Seq Content)
    tryShowRules [ShowRule]
    rest)
    tryShowRules [ShowRule]
    rs Content
    c =
      case [ShowRule]
    rs of
        [] -> Seq Content -> ParsecT [Markup] (EvalState m) m (Seq Content)
    forall a. a -> ParsecT [Markup] (EvalState m) m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Seq Content -> ParsecT [Markup] (EvalState m) m (Seq Content))
    -> Seq Content -> ParsecT [Markup] (EvalState m) m (Seq Content)
    forall a b. (a -> b) -> a -> b
    $ Content -> Seq Content
    forall a. a -> Seq a
    Seq.singleton Content
    c
        (ShowRule
    r:[ShowRule]
    rest) -> ShowRule
    -> Content -> ParsecT [Markup] (EvalState m) m (Seq Content)
    forall (m :: * -> *).
    Monad m =>
    ShowRule -> Content -> MP m (Seq Content)
    applyShowRule ShowRule
    r Content
    c ParsecT [Markup] (EvalState m) m (Seq Content)
    -> (Seq Content -> ParsecT [Markup] (EvalState m) m (Seq Content))
    -> ParsecT [Markup] (EvalState m) m (Seq Content)
    forall a b.
    ParsecT [Markup] (EvalState m) m a
    -> (a -> ParsecT [Markup] (EvalState m) m b)
    -> ParsecT [Markup] (EvalState m) m b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (Content -> ParsecT [Markup] (EvalState m) m (Seq Content))
    -> Seq Content -> ParsecT [Markup] (EvalState m) m (Seq Content)
    forall m a. Monoid m => (a -> m) -> Seq a -> m
    forall (t :: * -> *) m a.
    (Foldable t, Monoid m) =>
    (a -> m) -> t a -> m
    foldMap ([ShowRule]
    -> Content -> ParsecT [Markup] (EvalState m) m (Seq Content)
    forall (m :: * -> *).
    Monad m =>
    [ShowRule] -> Content -> MP m (Seq Content)
    tryShowRules [ShowRule]
    rest)
    -- TODO recursive applyShowRules?

    withoutShowRule :: Monad m => ShowRule -> MP m a -> MP m a
    withoutShowRule :: forall (m :: * -> *) a. Monad m => ShowRule -> MP m a -> MP m a
    withoutShowRule ShowRule
    rule MP m a
    pa = do
      oldShowRules <- EvalState m -> [ShowRule]
    forall (m :: * -> *). EvalState m -> [ShowRule]
    evalShowRules (EvalState m -> [ShowRule])
    -> ParsecT [Markup] (EvalState m) m (EvalState m)
    -> ParsecT [Markup] (EvalState m) m [ShowRule]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ParsecT [Markup] (EvalState m) m (EvalState m)
    forall (m :: * -> *) s u. Monad m => ParsecT s u m u
    getState
      updateState $ \EvalState m
    st ->
        EvalState m
    st { evalShowRules = filter (/= rule) (evalShowRules st) }
      res <- pa
      updateState $ \EvalState m
    st -> EvalState m
    st {evalShowRules = oldShowRules}
      pure res

    applyShowRule :: Monad m => ShowRule -> Content -> MP m (Seq Content)
    applyShowRule :: forall (m :: * -> *).
    Monad m =>
    ShowRule -> Content -> MP m (Seq Content)
    applyShowRule rule :: ShowRule
    rule@(ShowRule Int
    _ Selector
    sel forall (m :: * -> *). Monad m => Content -> MP m (Seq Content)
    f) Content
    c = ShowRule -> MP m (Seq Content) -> MP m (Seq Content)
    forall (m :: * -> *) a. Monad m => ShowRule -> MP m a -> MP m a
    withoutShowRule ShowRule
    rule (MP m (Seq Content) -> MP m (Seq Content))
    -> MP m (Seq Content) -> MP m (Seq Content)
    forall a b. (a -> b) -> a -> b
    $ do
      case (Selector
    sel, Content
    c) of
        (SelectString Text
    s, Txt Text
    t) | Text
    s Text -> Text -> Bool
    `T.isInfixOf` Text
    t -> do
          re <- Text -> ParsecT [Markup] (EvalState m) m RE
    forall (m :: * -> *). MonadFail m => Text -> m RE
    makeLiteralRE Text
    s
          replaceRegexContent re t f
        (SelectRegex re :: RE
    re@(RE Text
    _ Regex
    re'), Txt Text
    t) | Bool -> Bool
    not ([MatchArray] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (Regex -> Text -> [MatchArray]
    forall regex source.
    RegexLike regex source =>
    regex -> source -> [MatchArray]
    TDFA.matchAll Regex
    re' Text
    t)) -> do
          RE
    -> Text
    -> (forall (m :: * -> *). Monad m => Content -> MP m (Seq Content))
    -> MP m (Seq Content)
    forall (m :: * -> *).
    Monad m =>
    RE
    -> Text
    -> (forall (m :: * -> *). Monad m => Content -> MP m (Seq Content))
    -> MP m (Seq Content)
    replaceRegexContent RE
    re Text
    t Content -> MP m' (Seq Content)
    forall (m :: * -> *). Monad m => Content -> MP m (Seq Content)
    f
        (SelectLabel Text
    s, elt :: Content
    elt@(Elt Identifier
    _ Maybe SourcePos
    _ Map Identifier Val
    fields))
          | Just (VLabel Text
    s') <- Identifier -> Map Identifier Val -> Maybe Val
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup Identifier
    "label" Map Identifier Val
    fields
          , Text
    s' Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    s
          -> Content -> MP m (Seq Content)
    forall (m :: * -> *). Monad m => Content -> MP m (Seq Content)
    f Content
    elt
        (SelectElement Identifier
    name [(Identifier, Val)]
    fields, elt :: Content
    elt@(Elt Identifier
    name' Maybe SourcePos
    _ Map Identifier Val
    fields'))
          | Identifier
    name Identifier -> Identifier -> Bool
    forall a. Eq a => a -> a -> Bool
    == Identifier
    name' Bool -> Bool -> Bool
    && [(Identifier, Val)] -> Map Identifier Val -> Bool
    fieldsMatch [(Identifier, Val)]
    fields Map Identifier Val
    fields'
          -> Content -> MP m (Seq Content)
    forall (m :: * -> *). Monad m => Content -> MP m (Seq Content)
    f Content
    elt
        (Selector
    _, Content
    cont) -> Seq Content -> MP m (Seq Content)
    forall a. a -> ParsecT [Markup] (EvalState m) m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Content -> Seq Content
    forall a. a -> Seq a
    Seq.singleton Content
    cont)
        -- TODO not implemented: SelectOr, SelectAnd, SelectBefore, SelectAfter

    fieldsMatch :: [(Identifier, Val)] -> M.Map Identifier Val -> Bool
    fieldsMatch :: [(Identifier, Val)] -> Map Identifier Val -> Bool
    fieldsMatch [] Map Identifier Val
    _ = Bool
    True
    fieldsMatch ((Identifier
    k, Val
    v) : [(Identifier, Val)]
    rest) Map Identifier Val
    m =
      ( case Identifier -> Map Identifier Val -> Maybe Val
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup Identifier
    k Map Identifier Val
    m of
          Just Val
    v' -> Val
    v Val -> Val -> Bool
    forall a. Eq a => a -> a -> Bool
    == Val
    v'
          Maybe Val
    Nothing -> Bool
    False
      )
        Bool -> Bool -> Bool
    && [(Identifier, Val)] -> Map Identifier Val -> Bool
    fieldsMatch [(Identifier, Val)]
    rest Map Identifier Val
    m

    replaceRegexContent ::
      Monad m =>
      RE ->
      Text ->
      (forall m'. Monad m' => Content -> MP m' (Seq Content)) ->
      MP m (Seq Content)
    replaceRegexContent :: forall (m :: * -> *).
    Monad m =>
    RE
    -> Text
    -> (forall (m :: * -> *). Monad m => Content -> MP m (Seq Content))
    -> MP m (Seq Content)
    replaceRegexContent (RE Text
    _ Regex
    re) Text
    strIn forall (m :: * -> *). Monad m => Content -> MP m (Seq Content)
    f =
      let matches :: [(Int, Int)]
    matches = (MatchArray -> (Int, Int)) -> [MatchArray] -> [(Int, Int)]
    forall a b. (a -> b) -> [a] -> [b]
    map (MatchArray -> Int -> (Int, Int)
    forall i e. Ix i => Array i e -> i -> e
    ! Int
    0) (Regex -> Text -> [MatchArray]
    forall regex source.
    RegexLike regex source =>
    regex -> source -> [MatchArray]
    TDFA.matchAll Regex
    re Text
    strIn)
          go :: Int
    -> Text
    -> [(Int, Int)]
    -> ParsecT [Markup] (EvalState m') m' (Seq Content)
    go Int
    _i Text
    str [] = Seq Content -> ParsecT [Markup] (EvalState m') m' (Seq Content)
    forall a. a -> ParsecT [Markup] (EvalState m') m' a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Seq Content -> ParsecT [Markup] (EvalState m') m' (Seq Content))
    -> Seq Content -> ParsecT [Markup] (EvalState m') m' (Seq Content)
    forall a b. (a -> b) -> a -> b
    $ Content -> Seq Content
    forall a. a -> Seq a
    Seq.singleton (Text -> Content
    Txt Text
    str)
          go Int
    i Text
    str ((Int
    off, Int
    len) : [(Int, Int)]
    rest) =
            let i' :: Int
    i' = Int
    off Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    len
                before :: Text
    before = Int -> Text -> Text
    T.take (Int
    off Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    i) Text
    str
                matched :: Text
    matched = Int -> Text -> Text
    T.take Int
    len (Int -> Text -> Text
    T.drop (Int
    off Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    i) Text
    str)
                after :: Text
    after = Int -> Text -> Text
    T.drop (Int
    i' Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    i) Text
    str
             in Int
    -> ParsecT [Markup] (EvalState m') m' (Seq Content)
    -> ParsecT [Markup] (EvalState m') m' (Seq Content)
    forall a b. a -> b -> b
    seq Int
    i' (ParsecT [Markup] (EvalState m') m' (Seq Content)
     -> ParsecT [Markup] (EvalState m') m' (Seq Content))
    -> ParsecT [Markup] (EvalState m') m' (Seq Content)
    -> ParsecT [Markup] (EvalState m') m' (Seq Content)
    forall a b. (a -> b) -> a -> b
    $
                  (\Seq Content
    x Seq Content
    y -> Content -> Seq Content
    forall a. a -> Seq a
    Seq.singleton (Text -> Content
    Txt Text
    before) Seq Content -> Seq Content -> Seq Content
    forall a. Semigroup a => a -> a -> a
    <> Seq Content
    x Seq Content -> Seq Content -> Seq Content
    forall a. Semigroup a => a -> a -> a
    <> Seq Content
    y)
                    (Seq Content -> Seq Content -> Seq Content)
    -> ParsecT [Markup] (EvalState m') m' (Seq Content)
    -> ParsecT [Markup] (EvalState m') m' (Seq Content -> Seq Content)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Content -> ParsecT [Markup] (EvalState m') m' (Seq Content)
    forall (m :: * -> *). Monad m => Content -> MP m (Seq Content)
    f (Text -> Content
    Txt Text
    matched)
                    ParsecT [Markup] (EvalState m') m' (Seq Content -> Seq Content)
    -> ParsecT [Markup] (EvalState m') m' (Seq Content)
    -> ParsecT [Markup] (EvalState m') m' (Seq Content)
    forall a b.
    ParsecT [Markup] (EvalState m') m' (a -> b)
    -> ParsecT [Markup] (EvalState m') m' a
    -> ParsecT [Markup] (EvalState m') m' b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> Int
    -> Text
    -> [(Int, Int)]
    -> ParsecT [Markup] (EvalState m') m' (Seq Content)
    go Int
    i' Text
    after [(Int, Int)]
    rest
       in Int
    -> Text
    -> [(Int, Int)]
    -> ParsecT [Markup] (EvalState m) m (Seq Content)
    forall {m' :: * -> *}.
    Monad m' =>
    Int
    -> Text
    -> [(Int, Int)]
    -> ParsecT [Markup] (EvalState m') m' (Seq Content)
    go Int
    0 Text
    strIn [(Int, Int)]
    matches