Add some more persistent functions

SupercedeTech · Nov 24, 2020 · d93db4c · d93db4c
1 parent 023167b
commit d93db4c
Show file tree

Hide file tree

Showing 4 changed files with 79 additions and 5 deletions.
diff --git a/package.yaml b/package.yaml
@@ -8,6 +8,7 @@ library:
   source-dirs: src
   dependencies:
     - base >= 4.10 && < 5
+    - containers >= 0.5.10.2 && < 0.7
     - mtl >= 2.2.2 && < 3
     - persistent >= 2.8.2 && < 3
     - resource-pool >= 0.2.3.2 && < 0.3

diff --git a/persistent-mtl.cabal b/persistent-mtl.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: ed87d93280415b4fcbbb88057eb1df14d7ed6b3251947b40b2b150598adef468
+-- hash: f1717fb11c2c334c4fb635d2ab3fafd4960e5d56d9f998a53962019736a970e5
 
 name:           persistent-mtl
 version:        0.1.0.0
@@ -25,6 +25,7 @@ library
   ghc-options: -Wall
   build-depends:
       base >=4.10 && <5
+    , containers >=0.5.10.2 && <0.7
     , mtl >=2.2.2 && <3
     , persistent >=2.8.2 && <3
     , resource-pool >=0.2.3.2 && <0.3

diff --git a/src/Database/Persist/Monad/Shim.hs b/src/Database/Persist/Monad/Shim.hs
@@ -3,6 +3,7 @@
 module Database.Persist.Monad.Shim where
 
 import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Data.Map (Map)
 import Data.Text (Text)
 import Data.Typeable (Typeable)
 import Database.Persist
@@ -11,6 +12,31 @@ import Database.Persist.Sql
 import Database.Persist.Monad.Class (MonadSqlQuery(..))
 import Database.Persist.Monad.SqlQueryRep (SqlQueryRep(..))
 
+{- PersistStoreRead -}
+
+get :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) => Key record -> m (Maybe record)
+get a = runQueryRep $ Get a
+
+getMany :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) => [Key record] -> m (Map (Key record) record)
+getMany a = runQueryRep $ GetMany a
+
+getJust :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) => Key record -> m record
+getJust a = runQueryRep $ GetJust a
+
+getJustEntity :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) => Key record -> m (Entity record)
+getJustEntity a = runQueryRep $ GetJustEntity a
+
+getEntity :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) => Key record -> m (Maybe (Entity record))
+getEntity a = runQueryRep $ GetEntity a
+
+belongsTo :: (PersistEntity record1, PersistRecordBackend record2 SqlBackend, Typeable record1, Typeable record2, MonadSqlQuery m) => (record1 -> Maybe (Key record2)) -> record1 -> m (Maybe record2)
+belongsTo a b = runQueryRep $ BelongsTo a b
+
+belongsToJust :: (PersistEntity record1, PersistRecordBackend record2 SqlBackend, Typeable record1, Typeable record2, MonadSqlQuery m) => (record1 -> Key record2) -> record1 -> m record2
+belongsToJust a b = runQueryRep $ BelongsToJust a b
+
+{- Other -}
+
 selectList :: (PersistRecordBackend record SqlBackend, Typeable record, MonadSqlQuery m) => [Filter record] -> [SelectOpt record] -> m [Entity record]
 selectList a b = runQueryRep $ SelectList a b
 

diff --git a/src/Database/Persist/Monad/SqlQueryRep.hs b/src/Database/Persist/Monad/SqlQueryRep.hs
@@ -9,16 +9,46 @@ module Database.Persist.Monad.SqlQueryRep
   ) where
 
 import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Data.Map (Map)
 import Data.Proxy (Proxy(..))
 import Data.Text (Text)
 import Data.Typeable (Typeable, eqT, typeRep, (:~:)(..))
 import Data.Void (Void)
-import Database.Persist (Entity, Filter, Key, PersistRecordBackend, SelectOpt)
-import Database.Persist.Sql (Migration, SqlBackend)
-import qualified Database.Persist.Sql as Persist
+import Database.Persist.Sql as Persist
 
--- TODO: generate this
 data SqlQueryRep record a where
+  {- PersistStoreRead -}
+
+  Get
+    :: PersistRecordBackend record SqlBackend
+    => Key record -> SqlQueryRep record (Maybe record)
+
+  GetMany
+    :: PersistRecordBackend record SqlBackend
+    => [Key record] -> SqlQueryRep record (Map (Key record) record)
+
+  GetJust
+    :: PersistRecordBackend record SqlBackend
+    => Key record -> SqlQueryRep record record
+
+  GetJustEntity
+    :: PersistRecordBackend record SqlBackend
+    => Key record -> SqlQueryRep record (Entity record)
+
+  GetEntity
+    :: PersistRecordBackend record SqlBackend
+    => Key record -> SqlQueryRep record (Maybe (Entity record))
+
+  BelongsTo
+    :: (PersistEntity record1, PersistRecordBackend record2 SqlBackend)
+    => (record1 -> Maybe (Key record2)) -> record1 -> SqlQueryRep (record1, record2) (Maybe record2)
+
+  BelongsToJust
+    :: (PersistEntity record1, PersistRecordBackend record2 SqlBackend)
+    => (record1 -> Key record2) -> record1 -> SqlQueryRep (record1, record2) record2
+
+  {- Other -}
+
   SelectList
     :: PersistRecordBackend record SqlBackend
     => [Filter record] -> [SelectOpt record] -> SqlQueryRep record [Entity record]
@@ -36,6 +66,14 @@ data SqlQueryRep record a where
 
 instance Typeable record => Show (SqlQueryRep record a) where
   show = \case
+    Get{} -> "Get{..}" ++ record
+    GetMany{} -> "GetMany{..}" ++ record
+    GetJust{} -> "GetJust{..}" ++ record
+    GetJustEntity{} -> "GetJustEntity{..}" ++ record
+    GetEntity{} -> "GetEntity{..}" ++ record
+    BelongsTo{} -> "BelongsTo{..}" ++ record
+    BelongsToJust{} -> "BelongsToJust{..}" ++ record
+
     SelectList{} -> "SelectList{..}" ++ record
     Insert{} -> "Insert{..}" ++ record
     Insert_{} -> "Insert_{..}" ++ record
@@ -50,6 +88,14 @@ instance Typeable record => Show (SqlQueryRep record a) where
 
 runSqlQueryRep :: MonadUnliftIO m => SqlQueryRep record a -> Persist.SqlPersistT m a
 runSqlQueryRep = \case
+  Get a -> Persist.get a
+  GetMany a -> Persist.getMany a
+  GetJust a -> Persist.getJust a
+  GetJustEntity a -> Persist.getJustEntity a
+  GetEntity a -> Persist.getEntity a
+  BelongsTo a b -> Persist.belongsTo a b
+  BelongsToJust a b -> Persist.belongsToJust a b
+
   SelectList a b -> Persist.selectList a b
   Insert a -> Persist.insert a
   Insert_ a -> Persist.insert_ a