{-# 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 :: Monad m => HashMap k a -> HashMap k a -> m (HashMap k a)
merge HashMap k a
x HashMap k a
y = 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 forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList (forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap k a
x forall a. Semigroup a => a -> a -> 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 :: forall (m :: * -> *) a e.
(Monad m, Merge m a, MonadError e m) =>
NonEmpty a -> m a
mergeConcat (a
value :| []) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
value
mergeConcat (a
value :| (a
x : [a]
xs)) = do
  a
a <- forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge a
value a
x
  forall (m :: * -> *) a e.
(Monad m, Merge m a, MonadError e m) =>
NonEmpty a -> m a
mergeConcat (a
a forall a. a -> [a] -> NonEmpty a
:| [a]
xs)

throwErrors :: MonadError e m => NonEmpty e -> m b
throwErrors :: forall e (m :: * -> *) b. MonadError e m => NonEmpty e -> m b
throwErrors (e
e :| [e]
es) = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse 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 :: forall e (m :: * -> *) a.
(MonadError e m, NameCollision e a) =>
NonEmpty a -> m a
failOnDuplicates (a
x :| [a]
xs)
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  | Bool
otherwise = forall e (m :: * -> *) b. MonadError e m => NonEmpty e -> m b
throwErrors (forall e a. NameCollision e a => a -> e
nameCollision forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a
x forall a. a -> [a] -> NonEmpty a
:| [a]
xs)

mergeOnDuplicates ::
  ( Monad m,
    Eq a,
    Merge m a
  ) =>
  a ->
  a ->
  m a
mergeOnDuplicates :: forall (m :: * -> *) a. (Monad m, Eq a, Merge m a) => a -> a -> m a
mergeOnDuplicates a
oldValue a
newValue
  | a
oldValue forall a. Eq a => a -> a -> Bool
== a
newValue = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
oldValue
  | Bool
otherwise = 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 :: 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)] -> b
f [(k, a)]
xs = forall k a coll (m :: * -> *) b.
ResolutionT k a coll m b
-> ([(k, a)] -> coll) -> (NonEmpty a -> m a) -> m b
runResolutionT (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 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 :: forall k a (m :: * -> *) b.
(Eq k, Eq a, Hashable k, Monad m, Merge m a) =>
([(k, a)] -> b) -> [(k, a)] -> m b
recursiveMerge [(k, a)] -> b
f [(k, a)]
xs = forall k a coll (m :: * -> *) b.
ResolutionT k a coll m b
-> ([(k, a)] -> coll) -> (NonEmpty a -> m a) -> m b
runResolutionT (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 (forall (m :: * -> *) a.
Monad m =>
(a -> a -> m a) -> NonEmpty a -> m a
resolveWith 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 :: forall k (m :: * -> *) v.
(Eq k, Hashable k, Monad m, Semigroup v) =>
[(k, v)] -> m (HashMap k v)
collect [(k, v)]
xs = forall k a coll (m :: * -> *) b.
ResolutionT k a coll m b
-> ([(k, a)] -> coll) -> (NonEmpty a -> m a) -> m b
runResolutionT (forall (m :: * -> *) k a coll.
(Monad m, Eq k, Hashable k) =>
[(k, a)] -> ResolutionT k a coll m coll
fromListT [(k, v)]
xs) forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList (forall (m :: * -> *) a.
Monad m =>
(a -> a -> m a) -> NonEmpty a -> m a
resolveWith (\v
x v
y -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (v
x forall a. Semigroup a => a -> a -> a
<> v
y)))