QuasiQuoter Improvements

.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"

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)
@@ -409,39 +410,43 @@ 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
@@ -647,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
@@ -950,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.
@@ -971,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/Database/Persist/MySQL.hs

@@ -46,6 +46,7 @@ import Control.Monad.Trans.Except (ExceptT, runExceptT)
 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
 import Control.Monad.Trans.Writer (runWriterT)
 
+import qualified Data.List.NonEmpty as NEL
 import Data.Acquire (Acquire, mkAcquire, with)
 import Data.Aeson
 import Data.Aeson.Types (modifyFailure)
@@ -177,9 +178,11 @@ prepare' conn sql = do
 -- | SQL code to be executed when inserting an entity.
 insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult
 insertSql' ent vals =
-    case entityPrimary ent of
-        Just _ -> ISRManyKeys sql vals
-        Nothing -> ISRInsertGet sql "SELECT LAST_INSERT_ID()"
+    case getEntityId ent of
+        EntityIdNaturalKey _ ->
+            ISRManyKeys sql vals
+        EntityIdField _ ->
+            ISRInsertGet sql "SELECT LAST_INSERT_ID()"
   where
     (fieldNames, placeholders) = unzip (Util.mkInsertPlaceholders ent escapeFT)
     sql = T.concat
@@ -370,7 +373,7 @@ migrate' connectInfo allDefs getter val = do
                     let refTarget =
                           addReference allDefs refConstraintName refTblName cname (crFieldCascade cRef)
 
-                    guard $ cname /= fieldDB (getEntityId val)
+                    guard $ Just cname /= fmap fieldDB (getEntityIdField val)
                     return $ AlterColumn name refTarget
 
 
@@ -455,22 +458,20 @@ addTable cols entity = AddTable $ concat
     ]
   where
     nonIdCols =
-        filter (\c -> cName c /= fieldDB (getEntityId entity) ) cols
+        filter (\c -> Just (cName c) /= fmap fieldDB (getEntityIdField entity) ) cols
     name =
         getEntityDBName entity
     idtxt =
-        case entityPrimary entity of
-            Just pdef ->
+        case getEntityId entity of
+            EntityIdNaturalKey pdef ->
                 concat
                     [ " PRIMARY KEY ("
                     , intercalate ","
-                  $ map (escapeF . fieldDB) $ compositeFields pdef
+                  $ map (escapeF . fieldDB) $ NEL.toList $ compositeFields pdef
                     , ")"
                     ]
-            Nothing ->
+            EntityIdField idField ->
                 let
-                    idField =
-                        getEntityId entity
                     defText =
                         defaultAttribute $ fieldAttrs idField
                     sType =
@@ -483,7 +484,7 @@ addTable cols entity = AddTable $ concat
                         findMaxLenOfField idField
                 in
                     concat
-                        [ escapeF $ fieldDB $ getEntityId entity
+                        [ escapeF $ fieldDB idField
                         , " " <> showSqlType sType maxlen False
                         , " NOT NULL"
                         , autoIncrementText
@@ -554,7 +555,7 @@ addReference allDefs fkeyname reftable cname fc =
     referencedColumns =
         fromMaybe errorMessage $ do
             entDef <- find ((== reftable) . getEntityDBName) allDefs
-            return $ map fieldDB $ getEntityKeyFields entDef
+            return $ map fieldDB $ NEL.toList $ getEntityKeyFields entDef
 
 data AlterColumn = Change Column
                  | Add' Column
@@ -585,7 +586,7 @@ data AlterDB = AddTable String
 
 
 udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB])
-udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud)
+udToPair ud = (uniqueDBName ud, map snd $ NEL.toList $ uniqueFields ud)
 
 ----------------------------------------------------------------------
 
@@ -922,7 +923,8 @@ findAlters edef allDefs col@(Column name isNull type_ def gen _defConstraintName
                     case (ref == ref', ref) of
                         (False, Just ColumnReference {crTableName=tname, crConstraintName=cname, crFieldCascade = cfc })
                             | tname /= getEntityDBName edef
-                            , unConstraintNameDB cname /= unFieldNameDB (fieldDB (getEntityId edef))
+                            , Just idField <- getEntityIdField edef
+                            , unConstraintNameDB cname /= unFieldNameDB (fieldDB idField)
                             ->
                             [addReference allDefs cname tname name cfc]
                         _ -> []
@@ -1536,7 +1538,7 @@ putManySql ent n = putManySql' fields ent n
 repsertManySql :: EntityDef -> Int -> Text
 repsertManySql ent n = putManySql' fields ent n
   where
-    fields = keyAndEntityFields ent
+    fields = NEL.toList $ keyAndEntityFields ent
 
 putManySql' :: [FieldDef] -> EntityDef -> Int -> Text
 putManySql' (filter isFieldNotGenerated -> fields) ent n = q

persistent-mysql/test/ImplicitUuidSpec.hs

@@ -42,7 +42,7 @@ implicitUuidMigrate = do
 wipe :: IO ()
 wipe = db $ do
     rawExecute "DROP TABLE IF EXISTS with_def_uuid;" []
-    runMigration implicitUuidMigrate
+    void $ runMigrationSilent implicitUuidMigrate
 
 itDb :: String -> SqlPersistT (LoggingT (ResourceT IO)) a -> SpecWith (Arg (IO ()))
 itDb msg action = it msg $ db $ void action
@@ -57,11 +57,9 @@ spec = describe "ImplicitUuidSpec" $ before_ wipe $ do
             let withDefUuidKey = WithDefUuidKey (UUID "Hello")
             pass
     describe "getEntityId" $ do
-        let idField = getEntityId (entityDef (Proxy @WithDefUuid))
+        let Just idField = getEntityIdField (entityDef (Proxy @WithDefUuid))
         it "has a SqlString SqlType" $ asIO $ do
             fieldSqlType idField `shouldBe` SqlString
-        it "has a UUID type" $ asIO $ do
-            fieldType idField `shouldBe` fieldTypeFromTypeable @UUID
         it "is an implicit ID column" $ asIO $ do
             fieldIsImplicitIdColumn idField `shouldBe` True