{-# LANGUAGE RankNTypes #-}

module Typst.Bind (destructuringBind) where

import Control.Monad.State
import qualified Data.Map.Ordered as OM
import Data.Maybe (fromMaybe)
import qualified Data.Vector as V
import Typst.Syntax
import Typst.Types

destructuringBind ::
  Monad m =>
  (forall m'. Monad m' => Identifier -> Val -> MP m' ()) ->
  [BindPart] ->
  Val ->
  MP m ()
destructuringBind :: forall (m :: * -> *).
Monad m =>
(forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ())
-> [BindPart] -> Val -> MP m ()
destructuringBind forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ()
setIdentifier [BindPart]
parts Val
val = do
  let isSink :: BindPart -> Bool
isSink Sink {} = Bool
True
      isSink BindPart
_ = Bool
False
  let ([BindPart]
fronts, [BindPart]
rest) = (BindPart -> Bool) -> [BindPart] -> ([BindPart], [BindPart])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break BindPart -> Bool
isSink [BindPart]
parts
  let ([BindPart]
sinks, [BindPart]
backs) = (BindPart -> Bool) -> [BindPart] -> ([BindPart], [BindPart])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span BindPart -> Bool
isSink [BindPart]
rest
  Maybe Identifier
mbsink <- case [BindPart]
sinks of
    [Sink Maybe Identifier
s] -> Maybe Identifier
-> ParsecT [Markup] (EvalState m) m (Maybe Identifier)
forall a. a -> ParsecT [Markup] (EvalState m) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Identifier
s
    [] -> Maybe Identifier
-> ParsecT [Markup] (EvalState m) m (Maybe Identifier)
forall a. a -> ParsecT [Markup] (EvalState m) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Identifier
forall a. Maybe a
Nothing
    [BindPart]
_ -> String -> ParsecT [Markup] (EvalState m) m (Maybe Identifier)
forall a. String -> ParsecT [Markup] (EvalState m) m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Bind cannot contain multiple sinks"
  case Val
val of
    VDict OMap Identifier Val
m ->
      StateT (OMap Identifier Val) (ParsecT [Markup] (EvalState m) m) ()
-> OMap Identifier Val -> MP m ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ((forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ())
-> [BindPart]
-> [BindPart]
-> Maybe Identifier
-> StateT
     (OMap Identifier Val) (ParsecT [Markup] (EvalState m) m) ()
forall (m :: * -> *).
Monad m =>
(forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ())
-> [BindPart]
-> [BindPart]
-> Maybe Identifier
-> StateT (OMap Identifier Val) (MP m) ()
destructureDict Identifier -> Val -> MP m' ()
forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ()
setIdentifier [BindPart]
fronts [BindPart]
backs Maybe Identifier
mbsink) OMap Identifier Val
m
    VArray Vector Val
v ->
      StateT (Vector Val) (ParsecT [Markup] (EvalState m) m) ()
-> Vector Val -> MP m ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ((forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ())
-> [BindPart]
-> [BindPart]
-> Maybe Identifier
-> StateT (Vector Val) (ParsecT [Markup] (EvalState m) m) ()
forall (m :: * -> *).
Monad m =>
(forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ())
-> [BindPart]
-> [BindPart]
-> Maybe Identifier
-> StateT (Vector Val) (MP m) ()
destructureArray Identifier -> Val -> MP m' ()
forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ()
setIdentifier [BindPart]
fronts [BindPart]
backs Maybe Identifier
mbsink) Vector Val
v
    Val
_ -> String -> MP m ()
forall a. String -> ParsecT [Markup] (EvalState m) m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Only Array or Dictionary values can be destructured"

destructureDict ::
  Monad m =>
  (forall m'. Monad m' => Identifier -> Val -> MP m' ()) ->
  [BindPart] ->
  [BindPart] ->
  Maybe Identifier ->
  StateT (OM.OMap Identifier Val) (MP m) ()
destructureDict :: forall (m :: * -> *).
Monad m =>
(forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ())
-> [BindPart]
-> [BindPart]
-> Maybe Identifier
-> StateT (OMap Identifier Val) (MP m) ()
destructureDict forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ()
setIdentifier [BindPart]
fronts [BindPart]
backs Maybe Identifier
mbsink = do
  (BindPart -> StateT (OMap Identifier Val) (MP m) ())
-> [BindPart] -> StateT (OMap Identifier Val) (MP m) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BindPart -> StateT (OMap Identifier Val) (MP m) ()
forall (m :: * -> *).
Monad m =>
BindPart -> StateT (OMap Identifier Val) (MP m) ()
handleDictBind ([BindPart]
fronts [BindPart] -> [BindPart] -> [BindPart]
forall a. [a] -> [a] -> [a]
++ [BindPart]
backs)
  case Maybe Identifier
mbsink of
    Just Identifier
i -> StateT (OMap Identifier Val) (MP m) (OMap Identifier Val)
forall s (m :: * -> *). MonadState s m => m s
get StateT (OMap Identifier Val) (MP m) (OMap Identifier Val)
-> (OMap Identifier Val -> StateT (OMap Identifier Val) (MP m) ())
-> StateT (OMap Identifier Val) (MP m) ()
forall a b.
StateT (OMap Identifier Val) (MP m) a
-> (a -> StateT (OMap Identifier Val) (MP m) b)
-> StateT (OMap Identifier Val) (MP m) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MP m () -> StateT (OMap Identifier Val) (MP m) ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (OMap Identifier Val) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MP m () -> StateT (OMap Identifier Val) (MP m) ())
-> (OMap Identifier Val -> MP m ())
-> OMap Identifier Val
-> StateT (OMap Identifier Val) (MP m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> Val -> MP m ()
forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ()
setIdentifier Identifier
i (Val -> MP m ())
-> (OMap Identifier Val -> Val) -> OMap Identifier Val -> MP m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OMap Identifier Val -> Val
VDict
    Maybe Identifier
Nothing -> () -> StateT (OMap Identifier Val) (MP m) ()
forall a. a -> StateT (OMap Identifier Val) (MP m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    handleDictBind :: Monad m => BindPart -> StateT (OM.OMap Identifier Val) (MP m) ()
    handleDictBind :: forall (m :: * -> *).
Monad m =>
BindPart -> StateT (OMap Identifier Val) (MP m) ()
handleDictBind (Sink {}) = String -> StateT (OMap Identifier Val) (MP m) ()
forall a. String -> StateT (OMap Identifier Val) (MP m) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Bind cannot contain multiple sinks"
    handleDictBind (Simple Maybe Identifier
Nothing) = () -> StateT (OMap Identifier Val) (MP m) ()
forall a. a -> StateT (OMap Identifier Val) (MP m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    handleDictBind (Simple (Just Identifier
i)) = do
      OMap Identifier Val
m <- StateT (OMap Identifier Val) (MP m) (OMap Identifier Val)
forall s (m :: * -> *). MonadState s m => m s
get
      case Identifier -> OMap Identifier Val -> Maybe Val
forall k v. Ord k => k -> OMap k v -> Maybe v
OM.lookup Identifier
i OMap Identifier Val
m of
        Maybe Val
Nothing ->
          String -> StateT (OMap Identifier Val) (MP m) ()
forall a. String -> StateT (OMap Identifier Val) (MP m) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StateT (OMap Identifier Val) (MP m) ())
-> String -> StateT (OMap Identifier Val) (MP m) ()
forall a b. (a -> b) -> a -> b
$ String
"Destructuring key not found in dictionary: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Identifier -> String
forall a. Show a => a -> String
show Identifier
i
        Just Val
v -> do
          OMap Identifier Val -> StateT (OMap Identifier Val) (MP m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (OMap Identifier Val -> StateT (OMap Identifier Val) (MP m) ())
-> OMap Identifier Val -> StateT (OMap Identifier Val) (MP m) ()
forall a b. (a -> b) -> a -> b
$ Identifier -> OMap Identifier Val -> OMap Identifier Val
forall k v. Ord k => k -> OMap k v -> OMap k v
OM.delete Identifier
i OMap Identifier Val
m
          MP m () -> StateT (OMap Identifier Val) (MP m) ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (OMap Identifier Val) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MP m () -> StateT (OMap Identifier Val) (MP m) ())
-> MP m () -> StateT (OMap Identifier Val) (MP m) ()
forall a b. (a -> b) -> a -> b
$ Identifier -> Val -> MP m ()
forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ()
setIdentifier Identifier
i Val
v
    handleDictBind (WithKey Identifier
key Maybe Identifier
mbident) = do
      OMap Identifier Val
m <- StateT (OMap Identifier Val) (MP m) (OMap Identifier Val)
forall s (m :: * -> *). MonadState s m => m s
get
      case Identifier -> OMap Identifier Val -> Maybe Val
forall k v. Ord k => k -> OMap k v -> Maybe v
OM.lookup Identifier
key OMap Identifier Val
m of
        Maybe Val
Nothing ->
          String -> StateT (OMap Identifier Val) (MP m) ()
forall a. String -> StateT (OMap Identifier Val) (MP m) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StateT (OMap Identifier Val) (MP m) ())
-> String -> StateT (OMap Identifier Val) (MP m) ()
forall a b. (a -> b) -> a -> b
$ String
"Destructuring key not found in dictionary: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Identifier -> String
forall a. Show a => a -> String
show Identifier
key
        Just Val
v -> do
          OMap Identifier Val -> StateT (OMap Identifier Val) (MP m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (OMap Identifier Val -> StateT (OMap Identifier Val) (MP m) ())
-> OMap Identifier Val -> StateT (OMap Identifier Val) (MP m) ()
forall a b. (a -> b) -> a -> b
$ Identifier -> OMap Identifier Val -> OMap Identifier Val
forall k v. Ord k => k -> OMap k v -> OMap k v
OM.delete Identifier
key OMap Identifier Val
m
          MP m () -> StateT (OMap Identifier Val) (MP m) ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (OMap Identifier Val) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MP m () -> StateT (OMap Identifier Val) (MP m) ())
-> MP m () -> StateT (OMap Identifier Val) (MP m) ()
forall a b. (a -> b) -> a -> b
$ Identifier -> Val -> MP m ()
forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ()
setIdentifier (Identifier -> Maybe Identifier -> Identifier
forall a. a -> Maybe a -> a
fromMaybe Identifier
key Maybe Identifier
mbident) Val
v

destructureArray ::
  Monad m =>
  (forall m'. Monad m' => Identifier -> Val -> MP m' ()) ->
  [BindPart] ->
  [BindPart] ->
  Maybe Identifier ->
  StateT (V.Vector Val) (MP m) ()
destructureArray :: forall (m :: * -> *).
Monad m =>
(forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ())
-> [BindPart]
-> [BindPart]
-> Maybe Identifier
-> StateT (Vector Val) (MP m) ()
destructureArray forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ()
setIdentifier [BindPart]
fronts [BindPart]
backs Maybe Identifier
mbsink = do
  (BindPart -> StateT (Vector Val) (MP m) ())
-> [BindPart] -> StateT (Vector Val) (MP m) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BindPart -> StateT (Vector Val) (MP m) ()
forall (m :: * -> *).
Monad m =>
BindPart -> StateT (Vector Val) (MP m) ()
handleFrontBind [BindPart]
fronts
  (BindPart -> StateT (Vector Val) (MP m) ())
-> [BindPart] -> StateT (Vector Val) (MP m) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BindPart -> StateT (Vector Val) (MP m) ()
forall (m :: * -> *).
Monad m =>
BindPart -> StateT (Vector Val) (MP m) ()
handleBackBind ([BindPart] -> [BindPart]
forall a. [a] -> [a]
reverse [BindPart]
backs)
  case Maybe Identifier
mbsink of
    Just Identifier
i -> StateT (Vector Val) (MP m) (Vector Val)
forall s (m :: * -> *). MonadState s m => m s
get StateT (Vector Val) (MP m) (Vector Val)
-> (Vector Val -> StateT (Vector Val) (MP m) ())
-> StateT (Vector Val) (MP m) ()
forall a b.
StateT (Vector Val) (MP m) a
-> (a -> StateT (Vector Val) (MP m) b)
-> StateT (Vector Val) (MP m) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MP m () -> StateT (Vector Val) (MP m) ()
forall (m :: * -> *) a. Monad m => m a -> StateT (Vector Val) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MP m () -> StateT (Vector Val) (MP m) ())
-> (Vector Val -> MP m ())
-> Vector Val
-> StateT (Vector Val) (MP m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> Val -> MP m ()
forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ()
setIdentifier Identifier
i (Val -> MP m ()) -> (Vector Val -> Val) -> Vector Val -> MP m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Val -> Val
VArray
    Maybe Identifier
Nothing -> () -> StateT (Vector Val) (MP m) ()
forall a. a -> StateT (Vector Val) (MP m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    handleFrontBind :: Monad m => BindPart -> StateT (V.Vector Val) (MP m) ()
    handleFrontBind :: forall (m :: * -> *).
Monad m =>
BindPart -> StateT (Vector Val) (MP m) ()
handleFrontBind (Sink {}) = String -> StateT (Vector Val) (MP m) ()
forall a. String -> StateT (Vector Val) (MP m) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Bind cannot contain multiple sinks"
    handleFrontBind (WithKey {}) = String -> StateT (Vector Val) (MP m) ()
forall a. String -> StateT (Vector Val) (MP m) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot destructure array with key"
    handleFrontBind (Simple Maybe Identifier
mbi) = do
      Vector Val
v <- StateT (Vector Val) (MP m) (Vector Val)
forall s (m :: * -> *). MonadState s m => m s
get
      case Vector Val -> Maybe (Val, Vector Val)
forall a. Vector a -> Maybe (a, Vector a)
V.uncons Vector Val
v of
        Maybe (Val, Vector Val)
Nothing -> String -> StateT (Vector Val) (MP m) ()
forall a. String -> StateT (Vector Val) (MP m) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Array does not contain enough elements to destructure"
        Just (Val
x, Vector Val
v') -> do
          Vector Val -> StateT (Vector Val) (MP m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Vector Val
v'
          case Maybe Identifier
mbi of
            Maybe Identifier
Nothing -> () -> StateT (Vector Val) (MP m) ()
forall a. a -> StateT (Vector Val) (MP m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just Identifier
i -> MP m () -> StateT (Vector Val) (MP m) ()
forall (m :: * -> *) a. Monad m => m a -> StateT (Vector Val) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MP m () -> StateT (Vector Val) (MP m) ())
-> MP m () -> StateT (Vector Val) (MP m) ()
forall a b. (a -> b) -> a -> b
$ Identifier -> Val -> MP m ()
forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ()
setIdentifier Identifier
i Val
x

    handleBackBind :: Monad m => BindPart -> StateT (V.Vector Val) (MP m) ()
    handleBackBind :: forall (m :: * -> *).
Monad m =>
BindPart -> StateT (Vector Val) (MP m) ()
handleBackBind (Sink {}) = String -> StateT (Vector Val) (MP m) ()
forall a. String -> StateT (Vector Val) (MP m) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Bind cannot contain multiple sinks"
    handleBackBind (WithKey {}) = String -> StateT (Vector Val) (MP m) ()
forall a. String -> StateT (Vector Val) (MP m) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot destructure array with key"
    handleBackBind (Simple Maybe Identifier
mbi) = do
      Vector Val
v <- StateT (Vector Val) (MP m) (Vector Val)
forall s (m :: * -> *). MonadState s m => m s
get
      case Vector Val -> Maybe (Vector Val, Val)
forall a. Vector a -> Maybe (Vector a, a)
V.unsnoc Vector Val
v of
        Maybe (Vector Val, Val)
Nothing -> String -> StateT (Vector Val) (MP m) ()
forall a. String -> StateT (Vector Val) (MP m) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Array does not contain enough elements to destructure"
        Just (Vector Val
v', Val
x) -> do
          Vector Val -> StateT (Vector Val) (MP m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Vector Val
v'
          case Maybe Identifier
mbi of
            Maybe Identifier
Nothing -> () -> StateT (Vector Val) (MP m) ()
forall a. a -> StateT (Vector Val) (MP m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just Identifier
i -> MP m () -> StateT (Vector Val) (MP m) ()
forall (m :: * -> *) a. Monad m => m a -> StateT (Vector Val) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (MP m () -> StateT (Vector Val) (MP m) ())
-> MP m () -> StateT (Vector Val) (MP m) ()
forall a b. (a -> b) -> a -> b
$ Identifier -> Val -> MP m ()
forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ()
setIdentifier Identifier
i Val
x