{-# 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
applyShowRules :: Monad m => Seq Content -> MP m (Seq Content)
applyShowRules :: 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
(Seq Content -> Content -> MP m (Seq Content))
-> Seq Content -> Seq Content -> MP m (Seq Content)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([ShowRule] -> Seq Content -> Content -> MP m (Seq Content)
forall (m :: * -> *).
Monad m =>
[ShowRule] -> Seq Content -> Content -> MP m (Seq Content)
tryShowRules [ShowRule]
rules) Seq Content
forall a. Monoid a => a
mempty Seq Content
cs
withoutShowRule :: Monad m => Selector -> MP m a -> MP m a
withoutShowRule :: Selector -> MP m a -> MP m a
withoutShowRule Selector
selector 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 :: [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 <- EvalState m -> [ShowRule]
forall (m :: * -> *). EvalState m -> [ShowRule]
evalShowRules EvalState m
st, Selector
sel Selector -> Selector -> Bool
forall a. Eq a => a -> a -> Bool
/= Selector
selector
]
}
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 :: [ShowRule]
evalShowRules = [ShowRule]
oldShowRules}
a -> MP m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
tryShowRules ::
Monad m =>
[ShowRule] ->
Seq Content ->
Content ->
MP m (Seq Content)
tryShowRules :: [ShowRule] -> Seq Content -> Content -> MP m (Seq Content)
tryShowRules [] Seq Content
cs Content
c = Seq Content -> MP m (Seq Content)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq Content -> MP m (Seq Content))
-> Seq Content -> MP m (Seq Content)
forall a b. (a -> b) -> a -> b
$ Seq Content
cs Seq Content -> Content -> Seq Content
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
(Seq Content -> Val)
-> ParsecT [Markup] (EvalState m) m (Seq Content)
-> ParsecT [Markup] (EvalState m) m Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Content -> ParsecT [Markup] (EvalState m) m (Seq Content))
-> Seq Content -> ParsecT [Markup] (EvalState m) m (Seq Content)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([ShowRule]
-> Seq Content
-> Content
-> ParsecT [Markup] (EvalState m) m (Seq Content)
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] Seq Content
forall a. Monoid a => a
mempty) Seq Content
cs'
applyToVal (VArray Vector Val
as) = Vector Val -> Val
VArray (Vector Val -> Val)
-> ParsecT [Markup] (EvalState m) m (Vector Val)
-> ParsecT [Markup] (EvalState m) m Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> ParsecT [Markup] (EvalState m) m Val)
-> Vector Val -> ParsecT [Markup] (EvalState m) m (Vector Val)
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 = Val -> ParsecT [Markup] (EvalState m) m Val
forall (f :: * -> *) a. Applicative f => a -> f a
pure Val
x
Map Identifier Val
fields' <- (Val -> ParsecT [Markup] (EvalState m) m Val)
-> Map Identifier Val
-> ParsecT [Markup] (EvalState m) m (Map Identifier Val)
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
forall (m :: * -> *).
Monad m =>
Val -> ParsecT [Markup] (EvalState m) m Val
applyToVal Map Identifier Val
fields
Content -> ParsecT [Markup] (EvalState m) m Content
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Content -> ParsecT [Markup] (EvalState m) m Content)
-> Content -> ParsecT [Markup] (EvalState m) m Content
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
_ -> Content -> ParsecT [Markup] (EvalState m) m 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 <- Text -> ParsecT [Markup] (EvalState m) m RE
forall (m :: * -> *). MonadFail m => Text -> m RE
makeLiteralRE Text
s
Selector -> MP m (Seq Content) -> MP m (Seq Content)
forall (m :: * -> *) a. Monad m => Selector -> MP m a -> MP m a
withoutShowRule
Selector
sel
((Seq Content
cs Seq Content -> Seq Content -> Seq Content
forall a. Semigroup a => a -> a -> a
<>) (Seq Content -> Seq Content)
-> MP m (Seq Content) -> MP m (Seq Content)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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 forall (m :: * -> *). Monad m => Content -> MP m (Seq Content)
f MP m (Seq Content)
-> (Seq Content -> MP m (Seq Content)) -> MP m (Seq Content)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Seq Content -> MP m (Seq Content)
forall (m :: * -> *). Monad m => Seq Content -> MP m (Seq Content)
applyShowRules))
)
MP m (Seq Content) -> MP m (Seq Content) -> MP m (Seq Content)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> [ShowRule] -> Seq Content -> Content -> MP m (Seq Content)
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) ->
( Selector -> MP m (Seq Content) -> MP m (Seq Content)
forall (m :: * -> *) a. Monad m => Selector -> MP m a -> MP m a
withoutShowRule
Selector
sel
((Seq Content
cs Seq Content -> Seq Content -> Seq Content
forall a. Semigroup a => a -> a -> a
<>) (Seq Content -> Seq Content)
-> MP m (Seq Content) -> MP m (Seq Content)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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 forall (m :: * -> *). Monad m => Content -> MP m (Seq Content)
f MP m (Seq Content)
-> (Seq Content -> MP m (Seq Content)) -> MP m (Seq Content)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Seq Content -> MP m (Seq Content)
forall (m :: * -> *). Monad m => Seq Content -> MP m (Seq Content)
applyShowRules))
)
MP m (Seq Content) -> MP m (Seq Content) -> MP m (Seq Content)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> [ShowRule] -> Seq Content -> Content -> MP m (Seq Content)
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') <- 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 ->
Selector -> MP m (Seq Content) -> MP m (Seq Content)
forall (m :: * -> *) a. Monad m => Selector -> MP m a -> MP m a
withoutShowRule Selector
sel ((Seq Content
cs Seq Content -> Seq Content -> Seq Content
forall a. Semigroup a => a -> a -> a
<>) (Seq Content -> Seq Content)
-> MP m (Seq Content) -> MP m (Seq Content)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Content -> MP m (Seq Content)
forall (m :: * -> *). Monad m => Content -> MP m (Seq Content)
f Content
elt MP m (Seq Content)
-> (Seq Content -> MP m (Seq Content)) -> MP m (Seq Content)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Seq Content -> MP m (Seq Content)
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 Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
name',
[(Identifier, Val)] -> Map Identifier Val -> Bool
fieldsMatch [(Identifier, Val)]
fields Map Identifier Val
fields' ->
Selector -> MP m (Seq Content) -> MP m (Seq Content)
forall (m :: * -> *) a. Monad m => Selector -> MP m a -> MP m a
withoutShowRule Selector
sel (MP m (Seq Content) -> MP m (Seq Content))
-> MP m (Seq Content) -> MP m (Seq Content)
forall a b. (a -> b) -> a -> b
$ (Seq Content
cs Seq Content -> Seq Content -> Seq Content
forall a. Semigroup a => a -> a -> a
<>) (Seq Content -> Seq Content)
-> MP m (Seq Content) -> MP m (Seq Content)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Content -> MP m (Seq Content)
forall (m :: * -> *). Monad m => Content -> MP m (Seq Content)
f Content
elt MP m (Seq Content)
-> (Seq Content -> MP m (Seq Content)) -> MP m (Seq Content)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Seq Content -> MP m (Seq Content)
forall (m :: * -> *). Monad m => Seq Content -> MP m (Seq Content)
applyShowRules)
(SelectOr Selector
_sel1 Selector
_sel2, Content
_elt) ->
String -> MP m (Seq Content)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"or is not yet implemented for select"
(SelectAnd Selector
_sel1 Selector
_sel2, Content
_elt) ->
String -> MP m (Seq Content)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"and is not yet implemented for select"
(SelectBefore Selector
_sel1 Selector
_sel2, Content
_elt) ->
String -> MP m (Seq Content)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"before is not yet implemented for select"
(SelectAfter Selector
_sel1 Selector
_sel2, Content
_elt) ->
String -> MP m (Seq Content)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"after is not yet implemented for select"
(Selector, Content)
_ -> [ShowRule] -> Seq Content -> Content -> MP m (Seq 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 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 :: 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 = (Array MatchOffset (MatchOffset, MatchOffset)
-> (MatchOffset, MatchOffset))
-> [Array MatchOffset (MatchOffset, MatchOffset)]
-> [(MatchOffset, MatchOffset)]
forall a b. (a -> b) -> [a] -> [b]
map (Array MatchOffset (MatchOffset, MatchOffset)
-> MatchOffset -> (MatchOffset, MatchOffset)
forall i e. Ix i => Array i e -> i -> e
! MatchOffset
0) (Regex -> Text -> [Array MatchOffset (MatchOffset, MatchOffset)]
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 [] = Seq Content -> ParsecT [Markup] (EvalState m') m' (Seq Content)
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 MatchOffset
i Text
str ((MatchOffset
off, MatchOffset
len) : [(MatchOffset, MatchOffset)]
rest) =
let i' :: MatchOffset
i' = MatchOffset
off MatchOffset -> MatchOffset -> MatchOffset
forall a. Num a => a -> a -> a
+ MatchOffset
len
before :: Text
before = MatchOffset -> Text -> Text
T.take (MatchOffset
off MatchOffset -> MatchOffset -> MatchOffset
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 MatchOffset -> MatchOffset -> MatchOffset
forall a. Num a => a -> a -> a
- MatchOffset
i) Text
str)
after :: Text
after = MatchOffset -> Text -> Text
T.drop (MatchOffset
i' MatchOffset -> MatchOffset -> MatchOffset
forall a. Num a => a -> a -> a
- MatchOffset
i) Text
str
in MatchOffset
-> ParsecT [Markup] (EvalState m') m' (Seq Content)
-> ParsecT [Markup] (EvalState m') m' (Seq Content)
seq MatchOffset
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 (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 MatchOffset
-> Text -> [(MatchOffset, MatchOffset)] -> MP m (Seq Content)
forall (m' :: * -> *).
Monad m' =>
MatchOffset
-> Text
-> [(MatchOffset, MatchOffset)]
-> ParsecT [Markup] (EvalState m') m' (Seq Content)
go MatchOffset
0 Text
strIn [(MatchOffset, MatchOffset)]
matches