persistent 2.12.1.1 → 2.12.1.2
raw patch · 8 files changed
+304/−189 lines, 8 files
Files
- ChangeLog.md +13/−0
- Database/Persist/Class/PersistUnique.hs +1/−1
- Database/Persist/Quasi.hs +16/−8
- Database/Persist/TH.hs +205/−135
- Database/Persist/Types/Base.hs +1/−0
- persistent.cabal +1/−1
- test/Database/Persist/THSpec.hs +4/−2
- test/main.hs +63/−42
ChangeLog.md view
@@ -1,5 +1,18 @@ # Changelog for persistent +## Unreleased++## 2.12.1.2++* [#1258](https://github.com/yesodweb/persistent/pull/1258)+ * Support promoted types in Quasi Quoter+* [#1243](https://github.com/yesodweb/persistent/pull/1243)+ * Assorted cleanup of TH module+* [#1242](https://github.com/yesodweb/persistent/pull/1242)+ * Refactor setEmbedField to use do notation+* [#1237](https://github.com/yesodweb/persistent/pull/1237)+ * Remove nonEmptyOrFail function from recent tests+ ## 2.12.1.1 * [#1231](https://github.com/yesodweb/persistent/pull/1231)
Database/Persist/Class/PersistUnique.hs view
@@ -297,7 +297,7 @@ -- | Given a proxy for a 'PersistEntity' record, this returns the sole -- 'UniqueDef' for that entity. ----- @since 2.10.0+-- @since TODO release me onlyOneUniqueDef :: (OnlyOneUniqueKey record, Monad proxy) => proxy record
Database/Persist/Quasi.hs view
@@ -486,21 +486,29 @@ | isSpace c -> parse1 $ T.dropWhile isSpace t' | c == '(' -> parseEnclosed ')' id t' | c == '[' -> parseEnclosed ']' FTList t'- | isUpper c ->- let (a, b) = T.break (\x -> isSpace x || x `elem` ("()[]"::String)) t- in PSSuccess (getCon a) b+ | isUpper c || c == '\'' ->+ let (a, b) = T.break (\x -> isSpace x || x `elem` ("()[]"::String)) t'+ in PSSuccess (parseFieldTypePiece c a) b | otherwise -> PSFail $ show (c, t')- getCon t =- case T.breakOnEnd "." t of- (_, "") -> FTTypeCon Nothing t- ("", _) -> FTTypeCon Nothing t- (a, b) -> FTTypeCon (Just $ T.init a) b+ goMany front t = case parse1 t of PSSuccess x t' -> goMany (front . (x:)) t' PSFail err -> PSFail err PSDone -> PSSuccess (front []) t -- _ ->++parseFieldTypePiece :: Char -> Text -> FieldType+parseFieldTypePiece fstChar rest =+ case fstChar of+ '\'' ->+ FTTypePromoted rest+ _ ->+ let t = T.cons fstChar rest+ in case T.breakOnEnd "." t of+ (_, "") -> FTTypeCon Nothing t+ ("", _) -> FTTypeCon Nothing t+ (a, b) -> FTTypeCon (Just $ T.init a) b data PersistSettings = PersistSettings { psToDBName :: !(Text -> Text)
Database/Persist/TH.hs view
@@ -1,18 +1,18 @@-{-# LANGUAGE CPP, BangPatterns #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE ViewPatterns #-} -- {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-} @@ -61,48 +61,55 @@ -- Development Tip: See persistent-template/README.md for advice on seeing generated Template Haskell code -- It's highly recommended to check the diff between master and your PR's generated code. -import Prelude hiding ((++), take, concat, splitAt, exp)+import Prelude hiding (concat, exp, splitAt, take, (++)) -import Data.Either import Control.Monad import Data.Aeson- ( ToJSON (toJSON), FromJSON (parseJSON), (.=), object- , Value (Object), (.:), (.:?)- , eitherDecodeStrict'- )+ ( FromJSON(parseJSON)+ , ToJSON(toJSON)+ , Value(Object)+ , eitherDecodeStrict'+ , object+ , (.:)+ , (.:?)+ , (.=)+ ) import qualified Data.ByteString as BS-import Data.Typeable (Typeable)-import Data.Ix (Ix)-import Data.Data (Data) import Data.Char (toLower, toUpper)+import Data.Data (Data)+import Data.Either import qualified Data.HashMap.Strict as HM import Data.Int (Int64)+import Data.Ix (Ix) import Data.List (foldl') import qualified Data.List as List import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M-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, stripSuffix)+import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe)+import Data.Monoid (mappend, mconcat, (<>))+import Data.Proxy (Proxy(Proxy))+import Data.Text (Text, append, concat, cons, pack, stripSuffix, uncons, unpack) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import qualified Data.Text.Encoding as TE+import Data.Typeable (Typeable) import GHC.Generics (Generic) import GHC.TypeLits 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 (appT, varT, conK, conT, varE, varP, conE, litT, strTyLit)+import qualified Data.Set as Set+import Language.Haskell.TH.Lib+ (appT, conE, conK, conT, litT, strTyLit, varE, varP, varT) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax+import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..)) import Web.PathPieces (PathPiece(..))-import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..))-import qualified Data.Set as Set import Database.Persist-import Database.Persist.Sql (Migration, PersistFieldSql, SqlBackend, migrate, sqlType) import Database.Persist.Quasi+import Database.Persist.Sql+ (Migration, PersistFieldSql, SqlBackend, migrate, sqlType) -- | Converts a quasi-quoted syntax into a list of entity definitions, to be -- used as input to the template haskell generation code (mkPersist).@@ -191,7 +198,7 @@ embedEntityDefsMap :: [EntityDef] -> (M.Map EntityNameHS EmbedEntityDef, [EntityDef]) embedEntityDefsMap rawEnts = (embedEntityMap, noCycleEnts) where- noCycleEnts = map breakCycleEnt entsWithEmbeds+ noCycleEnts = map breakEntDefCycle entsWithEmbeds -- every EntityDef could reference each-other (as an EmbedRef) -- let Haskell tie the knot embedEntityMap = constructEmbedEntityMap entsWithEmbeds@@ -200,12 +207,15 @@ { entityFields = map (setEmbedField (entityHaskell ent) embedEntityMap) $ entityFields ent } - -- self references are already broken- -- look at every emFieldEmbed to see if it refers to an already seen EntityNameHS- -- so start with entityHaskell ent and accumulate embeddedHaskell em- breakCycleEnt entDef =- let entName = entityHaskell entDef- in entDef { entityFields = map (breakCycleField entName) $ entityFields entDef }+-- self references are already broken+-- look at every emFieldEmbed to see if it refers to an already seen EntityNameHS+-- so start with entityHaskell ent and accumulate embeddedHaskell em+breakEntDefCycle :: EntityDef -> EntityDef+breakEntDefCycle entDef =+ entDef { entityFields = breakCycleField entName <$> entityFields entDef }+ where+ entName =+ entityHaskell entDef breakCycleField entName f = case f of FieldDef { fieldReference = EmbedRef em } ->@@ -306,6 +316,12 @@ constructEmbedEntityMap = M.fromList . fmap (\ent -> (entityHaskell ent, toEmbedEntityDef ent)) +lookupEmbedEntity :: EmbedEntityMap -> FieldDef -> Maybe EntityNameHS+lookupEmbedEntity allEntities field = do+ entName <- EntityNameHS <$> stripId (fieldType field)+ guard (M.member entName allEntities) -- check entity name exists in embed map+ pure entName+ type EntityMap = M.Map EntityNameHS EntityDef constructEntityMap :: [EntityDef] -> EntityMap@@ -333,6 +349,8 @@ Left Nothing mEmbedded ents (FTTypeCon Nothing (EntityNameHS -> name)) = maybe (Left Nothing) Right $ M.lookup name ents+mEmbedded ents (FTTypePromoted (EntityNameHS -> name)) =+ Left Nothing mEmbedded ents (FTList x) = mEmbedded ents x mEmbedded ents (FTApp x y) =@@ -344,36 +362,30 @@ else mEmbedded ents y setEmbedField :: EntityNameHS -> EmbedEntityMap -> FieldDef -> FieldDef-setEmbedField entName allEntities field = field- { fieldReference =- case fieldReference field of- NoReference ->- case mEmbedded allEntities (fieldType field) of- Left _ ->- case stripId $ fieldType field of- Nothing ->- NoReference- Just name ->- case M.lookup (EntityNameHS name) allEntities of- Nothing ->- NoReference- Just _ ->- ForeignRef- (EntityNameHS name)- -- This can get corrected in mkEntityDefSqlTypeExp- (FTTypeCon (Just "Data.Int") "Int64")- Right em ->- if embeddedHaskell em /= entName- then EmbedRef em- else if maybeNullable field- then SelfReference- else case fieldType field of- FTList _ -> SelfReference- _ -> error $ unpack $ unEntityNameHS entName <> ": a self reference must be a Maybe"- existing ->- existing- }+setEmbedField entName allEntities field =+ case fieldReference field of+ NoReference -> setFieldReference ref field+ _ -> field+ where+ ref =+ case mEmbedded allEntities (fieldType field) of+ Left _ -> fromMaybe NoReference $ do+ entName <- lookupEmbedEntity allEntities field+ -- This can get corrected in mkEntityDefSqlTypeExp+ let placeholderIdType = FTTypeCon (Just "Data.Int") "Int64"+ pure $ ForeignRef entName placeholderIdType+ Right em ->+ if embeddedHaskell em /= entName+ then EmbedRef em+ else if maybeNullable field+ then SelfReference+ else case fieldType field of+ FTList _ -> SelfReference+ _ -> error $ unpack $ unEntityNameHS entName <> ": a self reference must be a Maybe" +setFieldReference :: ReferenceDef -> FieldDef -> FieldDef+setFieldReference ref field = field { fieldReference = ref }+ mkEntityDefSqlTypeExp :: EmbedEntityMap -> EntityMap -> EntityDef -> EntityDefSqlTypeExp mkEntityDefSqlTypeExp emEntities entityMap ent = EntityDefSqlTypeExp ent (getSqlType $ entityId ent) (map getSqlType $ entityFields ent)@@ -543,22 +555,6 @@ sqlSettings :: MkPersistSettings sqlSettings = mkPersistSettings $ ConT ''SqlBackend -recNameNoUnderscore :: MkPersistSettings -> EntityNameHS -> FieldNameHS -> Text-recNameNoUnderscore mps entName fieldName- | mpsPrefixFields mps = lowerFirst $ modifier (unEntityNameHS entName) (upperFirst ft)- | otherwise = lowerFirst ft- where- modifier = mpsFieldLabelModifier mps- ft = unFieldNameHS fieldName--recNameF :: MkPersistSettings -> EntityNameHS -> FieldNameHS -> Text-recNameF mps entName fieldName =- addUnderscore $ recNameNoUnderscore mps entName fieldName- where- addUnderscore- | mpsGenerateLenses mps = ("_" ++)- | otherwise = id- lowerFirst :: Text -> Text lowerFirst t = case uncons t of@@ -668,11 +664,12 @@ , "on the end of the line that defines your uniqueness " , "constraint in order to disable this check. ***" ] -maybeIdType :: MkPersistSettings- -> FieldDef- -> Maybe Name -- ^ backend- -> Maybe IsNullable- -> Type+maybeIdType+ :: MkPersistSettings+ -> FieldDef+ -> Maybe Name -- ^ backend+ -> Maybe IsNullable+ -> Type maybeIdType mps fieldDef mbackend mnull = maybeTyp mayNullable idtyp where mayNullable = case mnull of@@ -745,7 +742,6 @@ ] return $ normalClause [ConP name [VarP x]] body - mkToFieldNames :: [UniqueDef] -> Q Dec mkToFieldNames pairs = do pairs' <- mapM go pairs@@ -1077,18 +1073,18 @@ mkEntity :: EntityMap -> MkPersistSettings -> EntityDef -> Q [Dec] mkEntity entityMap mps entDef = do+ fields <- mkFields mps entDef entityDefExp <- if mpsGeneric mps then liftAndFixKeys entityMap entDef else makePersistEntityDefExp mps entityMap entDef+ let name = mkEntityDefName entDef let clazz = ConT ''PersistEntity `AppT` genDataType tpf <- mkToPersistFields mps entDef fpv <- mkFromPersistValues mps entDef utv <- mkUniqueToValues $ entityUniques entDef puk <- mkUniqueKeys entDef- let primaryField = entityId entDef- fields <- mapM (mkField mps entDef) $ primaryField : entityFields entDef fkc <- mapM (mkForeignKeysComposite mps entDef) $ entityForeigns entDef toFieldNames <- mkToFieldNames $ entityUniques entDef@@ -1132,9 +1128,11 @@ [d|$(varP 'keyFromRecordM) = Nothing|] dtd <- dataTypeDec mps entDef+ let allEntDefs = entityFieldTHCon <$> efthAllFields fields+ allEntDefClauses = entityFieldTHClause <$> efthAllFields fields return $ addSyn $ dtd : mconcat fkc `mappend`- ([ TySynD (keyIdName entDef) [] $+ ( [ TySynD (keyIdName entDef) [] $ ConT ''Key `AppT` ConT name , instanceD instanceConstraint clazz [ uniqueTypeDec mps entDef@@ -1154,7 +1152,7 @@ Nothing (AppT (AppT (ConT ''EntityField) genDataType) (VarT $ mkName "typ")) Nothing- (map fst fields)+ allEntDefs [] #else , DataInstD@@ -1164,10 +1162,10 @@ , VarT $ mkName "typ" ] Nothing- (map fst fields)+ allEntDefs [] #endif- , FunD 'persistFieldDef (map snd fields)+ , FunD 'persistFieldDef allEntDefClauses #if MIN_VERSION_template_haskell(2,15,0) , TySynInstD (TySynEqn@@ -1189,6 +1187,20 @@ genDataType = genericDataType mps entName backendT entName = entityHaskell entDef +data EntityFieldsTH = EntityFieldsTH+ { entityFieldsTHPrimary :: EntityFieldTH+ , entityFieldsTHFields :: [EntityFieldTH]+ }++efthAllFields :: EntityFieldsTH -> [EntityFieldTH]+efthAllFields EntityFieldsTH{..} = entityFieldsTHPrimary : entityFieldsTHFields++mkFields :: MkPersistSettings -> EntityDef -> Q EntityFieldsTH+mkFields mps entDef =+ EntityFieldsTH+ <$> mkField mps entDef (entityId entDef)+ <*> mapM (mkField mps entDef) (entityFields entDef)+ mkUniqueKeyInstances :: MkPersistSettings -> EntityDef -> Q [Dec] mkUniqueKeyInstances mps entDef = do requirePersistentExtensions@@ -1267,7 +1279,7 @@ mkLenses mps _ | not (mpsGenerateLenses mps) = return [] mkLenses _ ent | entitySum ent = return [] mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do- let lensName = mkName $ T.unpack $ recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field)+ let lensName = mkEntityLensName mps ent field fieldName = fieldDefToRecordName mps ent field needleN <- newName "needle" setterN <- newName "setter"@@ -1344,18 +1356,17 @@ maybeTyp may typ | may = ConT ''Maybe `AppT` typ | otherwise = typ -- entityToPersistValueHelper :: (PersistEntity record) => record -> PersistValue entityToPersistValueHelper entity = PersistMap $ zip columnNames fieldsAsPersistValues where columnNames = map (unFieldNameHS . fieldHaskell) (entityFields (entityDef (Just entity))) fieldsAsPersistValues = map toPersistValue $ toPersistFields entity -entityFromPersistValueHelper :: (PersistEntity record)- => [String] -- ^ Column names, as '[String]' to avoid extra calls to "pack" in the generated code- -> PersistValue- -> Either Text record+entityFromPersistValueHelper+ :: (PersistEntity record)+ => [String] -- ^ Column names, as '[String]' to avoid extra calls to "pack" in the generated code+ -> PersistValue+ -> Either Text record entityFromPersistValueHelper columnNames pv = do (persistMap :: [(T.Text, PersistValue)]) <- getPersistMap pv @@ -1463,8 +1474,6 @@ val (Nullable ByMaybeAttr) = just `AppE` VarE key val _ = VarE key -- let stmts :: [Stmt] stmts = map mkStmt deps `mappend` [NoBindS $ del `AppE` VarE key]@@ -1542,9 +1551,12 @@ sqlTypeFunD st = FunD 'sqlType [ normalClause [WildP] st ] -typeInstanceD :: Name- -> Bool -- ^ include PersistStore backend constraint- -> Type -> [Dec] -> Dec+typeInstanceD+ :: Name+ -> Bool -- ^ include PersistStore backend constraint+ -> Type+ -> [Dec]+ -> Dec typeInstanceD clazz hasBackend typ = instanceD ctx (ConT clazz `AppT` typ) where@@ -1696,29 +1708,41 @@ |] liftAndFixKey :: EntityMap -> FieldDef -> Q Exp-liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef fc mcomments fg) =- [|FieldDef a b c $(sqlTyp') e f (fieldRef') fc mcomments fg|]+liftAndFixKey entityMap fieldDef@(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 -> do- ent <- M.lookup refName entityMap- case fieldReference $ entityId ent of- fr@(ForeignRef _ ft) ->- Just (fr, lift $ SqlTypeExp ft)- _ ->- Nothing+ (fieldRef', sqlTyp') =+ case extractForeignRef entityMap fieldDef of+ Just (fr, ft) ->+ (fr, lift (SqlTypeExp ft))+ Nothing ->+ (fieldRef, lift sqlTyp)++extractForeignRef :: EntityMap -> FieldDef -> Maybe (ReferenceDef, FieldType)+extractForeignRef entityMap fieldDef =+ case fieldReference fieldDef of+ ForeignRef refName _ft -> do+ ent <- M.lookup refName entityMap+ case fieldReference $ entityId ent of+ fr@(ForeignRef _ ft) ->+ Just (fr, ft) _ -> Nothing+ _ ->+ Nothing +data EntityFieldTH = EntityFieldTH+ { entityFieldTHCon :: Con+ , entityFieldTHClause :: Clause+ }+ -- Ent -- fieldName FieldType -- -- forall . typ ~ FieldType => EntFieldName -- -- EntFieldName = FieldDef ....-mkField :: MkPersistSettings -> EntityDef -> FieldDef -> Q (Con, Clause)+mkField :: MkPersistSettings -> EntityDef -> FieldDef -> Q EntityFieldTH mkField mps et cd = do let con = ForallC []@@ -1728,7 +1752,7 @@ let cla = normalClause [ConP name []] bod- return (con, cla)+ return $ EntityFieldTH con cla where name = filterConName mps et cd @@ -1736,13 +1760,21 @@ maybeNullable fd = nullable (fieldAttrs fd) == Nullable ByMaybeAttr ftToType :: FieldType -> Type-ftToType (FTTypeCon Nothing t) = ConT $ mkName $ unpack t--- This type is generated from the Quasi-Quoter.--- Adding this special case avoids users needing to import Data.Int-ftToType (FTTypeCon (Just "Data.Int") "Int64") = ConT ''Int64-ftToType (FTTypeCon (Just m) t) = ConT $ mkName $ unpack $ concat [m, ".", t]-ftToType (FTApp x y) = ftToType x `AppT` ftToType y-ftToType (FTList x) = ListT `AppT` ftToType x+ftToType = \case+ FTTypeCon Nothing t ->+ ConT $ mkName $ T.unpack t+ -- This type is generated from the Quasi-Quoter.+ -- Adding this special case avoids users needing to import Data.Int+ FTTypeCon (Just "Data.Int") "Int64" ->+ ConT ''Int64+ FTTypeCon (Just m) t ->+ ConT $ mkName $ unpack $ concat [m, ".", t]+ FTTypePromoted t ->+ PromotedT $ mkName $ T.unpack t+ FTApp x y ->+ ftToType x `AppT` ftToType y+ FTList x ->+ ListT `AppT` ftToType x infixr 5 ++ (++) :: Text -> Text -> Text@@ -1764,7 +1796,7 @@ xs <- mapM fieldToJSONValName (entityFields def) - let conName = mkName $ unpack $ unEntityNameHS $ entityHaskell def+ let conName = mkEntityDefName def typ = genericDataType mps (entityHaskell def) backendT toJSONI = typeInstanceD ''ToJSON (mpsGeneric mps) typ [toJSON'] toJSON' = FunD 'toJSON $ return $ normalClause@@ -1838,7 +1870,6 @@ -- pu' <- lift pu -- return $ normalClause [RecP (mkName constr) []] pu' - -- mkToFieldName :: String -> [(String, String)] -> Dec -- mkToFieldName func pairs = -- FunD (mkName func) $ degen $ map go pairs@@ -1965,12 +1996,48 @@ -- -- This would generate `customerName` as a TH Name fieldNameToRecordName :: MkPersistSettings -> EntityDef -> FieldNameHS -> Name-fieldNameToRecordName mps entDef fieldName = mkName $ T.unpack $ recNameF mps (entityHaskell entDef) fieldName+fieldNameToRecordName mps entDef fieldName =+ mkRecordName mps mUnderscore (entityHaskell entDef) fieldName+ where+ mUnderscore+ | mpsGenerateLenses mps = Just "_"+ | otherwise = Nothing -- | as above, only takes a `FieldDef` fieldDefToRecordName :: MkPersistSettings -> EntityDef -> FieldDef -> Name-fieldDefToRecordName mps entDef fieldDef = fieldNameToRecordName mps entDef (fieldHaskell fieldDef)+fieldDefToRecordName mps entDef fieldDef =+ fieldNameToRecordName mps entDef (fieldHaskell fieldDef) +-- | creates a TH Name for a lens on an entity's field, based on the entity+-- name and the field name, so as above but for the Lens+--+-- Customer+-- name Text+--+-- Generates a lens `customerName` when `mpsGenerateLenses` is true+-- while `fieldNameToRecordName` generates a prefixed function+-- `_customerName`+mkEntityLensName :: MkPersistSettings -> EntityDef -> FieldDef -> Name+mkEntityLensName mps entDef fieldDef =+ mkRecordName mps Nothing (entityHaskell entDef) (fieldHaskell fieldDef)++mkRecordName :: MkPersistSettings -> Maybe Text -> EntityNameHS -> FieldNameHS -> Name+mkRecordName mps prefix entNameHS fieldNameHS =+ mkName $ T.unpack $ fromMaybe "" prefix <> lowerFirst recName+ where+ recName :: Text+ recName+ | mpsPrefixFields mps = mpsFieldLabelModifier mps entityNameText (upperFirst fieldNameText)+ | otherwise = fieldNameText++ entityNameText :: Text+ entityNameText =+ unEntityNameHS entNameHS++ fieldNameText :: Text+ fieldNameText =+ unFieldNameHS fieldNameHS+ -- | Construct a list of TH Names for the typeclasses of an EntityDef's `entityDerives` mkEntityDefDeriveNames :: MkPersistSettings -> EntityDef -> [Name] mkEntityDefDeriveNames mps entDef =@@ -2047,22 +2114,25 @@ | pkNewtype mps entDef = unKeyName entDef | otherwise = mkName $ T.unpack $ lowerFirst (keyText entDef) `mappend` unFieldNameHS (fieldHaskell fieldDef) -filterConName :: MkPersistSettings- -> EntityDef- -> FieldDef- -> Name+filterConName+ :: MkPersistSettings+ -> EntityDef+ -> FieldDef+ -> Name filterConName mps entity field = filterConName' mps (entityHaskell entity) (fieldHaskell field) -filterConName' :: MkPersistSettings- -> EntityNameHS- -> FieldNameHS- -> Name+filterConName'+ :: MkPersistSettings+ -> EntityNameHS+ -> FieldNameHS+ -> Name filterConName' mps entity field = mkName $ T.unpack name where name | field == FieldNameHS "Id" = entityName ++ fieldName | mpsPrefixFields mps = modifiedName | otherwise = fieldName+ modifiedName = mpsConstraintLabelModifier mps entityName fieldName- entityName = unEntityNameHS entity- fieldName = upperFirst $ unFieldNameHS field+ entityName = unEntityNameHS entity+ fieldName = upperFirst $ unFieldNameHS field
Database/Persist/Types/Base.hs view
@@ -264,6 +264,7 @@ data FieldType = FTTypeCon (Maybe Text) Text -- ^ Optional module and name.+ | FTTypePromoted Text | FTApp FieldType FieldType | FTList FieldType deriving (Show, Eq, Read, Ord, Lift)
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.12.1.1+version: 2.12.1.2 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>
test/Database/Persist/THSpec.hs view
@@ -42,9 +42,10 @@ import Database.Persist.TH import TemplateTestImports -import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpec-import qualified Database.Persist.TH.SharedPrimaryKeyImportedSpec as SharedPrimaryKeyImportedSpec+import qualified Database.Persist.TH.KindEntitiesSpec as KindEntitiesSpec import qualified Database.Persist.TH.OverloadedLabelSpec as OverloadedLabelSpec+import qualified Database.Persist.TH.SharedPrimaryKeyImportedSpec as SharedPrimaryKeyImportedSpec+import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpec share [mkPersist sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] }, mkDeleteCascade sqlSettings { mpsGeneric = False }] [persistUpperCase| @@ -131,6 +132,7 @@ spec :: Spec spec = do+ KindEntitiesSpec.spec OverloadedLabelSpec.spec SharedPrimaryKeySpec.spec SharedPrimaryKeyImportedSpec.spec
test/main.hs view
@@ -3,23 +3,23 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -import Test.Hspec-import Test.Hspec.QuickCheck-import Test.QuickCheck import qualified Data.Char as Char-import qualified Data.Text as T import Data.List import Data.List.NonEmpty (NonEmpty(..), (<|)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map+import qualified Data.Text as T+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck #if !MIN_VERSION_base(4,11,0) -- This can be removed when GHC < 8.2.2 isn't supported anymore import Data.Semigroup ((<>)) #endif-import Data.Time-import Text.Shakespeare.Text import Data.Aeson import qualified Data.ByteString.Char8 as BS8+import Data.Time+import Text.Shakespeare.Text import Database.Persist.Class.PersistField import Database.Persist.Quasi@@ -54,32 +54,36 @@ `shouldBe` ( [NEL.toList helloWorldTokens, NEL.toList foobarbazTokens], mempty ) it "works4" $ do- let foobarbarz = ["foo", "Bar", "baz"]- fbbTokens = Token <$> nonEmptyOrFail foobarbarz splitExtras- [ Line 0 (pure (Token "Hello"))- , Line 2 fbbTokens- , Line 2 fbbTokens+ [ Line 0 [Token "Product"]+ , Line 2 (Token <$> ["name", "Text"])+ , Line 2 (Token <$> ["added", "UTCTime", "default=CURRENT_TIMESTAMP"]) ] `shouldBe` ( [] , Map.fromList- [ ("Hello", [foobarbarz, foobarbarz])- ]+ [ ("Product",+ [ ["name", "Text"]+ , ["added", "UTCTime", "default=CURRENT_TIMESTAMP"]+ ]+ ) ] ) it "works5" $ do- let foobarbarz = ["foo", "Bar", "baz"]- fbbTokens = Token <$> nonEmptyOrFail foobarbarz splitExtras- [ Line 0 (pure (Token "Hello"))- , Line 2 fbbTokens- , Line 4 fbbTokens+ [ Line 0 [Token "Product"]+ , Line 2 (Token <$> ["name", "Text"])+ , Line 4 [Token "ExtraBlock"]+ , Line 4 (Token <$> ["added", "UTCTime", "default=CURRENT_TIMESTAMP"]) ] `shouldBe` ( [] , Map.fromList- [ ("Hello", [foobarbarz, foobarbarz])- ]+ [ ("Product",+ [ ["name", "Text"]+ , ["ExtraBlock"]+ , ["added", "UTCTime", "default=CURRENT_TIMESTAMP"]+ ]+ )] ) describe "takeColsEx" $ do let subject = takeColsEx upperCaseSettings@@ -140,7 +144,7 @@ it "handles normal words" $ parseLine " foo bar baz" `shouldBe` Just- ( Line 1 $ nonEmptyOrFail+ ( Line 1 [ Token "foo" , Token "bar" , Token "baz"@@ -150,7 +154,7 @@ it "handles quotes" $ parseLine " \"foo bar\" \"baz\"" `shouldBe` Just- ( Line 2 $ nonEmptyOrFail+ ( Line 2 [ Token "foo bar" , Token "baz" ]@@ -159,7 +163,7 @@ it "handles quotes mid-token" $ parseLine " x=\"foo bar\" \"baz\"" `shouldBe` Just- ( Line 2 $ nonEmptyOrFail+ ( Line 2 [ Token "x=foo bar" , Token "baz" ]@@ -168,7 +172,7 @@ it "handles escaped quote mid-token" $ parseLine " x=\\\"foo bar\" \"baz\"" `shouldBe` Just- ( Line 2 $ nonEmptyOrFail+ ( Line 2 [ Token "x=\\\"foo" , Token "bar\"" , Token "baz"@@ -178,7 +182,7 @@ it "handles unnested parantheses" $ parseLine " (foo bar) (baz)" `shouldBe` Just- ( Line 2 $ nonEmptyOrFail+ ( Line 2 [ Token "foo bar" , Token "baz" ]@@ -187,7 +191,7 @@ it "handles unnested parantheses mid-token" $ parseLine " x=(foo bar) (baz)" `shouldBe` Just- ( Line 2 $ nonEmptyOrFail+ ( Line 2 [ Token "x=foo bar" , Token "baz" ]@@ -196,7 +200,7 @@ it "handles nested parantheses" $ parseLine " (foo (bar)) (baz)" `shouldBe` Just- ( Line 2 $ nonEmptyOrFail+ ( Line 2 [ Token "foo (bar)" , Token "baz" ]@@ -205,7 +209,7 @@ it "escaping" $ parseLine " (foo \\(bar) y=\"baz\\\"\"" `shouldBe` Just- ( Line 2 $ nonEmptyOrFail+ ( Line 2 [ Token "foo (bar" , Token "y=baz\"" ]@@ -214,7 +218,7 @@ it "mid-token quote in later token" $ parseLine "foo bar baz=(bin\")" `shouldBe` Just- ( Line 0 $ nonEmptyOrFail+ ( Line 0 [ Token "foo" , Token "bar" , Token "baz=bin\""@@ -225,13 +229,14 @@ it "recognizes one line" $ do parseLine "-- | this is a comment" `shouldBe` Just- ( Line 0 $ pure- (DocComment "this is a comment")+ ( Line 0+ [ DocComment "this is a comment"+ ] ) it "works if comment is indented" $ do parseLine " -- | comment" `shouldBe`- Just (Line 2 (pure (DocComment "comment")))+ Just (Line 2 [DocComment "comment"]) describe "parse" $ do let subject =@@ -358,6 +363,28 @@ entityComments car `shouldBe` Just "This is a Car\n" entityComments vehicle `shouldBe` Nothing + describe "ticked types" $ do+ it "should be able to parse ticked types" $ do+ let simplifyField field =+ (fieldHaskell field, fieldType field)+ let tickedDefinition = [st|+CustomerTransfer+ customerId CustomerId+ moneyAmount (MoneyAmount 'Customer 'Debit)+ currencyCode CurrencyCode+ uuid TransferUuid+|]+ let [customerTransfer] = parse lowerCaseSettings tickedDefinition+ let expectedType =+ FTTypeCon Nothing "MoneyAmount" `FTApp` FTTypePromoted "Customer" `FTApp` FTTypePromoted "Debit"++ (simplifyField <$> entityFields customerTransfer) `shouldBe`+ [ (FieldNameHS "customerId", FTTypeCon Nothing "CustomerId")+ , (FieldNameHS "moneyAmount", expectedType)+ , (FieldNameHS "currencyCode", FTTypeCon Nothing "CurrencyCode")+ , (FieldNameHS "uuid", FTTypeCon Nothing "TransferUuid")+ ]+ describe "parseFieldType" $ do it "simple types" $ parseFieldType "FooBar" `shouldBe` Right (FTTypeCon Nothing "FooBar")@@ -576,10 +603,10 @@ , " name String" ] expected =- Line { lineIndent = 0, tokens = pure (DocComment "Model") } :|- [ Line { lineIndent = 0, tokens = pure (Token "Foo") }- , Line { lineIndent = 2, tokens = pure (DocComment "Field") }- , Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] }+ Line { lineIndent = 0, tokens = [DocComment "Model"] } :|+ [ Line { lineIndent = 0, tokens = [Token "Foo"] }+ , Line { lineIndent = 2, tokens = [DocComment "Field"] }+ , Line { lineIndent = 2, tokens = (Token <$> ["name", "String"]) } ] preparse text `shouldBe` Just expected @@ -880,12 +907,6 @@ takePrefix :: Value -> Value takePrefix (String a) = String (T.take 1 a) takePrefix a = a--nonEmptyOrFail :: [a] -> NonEmpty a-nonEmptyOrFail = maybe failure id . NEL.nonEmpty- where- failure =- error "nonEmptyOrFail expected a non empty list" arbitraryWhiteSpaceChar :: Gen Char arbitraryWhiteSpaceChar =