diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Database/Persist/FieldDef.hs b/Database/Persist/FieldDef.hs --- a/Database/Persist/FieldDef.hs +++ b/Database/Persist/FieldDef.hs @@ -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 diff --git a/Database/Persist/Quasi.hs b/Database/Persist/Quasi.hs --- a/Database/Persist/Quasi.hs +++ b/Database/Persist/Quasi.hs @@ -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 diff --git a/Database/Persist/Quasi/Internal.hs b/Database/Persist/Quasi/Internal.hs --- a/Database/Persist/Quasi/Internal.hs +++ b/Database/Persist/Quasi/Internal.hs @@ -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. diff --git a/Database/Persist/Sql/Class.hs b/Database/Persist/Sql/Class.hs --- a/Database/Persist/Sql/Class.hs +++ b/Database/Persist/Sql/Class.hs @@ -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 diff --git a/Database/Persist/Sql/Internal.hs b/Database/Persist/Sql/Internal.hs --- a/Database/Persist/Sql/Internal.hs +++ b/Database/Persist/Sql/Internal.hs @@ -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 diff --git a/Database/Persist/TH.hs b/Database/Persist/TH.hs --- a/Database/Persist/TH.hs +++ b/Database/Persist/TH.hs @@ -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 diff --git a/Database/Persist/Types.hs b/Database/Persist/Types.hs --- a/Database/Persist/Types.hs +++ b/Database/Persist/Types.hs @@ -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 + ) diff --git a/Database/Persist/Types/Base.hs b/Database/Persist/Types/Base.hs --- a/Database/Persist/Types/Base.hs +++ b/Database/Persist/Types/Base.hs @@ -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 diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.13.0.4 +version: 2.13.1.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -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 diff --git a/test/Database/Persist/TH/MaybeFieldDefsSpec.hs b/test/Database/Persist/TH/MaybeFieldDefsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/MaybeFieldDefsSpec.hs @@ -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 diff --git a/test/Database/Persist/THSpec.hs b/test/Database/Persist/THSpec.hs --- a/test/Database/Persist/THSpec.hs +++ b/test/Database/Persist/THSpec.hs @@ -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