persistent-2.13

.github/workflows/haskell.yml

@@ -45,13 +45,12 @@ jobs:
     runs-on: ubuntu-latest
     strategy:
       matrix:
-        cabal: ["3.2"]
+        cabal: ["3.4"]
         ghc:
-          - "8.2.2"
           - "8.4.4"
           - "8.6.5"
           - "8.8.4"
-          - "8.10.1"
+          - "8.10.3"
 
     env:
       CONFIG: "--enable-tests"
@@ -70,14 +69,15 @@ jobs:
         uses: supercharge/redis-github-action@1.1.0
       - run: cabal v2-update
       - run: cabal v2-freeze $CONFIG
+      - run: cat cabal.project.freeze
       - uses: actions/cache@v2
         with:
           path: |
             ${{ steps.setup-haskell-cabal.outputs.cabal-store }}
           key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
           restore-keys: |
             ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
-            #  ${{ runner.os }}-${{ matrix.ghc }}-
+            ${{ runner.os }}-${{ matrix.ghc }}-
       - run: cabal v2-build all --disable-optimization --only-dependencies $CONFIG
       - run: cabal v2-build all --disable-optimization $CONFIG
       - run: cabal v2-test all --disable-optimization $CONFIG

.gitignore

@@ -51,3 +51,4 @@ persistent-test/db/
 .hspec-failures
 
 stack.yaml.lock
+*.yaml.lock

cabal.project

@@ -2,7 +2,7 @@ packages:
   persistent
   persistent-sqlite
   persistent-test
-  persistent-mongoDB
+  -- persistent-mongoDB
   persistent-mysql
   persistent-postgresql
   persistent-redis

persistent-mongoDB/Database/Persist/MongoDB.hs

@@ -112,6 +112,7 @@ module Database.Persist.MongoDB
     , module Database.Persist
     ) where
 
+import qualified Data.List.NonEmpty as NEL
 import Control.Exception (throw, throwIO)
 import Control.Monad (liftM, (>=>), forM_, unless)
 import Control.Monad.IO.Class (liftIO)
@@ -156,6 +157,7 @@ import Database.MongoDB.Query (Database)
 
 import Database.Persist
 import qualified Database.Persist.Sql as Sql
+import Database.Persist.EntityDef.Internal (toEmbedEntityDef)
 
 instance HasPersistBackend DB.MongoContext where
     type BaseBackend DB.MongoContext = DB.MongoContext
@@ -408,53 +410,57 @@ updateToMongoField (BackendUpdate up)  = mongoUpdateToDoc up
 -- | convert a unique key into a MongoDB document
 toUniquesDoc :: forall record. (PersistEntity record) => Unique record -> [DB.Field]
 toUniquesDoc uniq = zipWith (DB.:=)
-  (map (unFieldNameDB . snd) $ persistUniqueToFieldNames uniq)
+  (map (unFieldNameDB . snd) $ NEL.toList $ persistUniqueToFieldNames uniq)
   (map DB.val (persistUniqueToValues uniq))
 
 -- | convert a PersistEntity into document fields.
 -- for inserts only: nulls are ignored so they will be unset in the document.
 -- 'recordToDocument' includes nulls
 toInsertDoc :: forall record.  (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
             => record -> DB.Document
-toInsertDoc record = zipFilter (embeddedFields $ toEmbedEntityDef entDef)
-    (map toPersistValue $ toPersistFields record)
+toInsertDoc record =
+    zipFilter
+        (embeddedFields $ toEmbedEntityDef entDef)
+        (map toPersistValue $ toPersistFields record)
   where
     entDef = entityDef $ Just record
-    zipFilter :: [EmbedFieldDef] -> [PersistValue] -> DB.Document
-    zipFilter [] _  = []
-    zipFilter _  [] = []
-    zipFilter (fd:efields) (pv:pvs) =
-        if isNull pv then recur else
-          (fieldToLabel fd DB.:= embeddedVal (emFieldEmbed fd) pv):recur
-
+    zipFilter xs ys =
+        map (\(fd, pv) ->
+            fieldToLabel fd
+                DB.:=
+                    embeddedVal pv
+        )
+        $ filter (\(_, pv) -> isNull pv)
+        $ zip xs ys
       where
-        recur = zipFilter efields pvs
-
         isNull PersistNull = True
         isNull (PersistMap m) = null m
         isNull (PersistList l) = null l
         isNull _ = False
 
     -- make sure to removed nulls from embedded entities also
-    embeddedVal :: Maybe EmbedEntityDef -> PersistValue -> DB.Value
-    embeddedVal (Just emDef) (PersistMap m) = DB.Doc $
-      zipFilter (embeddedFields emDef) $ map snd m
-    embeddedVal je@(Just _) (PersistList l) = DB.Array $ map (embeddedVal je) l
-    embeddedVal _ pv = DB.val pv
+    embeddedVal :: PersistValue -> DB.Value
+    embeddedVal (PersistMap m) =
+        DB.Doc $ fmap (\(k, v) -> k DB.:= DB.val v) $ m
+            -- zipFilter fields $ map snd m
+    embeddedVal (PersistList l) =
+        DB.Array $ map embeddedVal l
+    embeddedVal pv =
+        DB.val pv
 
 entityToInsertDoc :: forall record.  (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
                   => Entity record -> DB.Document
 entityToInsertDoc (Entity key record) = keyToMongoDoc key ++ toInsertDoc record
 
 collectionName :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
                => record -> Text
-collectionName = unEntityNameDB . entityDB . entityDef . Just
+collectionName = unEntityNameDB . getEntityDBName . entityDef . Just
 
 -- | convert a PersistEntity into document fields.
 -- unlike 'toInsertDoc', nulls are included.
 recordToDocument :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
                  => record -> DB.Document
-recordToDocument record = zipToDoc (map fieldDB $ entityFields entity) (toPersistFields record)
+recordToDocument record = zipToDoc (map fieldDB $ getEntityFields entity) (toPersistFields record)
   where
     entity = entityDef $ Just record
 
@@ -646,7 +652,7 @@ keyToMongoDoc k = case entityPrimary $ entityDefFromKey k of
     Nothing   -> zipToDoc [FieldNameDB id_] values
     Just pdef -> [id_ DB.=: zipToDoc (primaryNames pdef)  values]
   where
-    primaryNames = map fieldDB . compositeFields
+    primaryNames = map fieldDB . NEL.toList . compositeFields
     values = keyToValues k
 
 entityDefFromKey :: PersistEntity record => Key record -> EntityDef
@@ -658,7 +664,7 @@ collectionNameFromKey = collectionName . recordTypeFromKey
 
 projectionFromEntityDef :: EntityDef -> DB.Projector
 projectionFromEntityDef eDef =
-  map toField (entityFields eDef)
+  map toField (getEntityFields eDef)
   where
     toField :: FieldDef -> DB.Field
     toField fDef = (unFieldNameDB (fieldDB fDef)) DB.=: (1 :: Int)
@@ -920,7 +926,7 @@ fromPersistValuesThrow :: (Trans.MonadIO m, PersistEntity record, PersistEntityB
 fromPersistValuesThrow entDef doc =
     case eitherFromPersistValues entDef doc of
         Left t -> Trans.liftIO . throwIO $ PersistMarshalError $
-                   unEntityNameHS (entityHaskell entDef) `mappend` ": " `mappend` t
+                   unEntityNameHS (getEntityHaskellName entDef) `mappend` ": " `mappend` t
         Right entity -> return entity
 
 mapLeft :: (a -> c) -> Either a b -> Either c b
@@ -949,10 +955,13 @@ eitherFromPersistValues entDef doc = case mKey of
 -- Persistent creates a Haskell record from a list of PersistValue
 -- But most importantly it puts all PersistValues in the proper order
 orderPersistValues :: EmbedEntityDef -> [(Text, PersistValue)] -> [(Text, PersistValue)]
-orderPersistValues entDef castDoc = reorder
+orderPersistValues entDef castDoc =
+    match castColumns castDoc []
   where
-    castColumns = map nameAndEmbed (embeddedFields entDef)
-    nameAndEmbed fdef = (fieldToLabel fdef, emFieldEmbed fdef)
+    castColumns =
+        map nameAndEmbed (embeddedFields entDef)
+    nameAndEmbed fdef =
+        (fieldToLabel fdef, emFieldEmbed fdef)
 
     -- TODO: the below reasoning should be re-thought now that we are no longer inserting null: searching for a null column will look at every returned field before giving up
     -- Also, we are now doing the _id lookup at the start.
@@ -970,44 +979,44 @@ orderPersistValues entDef castDoc = reorder
     -- * but once we found an item in the alist use a new alist without that item for future lookups
     -- * so for the last query there is only one item left
     --
-    reorder :: [(Text, PersistValue)]
-    reorder = match castColumns castDoc []
+    match :: [(Text, Maybe (Either a EntityNameHS) )]
+          -> [(Text, PersistValue)]
+          -> [(Text, PersistValue)]
+          -> [(Text, PersistValue)]
+    -- when there are no more Persistent castColumns we are done
+    --
+    -- allow extra mongoDB fields that persistent does not know about
+    -- another application may use fields we don't care about
+    -- our own application may set extra fields with the raw driver
+    match [] _ values = values
+    match ((fieldName, medef) : columns) fields values =
+        let
+            ((_, pv) , unused) =
+                matchOne fields []
+        in
+            match columns unused $
+                values ++ [(fieldName, nestedOrder medef pv)]
       where
-        match :: [(Text, Maybe EmbedEntityDef)]
-              -> [(Text, PersistValue)]
-              -> [(Text, PersistValue)]
-              -> [(Text, PersistValue)]
-        -- when there are no more Persistent castColumns we are done
-        --
-        -- allow extra mongoDB fields that persistent does not know about
-        -- another application may use fields we don't care about
-        -- our own application may set extra fields with the raw driver
-        match [] _ values = values
-        match (column:columns) fields values =
-          let (found, unused) = matchOne fields []
-          in match columns unused $ values ++
-                [(fst column, nestedOrder (snd column) (snd found))]
-          where
-            nestedOrder (Just em) (PersistMap m) =
-              PersistMap $ orderPersistValues em m
-            nestedOrder (Just em) (PersistList l) =
-              PersistList $ map (nestedOrder (Just em)) l
-            -- implied: nestedOrder Nothing found = found
-            nestedOrder _ found = found
-
-            matchOne (field:fs) tried =
-              if fst column == fst field
+        nestedOrder (Just _) (PersistMap m) =
+            PersistMap m
+        nestedOrder (Just em) (PersistList l) =
+            PersistList $ map (nestedOrder (Just em)) l
+        nestedOrder Nothing found =
+            found
+
+        matchOne (field:fs) tried =
+            if fieldName == fst field
                 -- snd drops the name now that it has been used to make the match
                 -- persistent will add the field name later
                 then (field, tried ++ fs)
                 else matchOne fs (field:tried)
-            -- if field is not found, assume it was a Nothing
-            --
-            -- a Nothing could be stored as null, but that would take up space.
-            -- instead, we want to store no field at all: that takes less space.
-            -- Also, another ORM may be doing the same
-            -- Also, this adding a Maybe field means no migration required
-            matchOne [] tried = ((fst column, PersistNull), tried)
+        -- if field is not found, assume it was a Nothing
+        --
+        -- a Nothing could be stored as null, but that would take up space.
+        -- instead, we want to store no field at all: that takes less space.
+        -- Also, another ORM may be doing the same
+        -- Also, this adding a Maybe field means no migration required
+        matchOne [] tried = ((fieldName, PersistNull), tried)
 
 assocListFromDoc :: DB.Document -> [(Text, PersistValue)]
 assocListFromDoc = Prelude.map (\f -> ( (DB.label f), cast (DB.value f) ) )

persistent-mongoDB/README.md

@@ -0,0 +1,11 @@
+# persistent-mongoDB
+
+`persistent-mongoDB` is on hiatus.
+
+There's a lot of complexity around the `EmbedEntityDef` stuff that makes it
+really annoying to use.
+
+A new version of `persistent` will make that easy to work with, and I'll fix it
+up then.
+
+If you want MongoDB *now* then PRs are welcome.

persistent-mongoDB/persistent-mongoDB.cabal

@@ -72,9 +72,6 @@ test-suite test
                    , time
                    , transformers
                    , unliftio-core
-   if impl(ghc < 8)
-     build-depends:
-       semigroups
     default-language: Haskell2010
 
 source-repository head

persistent-mysql/ChangeLog.md

@@ -1,5 +1,11 @@
 # Changelog for persistent-mysql
 
+## 2.13.0.0 (unreleased)
+
+* [#1225](https://github.com/yesodweb/persistent/pull/1225)
+    * Support `persistent-2.13` changes for SqlBackend being made internal.
+    * Remove the deprecated `SomeField` type and pattern.
+
 ## 2.12.1.0
 
 * Expose `openMySQLConn` for explicit reference to opened connection. [#1248](https://github.com/yesodweb/persistent/pull/1248)