{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Ext.MergeSet
  ( MergeSet,
  )
where

import Data.Morpheus.Ext.Elems (Elems (..))
import Data.Morpheus.Ext.Map
  ( fromListT,
    resolveWith,
    runResolutionT,
  )
import Data.Morpheus.Ext.SemigroupM
  ( SemigroupM (..),
  )
import Data.Morpheus.Internal.Utils
  ( Collection (..),
    Failure (..),
    FromElems (..),
    KeyOf (..),
    Selectable (..),
    toPair,
  )
import Data.Morpheus.Types.Internal.AST.Base
  ( Ref,
    ValidationErrors,
  )
import Data.Morpheus.Types.Internal.AST.Stage
  ( RAW,
    Stage,
    VALID,
  )
import Language.Haskell.TH.Syntax (Lift (..))
import Relude

-- set with mergeable components
newtype MergeSet (dups :: Stage) k a = MergeSet
  { MergeSet dups k a -> [a]
unpack :: [a]
  }
  deriving
    ( Int -> MergeSet dups k a -> ShowS
[MergeSet dups k a] -> ShowS
MergeSet dups k a -> String
(Int -> MergeSet dups k a -> ShowS)
-> (MergeSet dups k a -> String)
-> ([MergeSet dups k a] -> ShowS)
-> Show (MergeSet dups k a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (dups :: Stage) k a.
Show a =>
Int -> MergeSet dups k a -> ShowS
forall (dups :: Stage) k a. Show a => [MergeSet dups k a] -> ShowS
forall (dups :: Stage) k a. Show a => MergeSet dups k a -> String
showList :: [MergeSet dups k a] -> ShowS
$cshowList :: forall (dups :: Stage) k a. Show a => [MergeSet dups k a] -> ShowS
show :: MergeSet dups k a -> String
$cshow :: forall (dups :: Stage) k a. Show a => MergeSet dups k a -> String
showsPrec :: Int -> MergeSet dups k a -> ShowS
$cshowsPrec :: forall (dups :: Stage) k a.
Show a =>
Int -> MergeSet dups k a -> ShowS
Show,
      MergeSet dups k a -> MergeSet dups k a -> Bool
(MergeSet dups k a -> MergeSet dups k a -> Bool)
-> (MergeSet dups k a -> MergeSet dups k a -> Bool)
-> Eq (MergeSet dups k a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (dups :: Stage) k a.
Eq a =>
MergeSet dups k a -> MergeSet dups k a -> Bool
/= :: MergeSet dups k a -> MergeSet dups k a -> Bool
$c/= :: forall (dups :: Stage) k a.
Eq a =>
MergeSet dups k a -> MergeSet dups k a -> Bool
== :: MergeSet dups k a -> MergeSet dups k a -> Bool
$c== :: forall (dups :: Stage) k a.
Eq a =>
MergeSet dups k a -> MergeSet dups k a -> Bool
Eq,
      a -> MergeSet dups k b -> MergeSet dups k a
(a -> b) -> MergeSet dups k a -> MergeSet dups k b
(forall a b. (a -> b) -> MergeSet dups k a -> MergeSet dups k b)
-> (forall a b. a -> MergeSet dups k b -> MergeSet dups k a)
-> Functor (MergeSet dups k)
forall a b. a -> MergeSet dups k b -> MergeSet dups k a
forall a b. (a -> b) -> MergeSet dups k a -> MergeSet dups k b
forall (dups :: Stage) k a b.
a -> MergeSet dups k b -> MergeSet dups k a
forall (dups :: Stage) k a b.
(a -> b) -> MergeSet dups k a -> MergeSet dups k b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> MergeSet dups k b -> MergeSet dups k a
$c<$ :: forall (dups :: Stage) k a b.
a -> MergeSet dups k b -> MergeSet dups k a
fmap :: (a -> b) -> MergeSet dups k a -> MergeSet dups k b
$cfmap :: forall (dups :: Stage) k a b.
(a -> b) -> MergeSet dups k a -> MergeSet dups k b
Functor,
      a -> MergeSet dups k a -> Bool
MergeSet dups k m -> m
MergeSet dups k a -> [a]
MergeSet dups k a -> Bool
MergeSet dups k a -> Int
MergeSet dups k a -> a
MergeSet dups k a -> a
MergeSet dups k a -> a
MergeSet dups k a -> a
(a -> m) -> MergeSet dups k a -> m
(a -> m) -> MergeSet dups k a -> m
(a -> b -> b) -> b -> MergeSet dups k a -> b
(a -> b -> b) -> b -> MergeSet dups k a -> b
(b -> a -> b) -> b -> MergeSet dups k a -> b
(b -> a -> b) -> b -> MergeSet dups k a -> b
(a -> a -> a) -> MergeSet dups k a -> a
(a -> a -> a) -> MergeSet dups k a -> a
(forall m. Monoid m => MergeSet dups k m -> m)
-> (forall m a. Monoid m => (a -> m) -> MergeSet dups k a -> m)
-> (forall m a. Monoid m => (a -> m) -> MergeSet dups k a -> m)
-> (forall a b. (a -> b -> b) -> b -> MergeSet dups k a -> b)
-> (forall a b. (a -> b -> b) -> b -> MergeSet dups k a -> b)
-> (forall b a. (b -> a -> b) -> b -> MergeSet dups k a -> b)
-> (forall b a. (b -> a -> b) -> b -> MergeSet dups k a -> b)
-> (forall a. (a -> a -> a) -> MergeSet dups k a -> a)
-> (forall a. (a -> a -> a) -> MergeSet dups k a -> a)
-> (forall a. MergeSet dups k a -> [a])
-> (forall a. MergeSet dups k a -> Bool)
-> (forall a. MergeSet dups k a -> Int)
-> (forall a. Eq a => a -> MergeSet dups k a -> Bool)
-> (forall a. Ord a => MergeSet dups k a -> a)
-> (forall a. Ord a => MergeSet dups k a -> a)
-> (forall a. Num a => MergeSet dups k a -> a)
-> (forall a. Num a => MergeSet dups k a -> a)
-> Foldable (MergeSet dups k)
forall a. Eq a => a -> MergeSet dups k a -> Bool
forall a. Num a => MergeSet dups k a -> a
forall a. Ord a => MergeSet dups k a -> a
forall m. Monoid m => MergeSet dups k m -> m
forall a. MergeSet dups k a -> Bool
forall a. MergeSet dups k a -> Int
forall a. MergeSet dups k a -> [a]
forall a. (a -> a -> a) -> MergeSet dups k a -> a
forall m a. Monoid m => (a -> m) -> MergeSet dups k a -> m
forall b a. (b -> a -> b) -> b -> MergeSet dups k a -> b
forall a b. (a -> b -> b) -> b -> MergeSet dups k a -> b
forall (dups :: Stage) k a. Eq a => a -> MergeSet dups k a -> Bool
forall (dups :: Stage) k a. Num a => MergeSet dups k a -> a
forall (dups :: Stage) k a. Ord a => MergeSet dups k a -> a
forall (dups :: Stage) k m. Monoid m => MergeSet dups k m -> m
forall (dups :: Stage) k a. MergeSet dups k a -> Bool
forall (dups :: Stage) k a. MergeSet dups k a -> Int
forall (dups :: Stage) k a. MergeSet dups k a -> [a]
forall (dups :: Stage) k a. (a -> a -> a) -> MergeSet dups k a -> a
forall (dups :: Stage) k m a.
Monoid m =>
(a -> m) -> MergeSet dups k a -> m
forall (dups :: Stage) k b a.
(b -> a -> b) -> b -> MergeSet dups k a -> b
forall (dups :: Stage) k a b.
(a -> b -> b) -> b -> MergeSet dups k a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: MergeSet dups k a -> a
$cproduct :: forall (dups :: Stage) k a. Num a => MergeSet dups k a -> a
sum :: MergeSet dups k a -> a
$csum :: forall (dups :: Stage) k a. Num a => MergeSet dups k a -> a
minimum :: MergeSet dups k a -> a
$cminimum :: forall (dups :: Stage) k a. Ord a => MergeSet dups k a -> a
maximum :: MergeSet dups k a -> a
$cmaximum :: forall (dups :: Stage) k a. Ord a => MergeSet dups k a -> a
elem :: a -> MergeSet dups k a -> Bool
$celem :: forall (dups :: Stage) k a. Eq a => a -> MergeSet dups k a -> Bool
length :: MergeSet dups k a -> Int
$clength :: forall (dups :: Stage) k a. MergeSet dups k a -> Int
null :: MergeSet dups k a -> Bool
$cnull :: forall (dups :: Stage) k a. MergeSet dups k a -> Bool
toList :: MergeSet dups k a -> [a]
$ctoList :: forall (dups :: Stage) k a. MergeSet dups k a -> [a]
foldl1 :: (a -> a -> a) -> MergeSet dups k a -> a
$cfoldl1 :: forall (dups :: Stage) k a. (a -> a -> a) -> MergeSet dups k a -> a
foldr1 :: (a -> a -> a) -> MergeSet dups k a -> a
$cfoldr1 :: forall (dups :: Stage) k a. (a -> a -> a) -> MergeSet dups k a -> a
foldl' :: (b -> a -> b) -> b -> MergeSet dups k a -> b
$cfoldl' :: forall (dups :: Stage) k b a.
(b -> a -> b) -> b -> MergeSet dups k a -> b
foldl :: (b -> a -> b) -> b -> MergeSet dups k a -> b
$cfoldl :: forall (dups :: Stage) k b a.
(b -> a -> b) -> b -> MergeSet dups k a -> b
foldr' :: (a -> b -> b) -> b -> MergeSet dups k a -> b
$cfoldr' :: forall (dups :: Stage) k a b.
(a -> b -> b) -> b -> MergeSet dups k a -> b
foldr :: (a -> b -> b) -> b -> MergeSet dups k a -> b
$cfoldr :: forall (dups :: Stage) k a b.
(a -> b -> b) -> b -> MergeSet dups k a -> b
foldMap' :: (a -> m) -> MergeSet dups k a -> m
$cfoldMap' :: forall (dups :: Stage) k m a.
Monoid m =>
(a -> m) -> MergeSet dups k a -> m
foldMap :: (a -> m) -> MergeSet dups k a -> m
$cfoldMap :: forall (dups :: Stage) k m a.
Monoid m =>
(a -> m) -> MergeSet dups k a -> m
fold :: MergeSet dups k m -> m
$cfold :: forall (dups :: Stage) k m. Monoid m => MergeSet dups k m -> m
Foldable,
      MergeSet dups k a -> Q Exp
MergeSet dups k a -> Q (TExp (MergeSet dups k a))
(MergeSet dups k a -> Q Exp)
-> (MergeSet dups k a -> Q (TExp (MergeSet dups k a)))
-> Lift (MergeSet dups k a)
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
forall (dups :: Stage) k a. Lift a => MergeSet dups k a -> Q Exp
forall (dups :: Stage) k a.
Lift a =>
MergeSet dups k a -> Q (TExp (MergeSet dups k a))
liftTyped :: MergeSet dups k a -> Q (TExp (MergeSet dups k a))
$cliftTyped :: forall (dups :: Stage) k a.
Lift a =>
MergeSet dups k a -> Q (TExp (MergeSet dups k a))
lift :: MergeSet dups k a -> Q Exp
$clift :: forall (dups :: Stage) k a. Lift a => MergeSet dups k a -> Q Exp
Lift,
      Functor (MergeSet dups k)
Foldable (MergeSet dups k)
Functor (MergeSet dups k)
-> Foldable (MergeSet dups k)
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> MergeSet dups k a -> f (MergeSet dups k b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    MergeSet dups k (f a) -> f (MergeSet dups k a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> MergeSet dups k a -> m (MergeSet dups k b))
-> (forall (m :: * -> *) a.
    Monad m =>
    MergeSet dups k (m a) -> m (MergeSet dups k a))
-> Traversable (MergeSet dups k)
(a -> f b) -> MergeSet dups k a -> f (MergeSet dups k b)
forall (dups :: Stage) k. Functor (MergeSet dups k)
forall (dups :: Stage) k. Foldable (MergeSet dups k)
forall (dups :: Stage) k (m :: * -> *) a.
Monad m =>
MergeSet dups k (m a) -> m (MergeSet dups k a)
forall (dups :: Stage) k (f :: * -> *) a.
Applicative f =>
MergeSet dups k (f a) -> f (MergeSet dups k a)
forall (dups :: Stage) k (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MergeSet dups k a -> m (MergeSet dups k b)
forall (dups :: Stage) k (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MergeSet dups k a -> f (MergeSet dups k b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
MergeSet dups k (m a) -> m (MergeSet dups k a)
forall (f :: * -> *) a.
Applicative f =>
MergeSet dups k (f a) -> f (MergeSet dups k a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MergeSet dups k a -> m (MergeSet dups k b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MergeSet dups k a -> f (MergeSet dups k b)
sequence :: MergeSet dups k (m a) -> m (MergeSet dups k a)
$csequence :: forall (dups :: Stage) k (m :: * -> *) a.
Monad m =>
MergeSet dups k (m a) -> m (MergeSet dups k a)
mapM :: (a -> m b) -> MergeSet dups k a -> m (MergeSet dups k b)
$cmapM :: forall (dups :: Stage) k (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MergeSet dups k a -> m (MergeSet dups k b)
sequenceA :: MergeSet dups k (f a) -> f (MergeSet dups k a)
$csequenceA :: forall (dups :: Stage) k (f :: * -> *) a.
Applicative f =>
MergeSet dups k (f a) -> f (MergeSet dups k a)
traverse :: (a -> f b) -> MergeSet dups k a -> f (MergeSet dups k b)
$ctraverse :: forall (dups :: Stage) k (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MergeSet dups k a -> f (MergeSet dups k b)
$cp2Traversable :: forall (dups :: Stage) k. Foldable (MergeSet dups k)
$cp1Traversable :: forall (dups :: Stage) k. Functor (MergeSet dups k)
Traversable,
      Collection a,
      Elems a
    )

instance (KeyOf k a) => Selectable k a (MergeSet opt k a) where
  selectOr :: d -> (a -> d) -> k -> MergeSet opt k a -> d
selectOr d
fb a -> d
f k
key (MergeSet [a]
ls) = d -> (a -> d) -> Maybe a -> d
forall b a. b -> (a -> b) -> Maybe a -> b
maybe d
fb a -> d
f ((a -> Bool) -> [a] -> Maybe a
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((k
key k -> k -> Bool
forall a. Eq a => a -> a -> Bool
==) (k -> Bool) -> (a -> k) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> k
forall k a. KeyOf k a => a -> k
keyOf) [a]
ls)

instance
  ( KeyOf k a,
    SemigroupM m a,
    Monad m,
    Failure ValidationErrors m,
    Eq a
  ) =>
  SemigroupM m (MergeSet VALID k a)
  where
  mergeM :: [Ref]
-> MergeSet VALID k a
-> MergeSet VALID k a
-> m (MergeSet VALID k a)
mergeM [Ref]
path (MergeSet [a]
x) (MergeSet [a]
y) = [Ref] -> [a] -> m (MergeSet VALID k a)
forall k a (m :: * -> *) (dups :: Stage).
(KeyOf k a, Monad m, Eq a, SemigroupM m a,
 Failure ValidationErrors m) =>
[Ref] -> [a] -> m (MergeSet dups k a)
resolveMergable [Ref]
path ([a]
x [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a]
y)

resolveMergable ::
  ( KeyOf k a,
    Monad m,
    Eq a,
    SemigroupM m a,
    Failure ValidationErrors m
  ) =>
  [Ref] ->
  [a] ->
  m (MergeSet dups k a)
resolveMergable :: [Ref] -> [a] -> m (MergeSet dups k a)
resolveMergable [Ref]
path [a]
xs = ResolutionT k a (MergeSet dups k a) m (MergeSet dups k a)
-> ([(k, a)] -> MergeSet dups k a)
-> (NonEmpty a -> m a)
-> m (MergeSet dups k a)
forall k a coll (m :: * -> *) b.
ResolutionT k a coll m b
-> ([(k, a)] -> coll) -> (NonEmpty a -> m a) -> m b
runResolutionT ([(k, a)]
-> ResolutionT k a (MergeSet dups k a) m (MergeSet dups k a)
forall (m :: * -> *) k a coll.
(Monad m, Eq k, Hashable k) =>
[(k, a)] -> ResolutionT k a coll m coll
fromListT (a -> (k, a)
forall k a. KeyOf k a => a -> (k, a)
toPair (a -> (k, a)) -> [a] -> [(k, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
xs)) ([a] -> MergeSet dups k a
forall (dups :: Stage) k a. [a] -> MergeSet dups k a
MergeSet ([a] -> MergeSet dups k a)
-> ([(k, a)] -> [a]) -> [(k, a)] -> MergeSet dups k a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, a) -> a) -> [(k, a)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (k, a) -> a
forall a b. (a, b) -> b
snd) ((a -> a -> m a) -> NonEmpty a -> m a
forall (m :: * -> *) a.
Monad m =>
(a -> a -> m a) -> NonEmpty a -> m a
resolveWith ([Ref] -> a -> a -> m a
forall (m :: * -> *) a k.
(Monad m, Eq a, KeyOf k a, SemigroupM m a,
 Failure ValidationErrors m) =>
[Ref] -> a -> a -> m a
resolveConflict [Ref]
path))

instance
  ( KeyOf k a,
    SemigroupM m a,
    Monad m,
    Failure ValidationErrors m,
    Eq a
  ) =>
  FromElems m a (MergeSet VALID k a)
  where
  fromElems :: [a] -> m (MergeSet VALID k a)
fromElems = [Ref] -> [a] -> m (MergeSet VALID k a)
forall k a (m :: * -> *) (dups :: Stage).
(KeyOf k a, Monad m, Eq a, SemigroupM m a,
 Failure ValidationErrors m) =>
[Ref] -> [a] -> m (MergeSet dups k a)
resolveMergable []

instance Applicative m => SemigroupM m (MergeSet RAW k a) where
  mergeM :: [Ref]
-> MergeSet RAW k a -> MergeSet RAW k a -> m (MergeSet RAW k a)
mergeM [Ref]
_ (MergeSet [a]
x) (MergeSet [a]
y) = MergeSet RAW k a -> m (MergeSet RAW k a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MergeSet RAW k a -> m (MergeSet RAW k a))
-> MergeSet RAW k a -> m (MergeSet RAW k a)
forall a b. (a -> b) -> a -> b
$ [a] -> MergeSet RAW k a
forall (dups :: Stage) k a. [a] -> MergeSet dups k a
MergeSet ([a] -> MergeSet RAW k a) -> [a] -> MergeSet RAW k a
forall a b. (a -> b) -> a -> b
$ [a]
x [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a]
y

instance Applicative m => FromElems m a (MergeSet RAW k a) where
  fromElems :: [a] -> m (MergeSet RAW k a)
fromElems = MergeSet RAW k a -> m (MergeSet RAW k a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MergeSet RAW k a -> m (MergeSet RAW k a))
-> ([a] -> MergeSet RAW k a) -> [a] -> m (MergeSet RAW k a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> MergeSet RAW k a
forall (dups :: Stage) k a. [a] -> MergeSet dups k a
MergeSet

resolveConflict :: (Monad m, Eq a, KeyOf k a, SemigroupM m a, Failure ValidationErrors m) => [Ref] -> a -> a -> m a
resolveConflict :: [Ref] -> a -> a -> m a
resolveConflict [Ref]
path a
oldValue a
newValue
  | a
oldValue a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
newValue = a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
oldValue
  | Bool
otherwise = [Ref] -> a -> a -> m a
forall (m :: * -> *) a. SemigroupM m a => [Ref] -> a -> a -> m a
mergeM [Ref]
path a
oldValue a
newValue