packages feed

heart-core (empty) → 0.1.0

raw patch · 13 files changed

+709/−0 lines, 13 filesdep +aesondep +aeson-casingdep +base

Dependencies added: aeson, aeson-casing, base, containers, exceptions, filepath, hashable, lens, list-t, mtl, newtype-generics, text, unliftio, unliftio-core, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Eric Conlon (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Eric Conlon nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,5 @@+# heart-core++[![CircleCI](https://circleci.com/gh/ejconlon/heart-core/tree/master.svg?style=svg)](https://circleci.com/gh/ejconlon/heart-core/tree/master)++An opinionated library prelude in the UnliftIO style.
+ heart-core.cabal view
@@ -0,0 +1,63 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: c4d8800e6e2a4c22bd77a058f3ad0baa8e722bee6f6d57446b5ee0382cafbde9++name:           heart-core+version:        0.1.0+synopsis:       An opinionated library prelude in the UnliftIO style+description:    Please see the README on GitHub at <https://github.com/ejconlon/heart-core#readme>+category:       Prelude+homepage:       https://github.com/ejconlon/heart-core#readme+bug-reports:    https://github.com/ejconlon/heart-core/issues+author:         Eric Conlon+maintainer:     ejconlon@gmail.com+copyright:      (c) 2019 Eric Conlon+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/ejconlon/heart-core++library+  exposed-modules:+      Heart.Core.Aeson+      Heart.Core.Alloc+      Heart.Core.Builder+      Heart.Core.Directory+      Heart.Core.ListT+      Heart.Core.MultiMap+      Heart.Core.Prelude+      Heart.Core.RIO+      Heart.Core.SuperPrelude+      Heart.Core.UnionFind+  other-modules:+      Paths_heart_core+  hs-source-dirs:+      src+  default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveFoldable DeriveGeneric DeriveTraversable DerivingStrategies FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings Rank2Types StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds+  build-depends:+      aeson >=1.4+    , aeson-casing >=0.2+    , base >=4.12 && <5+    , containers >=0.6+    , exceptions >=0.10+    , filepath >=1.4+    , hashable >=1.2+    , lens >=4.17+    , list-t >=1.0+    , mtl >=2.2+    , newtype-generics >=0.5+    , text >=1.2+    , unliftio >=0.2+    , unliftio-core >=0.1+    , unordered-containers >=0.2+  default-language: Haskell2010
+ src/Heart/Core/Aeson.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}++module Heart.Core.Aeson+  ( AesonRecord (..)+  , AesonNewtype (..)+  , AesonTag (..)+  , HasJSONOptions (..)+  , HasTagPrefix (..)+  ) where++import Control.Newtype.Generics (Newtype, O, pack, unpack)+import Data.Aeson+import Data.Aeson.Casing (aesonPrefix, snakeCase)+import qualified Data.Text as Text+import Heart.Core.Prelude++-- Options++recordOptions :: Options+recordOptions = (aesonPrefix snakeCase) { omitNothingFields = True }++tagOptions :: Text -> Options+tagOptions prefix =+  let prefixLen = Text.length prefix+  in defaultOptions+      { allNullaryToStringTag = True+      , constructorTagModifier = snakeCase . drop prefixLen+      }++newtypeOptions :: Options+newtypeOptions = defaultOptions+  { unwrapUnaryRecords = True+  }++-- Has classes++class HasJSONOptions a where+  getJSONOptions :: Proxy a -> Options++class HasTagPrefix a where+  getTagPrefix :: Proxy a -> Text++-- Wrappers++newtype AesonTag a = AesonTag { unAesonTag :: a }++instance HasTagPrefix a => HasJSONOptions (AesonTag a) where+  getJSONOptions _ = tagOptions (getTagPrefix (Proxy :: Proxy a))++instance (HasJSONOptions (AesonTag a), Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (AesonTag a) where+  toJSON = genericToJSON (getJSONOptions (Proxy :: Proxy (AesonTag a))) . unAesonTag+  toEncoding = genericToEncoding (getJSONOptions (Proxy :: Proxy (AesonTag a))) . unAesonTag++instance (HasJSONOptions (AesonTag a), Generic a, GFromJSON Zero (Rep a)) => FromJSON (AesonTag a) where+  parseJSON = (AesonTag <$>) . genericParseJSON (getJSONOptions (Proxy :: Proxy (AesonTag a)))++newtype AesonRecord a = AesonRecord { unAesonRecord :: a }++instance HasJSONOptions (AesonRecord a) where+  getJSONOptions _ = recordOptions++instance (HasJSONOptions (AesonRecord a), Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (AesonRecord a) where+  toJSON = genericToJSON (getJSONOptions (Proxy :: Proxy (AesonRecord a))) . unAesonRecord+  toEncoding = genericToEncoding (getJSONOptions (Proxy :: Proxy (AesonRecord a))) . unAesonRecord++instance (HasJSONOptions (AesonRecord a), Generic a, GFromJSON Zero (Rep a)) => FromJSON (AesonRecord a) where+  parseJSON = (AesonRecord <$>) . genericParseJSON (getJSONOptions (Proxy :: Proxy (AesonRecord a)))++newtype AesonNewtype n o = AesonNewtype { unAesonNewtype :: n }++instance HasJSONOptions (AesonNewtype n o) where+  getJSONOptions _ = newtypeOptions++instance (Newtype n, o ~ O n, ToJSON o) => ToJSON (AesonNewtype n o) where+  toJSON = toJSON . unpack . unAesonNewtype+  toEncoding = toEncoding . unpack . unAesonNewtype++instance (Newtype n, o ~ O n, FromJSON o) => FromJSON (AesonNewtype n o) where+  parseJSON = ((AesonNewtype . pack) <$>) . parseJSON
+ src/Heart/Core/Alloc.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE ExistentialQuantification #-}++module Heart.Core.Alloc+  ( Alloc+  , newAlloc+  , newEnumAlloc+  , incAlloc+  ) where++import Heart.Core.Prelude+import UnliftIO.IORef++data Alloc e = forall x. Alloc+  { _allocStep :: !(x -> x)+  , _allocRef:: !(IORef x)+  , _allocExtract :: !(x -> e)+  }++instance Functor Alloc where+  fmap f (Alloc step ref extract) = Alloc step ref (f . extract)++newAlloc :: MonadIO m => (e -> e) -> e -> m (Alloc e)+newAlloc f e = fmap (\r -> Alloc f r id) (newIORef e)++newEnumAlloc :: (MonadIO m, Enum e) => m (Alloc e)+newEnumAlloc = newAlloc succ (toEnum 0)++incAlloc :: MonadIO m => Alloc e -> m e+incAlloc (Alloc step ref extract) = atomicModifyIORef' ref (\e -> (step e, extract e))
+ src/Heart/Core/Builder.hs view
@@ -0,0 +1,172 @@+{-# 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)
+ src/Heart/Core/Directory.hs view
@@ -0,0 +1,23 @@+module Heart.Core.Directory where++import Heart.Core.ListT+import Heart.Core.Prelude+import System.FilePath ((</>))+import UnliftIO.Directory (doesDirectoryExist, doesPathExist, listDirectory)++listDirectoryRecursively :: MonadIO m => FilePath -> ListT m FilePath+listDirectoryRecursively path = ListT $ do+  pathExists <- doesPathExist path+  if pathExists+    then do+      dirExists <- doesDirectoryExist path+      if dirExists+        then do+          subPaths <- listDirectory path+          let rest = asum (fmap (listDirectoryRecursively . (path </>)) subPaths)+          pure (Just (path, rest))+        else pure (Just (path, empty))+    else pure empty++searchDirectory :: MonadIO m => (FilePath -> m Bool) -> FilePath -> ListT m FilePath+searchDirectory pcate path = filterListT pcate (listDirectoryRecursively path)
+ src/Heart/Core/ListT.hs view
@@ -0,0 +1,35 @@+module Heart.Core.ListT where++import Heart.Core.Prelude+import qualified ListT++effectListT :: Monad m => m (ListT m a) -> ListT m a+effectListT = ListT . (>>= ListT.uncons)++filterListT :: MonadIO m => (a -> m Bool) -> ListT m a -> ListT m a+filterListT pcate values = effectListT $ do+  mu <- ListT.uncons values+  case mu of+    Just (first, rest) -> do+      ok <- pcate first+      let filteredRest = filterListT pcate rest+      if ok+        then pure (ListT.cons first filteredRest)+        else pure filteredRest+    Nothing -> pure empty++seqListT :: Monad m => ListT m a -> m (Seq a)+seqListT = go Empty where+  go ss vs = do+    m <- ListT.uncons vs+    case m of+      Just (s, vs') -> go (ss :|> s) vs'+      Nothing -> pure ss++yieldListT :: Monad m => m (Maybe x) -> ListT m x+yieldListT act = go where+  go = ListT $ do+    mx <- act+    case mx of+      Nothing -> pure Nothing+      Just x -> pure (Just (x, go))
+ src/Heart/Core/MultiMap.hs view
@@ -0,0 +1,42 @@+module Heart.Core.MultiMap+  ( OrdMultiMap+  , insertOrdMultiMap+  , invertOrdMapWith+  , invertOrdMap+  , HashMultiMap+  , insertHashMultiMap+  , invertHashMapWith+  , invertHashMap+  ) where++import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import Heart.Core.Prelude++type OrdMultiMap k v = Map k (Set v)++insertOrdMultiMap :: (Ord k, Ord v) => k -> v -> OrdMultiMap k v -> OrdMultiMap k v+insertOrdMultiMap k v m =+  M.insert k (maybe (S.singleton v) (S.insert v) (M.lookup k m)) m++invertOrdMapWith :: (Monad m, Ord k, Ord u) => (v -> m u) -> Map k v -> m (OrdMultiMap u k)+invertOrdMapWith f m = foldM go M.empty (M.toList m) where+  go acc (k, v) = fmap (\u -> insertOrdMultiMap u k acc) (f v)++invertOrdMap :: (Ord k, Ord v) => Map k v -> OrdMultiMap v k+invertOrdMap = runIdentity . invertOrdMapWith Identity++type HashMultiMap k v = HashMap k (HashSet v)++insertHashMultiMap :: (Eq k, Hashable k, Eq v, Hashable v) => k -> v -> HashMultiMap k v -> HashMultiMap k v+insertHashMultiMap k v m =+  HM.insert k (maybe (HS.singleton v) (HS.insert v) (HM.lookup k m)) m++invertHashMapWith :: (Monad m, Eq k, Hashable k, Eq u, Hashable u) => (v -> m u) -> HashMap k v -> m (HashMultiMap u k)+invertHashMapWith f m = foldM go HM.empty (HM.toList m) where+  go acc (k, v) = fmap (\u -> insertHashMultiMap u k acc) (f v)++invertHashMap :: (Eq k, Hashable k, Eq v, Hashable v) => HashMap k v -> HashMultiMap v k+invertHashMap = runIdentity . invertHashMapWith Identity
+ src/Heart/Core/Prelude.hs view
@@ -0,0 +1,94 @@+module Heart.Core.Prelude+  ( module Prelude+  , Alternative (..)+  , Coercible+  , FromJSON (..)+  , FromJSONKey+  , Generic+  , Getter+  , HasCallStack+  , Exception (..)+  , Hashable (..)+  , HashMap+  , HashSet+  , Identity (..)+  , Int64+  , Iso'+  , IsString+  , Lens'+  , ListT (..)+  , Map+  , MonadFail (..)+  , MonadIO (..)+  , MonadReader (..)+  , MonadThrow (..)+  , MonadTrans (..)+  , MonadUnliftIO (..)+  , Newtype+  , Prism'+  , Proxy (..)+  , Rep+  , Seq (..)+  , Set+  , Setter'+  , Text+  , ToJSON (..)+  , ToJSONKey+  , Typeable+  , UnliftIO (..)+  , Void+  , ap+  , asum+  , coerce+  , coerced+  , foldl'+  , foldM+  , for+  , for_+  , iso+  , makeLenses+  , makePrisms+  , over+  , review+  , set+  , simple+  , toList+  , unless+  , view+  , when+  ) where++import Control.Applicative (Alternative (..))+import Control.Exception (Exception (..))+import Control.Lens (Getter, Iso', Lens', Prism', Setter', coerced, iso, over, review, set, simple, view)+import Control.Lens.TH (makeLenses, makePrisms)+import Control.Monad (ap, foldM, unless, when)+import Control.Monad.Catch (MonadThrow (..))+import Control.Monad.Fail (MonadFail (..))+import Control.Monad.Identity (Identity (..))+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.IO.Unlift (MonadUnliftIO (..), UnliftIO (..))+import Control.Monad.Reader (MonadReader (..))+import Control.Monad.Trans (MonadTrans (..))+import Control.Newtype.Generics (Newtype)+import Data.Aeson (FromJSON (..), FromJSONKey, ToJSON (..), ToJSONKey)+import Data.Coerce (Coercible, coerce)+import Data.Foldable (asum, for_, toList)+import Data.Hashable (Hashable (..))+import Data.HashMap.Strict (HashMap)+import Data.HashSet (HashSet)+import Data.Int (Int64)+import Data.List (foldl')+import Data.Map.Strict (Map)+import Data.Proxy (Proxy (..))+import Data.Sequence (Seq (..))+import Data.Set (Set)+import Data.String (IsString)+import Data.Text (Text)+import Data.Traversable (for)+import Data.Typeable (Typeable)+import Data.Void (Void)+import GHC.Generics (Generic, Rep)+import GHC.Stack (HasCallStack)+import ListT (ListT (..))+import Prelude hiding (fail, log)
+ src/Heart/Core/RIO.hs view
@@ -0,0 +1,24 @@+module Heart.Core.RIO+  ( RIO (..)+  , withRIO+  , runRIO+  ) where++import Control.Monad.IO.Unlift (withUnliftIO)+import Control.Monad.Reader (ReaderT (..))+import Heart.Core.Prelude++newtype RIO env a = RIO { unRIO :: ReaderT env IO a }+  deriving (Functor, Applicative, Monad, MonadReader env, MonadIO, MonadThrow, MonadFail)++instance MonadUnliftIO (RIO env) where+  askUnliftIO = RIO (ReaderT (\r -> withUnliftIO (\u -> return (UnliftIO (unliftIO u . flip runReaderT r . unRIO)))))++withRIO :: (env -> env') -> RIO env' a -> RIO env a+withRIO f m = do+  env <- ask+  let env' = f env+  runRIO env' m++runRIO :: MonadIO m => env -> RIO env a -> m a+runRIO r m = liftIO (runReaderT (unRIO m) r)
+ src/Heart/Core/SuperPrelude.hs view
@@ -0,0 +1,21 @@+module Heart.Core.SuperPrelude+  ( module Heart.Core.Aeson+  , module Heart.Core.Alloc+  , module Heart.Core.Builder+  , module Heart.Core.Directory+  , module Heart.Core.ListT+  , module Heart.Core.MultiMap+  , module Heart.Core.Prelude+  , module Heart.Core.RIO+  , module Heart.Core.UnionFind+  ) where++import Heart.Core.Aeson+import Heart.Core.Alloc+import Heart.Core.Builder+import Heart.Core.Directory+import Heart.Core.ListT+import Heart.Core.MultiMap+import Heart.Core.Prelude+import Heart.Core.RIO+import Heart.Core.UnionFind
+ src/Heart/Core/UnionFind.hs view
@@ -0,0 +1,91 @@+module Heart.Core.UnionFind+  ( PartitionAlloc+  , Term+  , newPartitionAlloc+  , newTerm+  , findTermRank+  , findTerm+  , unionTerm+  , decideEqTerm+  , hashSplitClasses+  , ordSplitClasses+  ) where++import Data.Function (on)+import Heart.Core.Alloc+import Heart.Core.MultiMap+import Heart.Core.Prelude+import UnliftIO.IORef (IORef, newIORef, readIORef, writeIORef)++newtype Partition = Partition { unPartition :: Int } deriving (Eq, Ord, Enum, Show, Hashable)++-- From Content/Term encoding simplified from+--- https://github.com/ekmett/guanxi/blob/master/src/Equality.hs+data Content+  = Root !Int+  | Child !Term++data Term = Term+  { _termPartition :: !Partition+  , _termParent :: !(IORef Content)+  }++instance Eq Term where+  (==) = (==) `on` _termPartition++instance Ord Term where+  (<=) = (<=) `on` _termPartition++instance Hashable Term where+  hash = hash . _termPartition+  hashWithSalt d = hashWithSalt d . _termPartition++newtype PartitionAlloc = PartitionAlloc { unPartitionAlloc :: Alloc Partition }++newPartitionAlloc :: MonadIO m => m PartitionAlloc+newPartitionAlloc = fmap PartitionAlloc newEnumAlloc++newTerm :: MonadIO m => PartitionAlloc -> m Term+newTerm (PartitionAlloc alloc) = do+  p <- incAlloc alloc+  r <- newIORef (Root 0)+  pure (Term p r)++findTermRank :: MonadIO m => Term -> m (Int, Term)+findTermRank t@(Term _ r) = do+  y <- readIORef r+  case y of+    Root i -> pure (i, t)+    Child s -> do+      z@(_, q) <- findTermRank s+      writeIORef r (Child q)+      pure z++findTerm :: MonadIO m => Term -> m Term+findTerm = fmap snd . findTermRank++unionTerm :: MonadIO m => Term -> Term -> m ()+unionTerm m n = do+  (mrank, mroot) <- findTermRank m+  (nrank, nroot) <- findTermRank n+  let mref = _termParent mroot+      nref = _termParent nroot+  case compare mrank nrank of+    LT -> do+      writeIORef mref (Child nroot)+      writeIORef nref (Root nrank)+    GT -> do+      writeIORef nref (Child mroot)+      writeIORef mref (Root mrank)+    EQ -> do+      writeIORef mref (Child nroot)+      writeIORef nref (Root (nrank + 1))++decideEqTerm :: MonadIO m => Term -> Term -> m Bool+decideEqTerm m n = (==) <$> findTerm m <*> findTerm n++hashSplitClasses :: (Eq k, Hashable k, MonadIO m) => HashMap k Term -> m (HashMultiMap Term k)+hashSplitClasses = invertHashMapWith findTerm++ordSplitClasses :: (Ord k, MonadIO m) => Map k Term -> m (OrdMultiMap Term k)+ordSplitClasses = invertOrdMapWith findTerm