{-# 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) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break BindPart -> Bool
isSink [BindPart]
parts
  let ([BindPart]
sinks, [BindPart]
backs) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span BindPart -> Bool
isSink [BindPart]
rest
  Maybe Identifier
mbsink <- case [BindPart]
sinks of
    [Sink Maybe Identifier
s] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Identifier
s
    [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    [BindPart]
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Bind cannot contain multiple sinks"
  case Val
val of
    VDict OMap Identifier Val
m ->
      forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (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) OMap Identifier Val
m
    VArray Vector Val
v ->
      forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (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) Vector Val
v
    Val
_ -> 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
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *).
Monad m =>
BindPart -> StateT (OMap Identifier Val) (MP m) ()
handleDictBind ([BindPart]
fronts forall a. [a] -> [a] -> [a]
++ [BindPart]
backs)
  case Maybe Identifier
mbsink of
    Just Identifier
i -> forall s (m :: * -> *). MonadState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ()
setIdentifier Identifier
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. OMap Identifier Val -> Val
VDict
    Maybe Identifier
Nothing -> 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 {}) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Bind cannot contain multiple sinks"
    handleDictBind (Simple Maybe Identifier
Nothing) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    handleDictBind (Simple (Just Identifier
i)) = do
      OMap Identifier Val
m <- forall s (m :: * -> *). MonadState s m => m s
get
      case forall k v. Ord k => k -> OMap k v -> Maybe v
OM.lookup Identifier
i OMap Identifier Val
m of
        Maybe Val
Nothing ->
          forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Destructuring key not found in dictionary: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Identifier
i
        Just Val
v -> do
          forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ forall k v. Ord k => k -> OMap k v -> OMap k v
OM.delete Identifier
i OMap Identifier Val
m
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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 <- forall s (m :: * -> *). MonadState s m => m s
get
      case forall k v. Ord k => k -> OMap k v -> Maybe v
OM.lookup Identifier
key OMap Identifier Val
m of
        Maybe Val
Nothing ->
          forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Destructuring key not found in dictionary: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Identifier
key
        Just Val
v -> do
          forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ forall k v. Ord k => k -> OMap k v -> OMap k v
OM.delete Identifier
key OMap Identifier Val
m
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ()
setIdentifier (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
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *).
Monad m =>
BindPart -> StateT (Vector Val) (MP m) ()
handleFrontBind [BindPart]
fronts
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *).
Monad m =>
BindPart -> StateT (Vector Val) (MP m) ()
handleBackBind (forall a. [a] -> [a]
reverse [BindPart]
backs)
  case Maybe Identifier
mbsink of
    Just Identifier
i -> forall s (m :: * -> *). MonadState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ()
setIdentifier Identifier
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Val -> Val
VArray
    Maybe Identifier
Nothing -> 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 {}) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Bind cannot contain multiple sinks"
    handleFrontBind (WithKey {}) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot destructure array with key"
    handleFrontBind (Simple Maybe Identifier
mbi) = do
      Vector Val
v <- forall s (m :: * -> *). MonadState s m => m s
get
      case forall a. Vector a -> Maybe (a, Vector a)
V.uncons Vector Val
v of
        Maybe (Val, Vector Val)
Nothing -> 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
          forall s (m :: * -> *). MonadState s m => s -> m ()
put Vector Val
v'
          case Maybe Identifier
mbi of
            Maybe Identifier
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just Identifier
i -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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 {}) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Bind cannot contain multiple sinks"
    handleBackBind (WithKey {}) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot destructure array with key"
    handleBackBind (Simple Maybe Identifier
mbi) = do
      Vector Val
v <- forall s (m :: * -> *). MonadState s m => m s
get
      case forall a. Vector a -> Maybe (Vector a, a)
V.unsnoc Vector Val
v of
        Maybe (Vector Val, Val)
Nothing -> 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
          forall s (m :: * -> *). MonadState s m => s -> m ()
put Vector Val
v'
          case Maybe Identifier
mbi of
            Maybe Identifier
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just Identifier
i -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m' :: * -> *). Monad m' => Identifier -> Val -> MP m' ()
setIdentifier Identifier
i Val
x