packages feed

polysemy-db (empty) → 0.0.1.0

raw patch · 24 files changed

+928/−0 lines, 24 filesdep +basedep +exondep +polysemysetup-changed

Dependencies added: base, exon, polysemy, polysemy-plugin, prelate, random, sqel, uuid

Files

+ LICENSE view
@@ -0,0 +1,34 @@+Copyright (c) 2023 Torsten Schmits++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the+following conditions are met:++  1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following+  disclaimer.+  2. 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.++Subject to the terms and conditions of this license, each copyright holder and contributor hereby grants to those+receiving rights under this license a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except+for failure to satisfy the conditions of this license) patent license to make, have made, use, offer to sell, sell,+import, and otherwise transfer this software, where such license applies only to those patent claims, already acquired+or hereafter acquired, licensable by such copyright holder or contributor that are necessarily infringed by:++  (a) their Contribution(s) (the licensed copyrights of copyright holders and non-copyrightable additions of+  contributors, in source or binary form) alone; or+  (b) combination of their Contribution(s) with the work of authorship to which such Contribution(s) was added by such+  copyright holder or contributor, if, at the time the Contribution is added, such addition causes such combination to+  be necessarily infringed. The patent license shall not apply to any other combinations which include the Contribution.++Except as expressly stated above, no rights or licenses from any copyright holder or contributor is granted under this+license, whether expressly, by implication, estoppel or otherwise.++DISCLAIMER++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 HOLDERS 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lib/Polysemy/Db.hs view
@@ -0,0 +1,132 @@+module Polysemy.Db (+  -- $intro++  -- * Effects+  module Polysemy.Db.Effect.Store,+  module Polysemy.Db.Effect.Query,+  module Polysemy.Db.Effect.Random,+  module Polysemy.Db.Effect.Id,++  -- * Interpreters+  interpretStoreConc,+  interpretStoreLocal,+  interpretStoreAtomicState,+  interpretStoreState,+  interpretStoreNull,+  PureStore (PureStore),+  pureStore,++  interpretQueryConc,+  interpretQueryConst,+  interpretQueryAtomicState,+  interpretQueryStoreConc,+  interpretQueryStoreAny,++  interpretRandom,+  interpretRandomAtomic,+  interpretRandomState,+  interpretRandomAtomicState,++  interpretIdUuid,+  interpretIdUuidIO,+  interpretIdAtomicState,+  interpretIdNum,+  interpretIdNumFrom,+  interpretIdNumLocal,+  interpretIdList,+  interpretIdConst,+  interpretIdUuidZero,++  interpretAtomicStateStore,+  interpretAtomicStateStoreAs,+  interpretAtomicStateStoreScoped,+  interpretAtomicStateStoreScopedAs,+  interpretAtomicStatesStore,++  interpretReaderStore,+  interpretReaderStoreAs,++  -- * Config+  module Polysemy.Db.Data.DbConfig,+  module Polysemy.Db.Data.DbHost,+  module Polysemy.Db.Data.DbPort,+  module Polysemy.Db.Data.DbName,+  module Polysemy.Db.Data.DbUser,+  module Polysemy.Db.Data.DbPassword,++  -- * Errors+  module Polysemy.Db.Data.DbError,+  module Polysemy.Db.Data.InitDbError,+  module Polysemy.Db.Data.DbConnectionError,+) where++import Polysemy.Db.Data.DbConfig (DbConfig (DbConfig))+import Polysemy.Db.Data.DbConnectionError (DbConnectionError)+import Polysemy.Db.Data.DbError (DbError)+import Polysemy.Db.Data.DbHost (DbHost (..))+import Polysemy.Db.Data.DbName (DbName (..))+import Polysemy.Db.Data.DbPassword (DbPassword (..))+import Polysemy.Db.Data.DbPort (DbPort (..))+import Polysemy.Db.Data.DbUser (DbUser (..))+import Polysemy.Db.Data.InitDbError (InitDbError (..))+import Polysemy.Db.Effect.Id (Id, newId)+import Polysemy.Db.Effect.Query (Query, query)+import Polysemy.Db.Effect.Random (Random, random, randomR)+import Polysemy.Db.Effect.Store (+  QStore,+  Store,+  alter,+  delete,+  deleteAll,+  elem,+  fetch,+  fetchAll,+  fetchPayload,+  insert,+  upsert,+  )+import Polysemy.Db.Interpreter.AtomicState (+  interpretAtomicStateStore,+  interpretAtomicStateStoreAs,+  interpretAtomicStateStoreScoped,+  interpretAtomicStateStoreScopedAs,+  interpretAtomicStatesStore,+  )+import Polysemy.Db.Interpreter.Id (+  interpretIdAtomicState,+  interpretIdConst,+  interpretIdList,+  interpretIdNum,+  interpretIdNumFrom,+  interpretIdNumLocal,+  interpretIdUuid,+  interpretIdUuidIO,+  interpretIdUuidZero,+  )+import Polysemy.Db.Interpreter.Query (+  interpretQueryAtomicState,+  interpretQueryConc,+  interpretQueryConst,+  interpretQueryStoreAny,+  interpretQueryStoreConc,+  )+import Polysemy.Db.Interpreter.Random (+  interpretRandom,+  interpretRandomAtomic,+  interpretRandomAtomicState,+  interpretRandomState,+  )+import Polysemy.Db.Interpreter.Reader (interpretReaderStore, interpretReaderStoreAs)+import Polysemy.Db.Interpreter.Store (+  PureStore (PureStore),+  interpretStoreAtomicState,+  interpretStoreConc,+  interpretStoreLocal,+  interpretStoreNull,+  interpretStoreState,+  pureStore,+  )++-- $intro+-- The 'Polysemy' effects 'Store' and 'Query' provide a high-level abstraction of database operations for+-- CRUD and arbitrary queries.
+ lib/Polysemy/Db/Data/DbConfig.hs view
@@ -0,0 +1,21 @@+module Polysemy.Db.Data.DbConfig where++import Polysemy.Db.Data.DbHost (DbHost)+import Polysemy.Db.Data.DbName (DbName)+import Polysemy.Db.Data.DbPassword (DbPassword)+import Polysemy.Db.Data.DbPort (DbPort)+import Polysemy.Db.Data.DbUser (DbUser)++-- |Connection information for a database.+-- >>> DbConfig "localhost" 5432 "users" "post" "gres"+data DbConfig =+  DbConfig {+    host :: DbHost,+    port :: DbPort,+    name :: DbName,+    user :: DbUser,+    password :: DbPassword+  }+  deriving stock (Eq, Show, Generic)++json ''DbConfig
+ lib/Polysemy/Db/Data/DbConnectionError.hs view
@@ -0,0 +1,11 @@+module Polysemy.Db.Data.DbConnectionError where++data DbConnectionError =+  Acquire Text+  |+  Release Text+  |+  Query Text+  |+  Limit Text+  deriving stock (Eq, Show, Generic)
+ lib/Polysemy/Db/Data/DbError.hs view
@@ -0,0 +1,17 @@+module Polysemy.Db.Data.DbError where++import Polysemy.Db.Data.DbConnectionError (DbConnectionError)++data DbError =+  Connection DbConnectionError+  |+  Query Text+  |+  Table Text+  |+  Unexpected Text+  deriving stock (Eq, Show)++instance IsString DbError where+  fromString =+    Table . fromString
+ lib/Polysemy/Db/Data/DbHost.hs view
@@ -0,0 +1,11 @@+module Polysemy.Db.Data.DbHost where++newtype DbHost =+  DbHost { unDbHost :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString, Ord)++instance Default DbHost where+  def = "localhost"++json ''DbHost
+ lib/Polysemy/Db/Data/DbName.hs view
@@ -0,0 +1,8 @@+module Polysemy.Db.Data.DbName where++newtype DbName =+  DbName { unDbName :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString, Ord)++json ''DbName
+ lib/Polysemy/Db/Data/DbPassword.hs view
@@ -0,0 +1,8 @@+module Polysemy.Db.Data.DbPassword where++newtype DbPassword =+  DbPassword { unDbPassword :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString, Ord)++json ''DbPassword
+ lib/Polysemy/Db/Data/DbPort.hs view
@@ -0,0 +1,11 @@+module Polysemy.Db.Data.DbPort where++newtype DbPort =+  DbPort { unDbPort :: Int }+  deriving stock (Eq, Show, Generic)+  deriving newtype (Read, Num, Real, Enum, Integral, Ord)++instance Default DbPort where+  def = 5432++json ''DbPort
+ lib/Polysemy/Db/Data/DbUser.hs view
@@ -0,0 +1,8 @@+module Polysemy.Db.Data.DbUser where++newtype DbUser =+  DbUser { unDbUser :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString, Ord)++json ''DbUser
+ lib/Polysemy/Db/Data/InitDbError.hs view
@@ -0,0 +1,6 @@+module Polysemy.Db.Data.InitDbError where++newtype InitDbError =+  InitDbError { unInitDbError :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString, Ord)
+ lib/Polysemy/Db/Effect/Id.hs view
@@ -0,0 +1,6 @@+module Polysemy.Db.Effect.Id where++data Id i :: Effect where+  NewId :: Id i m i++makeSem ''Id
+ lib/Polysemy/Db/Effect/Query.hs view
@@ -0,0 +1,6 @@+module Polysemy.Db.Effect.Query where++data Query q o :: Effect where+  Query :: q -> Query q o m o++makeSem ''Query
+ lib/Polysemy/Db/Effect/Random.hs view
@@ -0,0 +1,7 @@+module Polysemy.Db.Effect.Random where++data Random a :: Effect where+  Random :: Random a m a+  RandomR :: (a, a) -> Random a m a++makeSem ''Random
+ lib/Polysemy/Db/Effect/Store.hs view
@@ -0,0 +1,54 @@+module Polysemy.Db.Effect.Store where++import Data.UUID (UUID)+import qualified Sqel.Data.Uid as Uid+import Sqel.Data.Uid (Uid)++data QStore f q d :: Effect where+  Insert :: d -> QStore f i d m ()+  Upsert :: d -> QStore f i d m ()+  Delete :: i -> QStore f i d m (f d)+  DeleteAll :: QStore f i d m [d]+  Fetch :: i -> QStore f i d m (f d)+  FetchAll :: QStore f i d m [d]++makeSem ''QStore++type Store i d = QStore Maybe i (Uid i d)++type UuidStore d =+  Store UUID d++type family StoreEffects i e ds :: EffectRow where+  StoreEffects _ _ '[] = '[]+  StoreEffects i e (d : ds) = (Store i d !! e : StoreEffects i e ds)++type family Stores i e ds r :: Constraint where+  Stores _ _ '[] _ = ()+  Stores i e (d : ds) r = (Member (Store i d !! e) r, Stores i e ds r)++elem ::+  ∀ i d r .+  Member (Store i d) r =>+  i ->+  Sem r Bool+elem id' =+  isJust <$> fetch id'++fetchPayload ::+  ∀ i d r .+  Member (Store i d) r =>+  i ->+  Sem r (Maybe d)+fetchPayload id' =+  fmap Uid.payload <$> fetch id'++alter ::+  ∀ i d r .+  Member (Store i d) r =>+  i ->+  (d -> d) ->+  Sem r ()+alter id' f = do+  cur <- fetch id'+  traverse_ (upsert . (#payload %~ f)) cur
+ lib/Polysemy/Db/Ext.hs view
@@ -0,0 +1,12 @@+module Polysemy.Db.Ext (+  module Polysemy.Db.Effect.Store,+  module Polysemy.Db.Effect.Query,+  module Polysemy.Db.Effect.Random,+  module Polysemy.Db.Effect.Id,+) where+++import Polysemy.Db.Effect.Id (Id (..))+import Polysemy.Db.Effect.Query (Query (..))+import Polysemy.Db.Effect.Random (Random (..))+import Polysemy.Db.Effect.Store (QStore (..))
+ lib/Polysemy/Db/Interpreter/AtomicState.hs view
@@ -0,0 +1,97 @@+module Polysemy.Db.Interpreter.AtomicState where++import Conc (Lock, lock)+import Polysemy.AtomicState (AtomicState (AtomicGet, AtomicState))++import qualified Polysemy.Db.Effect.Store as Store+import Polysemy.Db.Effect.Store (QStore)++insertState ::+  ∀ d err r .+  Members [QStore Maybe () d !! err, Stop err] r =>+  Sem r d ->+  Sem r d+insertState initial = do+  restop do+    raise initial >>= tap \ d ->+      Store.deleteAll *> Store.insert d++readState ::+  ∀ d err r .+  Members [QStore Maybe () d !! err, Stop err] r =>+  Sem r d ->+  Sem r d+readState initial = do+  stored <- restop (Store.fetch ())+  maybe (insertState @d @err initial) pure stored++handleAtomicStateStore ::+  ∀ tag d err r0 r a .+  Members [QStore Maybe () d !! err, Lock @@ tag, Stop err] r =>+  Sem r d ->+  AtomicState d (Sem r0) a ->+  Sem r a+handleAtomicStateStore initial = \case+  AtomicState f ->+    tag @tag @Lock $ lock do+      (newState, a) <- f <$> raise (readState @d @err initial)+      a <$ insertState @d @err (pure newState)+  AtomicGet ->+    readState @d @err initial++-- |Interpret 'AtomicState' as a singleton table.+--+-- Given an action that produces an initial value, every action reads the value from the database and writes it+-- back.+interpretAtomicStateStore ::+  ∀ tag d err r .+  Members [QStore Maybe () d !! err, Lock @@ tag] r =>+  Sem (Stop err : r) d ->+  InterpreterFor (AtomicState d !! err) r+interpretAtomicStateStore initial =+  interpretResumable (handleAtomicStateStore initial)++-- |Interpret 'AtomicState' as a singleton table.+--+-- Given an initial value, every action reads the value from the database and writes it back.+interpretAtomicStateStoreAs ::+  ∀ tag d err r .+  Members [QStore Maybe () d !! err, Lock @@ tag] r =>+  d ->+  InterpreterFor (AtomicState d !! err) r+interpretAtomicStateStoreAs value =+  interpretAtomicStateStore (pure value)++atomicStateScope ::+  Member (Scoped param (QStore Maybe () d !! err) !! err) r =>+  param ->+  (() -> Sem (QStore Maybe () d !! err : Stop err : r) a) ->+  Sem (Stop err : r) a+atomicStateScope p use =+  restop (scoped p (raiseUnder (use ())))++interpretAtomicStateStoreScoped ::+  ∀ tag param d err r .+  Members [Scoped param (QStore Maybe () d !! err) !! err, Lock @@ tag] r =>+  Sem (Stop err : r) d ->+  InterpreterFor (Scoped param (AtomicState d !! err) !! err) r+interpretAtomicStateStoreScoped initial =+  interpretScopedRWith @'[QStore Maybe () d !! err] atomicStateScope \ () ->+    handleAtomicStateStore (insertAt @1 initial)++interpretAtomicStateStoreScopedAs ::+  ∀ tag param d err r .+  Members [Scoped param (QStore Maybe () d !! err) !! err, Lock @@ tag] r =>+  d ->+  InterpreterFor (Scoped param (AtomicState d !! err) !! err) r+interpretAtomicStateStoreScopedAs value =+  interpretAtomicStateStoreScoped (pure value)++interpretAtomicStatesStore ::+  ∀ tag param d err r .+  Members [QStore Maybe () d !! err, Scoped param (QStore Maybe () d !! err) !! err, Lock @@ tag] r =>+  Sem (Stop err : r) d ->+  InterpretersFor [AtomicState d !! err, Scoped param (AtomicState d !! err) !! err] r+interpretAtomicStatesStore initial =+  interpretAtomicStateStoreScoped initial .+  interpretAtomicStateStore (raiseUnder initial)
+ lib/Polysemy/Db/Interpreter/Id.hs view
@@ -0,0 +1,83 @@+module Polysemy.Db.Interpreter.Id where++import Conc (interpretAtomic)+import qualified Data.UUID as UUID+import Data.UUID (UUID)++import Polysemy.Db.Effect.Id (Id (NewId))+import Polysemy.Db.Effect.Random (Random, random)+import Polysemy.Db.Interpreter.Random (interpretRandom)++interpretIdUuid ::+  Member (Random UUID) r =>+  InterpreterFor (Id UUID) r+interpretIdUuid =+  interpret \ NewId -> random++interpretIdUuidIO ::+  Member (Embed IO) r =>+  InterpreterFor (Id UUID) r+interpretIdUuidIO =+  interpretRandom . interpretIdUuid . raiseUnder++interpretIdUuidZero ::+  InterpreterFor (Id UUID) r+interpretIdUuidZero =+  interpret \ NewId -> pure UUID.nil++interpretIdAtomicState ::+  ∀ i r .+  Members [AtomicState [i], Error Text] r =>+  InterpreterFor (Id i) r+interpretIdAtomicState =+  interpret \case+    NewId -> do+      i <- atomicState' \case+        u : rest -> (rest, Just u)+        [] -> ([], Nothing)+      fromMaybeA (throw "Id pool exhausted") i++interpretIdList ::+  ∀ i r .+  Members [Error Text, Embed IO] r =>+  [i] ->+  InterpreterFor (Id i) r+interpretIdList pool =+  interpretAtomic pool .+  interpretIdAtomicState .+  raiseUnder++interpretIdNumFrom ::+  ∀ i r .+  Member (Embed IO) r =>+  Num i =>+  i ->+  InterpreterFor (Id i) r+interpretIdNumFrom start =+  interpretAtomic @i start .+  reinterpret \ NewId ->+    atomicState' \ i -> ((i + 1), i)++interpretIdNum ::+  ∀ i r .+  Member (Embed IO) r =>+  Num i =>+  InterpreterFor (Id i) r+interpretIdNum =+  interpretIdNumFrom 1++interpretIdNumLocal ::+  ∀ i r .+  Num i =>+  InterpreterFor (Id i) r+interpretIdNumLocal =+  evalState @i 1 .+  reinterpret \ NewId ->+    get >>= \ i -> i <$ put (i + 1)++interpretIdConst ::+  ∀ i r .+  i ->+  InterpreterFor (Id i) r+interpretIdConst i =+  interpret \ NewId -> pure i
+ lib/Polysemy/Db/Interpreter/Query.hs view
@@ -0,0 +1,81 @@+module Polysemy.Db.Interpreter.Query where++import Conc (interpretAtomic)+import qualified Data.Map.Strict as Map+import Lens.Micro.Extras (view)+import qualified Sqel.Data.Uid as Uid+import Sqel.Data.Uid (Uid (Uid))++import qualified Polysemy.Db.Data.DbError as DbError+import Polysemy.Db.Data.DbError (DbError)+import Polysemy.Db.Effect.Query (Query (..))+import qualified Polysemy.Db.Effect.Store as Store+import Polysemy.Db.Effect.Store (Store)+import Polysemy.Db.Interpreter.Store (PureStore (PureStore), interpretStoreConc)++class QueryCheckResult f where+  queryCheckResult :: [a] -> Either DbError (f a)++instance QueryCheckResult Maybe where+  queryCheckResult = \case+    [] -> Right Nothing+    [a] -> Right (Just a)+    _ -> Left (DbError.Query "Multiple matches for single-result query")++instance QueryCheckResult [] where+  queryCheckResult = Right++interpretQueryConst ::+  Ord q =>+  QueryCheckResult f =>+  Map q [d] ->+  InterpreterFor (Query q (f d) !! DbError) r+interpretQueryConst store =+  interpretResumable \case+    Query params ->+      stopEither (queryCheckResult (fromMaybe [] (Map.lookup params store)))++interpretQueryAtomicState ::+  ∀ i a d q f r .+  Member (AtomicState (PureStore i a)) r =>+  QueryCheckResult f =>+  (q -> Uid i a -> Maybe d) ->+  InterpreterFor (Query q (f d) !! DbError) r+interpretQueryAtomicState match =+  interpretResumable \case+    Query q ->+      stopEither =<< atomicGets (queryCheckResult . mapMaybe (match q) . Map.elems . view #records)++interpretQueryConc ::+  Ord i =>+  QueryCheckResult f =>+  Member (Embed IO) r =>+  (q -> Uid i a -> Maybe d) ->+  [Uid i a] ->+  InterpreterFor (Query q (f d) !! DbError) r+interpretQueryConc match initial =+  interpretAtomic (PureStore (Map.fromList (initial <&> \ a@(Uid i _) -> (i, a)))) .+  interpretQueryAtomicState match .+  raiseUnder++interpretQueryStoreConc ::+  Ord i =>+  Show i =>+  QueryCheckResult f =>+  Member (Embed IO) r =>+  (q -> Uid i a -> Maybe d) ->+  [Uid i a] ->+  InterpretersFor [Query q (f d) !! DbError, Store i a !! DbError, AtomicState (PureStore i a)] r+interpretQueryStoreConc match initial =+  interpretStoreConc (PureStore (Map.fromList (initial <&> \ a@(Uid i _) -> (i, a)))) .+  interpretQueryAtomicState match++interpretQueryStoreAny ::+  ∀ q d i e r .+  Member (Store i d !! e) r =>+  (q -> d -> Bool) ->+  InterpreterFor (Query q Bool !! e) r+interpretQueryStoreAny match =+  interpretResumable \case+    Query q ->+      any (match q . Uid.payload) <$> restop Store.fetchAll
+ lib/Polysemy/Db/Interpreter/Random.hs view
@@ -0,0 +1,47 @@+module Polysemy.Db.Interpreter.Random where++import Conc (interpretAtomic)+import qualified System.Random as R++import Polysemy.Db.Effect.Random (Random (Random, RandomR))++interpretRandomAtomicState ::+  ∀ a q r .+  R.Random a =>+  R.RandomGen q =>+  Member (AtomicState q) r =>+  InterpreterFor (Random a) r+interpretRandomAtomicState =+  interpret \case+    Random ->+      atomicState' (swap . R.random)+    RandomR r ->+      atomicState' (swap . R.randomR r)++interpretRandomAtomic ::+  ∀ a q r .+  R.Random a =>+  R.RandomGen q =>+  Member (Embed IO) r =>+  q ->+  InterpreterFor (Random a) r+interpretRandomAtomic q =+  interpretAtomic q . interpretRandomAtomicState . raiseUnder++interpretRandomState ::+  ∀ a q r .+  R.Random a =>+  R.RandomGen q =>+  q ->+  InterpreterFor (Random a) r+interpretRandomState q =+  evalState q . atomicStateToState . interpretRandomAtomicState . raiseUnder2++interpretRandom ::+  ∀ a r .+  R.Random a =>+  Member (Embed IO) r =>+  InterpreterFor (Random a) r+interpretRandom sem = do+  q <- embed R.newStdGen+  interpretRandomAtomic q sem
+ lib/Polysemy/Db/Interpreter/Reader.hs view
@@ -0,0 +1,48 @@+module Polysemy.Db.Interpreter.Reader where++import Polysemy.Internal.Tactics (liftT)+import Polysemy.Reader (Reader (Ask, Local))++import qualified Polysemy.Db.Effect.Store as Store+import Polysemy.Db.Effect.Store (QStore)++insertValue ::+  ∀ d e r .+  Members [QStore Maybe () d !! e, Stop e] r =>+  Sem r d ->+  Sem r d+insertValue initial =+  initial >>= tap \ d ->+    restop (Store.deleteAll *> Store.insert d)++readValue ::+  ∀ d e r .+  Members [QStore Maybe () d !! e, Stop e] r =>+  Sem r d ->+  Sem r d+readValue initial = do+  stored <- restop (Store.fetch ())+  maybe (insertValue @d @e initial) pure stored++-- |Interpret 'Reader' as a singleton table.+--+-- Given an initial value, every action reads the value from the database, potentially writing it on first access.+interpretReaderStore ::+  ∀ d e r .+  Member (QStore Maybe () d !! e) r =>+  Sem r d ->+  InterpreterFor (Reader d !! e) r+interpretReaderStore initial =+  interpretResumableH \case+    Ask -> do+      liftT (readValue @d @e (raise initial))+    Local f ma ->+      raise . interpretReaderStore (f <$> raise initial) =<< runT ma++interpretReaderStoreAs ::+  ∀ d e r .+  Member (QStore Maybe () d !! e) r =>+  d ->+  InterpreterFor (Reader d !! e) r+interpretReaderStoreAs initial =+  interpretReaderStore (pure initial)
+ lib/Polysemy/Db/Interpreter/Store.hs view
@@ -0,0 +1,97 @@+module Polysemy.Db.Interpreter.Store where++import Conc (interpretAtomic)+import qualified Data.Map.Strict as Map+import Exon (exon)+import Sqel.Data.Uid (Uid (Uid))++import qualified Polysemy.Db.Data.DbError as DbError+import Polysemy.Db.Data.DbError (DbError)+import Polysemy.Db.Effect.Store (QStore (..), Store)++newtype PureStore i a =+  PureStore { records :: Map i (Uid i a) }+  deriving stock (Eq, Show, Generic)+  deriving newtype (Default, Semigroup, Monoid)++pureStore ::+  Ord i =>+  [Uid i a] ->+  PureStore i a+pureStore =+  PureStore . Map.fromList . fmap \ a@(Uid i _) -> (i, a)++interpretStoreAtomicState ::+  ∀ i a r .+  Ord i =>+  Show i =>+  Member (AtomicState (PureStore i a)) r =>+  InterpreterFor (Store i a !! DbError) r+interpretStoreAtomicState =+  interpretResumable \case+    Insert a@(Uid i _) ->+      stopEither =<< atomicState' \ (PureStore records) ->+        let+          update = \case+            Just x -> (Left (DbError.Query [exon|'#{show i}' is already in the store|]), Just x)+            Nothing -> (Right (), Just a)+        in first PureStore (swap (Map.alterF update i records))+    Upsert a@(Uid i _) ->+      atomicModify' (#records %~ Map.insert i a)+    Delete i ->+      atomicState' \ (PureStore as) -> (PureStore (Map.delete i as), Map.lookup i as)+    DeleteAll ->+      atomicState' \ (PureStore as) -> (mempty, Map.elems as)+    Fetch i ->+      atomicGets \ (PureStore as) -> Map.lookup i as+    FetchAll ->+      atomicGets \ (PureStore as) -> Map.elems as++interpretStoreConc ::+  ∀ i a r .+  Ord i =>+  Show i =>+  Member (Embed IO) r =>+  PureStore i a ->+  InterpretersFor [Store i a !! DbError, AtomicState (PureStore i a)] r+interpretStoreConc initial =+  interpretAtomic initial .+  interpretStoreAtomicState++interpretStoreState ::+  ∀ i a r .+  Ord i =>+  Show i =>+  Member (State (PureStore i a)) r =>+  InterpreterFor (Store i a !! DbError) r+interpretStoreState =+  atomicStateToState .+  interpretStoreAtomicState .+  raiseUnder++interpretStoreLocal ::+  ∀ i a r .+  Ord i =>+  Show i =>+  PureStore i a ->+  InterpretersFor [Store i a !! DbError, State (PureStore i a)] r+interpretStoreLocal initial =+  evalState initial .+  interpretStoreState++interpretStoreNull ::+  InterpreterFor (Store i a !! e) r+interpretStoreNull =+  interpretResumable \case+    Insert _ ->+      unit+    Upsert _ ->+      unit+    Delete _ ->+      pure Nothing+    DeleteAll ->+      pure []+    Fetch _ ->+      pure Nothing+    FetchAll ->+      pure []
+ polysemy-db.cabal view
@@ -0,0 +1,121 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.35.0.+--+-- see: https://github.com/sol/hpack++name:           polysemy-db+version:        0.0.1.0+synopsis:       Polysemy effects for databases+description:    See https://hackage.haskell.org/package/polysemy-db/docs/Polysemy-Db.html+category:       Database+author:         Torsten Schmits+maintainer:     hackage@tryp.io+copyright:      2023 Torsten Schmits+license:        BSD-2-Clause-Patent+license-file:   LICENSE+build-type:     Simple++library+  exposed-modules:+      Polysemy.Db+      Polysemy.Db.Data.DbConfig+      Polysemy.Db.Data.DbConnectionError+      Polysemy.Db.Data.DbError+      Polysemy.Db.Data.DbHost+      Polysemy.Db.Data.DbName+      Polysemy.Db.Data.DbPassword+      Polysemy.Db.Data.DbPort+      Polysemy.Db.Data.DbUser+      Polysemy.Db.Data.InitDbError+      Polysemy.Db.Effect.Id+      Polysemy.Db.Effect.Query+      Polysemy.Db.Effect.Random+      Polysemy.Db.Effect.Store+      Polysemy.Db.Ext+      Polysemy.Db.Interpreter.AtomicState+      Polysemy.Db.Interpreter.Id+      Polysemy.Db.Interpreter.Query+      Polysemy.Db.Interpreter.Random+      Polysemy.Db.Interpreter.Reader+      Polysemy.Db.Interpreter.Store+  hs-source-dirs:+      lib+  default-extensions:+      StandaloneKindSignatures+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveLift+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      DisambiguateRecordFields+      DoAndIfThenElse+      DuplicateRecordFields+      EmptyCase+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      KindSignatures+      LambdaCase+      LiberalTypeSynonyms+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedLabels+      OverloadedLists+      OverloadedStrings+      PackageImports+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      QuantifiedConstraints+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      RoleAnnotations+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      UnicodeSyntax+      ViewPatterns+  ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages -fplugin=Polysemy.Plugin+  build-depends:+      base >=4.12 && <5+    , exon ==1.4.*+    , polysemy+    , polysemy-plugin+    , prelate >=0.5.1 && <0.6+    , random ==1.2.*+    , sqel >=0.0.1 && <0.1+    , uuid ==1.3.*+  mixins:+      base hiding (Prelude)+    , prelate (Prelate as Prelude)+    , prelate hiding (Prelate)+  default-language: Haskell2010