persistent 2.13.0.4 → 2.13.1.0
raw patch · 12 files changed
+181/−69 lines, 12 files
Files
- ChangeLog.md +5/−1
- Database/Persist/FieldDef.hs +26/−3
- Database/Persist/Quasi.hs +31/−1
- Database/Persist/Quasi/Internal.hs +32/−21
- Database/Persist/Sql/Class.hs +2/−0
- Database/Persist/Sql/Internal.hs +4/−2
- Database/Persist/TH.hs +9/−9
- Database/Persist/Types.hs +31/−31
- Database/Persist/Types/Base.hs +6/−0
- persistent.cabal +2/−1
- test/Database/Persist/TH/MaybeFieldDefsSpec.hs +30/−0
- test/Database/Persist/THSpec.hs +3/−0
ChangeLog.md view
@@ -1,5 +1,10 @@ # Changelog for persistent +## 2.13.1.0++* [#1264](https://github.com/yesodweb/persistent/pull/1264)+ * Support declaring Maybe before the type in model definitions+ ## 2.13.0.4 * [#1277](https://github.com/yesodweb/persistent/pull/1277)@@ -13,7 +18,6 @@ * Fixes an issue where generating code would refer to the `ModelName` when making a reference to another table when the explicit code only refers to `ModelNameId`.- ## 2.13.0.2
Database/Persist/FieldDef.hs view
@@ -9,6 +9,8 @@ , overFieldAttrs , addFieldAttr -- ** Helpers+ , isFieldNullable+ , isFieldMaybe , isFieldNotGenerated , isHaskellField -- * 'FieldCascade'@@ -22,9 +24,12 @@ import Database.Persist.FieldDef.Internal import Database.Persist.Types.Base- ( isHaskellField- , FieldAttr- )+ ( FieldAttr(..)+ , FieldType(..)+ , IsNullable(..)+ , fieldAttrsContainsNullable+ , isHaskellField+ ) -- | Replace the 'FieldDef' 'FieldAttr' with the new list. --@@ -43,3 +48,21 @@ -- @since 2.13.0.0 addFieldAttr :: FieldAttr -> FieldDef -> FieldDef addFieldAttr fa = overFieldAttrs (fa :)++-- | Check if the field definition is nullable+--+-- @since 2.13.0.0+isFieldNullable :: FieldDef -> IsNullable+isFieldNullable =+ fieldAttrsContainsNullable . fieldAttrs++-- | Check if the field is `Maybe a`+--+-- @since 2.13.0.0+isFieldMaybe :: FieldDef -> Bool+isFieldMaybe field =+ case fieldType field of+ FTApp (FTTypeCon _ "Maybe") _ ->+ True+ _ ->+ False
Database/Persist/Quasi.hs view
@@ -366,6 +366,37 @@ Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond @ += Nullable Fields++As illustrated in the example at the beginning of this page, we are able to represent nullable+fields by including 'Maybe' at the end of the type declaration:++> TableName+> fieldName FieldType+> otherField String+> nullableField Int Maybe++Alternatively we can specify the keyword nullable:++> TableName+> fieldName FieldType+> otherField String+> nullableField Int nullable++However the difference here is in the first instance the Haskell type will be 'Maybe Int',+but in the second it will be 'Int'. Be aware that this will cause runtime errors if the+database returns `NULL` and the `PersistField` instance does not handle `PersistNull`.++If you wish to define your Maybe types in a way that is similar to the actual Haskell+definition, you can define 'Maybe Int' like so:++> TableName+> fieldName FieldType+> otherField String+> nullableField (Maybe Int)++However, note, the field _must_ be enclosed in parenthesis.+ = Documentation Comments The quasiquoter supports ordinary comments with @--@ and @#@.@@ -417,7 +448,6 @@ , PersistSettings , upperCaseSettings , lowerCaseSettings- , nullable -- ** Getters and Setters , module Database.Persist.Quasi ) where
Database/Persist/Quasi/Internal.hs view
@@ -19,7 +19,6 @@ , upperCaseSettings , lowerCaseSettings , toFKNameInfixed- , nullable , Token (..) , Line (..) , preparse@@ -40,6 +39,7 @@ , UnboundCompositeDef(..) , UnboundIdDef(..) , unbindFieldDef+ , isUnboundFieldNullable , unboundIdDefToFieldDef , PrimarySpec(..) , mkAutoIdField'@@ -77,6 +77,7 @@ PSFail err -> Left $ "PSFail " ++ err other -> Left $ show other where+ parseApplyFT :: Text -> ParseState FieldType parseApplyFT t = case goMany id t of PSSuccess (ft:fts) t' -> PSSuccess (foldl' FTApp ft fts) t'@@ -93,6 +94,7 @@ (x, y) -> PSFail $ show (b, x, y) x -> PSFail $ show x + parse1 :: Text -> ParseState FieldType parse1 t = case T.uncons t of Nothing -> PSDone@@ -105,6 +107,7 @@ in PSSuccess (parseFieldTypePiece c a) b | otherwise -> PSFail $ show (c, t') + goMany :: ([FieldType] -> a) -> Text -> ParseState a goMany front t = case parse1 t of PSSuccess x t' -> goMany (front . (x:)) t'@@ -217,12 +220,14 @@ let (token, rest) = T.break isSpace t in Token token : tokenize rest where+ findMidToken :: Text -> Maybe (Text, Text) findMidToken t' = case T.break (== '=') t' of (x, T.drop 1 -> y) | "\"" `T.isPrefixOf` y || "(" `T.isPrefixOf` y -> Just (x, y) _ -> Nothing + quotes :: Text -> ([Text] -> [Text]) -> [Token] quotes t' front | T.null t' = error $ T.unpack $ T.concat $ "Unterminated quoted string starting with " : front []@@ -232,6 +237,8 @@ | otherwise = let (x, y) = T.break (`elem` ['\\','\"']) t' in quotes y (front . (x:))++ parens :: Int -> Text -> ([Text] -> [Text]) -> [Token] parens count t' front | T.null t' = error $ T.unpack $ T.concat $ "Unterminated parens string starting with " : front []@@ -376,7 +383,7 @@ else lwc : lwc' : lwcs -+ minimumIndentOf :: LinesWithComments -> Int minimumIndentOf = lowestIndent . lwcLines -- | An 'EntityDef' produced by the QuasiQuoter. It contains information that@@ -563,6 +570,10 @@ fieldGenerated fd } +isUnboundFieldNullable :: UnboundFieldDef -> IsNullable+isUnboundFieldNullable =+ fieldAttrsContainsNullable . unboundFieldAttrs+ -- | The specification for how an entity's primary key should be formed. -- -- Persistent requires that every table have a primary key. By default, an@@ -691,22 +702,13 @@ textAttribs cols :: [UnboundFieldDef]- cols = reverse . fst . foldr k ([], []) $ reverse attribs-- k x (!acc, !comments) =- case listToMaybe x of- Just (DocComment comment) ->- (acc, comment : comments)- _ ->- case (setFieldComments comments <$> takeColsEx ps (tokenText <$> x)) of- Just sm ->- (sm : acc, [])- Nothing ->- (acc, [])+ cols = reverse . fst . foldr (associateComments ps) ([], []) $ reverse attribs + autoIdField :: FieldDef autoIdField = mkAutoIdField ps entNameHS idSqlType + idSqlType :: SqlType idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite @@ -777,6 +779,22 @@ Just $ fieldType fd } +associateComments+ :: PersistSettings+ -> [Token]+ -> ([UnboundFieldDef], [Text])+ -> ([UnboundFieldDef], [Text])+associateComments ps x (!acc, !comments) =+ case listToMaybe x of+ Just (DocComment comment) ->+ (acc, comment : comments)+ _ ->+ case (setFieldComments comments <$> takeColsEx ps (tokenText <$> x)) of+ Just sm ->+ (sm : acc, [])+ Nothing ->+ (acc, [])+ setFieldComments :: [Text] -> UnboundFieldDef -> UnboundFieldDef setFieldComments xs fld = case xs of@@ -1358,13 +1376,6 @@ takeDerives :: [Text] -> Maybe [Text] takeDerives ("deriving":rest) = Just rest takeDerives _ = Nothing--nullable :: [FieldAttr] -> IsNullable-nullable s- | FieldAttrMaybe `elem` s = Nullable ByMaybeAttr- | FieldAttrNullable `elem` s = Nullable ByNullableAttr- | otherwise = NotNullable- -- | Returns 'True' if the 'UnboundFieldDef' does not have a 'MigrationOnly' or -- 'SafeToRemove' flag from the QuasiQuoter.
Database/Persist/Sql/Class.hs view
@@ -1237,6 +1237,8 @@ sqlType _ = SqlTime instance PersistFieldSql UTCTime where sqlType _ = SqlDayTime+instance PersistFieldSql a => PersistFieldSql (Maybe a) where+ sqlType _ = sqlType (Proxy :: Proxy a) instance {-# OVERLAPPABLE #-} PersistFieldSql a => PersistFieldSql [a] where sqlType _ = SqlString instance PersistFieldSql a => PersistFieldSql (V.Vector a) where
Database/Persist/Sql/Internal.hs view
@@ -20,7 +20,6 @@ import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Database.Persist.EntityDef-import Database.Persist.Quasi import Database.Persist.Sql.Types import Database.Persist.Types @@ -140,7 +139,10 @@ go fd = Column { cName = fieldDB fd- , cNull = nullable (fieldAttrs fd) /= NotNullable || isEntitySum t+ , cNull =+ case isFieldNullable fd of+ Nullable _ -> True+ NotNullable -> isFieldMaybe fd || isEntitySum t , cSqlType = fieldSqlType fd , cDefault = defaultAttribute $ fieldAttrs fd , cGenerated = fieldGenerated fd
Database/Persist/TH.hs view
@@ -71,8 +71,6 @@ import Prelude hiding (concat, exp, splitAt, take, (++)) -import GHC.Stack (HasCallStack)-import Data.Coerce import Control.Monad import Data.Aeson ( FromJSON(parseJSON)@@ -86,6 +84,7 @@ ) import qualified Data.ByteString as BS import Data.Char (toLower, toUpper)+import Data.Coerce import Data.Data (Data) import Data.Either import qualified Data.HashMap.Strict as HM@@ -104,6 +103,7 @@ import qualified Data.Text.Encoding as TE import Data.Typeable (Typeable) import GHC.Generics (Generic)+import GHC.Stack (HasCallStack) import GHC.TypeLits import Instances.TH.Lift () -- Bring `Lift (fmap k v)` instance into scope, as well as `Lift Text`@@ -387,14 +387,14 @@ , withDbName parentFieldStore ffrTargetField ) fixForeignNullable =- all ((NotNullable /=) . isFieldNullable) foreignFieldNames+ all ((NotNullable /=) . isForeignNullable) foreignFieldNames where- isFieldNullable fieldNameHS =+ isForeignNullable fieldNameHS = case getFieldDef fieldNameHS fieldStore of Nothing -> error "Field name not present in map" Just a ->- nullable (unboundFieldAttrs a)+ isUnboundFieldNullable a fieldStore = mkFieldStore unboundEnt@@ -1093,7 +1093,7 @@ error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ unConstraintNameHS constr lookup3 x (fd:rest) | x == unFieldNameHS (unboundFieldNameHS fd) =- (fd, nullable $ unboundFieldAttrs fd)+ (fd, isUnboundFieldNullable fd) | otherwise = lookup3 x rest @@ -2273,7 +2273,7 @@ { depTarget = name , depSourceTable = entityHaskell (unboundEntityDef def) , depSourceField = unboundFieldNameHS field- , depSourceNull = nullable (unboundFieldAttrs field)+ , depSourceNull = isUnboundFieldNullable field } Nothing -> []@@ -2607,7 +2607,7 @@ entityName = mkEntityNameHSName (getUnboundEntityNameHS ued) maybeNullable :: UnboundFieldDef -> Bool-maybeNullable fd = nullable (unboundFieldAttrs fd) == Nullable ByMaybeAttr+maybeNullable fd = isUnboundFieldNullable fd == Nullable ByMaybeAttr ftToType :: FieldType -> Type ftToType = \case@@ -3125,7 +3125,7 @@ nullSetting = isNull fd isNull =- (NotNullable /=) . nullable . unboundFieldAttrs+ (NotNullable /=) . isUnboundFieldNullable in if all ((nullSetting ==) . isNull) fds then nullSetting
Database/Persist/Types.hs view
@@ -16,43 +16,43 @@ , OverflowNatural(..) ) where -import Database.Persist.Names-import Database.Persist.Class.PersistField import Database.Persist.Class.PersistEntity+import Database.Persist.Class.PersistField import Database.Persist.EntityDef import Database.Persist.FieldDef+import Database.Persist.Names import Database.Persist.PersistValue -- this module is a bit of a kitchen sink of types and concepts. the guts of -- persistent, just strewn across the table. in 2.13 let's get this cleaned up -- and a bit more tidy. import Database.Persist.Types.Base- ( FieldCascade(..)- , ForeignDef(..)- , CascadeAction(..)- , FieldDef(..)- , UniqueDef(..)- , FieldAttr(..)- , IsNullable(..)- , WhyNullable(..)- , ExtraLine- , Checkmark(..)- , FieldType(..)- , PersistException(..)- , ForeignFieldDef- , Attr- , CompositeDef(..)- , SqlType(..)- , ReferenceDef(..)- , noCascade- , parseFieldAttrs- , keyAndEntityFields- , PersistException(..)- , UpdateException(..)- , PersistValue(..)- , PersistFilter(..)- , PersistUpdate(..)- , EmbedEntityDef(..)- , EmbedFieldDef(..)- , LiteralType(..)- )+ ( Attr+ , CascadeAction(..)+ , Checkmark(..)+ , CompositeDef(..)+ , EmbedEntityDef(..)+ , EmbedFieldDef(..)+ , ExtraLine+ , FieldAttr(..)+ , FieldCascade(..)+ , FieldDef(..)+ , FieldType(..)+ , ForeignDef(..)+ , ForeignFieldDef+ , IsNullable(..)+ , LiteralType(..)+ , PersistException(..)+ , PersistFilter(..)+ , PersistUpdate(..)+ , PersistValue(..)+ , ReferenceDef(..)+ , SqlType(..)+ , UniqueDef(..)+ , UpdateException(..)+ , WhyNullable(..)+ , fieldAttrsContainsNullable+ , keyAndEntityFields+ , noCascade+ , parseFieldAttrs+ )
Database/Persist/Types/Base.hs view
@@ -108,6 +108,12 @@ | NotNullable deriving (Eq, Show) +fieldAttrsContainsNullable :: [FieldAttr] -> IsNullable+fieldAttrsContainsNullable s+ | FieldAttrMaybe `elem` s = Nullable ByMaybeAttr+ | FieldAttrNullable `elem` s = Nullable ByNullableAttr+ | otherwise = NotNullable+ -- | The reason why a field is 'nullable' is very important. A -- field that is nullable because of a @Maybe@ tag will have its -- type changed from @A@ to @Maybe A@. OTOH, a field that is
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.13.0.4+version: 2.13.1.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -172,6 +172,7 @@ Database.Persist.TH.KindEntitiesSpec Database.Persist.TH.KindEntitiesSpecImports Database.Persist.TH.MigrationOnlySpec+ Database.Persist.TH.MaybeFieldDefsSpec Database.Persist.TH.MultiBlockSpec Database.Persist.TH.MultiBlockSpec.Model Database.Persist.TH.OverloadedLabelSpec
+ test/Database/Persist/TH/MaybeFieldDefsSpec.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++module Database.Persist.TH.MaybeFieldDefsSpec where++import TemplateTestImports++mkPersist sqlSettings [persistLowerCase|+Account+ name (Maybe String)+ email String+|]++spec :: Spec+spec = describe "MaybeFieldDefs" $ do+ it "should support literal `Maybe` declaration in entity definition" $ do+ let mkAccount :: Maybe String -> String -> Account+ mkAccount = Account+ compiles++compiles :: Expectation+compiles = True `shouldBe` True
test/Database/Persist/THSpec.hs view
@@ -53,6 +53,7 @@ import qualified Database.Persist.TH.ImplicitIdColSpec as ImplicitIdColSpec import qualified Database.Persist.TH.JsonEncodingSpec as JsonEncodingSpec import qualified Database.Persist.TH.KindEntitiesSpec as KindEntitiesSpec+import qualified Database.Persist.TH.MaybeFieldDefsSpec as MaybeFieldDefsSpec import qualified Database.Persist.TH.MigrationOnlySpec as MigrationOnlySpec import qualified Database.Persist.TH.MultiBlockSpec as MultiBlockSpec import qualified Database.Persist.TH.OverloadedLabelSpec as OverloadedLabelSpec@@ -63,6 +64,7 @@ import qualified Database.Persist.TH.OverloadedLabelSpec as OverloadedLabelSpec import qualified Database.Persist.TH.SharedPrimaryKeyImportedSpec as SharedPrimaryKeyImportedSpec import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpec+import qualified Database.Persist.TH.ToFromPersistValuesSpec as ToFromPersistValuesSpec -- test to ensure we can have types ending in Id that don't trash the TH -- machinery@@ -179,6 +181,7 @@ SharedPrimaryKeySpec.spec SharedPrimaryKeyImportedSpec.spec ImplicitIdColSpec.spec+ MaybeFieldDefsSpec.spec MigrationOnlySpec.spec EmbedSpec.spec DiscoverEntitiesSpec.spec