{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Mergeable.Internal.Merge
  ( mergeConcat,
    Merge (..),
    mergeNoDuplicates,
    recursiveMerge,
    collect,
    throwErrors,
  )
where

import Control.Monad.Except (MonadError (throwError))
import qualified Data.HashMap.Lazy as HM
import Data.Mergeable.Internal.NameCollision (NameCollision (nameCollision))
import Data.Mergeable.Internal.Resolution
  ( fromListT,
    resolveWith,
    runResolutionT,
  )
import Relude hiding (empty, join)

class Merge m a where
  merge :: (Monad m) => a -> a -> m a

instance
  ( Eq k,
    Hashable k,
    MonadError e m,
    NameCollision e a
  ) =>
  Merge m (HashMap k a)
  where
  merge :: HashMap k a -> HashMap k a -> m (HashMap k a)
merge HashMap k a
x HashMap k a
y = ([(k, a)] -> HashMap k a) -> [(k, a)] -> m (HashMap k a)
forall k (m :: * -> *) e a b.
(Eq k, Hashable k, Monad m, MonadError e m, NameCollision e a) =>
([(k, a)] -> b) -> [(k, a)] -> m b
mergeNoDuplicates [(k, a)] -> HashMap k a
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList (HashMap k a -> [(k, a)]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap k a
x [(k, a)] -> [(k, a)] -> [(k, a)]
forall a. Semigroup a => a -> a -> a
<> HashMap k a -> [(k, a)]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap k a
y)

mergeConcat ::
  ( Monad m,
    Merge m a,
    MonadError e m
  ) =>
  NonEmpty a ->
  m a
mergeConcat :: NonEmpty a -> m a
mergeConcat (a
value :| []) = a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
value
mergeConcat (a
value :| (a
x : [a]
xs)) = do
  a
a <- a -> a -> m a
forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge a
value a
x
  NonEmpty a -> m a
forall (m :: * -> *) a e.
(Monad m, Merge m a, MonadError e m) =>
NonEmpty a -> m a
mergeConcat (a
a a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs)

throwErrors :: MonadError e m => NonEmpty e -> m b
throwErrors :: NonEmpty e -> m b
throwErrors (e
e :| [e]
es) = e -> m b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e m b -> m [Any] -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (e -> m Any) -> [e] -> m [Any]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse e -> m Any
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [e]
es

-- Merge Object with of Failure as an Option
failOnDuplicates :: (MonadError e m, NameCollision e a) => NonEmpty a -> m a
failOnDuplicates :: NonEmpty a -> m a
failOnDuplicates (a
x :| [a]
xs)
  | [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs = a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  | Bool
otherwise = NonEmpty e -> m a
forall e (m :: * -> *) b. MonadError e m => NonEmpty e -> m b
throwErrors (a -> e
forall e a. NameCollision e a => a -> e
nameCollision (a -> e) -> NonEmpty a -> NonEmpty e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs)

mergeOnDuplicates ::
  ( Monad m,
    Eq a,
    Merge m a
  ) =>
  a ->
  a ->
  m a
mergeOnDuplicates :: a -> a -> m a
mergeOnDuplicates 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 = a -> a -> m a
forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge a
oldValue a
newValue

mergeNoDuplicates ::
  ( Eq k,
    Hashable k,
    Monad m,
    MonadError e m,
    NameCollision e a
  ) =>
  ([(k, a)] -> b) ->
  [(k, a)] ->
  m b
mergeNoDuplicates :: ([(k, a)] -> b) -> [(k, a)] -> m b
mergeNoDuplicates [(k, a)] -> b
f [(k, a)]
xs = ResolutionT k a b m b
-> ([(k, a)] -> b) -> (NonEmpty a -> m a) -> m b
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 b m b
forall (m :: * -> *) k a coll.
(Monad m, Eq k, Hashable k) =>
[(k, a)] -> ResolutionT k a coll m coll
fromListT [(k, a)]
xs) [(k, a)] -> b
f NonEmpty a -> m a
forall e (m :: * -> *) a.
(MonadError e m, NameCollision e a) =>
NonEmpty a -> m a
failOnDuplicates

recursiveMerge ::
  ( Eq k,
    Eq a,
    Hashable k,
    Monad m,
    Merge m a
  ) =>
  ([(k, a)] -> b) ->
  [(k, a)] ->
  m b
recursiveMerge :: ([(k, a)] -> b) -> [(k, a)] -> m b
recursiveMerge [(k, a)] -> b
f [(k, a)]
xs = ResolutionT k a b m b
-> ([(k, a)] -> b) -> (NonEmpty a -> m a) -> m b
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 b m b
forall (m :: * -> *) k a coll.
(Monad m, Eq k, Hashable k) =>
[(k, a)] -> ResolutionT k a coll m coll
fromListT [(k, a)]
xs) [(k, a)] -> b
f ((a -> a -> m a) -> NonEmpty a -> m a
forall (m :: * -> *) a.
Monad m =>
(a -> a -> m a) -> NonEmpty a -> m a
resolveWith a -> a -> m a
forall (m :: * -> *) a. (Monad m, Eq a, Merge m a) => a -> a -> m a
mergeOnDuplicates)

collect ::
  ( Eq k,
    Hashable k,
    Monad m,
    Semigroup v
  ) =>
  [(k, v)] ->
  m (HashMap k v)
collect :: [(k, v)] -> m (HashMap k v)
collect [(k, v)]
xs = ResolutionT k v (HashMap k v) m (HashMap k v)
-> ([(k, v)] -> HashMap k v)
-> (NonEmpty v -> m v)
-> m (HashMap k v)
forall k a coll (m :: * -> *) b.
ResolutionT k a coll m b
-> ([(k, a)] -> coll) -> (NonEmpty a -> m a) -> m b
runResolutionT ([(k, v)] -> ResolutionT k v (HashMap k v) m (HashMap k v)
forall (m :: * -> *) k a coll.
(Monad m, Eq k, Hashable k) =>
[(k, a)] -> ResolutionT k a coll m coll
fromListT [(k, v)]
xs) [(k, v)] -> HashMap k v
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ((v -> v -> m v) -> NonEmpty v -> m v
forall (m :: * -> *) a.
Monad m =>
(a -> a -> m a) -> NonEmpty a -> m a
resolveWith (\v
x v
y -> v -> m v
forall (f :: * -> *) a. Applicative f => a -> f a
pure (v
x v -> v -> v
forall a. Semigroup a => a -> a -> a
<> v
y)))