{-# 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
  [ShowRule]
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
  (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]
rules) Seq Content
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
      Seq Content
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
      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 -> Seq Content) -> Content -> Seq Content
forall a b. (a -> b) -> a -> b
$
        Identifier -> Maybe SourcePos -> Map Identifier Val -> Content
Elt Identifier
"text" Maybe SourcePos
pos (Identifier -> Val -> Map Identifier Val -> Map Identifier Val
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Identifier
"body" (Seq Content -> Val
VContent Seq Content
cs') Map Identifier Val
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
  [ShowRule]
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
  (EvalState m -> EvalState m) -> ParsecT [Markup] (EvalState m) m ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState ((EvalState m -> EvalState m)
 -> ParsecT [Markup] (EvalState m) m ())
-> (EvalState m -> EvalState m)
-> ParsecT [Markup] (EvalState m) m ()
forall a b. (a -> b) -> a -> b
$ \EvalState m
st ->
    EvalState m
st { evalShowRules = filter (/= rule) (evalShowRules st) }
  a
res <- MP m a
pa
  (EvalState m -> EvalState m) -> ParsecT [Markup] (EvalState m) m ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState ((EvalState m -> EvalState m)
 -> ParsecT [Markup] (EvalState m) m ())
-> (EvalState m -> EvalState m)
-> ParsecT [Markup] (EvalState m) m ()
forall a b. (a -> b) -> a -> b
$ \EvalState m
st -> EvalState m
st {evalShowRules = oldShowRules}
  a -> MP m a
forall a. a -> ParsecT [Markup] (EvalState m) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
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
re <- Text -> ParsecT [Markup] (EvalState m) m RE
forall (m :: * -> *). MonadFail m => Text -> m RE
makeLiteralRE Text
s
      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
    (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