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

module Typst.Show (applyShowRules) where

import Control.Monad (foldM)
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
  [ShowRule]
rules <- forall (m :: * -> *). EvalState m -> [ShowRule]
evalShowRules forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
  forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall (m :: * -> *).
Monad m =>
[ShowRule] -> Seq Content -> Content -> MP m (Seq Content)
tryShowRules [ShowRule]
rules) forall a. Monoid a => a
mempty Seq Content
cs

withoutShowRule :: Monad m => Selector -> MP m a -> MP m a
withoutShowRule :: forall (m :: * -> *) a. Monad m => Selector -> MP m a -> MP m a
withoutShowRule Selector
selector MP m a
pa = do
  [ShowRule]
oldShowRules <- forall (m :: * -> *). EvalState m -> [ShowRule]
evalShowRules forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
  forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState forall a b. (a -> b) -> a -> b
$ \EvalState m
st ->
    EvalState m
st
      { evalShowRules :: [ShowRule]
evalShowRules =
          [ Selector
-> (forall (m :: * -> *). Monad m => Content -> MP m (Seq Content))
-> ShowRule
ShowRule Selector
sel forall (m :: * -> *). Monad m => Content -> MP m (Seq Content)
f | ShowRule Selector
sel forall (m :: * -> *). Monad m => Content -> MP m (Seq Content)
f <- forall (m :: * -> *). EvalState m -> [ShowRule]
evalShowRules EvalState m
st, Selector
sel forall a. Eq a => a -> a -> Bool
/= Selector
selector
          ]
      }
  a
res <- MP m a
pa
  forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState forall a b. (a -> b) -> a -> b
$ \EvalState m
st -> EvalState m
st {evalShowRules :: [ShowRule]
evalShowRules = [ShowRule]
oldShowRules}
  forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res

-- 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] ->
  Seq Content ->
  Content ->
  MP m (Seq Content)
tryShowRules :: forall (m :: * -> *).
Monad m =>
[ShowRule] -> Seq Content -> Content -> MP m (Seq Content)
tryShowRules [] Seq Content
cs Content
c = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Seq Content
cs forall a. Seq a -> a -> Seq a
Seq.|> Content
c
tryShowRules (ShowRule Selector
sel forall (m :: * -> *). Monad m => Content -> MP m (Seq Content)
f : [ShowRule]
rs) Seq Content
cs Content
c = do
  Content
c' <- case Content
c of
    Elt Identifier
name Maybe SourcePos
pos Map Identifier Val
fields -> do
      let applyToVal :: Val -> ParsecT [Markup] (EvalState m) m Val
applyToVal (VContent Seq Content
cs') =
            Seq Content -> Val
VContent
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (m :: * -> *).
Monad m =>
[ShowRule] -> Seq Content -> Content -> MP m (Seq Content)
tryShowRules [Selector
-> (forall (m :: * -> *). Monad m => Content -> MP m (Seq Content))
-> ShowRule
ShowRule Selector
sel forall (m :: * -> *). Monad m => Content -> MP m (Seq Content)
f] forall a. Monoid a => a
mempty) Seq Content
cs'
          applyToVal (VArray Vector Val
as) = Vector Val -> Val
VArray forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Val -> ParsecT [Markup] (EvalState m) m Val
applyToVal Vector Val
as
          applyToVal Val
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure Val
x
      Map Identifier Val
fields' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}.
Monad m =>
Val -> ParsecT [Markup] (EvalState m) m Val
applyToVal Map Identifier Val
fields
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Identifier -> Maybe SourcePos -> Map Identifier Val -> Content
Elt Identifier
name Maybe SourcePos
pos Map Identifier Val
fields'
    Content
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Content
c
  case (Selector
sel, Content
c') of
    (SelectString Text
s, Txt Text
t) ->
      ( do
          RE
re <- forall (m :: * -> *). MonadFail m => Text -> m RE
makeLiteralRE Text
s
          forall (m :: * -> *) a. Monad m => Selector -> MP m a -> MP m a
withoutShowRule
            Selector
sel
            ((Seq Content
cs forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *).
Monad m =>
RE
-> Text
-> (forall (m :: * -> *). Monad m => Content -> MP m (Seq Content))
-> MP m (Seq Content)
replaceRegexContent RE
re Text
t forall (m :: * -> *). Monad m => Content -> MP m (Seq Content)
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). Monad m => Seq Content -> MP m (Seq Content)
applyShowRules))
      )
        forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (m :: * -> *).
Monad m =>
[ShowRule] -> Seq Content -> Content -> MP m (Seq Content)
tryShowRules [ShowRule]
rs Seq Content
cs Content
c'
    (SelectRegex RE
re, Txt Text
t) ->
      ( forall (m :: * -> *) a. Monad m => Selector -> MP m a -> MP m a
withoutShowRule
          Selector
sel
          ((Seq Content
cs forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *).
Monad m =>
RE
-> Text
-> (forall (m :: * -> *). Monad m => Content -> MP m (Seq Content))
-> MP m (Seq Content)
replaceRegexContent RE
re Text
t forall (m :: * -> *). Monad m => Content -> MP m (Seq Content)
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). Monad m => Seq Content -> MP m (Seq Content)
applyShowRules))
      )
        forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (m :: * -> *).
Monad m =>
[ShowRule] -> Seq Content -> Content -> MP m (Seq Content)
tryShowRules [ShowRule]
rs Seq Content
cs Content
c'
    (SelectLabel Text
s, elt :: Content
elt@(Elt Identifier
_ Maybe SourcePos
_ Map Identifier Val
fields))
      | Just (VLabel Text
s') <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Identifier
"label" Map Identifier Val
fields,
        Text
s' forall a. Eq a => a -> a -> Bool
== Text
s ->
          forall (m :: * -> *) a. Monad m => Selector -> MP m a -> MP m a
withoutShowRule Selector
sel ((Seq Content
cs forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *). Monad m => Content -> MP m (Seq Content)
f Content
elt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). Monad m => Seq Content -> MP m (Seq Content)
applyShowRules))
    (SelectElement Identifier
name [(Identifier, Val)]
fields, elt :: Content
elt@(Elt Identifier
name' Maybe SourcePos
_ Map Identifier Val
fields'))
      | Identifier
name forall a. Eq a => a -> a -> Bool
== Identifier
name',
        [(Identifier, Val)] -> Map Identifier Val -> Bool
fieldsMatch [(Identifier, Val)]
fields Map Identifier Val
fields' ->
          forall (m :: * -> *) a. Monad m => Selector -> MP m a -> MP m a
withoutShowRule Selector
sel forall a b. (a -> b) -> a -> b
$ (Seq Content
cs forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *). Monad m => Content -> MP m (Seq Content)
f Content
elt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). Monad m => Seq Content -> MP m (Seq Content)
applyShowRules)
    (SelectOr Selector
_sel1 Selector
_sel2, Content
_elt) ->
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"or is not yet implemented for select"
    (SelectAnd Selector
_sel1 Selector
_sel2, Content
_elt) ->
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"and is not yet implemented for select"
    (SelectBefore Selector
_sel1 Selector
_sel2, Content
_elt) ->
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"before is not yet implemented for select"
    (SelectAfter Selector
_sel1 Selector
_sel2, Content
_elt) ->
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"after is not yet implemented for select"
    (Selector, Content)
_ -> forall (m :: * -> *).
Monad m =>
[ShowRule] -> Seq Content -> Content -> MP m (Seq Content)
tryShowRules [ShowRule]
rs Seq Content
cs Content
c'

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