Builder.hs

{-# LANGUAGE ExistentialQuantification #-}

module Heart.Core.Builder
  ( Builder
  , premapBuilder
  , newBuilder
  , newMonoidBuilder
  , addBuilder
  , addAllBuilder
  , consumeBuilder
  , drainBuilder
  , runBuilder
  , evalBuilder
  , SeqBuilder
  , newSeqBuilder
  , runSeqBuilder
  , evalSeqBuilder
  , MapBuilder
  , newMapBuilder
  , runMapBuilder
  , evalMapBuilder
  , SetBuilder
  , newSetBuilder
  , runSetBuilder
  , evalSetBuilder
  , HashMapBuilder
  , newHashMapBuilder
  , runHashMapBuilder
  , evalHashMapBuilder
  , HashSetBuilder
  , newHashSetBuilder
  , runHashSetBuilder
  , evalHashSetBuilder
  , OrdMultiMapBuilder
  , newOrdMultiMapBuilder
  , runOrdMultiMapBuilder
  , evalOrdMultiMapBuilder
  , HashMultiMapBuilder
  , newHashMultiMapBuilder
  , runHashMultiMapBuilder
  , evalHashMultiMapBuilder
  ) where

import qualified Data.HashMap.Strict as HashMap
import qualified Data.HashSet as HashSet
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Heart.Core.MultiMap
import Heart.Core.Prelude
import qualified ListT
import UnliftIO.IORef

data Builder a b = forall x. Builder
  { _builderStep :: !(x -> a -> x)
  , _builderRef :: !(IORef x)
  , _builderExtract :: !(x -> b)
  }

instance Functor (Builder a) where
  fmap f (Builder step ref extract) = Builder step ref (f . extract)

premapBuilder :: (z -> a) -> Builder a b -> Builder z b
premapBuilder f (Builder step ref extract) = Builder (\x z -> step x (f z)) ref extract

newBuilder :: MonadIO m => (b -> a -> b) -> b -> m (Builder a b)
newBuilder f b = fmap (\ref -> Builder f ref id) (newIORef b)

newMonoidBuilder :: (MonadIO m, Monoid b) => m (Builder b b)
newMonoidBuilder = newBuilder mappend mempty

addBuilder :: MonadIO m => Builder a b -> a -> m ()
addBuilder (Builder step ref _) b = modifyIORef' ref (`step` b)

addAllBuilder :: (MonadIO m, Foldable f) => Builder a b -> f a -> m ()
addAllBuilder (Builder step ref _) as = modifyIORef' ref (\a -> foldl step a as)

consumeBuilder :: MonadIO m => Builder a b -> ListT m a -> m ()
consumeBuilder b = ListT.traverse_ (addBuilder b)

drainBuilder :: MonadIO m => Builder a b -> m b
drainBuilder (Builder _ ref extract) = fmap extract (readIORef ref)

rawRunBuilder :: MonadIO m => Builder a b -> (Builder a b -> m c) -> m (b, c)
rawRunBuilder s h = do
  c <- h s
  a' <- drainBuilder s
  pure (a', c)

runBuilder :: MonadIO m => (b -> a -> b) -> b -> (Builder a b -> m c) -> m (b, c)
runBuilder f a h = do
  s <- newBuilder f a
  rawRunBuilder s h

evalBuilder :: MonadIO m => (b -> a -> b) -> b -> (Builder a b -> m ()) -> m b
evalBuilder f a h = fmap fst (runBuilder f a h)

type SeqBuilder a = Builder a (Seq a)

newSeqBuilder :: MonadIO m => m (SeqBuilder a)
newSeqBuilder = newBuilder (:|>) Empty

runSeqBuilder :: MonadIO m => (SeqBuilder a -> m c) -> m (Seq a, c)
runSeqBuilder h = newSeqBuilder >>= flip rawRunBuilder h

evalSeqBuilder :: MonadIO m => (SeqBuilder a -> m ()) -> m (Seq a)
evalSeqBuilder h = fmap fst (runSeqBuilder h)

type MapBuilder k v = Builder (k, v) (Map k v)

newMapBuilder :: (MonadIO m, Ord k) => m (MapBuilder k v)
newMapBuilder = newBuilder (\m (k, v) -> Map.insert k v m) Map.empty

runMapBuilder :: (MonadIO m, Ord k) => (MapBuilder k v -> m c) -> m (Map k v, c)
runMapBuilder h = newMapBuilder >>= flip rawRunBuilder h

evalMapBuilder :: (MonadIO m, Ord k) => (MapBuilder k v -> m ()) -> m (Map k v)
evalMapBuilder h = fmap fst (runMapBuilder h)

type SetBuilder k = Builder k (Set k)

newSetBuilder :: (MonadIO m, Ord k) => m (SetBuilder k)
newSetBuilder = newBuilder (flip Set.insert) Set.empty

runSetBuilder :: (MonadIO m, Ord k) => (SetBuilder k -> m c) -> m (Set k, c)
runSetBuilder h = newSetBuilder >>= flip rawRunBuilder h

evalSetBuilder :: (MonadIO m, Ord k) => (SetBuilder k -> m ()) -> m (Set k)
evalSetBuilder h = fmap fst (runSetBuilder h)

type HashMapBuilder k v = Builder (k, v) (HashMap k v)

newHashMapBuilder :: (MonadIO m, Eq k, Hashable k) => m (HashMapBuilder k v)
newHashMapBuilder = newBuilder (\m (k, v) -> HashMap.insert k v m) HashMap.empty

runHashMapBuilder :: (MonadIO m, Eq k, Hashable k) => (HashMapBuilder k v -> m c) -> m (HashMap k v, c)
runHashMapBuilder h = newHashMapBuilder >>= flip rawRunBuilder h

evalHashMapBuilder :: (MonadIO m, Eq k, Hashable k) => (HashMapBuilder k v -> m ()) -> m (HashMap k v)
evalHashMapBuilder h = fmap fst (runHashMapBuilder h)

type HashSetBuilder k = Builder k (HashSet k)

newHashSetBuilder :: (MonadIO m, Eq k, Hashable k) => m (HashSetBuilder k)
newHashSetBuilder = newBuilder (flip HashSet.insert) HashSet.empty

runHashSetBuilder :: (MonadIO m, Eq k, Hashable k) => (HashSetBuilder k -> m c) -> m (HashSet k, c)
runHashSetBuilder h = newHashSetBuilder >>= flip rawRunBuilder h

evalHashSetBuilder :: (MonadIO m, Eq k, Hashable k) => (HashSetBuilder k -> m ()) -> m (HashSet k)
evalHashSetBuilder h = fmap fst (runHashSetBuilder h)

type OrdMultiMapBuilder k v = Builder (k, v) (OrdMultiMap k v)

newOrdMultiMapBuilder :: (MonadIO m, Ord k, Ord v) => m (OrdMultiMapBuilder k v)
newOrdMultiMapBuilder = newBuilder (\m (k, v) -> insertOrdMultiMap k v m) Map.empty

runOrdMultiMapBuilder :: (MonadIO m, Ord k, Ord v) => (OrdMultiMapBuilder k v -> m c) -> m (OrdMultiMap k v, c)
runOrdMultiMapBuilder h = newOrdMultiMapBuilder >>= flip rawRunBuilder h

evalOrdMultiMapBuilder :: (MonadIO m, Ord k, Ord v) => (OrdMultiMapBuilder k v -> m ()) -> m (OrdMultiMap k v)
evalOrdMultiMapBuilder h = fmap fst (runOrdMultiMapBuilder h)

type HashMultiMapBuilder k v = Builder (k, v) (HashMultiMap k v)

newHashMultiMapBuilder :: (MonadIO m, Eq k, Hashable k, Eq v, Hashable v) => m (HashMultiMapBuilder k v)
newHashMultiMapBuilder = newBuilder (\m (k, v) -> insertHashMultiMap k v m) HashMap.empty

runHashMultiMapBuilder :: (MonadIO m, Eq k, Hashable k, Eq v, Hashable v) => (HashMultiMapBuilder k v -> m c) -> m (HashMultiMap k v, c)
runHashMultiMapBuilder h = newHashMultiMapBuilder >>= flip rawRunBuilder h

evalHashMultiMapBuilder :: (MonadIO m, Eq k, Hashable k, Eq v, Hashable v) => (HashMultiMapBuilder k v -> m ()) -> m (HashMultiMap k v)
evalHashMultiMapBuilder h = fmap fst (runHashMultiMapBuilder h)