persistent-template 2.9 → 2.9.1.0
raw patch · 8 files changed
+578/−75 lines, 8 filesdep ~persistent
Dependency ranges changed: persistent
Files
- ChangeLog.md +10/−0
- Database/Persist/TH.hs +143/−68
- persistent-template.cabal +7/−2
- test/OverloadedLabelTest.hs +56/−0
- test/SharedPrimaryKeyTest.hs +57/−0
- test/SharedPrimaryKeyTestImported.hs +54/−0
- test/TemplateTestImports.hs +8/−2
- test/main.hs +243/−3
ChangeLog.md view
@@ -1,5 +1,15 @@ ## Unreleased changes +## 2.9.1.0++* [#1145](https://github.com/yesodweb/persistent/pull/1148)+ * Fix a bug where the `SqlType` for a shared primary key was being+ incorrectly set to `SqlString` instead of whatever the target primary key+ sql type was.+* [#1151](https://github.com/yesodweb/persistent/pull/1151)+ * Automatically generate `SymbolToField` instances for datatypes, allowing+ `OverloadedLabels` to be used with the `EntityField` type.+ ## 2.9 * Always use the "stock" strategy when deriving Show/Read for keys [#1106](https://github.com/yesodweb/persistent/pull/1106)
Database/Persist/TH.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, BangPatterns #-}+{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}@@ -12,6 +13,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveLift #-}+ {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-} -- | This module provides the tools for defining your database schema and using@@ -53,6 +55,7 @@ , fieldError , AtLeastOneUniqueKey(..) , OnlyOneUniqueKey(..)+ , pkNewtype ) where -- Development Tip: See persistent-template/README.md for advice on seeing generated Template Haskell code@@ -61,7 +64,7 @@ import Prelude hiding ((++), take, concat, splitAt, exp) import Data.Either-import Control.Monad (forM, mzero, filterM, guard, unless)+import Control.Monad import Data.Aeson ( ToJSON (toJSON), FromJSON (parseJSON), (.=), object , Value (Object), (.:), (.:?)@@ -81,7 +84,7 @@ import Data.Maybe (isJust, listToMaybe, mapMaybe, fromMaybe) import Data.Monoid ((<>), mappend, mconcat) import Data.Proxy (Proxy (Proxy))-import Data.Text (pack, Text, append, unpack, concat, uncons, cons, stripPrefix, stripSuffix)+import Data.Text (pack, Text, append, unpack, concat, uncons, cons, stripSuffix) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import qualified Data.Text.Encoding as TE@@ -90,7 +93,7 @@ import Instances.TH.Lift () -- Bring `Lift (Map k v)` instance into scope, as well as `Lift Text` -- instance on pre-1.2.4 versions of `text`-import Language.Haskell.TH.Lib (conT, varE, varP)+import Language.Haskell.TH.Lib (appT, varT, conT, varE, varP, conE, litT, strTyLit) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Web.PathPieces (PathPiece(..))@@ -290,7 +293,10 @@ instance Lift FieldSqlTypeExp where lift (FieldSqlTypeExp FieldDef{..} sqlTypeExp) =- [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs fieldStrict fieldReference fieldComments|]+ [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs fieldStrict fieldReference fieldCascade fieldComments fieldGenerated|]+ where+ FieldDef _x _ _ _ _ _ _ _ _ _ =+ error "need to update this record wildcard match" #if MIN_VERSION_template_haskell(2,16,0) liftTyped = unsafeTExpCoerce . lift #endif@@ -323,14 +329,29 @@ constructEntityMap = M.fromList . fmap (\ent -> (entityHaskell ent, ent)) -data FTTypeConDescr = FTKeyCon deriving Show+data FTTypeConDescr = FTKeyCon+ deriving Show -mEmbedded :: EmbedEntityMap -> FieldType -> Either (Maybe FTTypeConDescr) EmbedEntityDef-mEmbedded _ (FTTypeCon Just{} _) = Left Nothing-mEmbedded ents (FTTypeCon Nothing n) =- let name = HaskellName n- in maybe (Left Nothing) Right $ M.lookup name ents-mEmbedded ents (FTList x) = mEmbedded ents x+-- | Recurses through the 'FieldType'. Returns a 'Right' with the+-- 'EmbedEntityDef' if the 'FieldType' corresponds to an unqualified use of+-- a name and that name is present in the 'EmbedEntityMap' provided as+-- a first argument.+--+-- If the 'FieldType' represents a @Key something@, this returns a @'Left+-- ('Just' 'FTKeyCon')@.+--+-- If the 'FieldType' has a module qualified value, then it returns @'Left'+-- 'Nothing'@.+mEmbedded+ :: EmbedEntityMap+ -> FieldType+ -> Either (Maybe FTTypeConDescr) EmbedEntityDef+mEmbedded _ (FTTypeCon Just{} _) =+ Left Nothing+mEmbedded ents (FTTypeCon Nothing (HaskellName -> name)) =+ maybe (Left Nothing) Right $ M.lookup name ents+mEmbedded ents (FTList x) =+ mEmbedded ents x mEmbedded ents (FTApp x y) = -- Key converts an Record to a RecordId -- special casing this is obviously a hack@@ -347,13 +368,17 @@ case mEmbedded allEntities (fieldType field) of Left _ -> case stripId $ fieldType field of- Nothing -> NoReference+ Nothing ->+ NoReference Just name -> case M.lookup (HaskellName name) allEntities of- Nothing -> NoReference- Just _ -> ForeignRef (HaskellName name)- -- This can get corrected in mkEntityDefSqlTypeExp- (FTTypeCon (Just "Data.Int") "Int64")+ Nothing ->+ NoReference+ Just _ ->+ ForeignRef+ (HaskellName name)+ -- This can get corrected in mkEntityDefSqlTypeExp+ (FTTypeCon (Just "Data.Int") "Int64") Right em -> if embeddedHaskell em /= entName then EmbedRef em@@ -362,7 +387,8 @@ else case fieldType field of FTList _ -> SelfReference _ -> error $ unpack $ unHaskellName entName <> ": a self reference must be a Maybe"- existing -> existing+ existing ->+ existing } mkEntityDefSqlTypeExp :: EmbedEntityMap -> EntityMap -> EntityDef -> EntityDefSqlTypeExp@@ -373,38 +399,45 @@ maybe (defaultSqlTypeExp field) (SqlType' . SqlOther)- (listToMaybe $ mapMaybe (stripPrefix "sqltype=") $ fieldAttrs field)+ (listToMaybe $ mapMaybe (\case {FieldAttrSqltype x -> Just x; _ -> Nothing}) $ fieldAttrs field) -- In the case of embedding, there won't be any datatype created yet. -- We just use SqlString, as the data will be serialized to JSON. defaultSqlTypeExp field = case mEmbedded emEntities ftype of- Right _ -> SqlType' SqlString- Left (Just FTKeyCon) -> SqlType' SqlString- Left Nothing -> case fieldReference field of- ForeignRef refName ft -> case M.lookup refName entityMap of- Nothing -> SqlTypeExp ft- -- A ForeignRef is blindly set to an Int64 in setEmbedField- -- correct that now- Just ent' -> case entityPrimary ent' of- Nothing -> SqlTypeExp ft- Just pdef -> case compositeFields pdef of- [] -> error "mkEntityDefSqlTypeExp: no composite fields"- [x] -> SqlTypeExp $ fieldType x- _ -> SqlType' $ SqlOther "Composite Reference"- CompositeRef _ -> SqlType' $ SqlOther "Composite Reference"- _ ->- case ftype of- -- In the case of lists, we always serialize to a string- -- value (via JSON).- --- -- Normally, this would be determined automatically by- -- SqlTypeExp. However, there's one corner case: if there's- -- a list of entity IDs, the datatype for the ID has not- -- yet been created, so the compiler will fail. This extra- -- clause works around this limitation.- FTList _ -> SqlType' SqlString- _ -> SqlTypeExp ftype+ Right _ ->+ SqlType' SqlString+ Left (Just FTKeyCon) ->+ SqlType' SqlString+ Left Nothing ->+ case fieldReference field of+ ForeignRef refName ft ->+ case M.lookup refName entityMap of+ Nothing -> SqlTypeExp ft+ -- A ForeignRef is blindly set to an Int64 in setEmbedField+ -- correct that now+ Just ent' ->+ case entityPrimary ent' of+ Nothing -> SqlTypeExp ft+ Just pdef ->+ case compositeFields pdef of+ [] -> error "mkEntityDefSqlTypeExp: no composite fields"+ [x] -> SqlTypeExp $ fieldType x+ _ -> SqlType' $ SqlOther "Composite Reference"+ CompositeRef _ ->+ SqlType' $ SqlOther "Composite Reference"+ _ ->+ case ftype of+ -- In the case of lists, we always serialize to a string+ -- value (via JSON).+ --+ -- Normally, this would be determined automatically by+ -- SqlTypeExp. However, there's one corner case: if there's+ -- a list of entity IDs, the datatype for the ID has not+ -- yet been created, so the compiler will fail. This extra+ -- clause works around this limitation.+ FTList _ -> SqlType' SqlString+ _ -> SqlTypeExp ftype where ftype = fieldType field @@ -412,12 +445,17 @@ -- 'EntityDef's. Works well with the persist quasi-quoter. mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec] mkPersist mps ents' = do- requireExtensions [[TypeFamilies], [GADTs, ExistentialQuantification]]+ requireExtensions+ [ [TypeFamilies], [GADTs, ExistentialQuantification]+ , [DerivingStrategies], [GeneralizedNewtypeDeriving], [StandaloneDeriving]+ , [UndecidableInstances], [DataKinds], [FlexibleInstances]+ ] x <- fmap Data.Monoid.mconcat $ mapM (persistFieldFromEntity mps) ents y <- fmap mconcat $ mapM (mkEntity entityMap mps) ents z <- fmap mconcat $ mapM (mkJSON mps) ents uniqueKeyInstances <- fmap mconcat $ mapM (mkUniqueKeyInstances mps) ents- return $ mconcat [x, y, z, uniqueKeyInstances]+ symbolToFieldInstances <- fmap mconcat $ mapM (mkSymbolToFieldInstances mps) ents+ return $ mconcat [x, y, z, uniqueKeyInstances, symbolToFieldInstances] where ents = map fixEntityDef ents' entityMap = constructEntityMap ents@@ -428,8 +466,8 @@ fixEntityDef ed = ed { entityFields = filter keepField $ entityFields ed } where- keepField fd = "MigrationOnly" `notElem` fieldAttrs fd &&- "SafeToRemove" `notElem` fieldAttrs fd+ keepField fd = FieldAttrMigrationOnly `notElem` fieldAttrs fd &&+ FieldAttrSafeToRemove `notElem` fieldAttrs fd -- | Settings to be passed to the 'mkPersist' function. data MkPersistSettings = MkPersistSettings@@ -984,6 +1022,9 @@ keyText :: EntityDef -> Text keyText t = unHaskellName (entityHaskell t) ++ "Key" +-- | Returns 'True' if the key definition has more than 1 field.+--+-- @since 2.11.0.0 pkNewtype :: MkPersistSettings -> EntityDef -> Bool pkNewtype mps t = length (keyFields mps t) < 2 @@ -1104,11 +1145,11 @@ fpv <- mkFromPersistValues mps t utv <- mkUniqueToValues $ entityUniques t puk <- mkUniqueKeys t+ let primaryField = entityId t+ fields <- mapM (mkField mps t) $ primaryField : entityFields t fkc <- mapM (mkForeignKeysComposite mps t) $ entityForeigns t - let primaryField = entityId t - fields <- mapM (mkField mps t) $ primaryField : entityFields t toFieldNames <- mkToFieldNames $ entityUniques t (keyTypeDec, keyInstanceDecs) <- mkKeyTypeDec mps t@@ -1131,8 +1172,7 @@ case entityPrimary t of Just prim -> do recordName <- newName "record"- let fields = map fieldHaskell (compositeFields prim)- keyCon = keyConName t+ let keyCon = keyConName t keyFields' = map (mkName . T.unpack . recName mps entName . fieldHaskell) (compositeFields prim)@@ -1335,7 +1375,8 @@ ] mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec]-mkForeignKeysComposite mps t ForeignDef {..} = do+mkForeignKeysComposite mps t ForeignDef {..} =+ if not foreignToPrimary then return [] else do let fieldName f = mkName $ unpack $ recName mps (entityHaskell t) f let fname = fieldName foreignConstraintNameHaskell let reftableString = unpack $ unHaskellName foreignRefTableHaskell@@ -1343,8 +1384,12 @@ let tablename = mkName $ unpack $ entityText t recordName <- newName "record" - let fldsE = map (\((foreignName, _),_) -> VarE (fieldName foreignName)- `AppE` VarE recordName) foreignFields+ let mkFldE ((foreignName, _),ff) = case ff of+ (HaskellName {unHaskellName = "Id"}, DBName {unDBName = "id"})+ -> AppE (VarE $ mkName "toBackendKey") $+ VarE (fieldName foreignName) `AppE` VarE recordName+ _ -> VarE (fieldName foreignName) `AppE` VarE recordName+ let fldsE = map mkFldE foreignFields let mkKeyE = foldl' AppE (maybeExp foreignNullable $ ConE reftableKeyName) fldsE let fn = FunD fname [normalClause [VarP recordName] mkKeyE] @@ -1677,7 +1722,7 @@ [|EntityDef entityHaskell entityDB- entityId+ $(liftAndFixKey entityMap entityId) entityAttrs $(ListE <$> mapM (liftAndFixKey entityMap) entityFields) entityUniques@@ -1689,23 +1734,28 @@ |] liftAndFixKey :: EntityMap -> FieldDef -> Q Exp-liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef mcomments) =- [|FieldDef a b c $(sqlTyp') e f fieldRef' mcomments|]+liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef fc mcomments fg) =+ [|FieldDef a b c $(sqlTyp') e f (fieldRef') fc mcomments fg|] where- (fieldRef', sqlTyp') = fromMaybe (fieldRef, lift sqlTyp) $- case fieldRef of- ForeignRef refName _ft -> case M.lookup refName entityMap of- Nothing -> Nothing- Just ent ->- case fieldReference $ entityId ent of- fr@(ForeignRef _Name ft) -> Just (fr, lift $ SqlTypeExp ft)- _ -> Nothing- _ -> Nothing+ (fieldRef', sqlTyp') =+ fromMaybe (fieldRef, lift sqlTyp) $+ case fieldRef of+ ForeignRef refName _ft -> do+ ent <- M.lookup refName entityMap+ case fieldReference $ entityId ent of+ fr@(ForeignRef _ ft) ->+ Just (fr, lift $ SqlTypeExp ft)+ _ ->+ Nothing+ _ ->+ Nothing deriving instance Lift EntityDef deriving instance Lift FieldDef +deriving instance Lift FieldAttr+ deriving instance Lift UniqueDef deriving instance Lift CompositeDef@@ -1906,7 +1956,32 @@ , GeneralizedNewtypeDeriving , StandaloneDeriving , UndecidableInstances+ , MultiParamTypeClasses ]++mkSymbolToFieldInstances :: MkPersistSettings -> EntityDef -> Q [Dec]+mkSymbolToFieldInstances mps ed = do+ fmap join $ forM (entityFields ed) $ \fieldDef -> do+ let fieldNameT =+ litT $ strTyLit $ T.unpack $ unHaskellName $ fieldHaskell fieldDef+ :: Q Type+ nameG = mkName $ unpack $ unHaskellName (entityHaskell ed) ++ "Generic"++ recordNameT+ | mpsGeneric mps =+ conT nameG `appT` varT backendName+ | otherwise =+ conT $ mkName $ T.unpack $ unHaskellName $ entityHaskell ed+ fieldTypeT =+ maybeIdType mps fieldDef Nothing Nothing+ entityFieldConstr =+ conE $ filterConName mps ed fieldDef+ :: Q Exp+ [d|+ instance SymbolToField $(fieldNameT) $(recordNameT) $(pure fieldTypeT) where+ symbolToField = $(entityFieldConstr)++ |] -- | Pass in a list of lists of extensions, where any of the given -- extensions will satisfy it. For example, you might need either GADTs or
persistent-template.cabal view
@@ -1,5 +1,5 @@ name: persistent-template-version: 2.9+version: 2.9.1.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -37,7 +37,12 @@ type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test- other-modules: TemplateTestImports+ other-modules: + TemplateTestImports+ , SharedPrimaryKeyTest+ , SharedPrimaryKeyTestImported+ , OverloadedLabelTest+ ghc-options: -Wall build-depends: base >= 4.10 && < 5
+ test/OverloadedLabelTest.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module OverloadedLabelTest where++import TemplateTestImports++mkPersist sqlSettings [persistUpperCase|++User+ name String+ age Int++Dog+ userId UserId+ name String+ age Int++Organization+ name String++|]++spec :: Spec+spec = describe "OverloadedLabels" $ do+ it "works for monomorphic labels" $ do+ let UserName = #name+ OrganizationName = #name+ DogName = #name++ compiles++ it "works for polymorphic labels" $ do+ let name :: _ => EntityField rec a+ name = #name++ UserName = name+ OrganizationName = name+ DogName = name++ compiles++compiles :: Expectation+compiles = True `shouldBe` True
@@ -0,0 +1,57 @@+{-# LANGUAGE TypeApplications, DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DataKinds, FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}++module SharedPrimaryKeyTest where++import TemplateTestImports++import Data.Proxy+import Test.Hspec+import Database.Persist+import Database.Persist.Sql+import Database.Persist.Sql.Util+import Database.Persist.TH++share [ mkPersist sqlSettings ] [persistLowerCase|++User+ name String++-- TODO: uncomment this out https://github.com/yesodweb/persistent/issues/1149+-- Profile+-- Id UserId+-- email String++Profile+ Id (Key User)+ email String++|]++spec :: Spec+spec = describe "Shared Primary Keys" $ do++ describe "PersistFieldSql" $ do+ it "should match underlying key" $ do+ sqlType (Proxy @UserId)+ `shouldBe`+ sqlType (Proxy @ProfileId)++ describe "entityId FieldDef" $ do+ it "should match underlying primary key" $ do+ let getSqlType :: PersistEntity a => Proxy a -> SqlType+ getSqlType =+ fieldSqlType . entityId . entityDef+ getSqlType (Proxy @User)+ `shouldBe`+ getSqlType (Proxy @Profile)
@@ -0,0 +1,54 @@+{-# LANGUAGE TypeApplications, DeriveGeneric #-}+{-# LANGUAGE DataKinds, ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}++module SharedPrimaryKeyTestImported where++import TemplateTestImports++import Data.Proxy+import Test.Hspec+import Database.Persist+import Database.Persist.Sql+import Database.Persist.Sql.Util+import Database.Persist.TH++import SharedPrimaryKeyTest (User, UserId)++share [ mkPersist sqlSettings ] [persistLowerCase|++Profile+ Id UserId+ email String++|]++-- This test is very similar to the one in SharedPrimaryKeyTest, but it is+-- able to use 'UserId' directly, since the type is imported from another+-- module.+spec :: Spec+spec = describe "Shared Primary Keys Imported" $ do++ describe "PersistFieldSql" $ do+ it "should match underlying key" $ do+ sqlType (Proxy @UserId)+ `shouldBe`+ sqlType (Proxy @ProfileId)++ describe "entityId FieldDef" $ do+ it "should match underlying primary key" $ do+ let getSqlType :: PersistEntity a => Proxy a -> SqlType+ getSqlType =+ fieldSqlType . entityId . entityDef+ getSqlType (Proxy @User)+ `shouldBe`+ getSqlType (Proxy @Profile)
test/TemplateTestImports.hs view
@@ -1,10 +1,16 @@ {-# LANGUAGE TemplateHaskell #-}-module TemplateTestImports where +module TemplateTestImports+ ( module TemplateTestImports+ , module X+ ) where+ import Data.Aeson.TH import Test.QuickCheck -import Database.Persist.TH+import Test.Hspec as X+import Database.Persist.Sql as X+import Database.Persist.TH as X data Foo = Bar | Baz deriving (Show, Eq)
test/main.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeApplications, DeriveGeneric, RecordWildCards #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -10,6 +10,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE StandaloneDeriving #-}+{-# language DataKinds #-} -- DeriveAnyClass is not actually used by persistent-template -- But a long standing bug was that if it was enabled, it was used to derive instead of GeneralizedNewtypeDeriving@@ -23,6 +24,8 @@ module Main ) where +import Data.Int+import Data.Proxy import Control.Applicative (Const (..)) import Data.Aeson import Data.ByteString.Lazy.Char8 ()@@ -33,20 +36,32 @@ import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen (Gen) import GHC.Generics (Generic)+import qualified Data.List as List+import Data.Coerce import Database.Persist import Database.Persist.Sql+import Database.Persist.Sql.Util import Database.Persist.TH import TemplateTestImports +import qualified SharedPrimaryKeyTest+import qualified SharedPrimaryKeyTestImported+import qualified OverloadedLabelTest share [mkPersist sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] }, mkDeleteCascade sqlSettings { mpsGeneric = False }] [persistUpperCase|+ Person json name Text age Int Maybe foo Foo address Address deriving Show Eq++HasSimpleCascadeRef+ person PersonId OnDeleteCascade+ deriving Show Eq+ Address json street Text city Text@@ -57,9 +72,41 @@ deriving Show Eq |] --- TODO: Derive Generic at the source site to get this unblocked.-deriving instance Generic (BackendKey SqlBackend)+mkPersist sqlSettings [persistLowerCase|+HasPrimaryDef+ userId Int+ name String+ Primary userId +HasMultipleColPrimaryDef+ foobar Int+ barbaz String+ Primary foobar barbaz++HasIdDef+ Id Int+ name String++HasDefaultId+ name String++HasCustomSqlId+ Id String sql=my_id+ name String++SharedPrimaryKey+ Id (Key HasDefaultId)+ name String++SharedPrimaryKeyWithCascade+ Id (Key HasDefaultId) OnDeleteCascade+ name String++SharedPrimaryKeyWithCascadeAndCustomName+ Id (Key HasDefaultId) OnDeleteCascade sql=my_id+ name String+|]+ share [mkPersist sqlSettings { mpsGeneric = False, mpsGenerateLenses = True }] [persistLowerCase| Lperson json name Text@@ -81,11 +128,204 @@ instance Arbitrary Person where arbitrary = Person <$> arbitraryT <*> arbitrary <*> arbitrary <*> arbitrary+ instance Arbitrary Address where arbitrary = Address <$> arbitraryT <*> arbitraryT <*> arbitrary main :: IO () main = hspec $ do+ OverloadedLabelTest.spec+ SharedPrimaryKeyTest.spec+ SharedPrimaryKeyTestImported.spec+ describe "HasDefaultId" $ do+ let FieldDef{..} =+ entityId (entityDef (Proxy @HasDefaultId))+ it "should have usual db name" $ do+ fieldDB `shouldBe` DBName "id"+ it "should have usual haskell name" $ do+ fieldHaskell `shouldBe` HaskellName "Id"+ it "should have correct underlying sql type" $ do+ fieldSqlType `shouldBe` SqlInt64+ it "persistfieldsql should be right" $ do+ sqlType (Proxy @HasDefaultIdId) `shouldBe` SqlInt64+ it "should have correct haskell type" $ do+ fieldType `shouldBe` FTTypeCon Nothing "HasDefaultIdId"++ describe "HasCustomSqlId" $ do+ let FieldDef{..} =+ entityId (entityDef (Proxy @HasCustomSqlId))+ it "should have custom db name" $ do+ fieldDB `shouldBe` DBName "my_id"+ it "should have usual haskell name" $ do+ fieldHaskell `shouldBe` HaskellName "id"+ it "should have correct underlying sql type" $ do+ fieldSqlType `shouldBe` SqlString+ it "should have correct haskell type" $ do+ fieldType `shouldBe` FTTypeCon Nothing "String"+ describe "HasIdDef" $ do+ let FieldDef{..} =+ entityId (entityDef (Proxy @HasIdDef))+ it "should have usual db name" $ do+ fieldDB `shouldBe` DBName "id"+ it "should have usual haskell name" $ do+ fieldHaskell `shouldBe` HaskellName "id"+ it "should have correct underlying sql type" $ do+ fieldSqlType `shouldBe` SqlInt64+ it "should have correct haskell type" $ do+ fieldType `shouldBe` FTTypeCon Nothing "Int"++ describe "SharedPrimaryKey" $ do+ let sharedDef = entityDef (Proxy @SharedPrimaryKey)+ FieldDef{..} =+ entityId sharedDef+ it "should have usual db name" $ do+ fieldDB `shouldBe` DBName "id"+ it "should have usual haskell name" $ do+ fieldHaskell `shouldBe` HaskellName "id"+ it "should have correct underlying sql type" $ do+ fieldSqlType `shouldBe` SqlInt64+ it "should have correct haskell type" $ do+ fieldType `shouldBe` FTApp (FTTypeCon Nothing "Key") (FTTypeCon Nothing "HasDefaultId")+ it "should have correct sql type from PersistFieldSql" $ do+ sqlType (Proxy @SharedPrimaryKeyId)+ `shouldBe`+ SqlInt64+ it "should have same sqlType as underlying record" $ do+ sqlType (Proxy @SharedPrimaryKeyId)+ `shouldBe`+ sqlType (Proxy @HasDefaultIdId)+ it "should be a coercible newtype" $ do+ coerce @Int64 3+ `shouldBe`+ SharedPrimaryKeyKey (toSqlKey 3)++ it "is a newtype" $ do+ pkNewtype sqlSettings sharedDef+ `shouldBe`+ True++ describe "SharedPrimaryKeyWithCascade" $ do+ let FieldDef{..} =+ entityId (entityDef (Proxy @SharedPrimaryKeyWithCascade))+ it "should have usual db name" $ do+ fieldDB `shouldBe` DBName "id"+ it "should have usual haskell name" $ do+ fieldHaskell `shouldBe` HaskellName "id"+ it "should have correct underlying sql type" $ do+ fieldSqlType `shouldBe` SqlInt64+ it "should have correct haskell type" $ do+ fieldType+ `shouldBe`+ FTApp (FTTypeCon Nothing "Key") (FTTypeCon Nothing "HasDefaultId")+ it "should have cascade in field def" $ do+ fieldCascade `shouldBe` noCascade { fcOnDelete = Just Cascade }++ describe "OnCascadeDelete" $ do+ let subject :: FieldDef+ Just subject =+ List.find ((HaskellName "person" ==) . fieldHaskell)+ $ entityFields+ $ simpleCascadeDef+ simpleCascadeDef =+ entityDef (Proxy :: Proxy HasSimpleCascadeRef)+ expected =+ FieldCascade+ { fcOnDelete = Just Cascade+ , fcOnUpdate = Nothing+ }+ describe "entityDef" $ do+ it "works" $ do+ simpleCascadeDef+ `shouldBe`+ EntityDef+ { entityHaskell = HaskellName "HasSimpleCascadeRef"+ , entityDB = DBName "HasSimpleCascadeRef"+ , entityId =+ FieldDef+ { fieldHaskell = HaskellName "Id"+ , fieldDB = DBName "id"+ , fieldType = FTTypeCon Nothing "HasSimpleCascadeRefId"+ , fieldSqlType = SqlInt64+ , fieldReference =+ ForeignRef (HaskellName "HasSimpleCascadeRef") (FTTypeCon (Just "Data.Int") "Int64")+ , fieldAttrs = []+ , fieldStrict = True+ , fieldComments = Nothing+ , fieldCascade = noCascade+ , fieldGenerated = Nothing+ }+ , entityAttrs = []+ , entityFields =+ [ FieldDef+ { fieldHaskell = HaskellName "person"+ , fieldDB = DBName "person"+ , fieldType = FTTypeCon Nothing "PersonId"+ , fieldSqlType = SqlInt64+ , fieldAttrs = []+ , fieldStrict = True+ , fieldReference =+ ForeignRef+ (HaskellName "Person")+ (FTTypeCon (Just "Data.Int") "Int64")+ , fieldCascade =+ FieldCascade { fcOnUpdate = Nothing, fcOnDelete = Just Cascade }+ , fieldComments = Nothing+ , fieldGenerated = Nothing+ }+ ]+ , entityUniques = []+ , entityForeigns = []+ , entityDerives = ["Show", "Eq"]+ , entityExtra = mempty+ , entitySum = False+ , entityComments = Nothing+ }+ it "has the cascade on the field def" $ do+ fieldCascade subject `shouldBe` expected+ it "doesn't have any extras" $ do+ entityExtra simpleCascadeDef+ `shouldBe`+ mempty++ describe "hasNaturalKey" $ do+ let subject :: PersistEntity a => Proxy a -> Bool+ subject p = hasNaturalKey (entityDef p)+ it "is True for Primary keyword" $ do+ subject (Proxy @HasPrimaryDef)+ `shouldBe`+ True+ it "is True for multiple Primary columns " $ do+ subject (Proxy @HasMultipleColPrimaryDef)+ `shouldBe`+ True+ it "is False for Id keyword" $ do+ subject (Proxy @HasIdDef)+ `shouldBe`+ False+ it "is False for unspecified/default id" $ do+ subject (Proxy @HasDefaultId)+ `shouldBe`+ False+ describe "hasCompositePrimaryKey" $ do+ let subject :: PersistEntity a => Proxy a -> Bool+ subject p = hasCompositePrimaryKey (entityDef p)+ it "is False for Primary with single column" $ do+ subject (Proxy @HasPrimaryDef)+ `shouldBe`+ False+ it "is True for multiple Primary columns " $ do+ subject (Proxy @HasMultipleColPrimaryDef)+ `shouldBe`+ True+ it "is False for Id keyword" $ do+ subject (Proxy @HasIdDef)+ `shouldBe`+ False+ it "is False for unspecified/default id" $ do+ subject (Proxy @HasDefaultId)+ `shouldBe`+ False+ describe "JSON serialization" $ do prop "to/from is idempotent" $ \person -> decode (encode person) == Just (person :: Person)