persistent-template 2.1.8.1 → 2.12.0.0
raw patch · 5 files changed
Files
- ChangeLog.md +154/−3
- Database/Persist/TH.hs +0/−1636
- README.md +19/−1
- persistent-template.cabal +6/−37
- test/main.hs +0/−104
ChangeLog.md view
@@ -1,15 +1,166 @@-## 2.1.8.1+## Unreleased changes +## 2.12.0.0++* Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174)+* [#1214](https://github.com/yesodweb/persistent/pull/1214):+ * This package was asborbed into `persistent` itself.++## 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)+ * This fixes a regression from 2.8.0, which started using the `newtype` strategy when deriving `Show`/`Read` for keys+ * In practice, this means that from 2.8.0–2.8.3.1, for the following schema:++ ```+ Person+ name Text+ CustomPrimary+ anInt Int+ Primary anInt+ name Text+ ```++ `PersonKey 1` would show as `"SqlBackendKey {unSqlBackendKey = 1}"`+ and `CustomPrimaryKey 1` would show as `"1"`++ This was generally poor for debugging and logging, since all tables keys would print the same. For Persistent < 2.8.0 and > 2.8.3.1, they instead will show as:++ `"PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 1}}"`+ and `"CustomPrimaryKey {unCustomPrimaryKey = 1}"`++ This could be a breaking change if you have used `Show` on a key, wrote that string into some persistent storage like a database, and are trying to `Read` it back again later.++## 2.8.3.1++* Allow aeson 1.5. [#1085](https://github.com/yesodweb/persistent/pull/1085)++## 2.8.3.0++* Add `Lift` instances for the cascade types. [#1060](https://github.com/yesodweb/persistent/pull/1060)+* Use `DeriveLift` to implement all `Lift` instances. Among other benefits,+ this provides implementations of `liftTyped` on `template-haskell-2.16` (GHC+ 8.10) or later. [#1064](https://github.com/yesodweb/persistent/pull/1064)++## 2.8.2.3++* Require extensions in a more friendly manner. [#1030](https://github.com/yesodweb/persistent/pull/1030)+* Specify a strategy for all deriving clauses, which avoids the `-Wmissing-deriving-strategy` warning introduced in GHC 8.8.2. [#1030](https://github.com/yesodweb/persistent/pull/1030)++## 2.8.2.2++* Fix the `mkPersist` function to not require importing the classes explicitly. [#1027](https://github.com/yesodweb/persistent/pull/1027)++## 2.8.2.1++* Fix the test-suite for persistent-template. [#1023](https://github.com/yesodweb/persistent/pull/1023)++## 2.8.2++* Add `fieldError` to the export list of `Database.Persist.TH` [#1008](https://github.com/yesodweb/persistent/pull/1008)++## 2.8.1++* Let the user pass instances that will be derived for record and for key types (https://github.com/yesodweb/persistent/pull/990++## 2.8.0.1++* Small optimization/code cleanup to generated Template Haskell code size, by slimming the implementation of to/fromPersistValue for Entities. [#1014](https://github.com/yesodweb/persistent/pull/1014)++## 2.8.0++* Reduces the amount of code generated by Template Haskell. The amount of code generated for a certain function was O(N^2) with respect to the number of fields on a given Entity. This change shows dramatic improvements in benchmarks for compiling Persistent models. [#]()+* Drops support for GHC 8.0, so that `DerivingStrategies` can be used by `persistent-template`+* `persistent-template` now requires `DerivingStrategies`, `GeneralizedNewtypeDeriving`, and `StandaloneDeriving` to be enabled in the file where Persistent entities are created+* Fixes a long-standing issue where persistent-template would fail when `DeriveAnyClass` was enabled (See #578)+* [#1002](https://github.com/yesodweb/persistent/pull/1002)++## 2.7.4++* Remove an overlapping instance for `Lift a`. [#998](https://github.com/yesodweb/persistent/pull/998)++## 2.7.3++* Update module documentation for `Database.Persist.TH` to better describe the purpose of the module [#968](https://github.com/yesodweb/persistent/pull/968)+* Support template-haskell-2.15 [#959](https://github.com/yesodweb/persistent/pull/959)++## 2.7.2++* Expose the knot tying logic of `parseReferences` so that users can build+ migrations from independently define entities at runtime [#932](https://github.com/yesodweb/persistent/pull/932)++## 2.7.1++* Add the `mkEntityDefList` function to work around [#902](https://github.com/yesodweb/persistent/issues/902). [#904](https://github.com/yesodweb/persistent/pull/904)++## 2.7.0++* Depends on `persistent-2.10.0` which provides the `OnlyOneUniqueKey` and `AtLeastOneUniqueKey` classes. Automatically generates instances for these classes based on how many unique keys the entity definition gets. This changes requires `UndecidableInstances` to be enabled on each module that generates entity definitions. [#885](https://github.com/yesodweb/persistent/pull/885)+* Removed deprecated `sqlOnlySettings`. Please use `sqlSettings` instead. [#894](https://github.com/yesodweb/persistent/pull/894)++## 2.6.0+* [persistent#846](https://github.com/yesodweb/persistent/pull/846): Improve error message when marshalling fails+* [persistent#826](https://github.com/yesodweb/persistent/pull/826): Change `Unique` derive `Show`++## 2.5.4++* [persistent#778](https://github.com/yesodweb/persistent/issues/778): Add `persistManyFileWith`.++## 2.5.3.1++* Slight improvement to the error message when a Persistent field can't be parsed from database results++## 2.5.3++* Exposed `parseReferences` to allow custom QuasiQuoters++## 2.5.2++* Fix incorrect `ToJSON`/`FromJSON` instance generation for generic+ backends++## 2.5.1.6++Allow non-null self-references in a list++## 2.5.1.4++* Allow composite Primary keys for tables that contain nullable fields.+* Support foreign keys to non-integer ids++## 2.5.1.3++* fix GHC 7.8 bug when a field name is "type"++## 2.5.1.2+ * fix a bad Eq instance /= definition for Key when mpsGenetric=True -## 2.1.7+## 2.5.0.1 -* Support for GHC 8 [#556](https://github.com/yesodweb/persistent/issues/556)+* workaround TH bug in GHC 7.10 +## 2.5++* read/write typeclass split+ ## 2.1.6 * aeson 0.11 * transformers 0.5+## 2.1.4++support http-api-data for url serialization ## 2.1.3.3
− Database/Persist/TH.hs
@@ -1,1636 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-}--- overlapping instances is for automatic lifting--- while avoiding an orphan of Lift for Text-{-# LANGUAGE OverlappingInstances #-}--- | This module provides utilities for creating backends. Regular users do not--- need to use this module.-module Database.Persist.TH- ( -- * Parse entity defs- persistWith- , persistUpperCase- , persistLowerCase- , persistFileWith- -- * Turn @EntityDef@s into types- , mkPersist- , MkPersistSettings- , mpsBackend- , mpsGeneric- , mpsPrefixFields- , mpsEntityJSON- , mpsGenerateLenses- , EntityJSON(..)- , mkPersistSettings- , sqlSettings- , sqlOnlySettings- -- * Various other TH functions- , mkMigrate- , mkSave- , mkDeleteCascade- , share- , derivePersistField- , derivePersistFieldJSON- , persistFieldFromEntity- -- * Internal- , packPTH- , lensPTH- ) where--import Prelude hiding ((++), take, concat, splitAt, exp)-import Database.Persist-import Database.Persist.Sql (Migration, migrate, SqlBackend, PersistFieldSql)-import Database.Persist.Quasi-import Language.Haskell.TH.Lib (-#if MIN_VERSION_template_haskell(2,11,0)- conT,-#endif- varE)-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax-import Data.Char (toLower, toUpper)-import Control.Monad (forM, (<=<), mzero)-import qualified System.IO as SIO-import Data.Text (pack, Text, append, unpack, concat, uncons, cons, stripPrefix, stripSuffix)-import Data.Text.Encoding (decodeUtf8)-import qualified Data.Text.IO as TIO-import Data.Int (Int64)-import Data.List (foldl')-import Data.Maybe (isJust, listToMaybe, mapMaybe, fromMaybe)-import Data.Monoid (mappend, mconcat)-import Text.Read (readPrec, lexP, step, prec, parens, Lexeme(Ident))-import qualified Data.Map as M-import qualified Data.HashMap.Strict as HM-import Data.Aeson.Compat- ( ToJSON (toJSON), FromJSON (parseJSON), (.=), object- , Value (Object), (.:), (.:?)- , eitherDecodeStrict'- )-import Control.Applicative (pure, (<$>), (<*>))-import Database.Persist.Sql (sqlType)-import Data.Proxy (Proxy (Proxy))-import Web.PathPieces (PathPiece(..))-import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..), parseUrlPieceMaybe)-import GHC.Generics (Generic)-import qualified Data.Text.Encoding as TE---- | Converts a quasi-quoted syntax into a list of entity definitions, to be--- used as input to the template haskell generation code (mkPersist).-persistWith :: PersistSettings -> QuasiQuoter-persistWith ps = QuasiQuoter- { quoteExp = parseReferences ps . pack- }---- | Apply 'persistWith' to 'upperCaseSettings'.-persistUpperCase :: QuasiQuoter-persistUpperCase = persistWith upperCaseSettings---- | Apply 'persistWith' to 'lowerCaseSettings'.-persistLowerCase :: QuasiQuoter-persistLowerCase = persistWith lowerCaseSettings---- | Same as 'persistWith', but uses an external file instead of a--- quasiquotation.-persistFileWith :: PersistSettings -> FilePath -> Q Exp-persistFileWith ps fp = do-#ifdef GHC_7_4- qAddDependentFile fp-#endif- h <- qRunIO $ SIO.openFile fp SIO.ReadMode- qRunIO $ SIO.hSetEncoding h SIO.utf8_bom- s <- qRunIO $ TIO.hGetContents h- parseReferences ps s---- calls parse to Quasi.parse individual entities in isolation--- afterwards, sets references to other entities-parseReferences :: PersistSettings -> Text -> Q Exp-parseReferences ps s = lift $- map (mkEntityDefSqlTypeExp embedEntityMap entMap) noCycleEnts- where- entMap = M.fromList $ map (\ent -> (entityHaskell ent, ent)) noCycleEnts- noCycleEnts = map breakCycleEnt entsWithEmbeds- -- every EntityDef could reference each-other (as an EmbedRef)- -- let Haskell tie the knot- embedEntityMap = M.fromList $ map (\ent -> (entityHaskell ent, toEmbedEntityDef ent)) entsWithEmbeds- entsWithEmbeds = map setEmbedEntity rawEnts- setEmbedEntity ent = ent- { entityFields = map (setEmbedField (entityHaskell ent) embedEntityMap) $ entityFields ent- }- rawEnts = parse ps s-- -- self references are already broken- -- look at every emFieldEmbed to see if it refers to an already seen HaskellName- -- so start with entityHaskell ent and accumulate embeddedHaskell em- breakCycleEnt entDef =- let entName = entityHaskell entDef- in entDef { entityFields = map (breakCycleField entName) $ entityFields entDef }-- breakCycleField entName f@(FieldDef { fieldReference = EmbedRef em }) =- f { fieldReference = EmbedRef $ breakCycleEmbed [entName] em }- breakCycleField _ f = f-- breakCycleEmbed ancestors em =- em { embeddedFields = map (breakCycleEmField $ emName : ancestors)- (embeddedFields em)- }- where- emName = embeddedHaskell em-- breakCycleEmField ancestors emf = case embeddedHaskell <$> membed of- Nothing -> emf- Just embName -> if embName `elem` ancestors- then emf { emFieldEmbed = Nothing, emFieldCycle = Just embName }- else emf { emFieldEmbed = breakCycleEmbed ancestors <$> membed }- where- membed = emFieldEmbed emf----stripId :: FieldType -> Maybe Text-stripId (FTTypeCon Nothing t) = stripSuffix "Id" t-stripId _ = Nothing--foreignReference :: FieldDef -> Maybe HaskellName-foreignReference field = case fieldReference field of- ForeignRef ref _ -> Just ref- _ -> Nothing----- fieldSqlType at parse time can be an Exp--- This helps delay setting fieldSqlType until lift time-data EntityDefSqlTypeExp = EntityDefSqlTypeExp EntityDef SqlTypeExp [SqlTypeExp]- deriving Show--data SqlTypeExp = SqlTypeExp FieldType- | SqlType' SqlType- deriving Show--instance Lift SqlTypeExp where- lift (SqlType' t) = lift t- lift (SqlTypeExp ftype) = return st- where- typ = ftToType ftype- mtyp = (ConT ''Proxy `AppT` typ)- typedNothing = SigE (ConE 'Proxy) mtyp- st = VarE 'sqlType `AppE` typedNothing--data FieldsSqlTypeExp = FieldsSqlTypeExp [FieldDef] [SqlTypeExp]--instance Lift FieldsSqlTypeExp where- lift (FieldsSqlTypeExp fields sqlTypeExps) =- lift $ zipWith FieldSqlTypeExp fields sqlTypeExps--data FieldSqlTypeExp = FieldSqlTypeExp FieldDef SqlTypeExp-instance Lift FieldSqlTypeExp where- lift (FieldSqlTypeExp (FieldDef{..}) sqlTypeExp) =- [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs fieldStrict fieldReference|]--instance Lift EntityDefSqlTypeExp where- lift (EntityDefSqlTypeExp ent sqlTypeExp sqlTypeExps) =- [|ent { entityFields = $(lift $ FieldsSqlTypeExp (entityFields ent) sqlTypeExps)- , entityId = $(lift $ FieldSqlTypeExp (entityId ent) sqlTypeExp)- }- |]--instance Lift ReferenceDef where- lift NoReference = [|NoReference|]- lift (ForeignRef name ft) = [|ForeignRef name ft|]- lift (EmbedRef em) = [|EmbedRef em|]- lift (CompositeRef cdef) = [|CompositeRef cdef|]- lift (SelfReference) = [|SelfReference|]--instance Lift EmbedEntityDef where- lift (EmbedEntityDef name fields) = [|EmbedEntityDef name fields|]--instance Lift EmbedFieldDef where- lift (EmbedFieldDef name em cyc) = [|EmbedFieldDef name em cyc|]--type EmbedEntityMap = M.Map HaskellName EmbedEntityDef-type EntityMap = M.Map HaskellName EntityDef--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-mEmbedded ents (FTApp x y) =- -- Key converts an Record to a RecordId- -- special casing this is obviously a hack- -- This problem may not be solvable with the current QuasiQuoted approach though- if x == FTTypeCon Nothing "Key"- then Left $ Just FTKeyCon- else mEmbedded ents y--setEmbedField :: HaskellName -> 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 (HaskellName name) allEntities of- Nothing -> NoReference- Just x -> ForeignRef (HaskellName 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 error $ unpack $ unHaskellName entName `mappend` ": a self reference must be a Maybe"- existing@_ -> existing- }--mkEntityDefSqlTypeExp :: EmbedEntityMap -> EntityMap -> EntityDef -> EntityDefSqlTypeExp-mkEntityDefSqlTypeExp emEntities entMap ent = EntityDefSqlTypeExp ent- (getSqlType $ entityId ent)- $ (map getSqlType $ entityFields ent)- where- getSqlType field = maybe- (defaultSqlTypeExp field)- (SqlType' . SqlOther)- (listToMaybe $ mapMaybe (stripPrefix "sqltype=") $ 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 entMap 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---- | Create data types and appropriate 'PersistEntity' instances for the given--- 'EntityDef's. Works well with the persist quasi-quoter.-mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec]-mkPersist mps ents' = do- x <- fmap mconcat $ mapM (persistFieldFromEntity mps) ents- y <- fmap mconcat $ mapM (mkEntity mps) ents- z <- fmap mconcat $ mapM (mkJSON mps) ents- return $ mconcat [x, y, z]- where- ents = map fixEntityDef ents'---- | Implement special preprocessing on EntityDef as necessary for 'mkPersist'.--- For example, strip out any fields marked as MigrationOnly.-fixEntityDef :: EntityDef -> EntityDef-fixEntityDef ed =- ed { entityFields = filter keepField $ entityFields ed }- where- keepField fd = "MigrationOnly" `notElem` fieldAttrs fd &&- "SafeToRemove" `notElem` fieldAttrs fd---- | Settings to be passed to the 'mkPersist' function.-data MkPersistSettings = MkPersistSettings- { mpsBackend :: Type- -- ^ Which database backend we\'re using.- --- -- When generating data types, each type is given a generic version- which- -- works with any backend- and a type synonym for the commonly used- -- backend. This is where you specify that commonly used backend.- , mpsGeneric :: Bool- -- ^ Create generic types that can be used with multiple backends. Good for- -- reusable code, but makes error messages harder to understand. Default:- -- True.- , mpsPrefixFields :: Bool- -- ^ Prefix field names with the model name. Default: True.- , mpsEntityJSON :: Maybe EntityJSON- -- ^ Generate @ToJSON@/@FromJSON@ instances for each model types. If it's- -- @Nothing@, no instances will be generated. Default:- --- -- @- -- Just EntityJSON- -- { entityToJSON = 'keyValueEntityToJSON- -- , entityFromJSON = 'keyValueEntityFromJSON- -- }- -- @- , mpsGenerateLenses :: !Bool- -- ^ Instead of generating normal field accessors, generator lens-style accessors.- --- -- Default: False- --- -- Since 1.3.1- }--data EntityJSON = EntityJSON- { entityToJSON :: Name- -- ^ Name of the @toJSON@ implementation for @Entity a@.- , entityFromJSON :: Name- -- ^ Name of the @fromJSON@ implementation for @Entity a@.- }---- | Create an @MkPersistSettings@ with default values.-mkPersistSettings :: Type -- ^ Value for 'mpsBackend'- -> MkPersistSettings-mkPersistSettings t = MkPersistSettings- { mpsBackend = t- , mpsGeneric = False- , mpsPrefixFields = True- , mpsEntityJSON = Just EntityJSON- { entityToJSON = 'entityIdToJSON- , entityFromJSON = 'entityIdFromJSON- }- , mpsGenerateLenses = False- }---- | Use the 'SqlPersist' backend.-sqlSettings :: MkPersistSettings-sqlSettings = mkPersistSettings $ ConT ''SqlBackend---- | Same as 'sqlSettings'.------ Since 1.1.1-sqlOnlySettings :: MkPersistSettings-sqlOnlySettings = sqlSettings-{-# DEPRECATED sqlOnlySettings "use sqlSettings" #-}--recNameNoUnderscore :: MkPersistSettings -> HaskellName -> HaskellName -> Text-recNameNoUnderscore mps dt f- | mpsPrefixFields mps = lowerFirst (unHaskellName dt) ++ upperFirst ft- | otherwise = lowerFirst ft- where ft = unHaskellName f--recName :: MkPersistSettings -> HaskellName -> HaskellName -> Text-recName mps dt f =- addUnderscore $ recNameNoUnderscore mps dt f- where- addUnderscore- | mpsGenerateLenses mps = ("_" ++)- | otherwise = id--lowerFirst :: Text -> Text-lowerFirst t =- case uncons t of- Just (a, b) -> cons (toLower a) b- Nothing -> t--upperFirst :: Text -> Text-upperFirst t =- case uncons t of- Just (a, b) -> cons (toUpper a) b- Nothing -> t--dataTypeDec :: MkPersistSettings -> EntityDef -> Q Dec-dataTypeDec mps t = do- let names = map (mkName . unpack) $ entityDerives t-#if MIN_VERSION_template_haskell(2,11,0)- DataD [] nameFinal paramsFinal- Nothing- constrs- <$> mapM conT names-#else- return $ DataD [] nameFinal paramsFinal constrs names-#endif- where- mkCol x fd@FieldDef {..} =- (mkName $ unpack $ recName mps x fieldHaskell,- if fieldStrict then isStrict else notStrict,- maybeIdType mps fd Nothing Nothing- )- (nameFinal, paramsFinal)- | mpsGeneric mps = (nameG, [PlainTV backend])- | otherwise = (name, [])- nameG = mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Generic"- name = mkName $ unpack $ unHaskellName $ entityHaskell t- cols = map (mkCol $ entityHaskell t) $ entityFields t- backend = backendName-- constrs- | entitySum t = map sumCon $ entityFields t- | otherwise = [RecC name cols]-- sumCon fd = NormalC- (sumConstrName mps t fd)- [(notStrict, maybeIdType mps fd Nothing Nothing)]--sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name-sumConstrName mps t FieldDef {..} = mkName $ unpack $ concat- [ if mpsPrefixFields mps- then unHaskellName $ entityHaskell t- else ""- , upperFirst $ unHaskellName fieldHaskell- , "Sum"- ]--uniqueTypeDec :: MkPersistSettings -> EntityDef -> Dec-uniqueTypeDec mps t =- DataInstD [] ''Unique- [genericDataType mps (entityHaskell t) backendT]-#if MIN_VERSION_template_haskell(2,11,0)- Nothing-#endif- (map (mkUnique mps t) $ entityUniques t)- []--mkUnique :: MkPersistSettings -> EntityDef -> UniqueDef -> Con-mkUnique mps t (UniqueDef (HaskellName constr) _ fields attrs) =- NormalC (mkName $ unpack constr) types- where- types = map (go . flip lookup3 (entityFields t))- $ map (unHaskellName . fst) fields-- force = "!force" `elem` attrs-- go :: (FieldDef, IsNullable) -> (Strict, Type)- go (_, Nullable _) | not force = error nullErrMsg- go (fd, y) = (notStrict, maybeIdType mps fd Nothing (Just y))-- lookup3 :: Text -> [FieldDef] -> (FieldDef, IsNullable)- lookup3 s [] =- error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ constr- lookup3 x (fd@FieldDef {..}:rest)- | x == unHaskellName fieldHaskell = (fd, nullable fieldAttrs)- | otherwise = lookup3 x rest-- nullErrMsg =- mconcat [ "Error: By default we disallow NULLables in an uniqueness "- , "constraint. The semantics of how NULL interacts with those "- , "constraints is non-trivial: two NULL values are not "- , "considered equal for the purposes of an uniqueness "- , "constraint. If you understand this feature, it is possible "- , "to use it your advantage. *** Use a \"!force\" attribute "- , "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 mps fd mbackend mnull = maybeTyp mayNullable idtyp- where- mayNullable = case mnull of- (Just (Nullable ByMaybeAttr)) -> True- _ -> maybeNullable fd- idtyp = idType mps fd mbackend--backendDataType :: MkPersistSettings -> Type-backendDataType mps- | mpsGeneric mps = backendT- | otherwise = mpsBackend mps--genericDataType :: MkPersistSettings- -> HaskellName -- ^ entity name- -> Type -- ^ backend- -> Type-genericDataType mps (HaskellName typ') backend- | mpsGeneric mps = ConT (mkName $ unpack $ typ' ++ "Generic") `AppT` backend- | otherwise = ConT $ mkName $ unpack typ'--idType :: MkPersistSettings -> FieldDef -> Maybe Name -> Type-idType mps fd mbackend =- case foreignReference fd of- Just typ ->- ConT ''Key- `AppT` genericDataType mps typ (VarT $ fromMaybe backendName mbackend)- Nothing -> ftToType $ fieldType fd--degen :: [Clause] -> [Clause]-degen [] =- let err = VarE 'error `AppE` LitE (StringL- "Degenerate case, should never happen")- in [normalClause [WildP] err]-degen x = x--mkToPersistFields :: MkPersistSettings -> String -> EntityDef -> Q Dec-mkToPersistFields mps constr ed@EntityDef { entitySum = isSum, entityFields = fields } = do- clauses <-- if isSum- then sequence $ zipWith goSum fields [1..]- else fmap return go- return $ FunD 'toPersistFields clauses- where- go :: Q Clause- go = do- xs <- sequence $ replicate fieldCount $ newName "x"- let pat = ConP (mkName constr) $ map VarP xs- sp <- [|SomePersistField|]- let bod = ListE $ map (AppE sp . VarE) xs- return $ normalClause [pat] bod-- fieldCount = length fields-- goSum :: FieldDef -> Int -> Q Clause- goSum fd idx = do- let name = sumConstrName mps ed fd- enull <- [|SomePersistField PersistNull|]- let beforeCount = idx - 1- afterCount = fieldCount - idx- before = replicate beforeCount enull- after = replicate afterCount enull- x <- newName "x"- sp <- [|SomePersistField|]- let body = ListE $ mconcat- [ before- , [sp `AppE` VarE x]- , after- ]- return $ normalClause [ConP name [VarP x]] body---mkToFieldNames :: [UniqueDef] -> Q Dec-mkToFieldNames pairs = do- pairs' <- mapM go pairs- return $ FunD 'persistUniqueToFieldNames $ degen pairs'- where- go (UniqueDef constr _ names _) = do- names' <- lift names- return $- normalClause- [RecP (mkName $ unpack $ unHaskellName constr) []]- names'--mkUniqueToValues :: [UniqueDef] -> Q Dec-mkUniqueToValues pairs = do- pairs' <- mapM go pairs- return $ FunD 'persistUniqueToValues $ degen pairs'- where- go :: UniqueDef -> Q Clause- go (UniqueDef constr _ names _) = do- xs <- mapM (const $ newName "x") names- let pat = ConP (mkName $ unpack $ unHaskellName constr) $ map VarP xs- tpv <- [|toPersistValue|]- let bod = ListE $ map (AppE tpv . VarE) xs- return $ normalClause [pat] bod--isNotNull :: PersistValue -> Bool-isNotNull PersistNull = False-isNotNull _ = True--mapLeft :: (a -> c) -> Either a b -> Either c b-mapLeft _ (Right r) = Right r-mapLeft f (Left l) = Left (f l)--fieldError :: Text -> Text -> Text-fieldError fieldName err = "field " `mappend` fieldName `mappend` ": " `mappend` err--mkFromPersistValues :: MkPersistSettings -> EntityDef -> Q [Clause]-mkFromPersistValues _ t@(EntityDef { entitySum = False }) =- fromValues t "fromPersistValues" entE $ entityFields t- where- entE = ConE $ mkName $ unpack entName- entName = unHaskellName $ entityHaskell t--mkFromPersistValues mps t@(EntityDef { entitySum = True }) = do- nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|]- clauses <- mkClauses [] $ entityFields t- return $ clauses `mappend` [normalClause [WildP] nothing]- where- entName = unHaskellName $ entityHaskell t- mkClauses _ [] = return []- mkClauses before (field:after) = do- x <- newName "x"- let null' = ConP 'PersistNull []- pat = ListP $ mconcat- [ map (const null') before- , [VarP x]- , map (const null') after- ]- constr = ConE $ sumConstrName mps t field- fs <- [|fromPersistValue $(return $ VarE x)|]- let guard' = NormalG $ VarE 'isNotNull `AppE` VarE x- let clause = Clause [pat] (GuardedB [(guard', InfixE (Just constr) fmapE (Just fs))]) []- clauses <- mkClauses (field : before) after- return $ clause : clauses--type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t--lensPTH :: (s -> a) -> (s -> b -> t) -> Lens s t a b-lensPTH sa sbt afb s = fmap (sbt s) (afb $ sa s)--fmapE :: Exp-fmapE = VarE 'fmap--mkLensClauses :: MkPersistSettings -> EntityDef -> Q [Clause]-mkLensClauses mps t = do- lens' <- [|lensPTH|]- getId <- [|entityKey|]- setId <- [|\(Entity _ value) key -> Entity key value|]- getVal <- [|entityVal|]- dot <- [|(.)|]- keyVar <- newName "key"- valName <- newName "value"- xName <- newName "x"- let idClause = normalClause- [ConP (keyIdName t) []]- (lens' `AppE` getId `AppE` setId)- if entitySum t- then return $ idClause : map (toSumClause lens' keyVar valName xName) (entityFields t)- else return $ idClause : map (toClause lens' getVal dot keyVar valName xName) (entityFields t)- where- toClause lens' getVal dot keyVar valName xName f = normalClause- [ConP (filterConName mps t f) []]- (lens' `AppE` getter `AppE` setter)- where- fieldName = mkName $ unpack $ recName mps (entityHaskell t) (fieldHaskell f)- getter = InfixE (Just $ VarE fieldName) dot (Just getVal)- setter = LamE- [ ConP 'Entity [VarP keyVar, VarP valName]- , VarP xName- ]- $ ConE 'Entity `AppE` VarE keyVar `AppE` RecUpdE- (VarE valName)- [(fieldName, VarE xName)]-- toSumClause lens' keyVar valName xName f = normalClause- [ConP (filterConName mps t f) []]- (lens' `AppE` getter `AppE` setter)- where- emptyMatch = Match WildP (NormalB $ VarE 'error `AppE` LitE (StringL "Tried to use fieldLens on a Sum type")) []- getter = LamE- [ ConP 'Entity [WildP, VarP valName]- ] $ CaseE (VarE valName)- $ Match (ConP (sumConstrName mps t f) [VarP xName]) (NormalB $ VarE xName) []-- -- FIXME It would be nice if the types expressed that the Field is- -- a sum type and therefore could result in Maybe.- : if length (entityFields t) > 1 then [emptyMatch] else []- setter = LamE- [ ConP 'Entity [VarP keyVar, WildP]- , VarP xName- ]- $ ConE 'Entity `AppE` VarE keyVar `AppE` (ConE (sumConstrName mps t f) `AppE` VarE xName)------ | declare the key type and associated instances--- @'PathPiece'@, @'ToHttpApiData'@ and @'FromHttpApiData'@ instances are only generated for a Key with one field-mkKeyTypeDec :: MkPersistSettings -> EntityDef -> Q (Dec, [Dec])-mkKeyTypeDec mps t = do- (instDecs, i) <-- if mpsGeneric mps- then if not useNewtype- then do pfDec <- pfInstD- return (pfDec, [''Generic])- else do gi <- genericNewtypeInstances- return (gi, [])- else if not useNewtype- then do pfDec <- pfInstD- return (pfDec, [''Show, ''Read, ''Eq, ''Ord, ''Generic])- else do- let allInstances = [''Show, ''Read, ''Eq, ''Ord, ''PathPiece, ''ToHttpApiData, ''FromHttpApiData, ''PersistField, ''PersistFieldSql, ''ToJSON, ''FromJSON]- if customKeyType- then return ([], allInstances)- else do- bi <- backendKeyI- return (bi, allInstances)--#if MIN_VERSION_template_haskell(2,11,0)- cxti <- mapM conT i- let kd = if useNewtype- then NewtypeInstD [] k [recordType] Nothing dec cxti- else DataInstD [] k [recordType] Nothing [dec] cxti-#else- let kd = if useNewtype- then NewtypeInstD [] k [recordType] dec i- else DataInstD [] k [recordType] [dec] i-#endif- return (kd, instDecs)- where- keyConE = keyConExp t- unKeyE = unKeyExp t- dec = RecC (keyConName t) (keyFields mps t)- k = ''Key- recordType = genericDataType mps (entityHaskell t) backendT- pfInstD = -- FIXME: generate a PersistMap instead of PersistList- [d|instance PersistField (Key $(pure recordType)) where- toPersistValue = PersistList . keyToValues- fromPersistValue (PersistList l) = keyFromValues l- fromPersistValue got = error $ "fromPersistValue: expected PersistList, got: " `mappend` show got- instance PersistFieldSql (Key $(pure recordType)) where- sqlType _ = SqlString- instance ToJSON (Key $(pure recordType))- instance FromJSON (Key $(pure recordType))- |]-- keyStringL = StringL . keyString- -- ghc 7.6 cannot parse the left arrow Ident $() <- lexP- keyPattern = BindS (ConP 'Ident [LitP $ keyStringL t])-- backendKeyGenericI =- [d| instance PersistStore $(pure backendT) =>- ToBackendKey $(pure backendT) $(pure recordType) where- toBackendKey = $(return unKeyE)- fromBackendKey = $(return keyConE)- |]- backendKeyI = let bdt = backendDataType mps in- [d| instance ToBackendKey $(pure bdt) $(pure recordType) where- toBackendKey = $(return unKeyE)- fromBackendKey = $(return keyConE)- |]-- -- truly unfortunate that TH doesn't support standalone deriving- -- https://ghc.haskell.org/trac/ghc/ticket/8100- genericNewtypeInstances = do- instances <- [|lexP|] >>= \lexPE -> [| step readPrec >>= return . ($(pure keyConE) )|] >>= \readE -> do- alwaysInstances <-- [d|instance Show (BackendKey $(pure backendT)) => Show (Key $(pure recordType)) where- showsPrec i x = showParen (i > app_prec) $- (showString $ $(pure $ LitE $ keyStringL t) `mappend` " ") .- showsPrec i ($(return unKeyE) x)- where app_prec = (10::Int)- instance Read (BackendKey $(pure backendT)) => Read (Key $(pure recordType)) where- readPrec = parens $ (prec app_prec $ $(pure $ DoE [keyPattern lexPE, NoBindS readE]))- where app_prec = (10::Int)- instance Eq (BackendKey $(pure backendT)) => Eq (Key $(pure recordType)) where- x == y =- ($(return unKeyE) x) ==- ($(return unKeyE) y)- instance Ord (BackendKey $(pure backendT)) => Ord (Key $(pure recordType)) where- compare x y = compare- ($(return unKeyE) x)- ($(return unKeyE) y)- instance ToHttpApiData (BackendKey $(pure backendT)) => ToHttpApiData (Key $(pure recordType)) where- toUrlPiece = toUrlPiece . $(return unKeyE)- instance FromHttpApiData (BackendKey $(pure backendT)) => FromHttpApiData(Key $(pure recordType)) where- parseUrlPiece = fmap $(return keyConE) . parseUrlPiece- instance PathPiece (BackendKey $(pure backendT)) => PathPiece (Key $(pure recordType)) where- toPathPiece = toPathPiece . $(return unKeyE)- fromPathPiece = fmap $(return keyConE) . fromPathPiece- instance PersistField (BackendKey $(pure backendT)) => PersistField (Key $(pure recordType)) where- toPersistValue = toPersistValue . $(return unKeyE)- fromPersistValue = fmap $(return keyConE) . fromPersistValue- instance PersistFieldSql (BackendKey $(pure backendT)) => PersistFieldSql (Key $(pure recordType)) where- sqlType = sqlType . fmap $(return unKeyE)- instance ToJSON (BackendKey $(pure backendT)) => ToJSON (Key $(pure recordType)) where- toJSON = toJSON . $(return unKeyE)- instance FromJSON (BackendKey $(pure backendT)) => FromJSON (Key $(pure recordType)) where- parseJSON = fmap $(return keyConE) . parseJSON- |]-- if customKeyType then return alwaysInstances- else fmap (alwaysInstances `mappend`) backendKeyGenericI- return instances-- useNewtype = pkNewtype mps t- customKeyType = not (defaultIdType t) || not useNewtype || isJust (entityPrimary t)---keyIdName :: EntityDef -> Name-keyIdName = mkName . unpack . keyIdText--keyIdText :: EntityDef -> Text-keyIdText t = (unHaskellName $ entityHaskell t) `mappend` "Id"--unKeyName :: EntityDef -> Name-unKeyName t = mkName $ "un" `mappend` keyString t--unKeyExp :: EntityDef -> Exp-unKeyExp = VarE . unKeyName--backendT :: Type-backendT = VarT backendName--backendName :: Name-backendName = mkName "backend"--keyConName :: EntityDef -> Name-keyConName t = mkName $ resolveConflict $ keyString t- where- resolveConflict kn = if conflict then kn `mappend` "'" else kn- conflict = any ((== HaskellName "key") . fieldHaskell) $ entityFields t--keyConExp :: EntityDef -> Exp-keyConExp = ConE . keyConName--keyString :: EntityDef -> String-keyString = unpack . keyText--keyText :: EntityDef -> Text-keyText t = unHaskellName (entityHaskell t) ++ "Key"--pkNewtype :: MkPersistSettings -> EntityDef -> Bool-pkNewtype mps t = length (keyFields mps t) < 2--defaultIdType :: EntityDef -> Bool-defaultIdType t = fieldType (entityId t) == FTTypeCon Nothing (keyIdText t)--keyFields :: MkPersistSettings -> EntityDef -> [(Name, Strict, Type)]-keyFields mps t = case entityPrimary t of- Just pdef -> map primaryKeyVar $ (compositeFields pdef)- Nothing -> if defaultIdType t- then [idKeyVar backendKeyType]- else [idKeyVar $ ftToType $ fieldType $ entityId t]- where- backendKeyType- | mpsGeneric mps = ConT ''BackendKey `AppT` backendT- | otherwise = ConT ''BackendKey `AppT` mpsBackend mps- idKeyVar ft = (unKeyName t, notStrict, ft)- primaryKeyVar fd = ( keyFieldName mps t fd- , notStrict- , ftToType $ fieldType fd- )--keyFieldName :: MkPersistSettings -> EntityDef -> FieldDef -> Name-keyFieldName mps t fd- | pkNewtype mps t = unKeyName t- | otherwise = mkName $ unpack- $ lowerFirst (keyText t) `mappend` (unHaskellName $ fieldHaskell fd)--mkKeyToValues :: MkPersistSettings -> EntityDef -> Q Dec-mkKeyToValues mps t = do- (p, e) <- case entityPrimary t of- Nothing ->- ([],) <$> [|(:[]) . toPersistValue . $(return $ unKeyExp t)|]- Just pdef ->- return $ toValuesPrimary pdef- return $ FunD 'keyToValues $ return $ normalClause p e- where- toValuesPrimary pdef =- ( [VarP recordName]- , ListE $ map (\fd -> VarE 'toPersistValue `AppE` (VarE (keyFieldName mps t fd) `AppE` VarE recordName)) $ compositeFields pdef- )- recordName = mkName "record"--normalClause :: [Pat] -> Exp -> Clause-normalClause p e = Clause p (NormalB e) []--mkKeyFromValues :: MkPersistSettings -> EntityDef -> Q Dec-mkKeyFromValues _mps t = do- clauses <- case entityPrimary t of- Nothing -> do- e <- [|fmap $(return $ keyConE) . fromPersistValue . headNote|]- return $ [normalClause [] e]- Just pdef ->- fromValues t "keyFromValues" keyConE (compositeFields pdef)- return $ FunD 'keyFromValues clauses- where- keyConE = keyConExp t--headNote :: [PersistValue] -> PersistValue-headNote (x:[]) = x-headNote xs = error $ "mkKeyFromValues: expected a list of one element, got: "- `mappend` show xs---fromValues :: EntityDef -> Text -> Exp -> [FieldDef] -> Q [Clause]-fromValues t funName conE fields = do- x <- newName "x"- let funMsg = entityText t `mappend` ": " `mappend` funName `mappend` " failed on: "- patternMatchFailure <-- [|Left $ mappend funMsg (pack $ show $(return $ VarE x))|]- suc <- patternSuccess fields- return [ suc, normalClause [VarP x] patternMatchFailure ]- where- patternSuccess [] = do- rightE <- [|Right|]- return $ normalClause [ListP []] (rightE `AppE` conE)- patternSuccess fieldsNE = do- x1 <- newName "x1"- restNames <- mapM (\i -> newName $ "x" `mappend` show i) [2..length fieldsNE]- (fpv1:mkPersistValues) <- mapM mkPvFromFd fieldsNE- app1E <- [|(<$>)|]- let conApp = infixFromPersistValue app1E fpv1 conE x1- applyE <- [|(<*>)|]- let applyFromPersistValue = infixFromPersistValue applyE-- return $ normalClause- [ListP $ map VarP (x1:restNames)]- (foldl' (\exp (name, fpv) -> applyFromPersistValue fpv exp name) conApp (zip restNames mkPersistValues))- where- infixFromPersistValue applyE fpv exp name =- UInfixE exp applyE (fpv `AppE` VarE name)- mkPvFromFd = mkPersistValue . unHaskellName . fieldHaskell- mkPersistValue fieldName = [|mapLeft (fieldError fieldName) . fromPersistValue|]---mkEntity :: MkPersistSettings -> EntityDef -> Q [Dec]-mkEntity mps t = do- t' <- lift t- let nameT = unHaskellName entName- let nameS = unpack nameT- let clazz = ConT ''PersistEntity `AppT` genDataType- tpf <- mkToPersistFields mps nameS t- fpv <- mkFromPersistValues mps t- utv <- mkUniqueToValues $ entityUniques t- puk <- mkUniqueKeys 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- keyToValues' <- mkKeyToValues mps t- keyFromValues' <- mkKeyFromValues mps t-- let addSyn -- FIXME maybe remove this- | mpsGeneric mps = (:) $- TySynD (mkName nameS) [] $- genericDataType mps entName $ mpsBackend mps- | otherwise = id-- lensClauses <- mkLensClauses mps t-- lenses <- mkLenses mps t- let instanceConstraint = if not (mpsGeneric mps) then [] else- [mkClassP ''PersistStore [backendT]]-- dtd <- dataTypeDec mps t- return $ addSyn $- dtd : mconcat fkc `mappend`- ([ TySynD (keyIdName t) [] $- ConT ''Key `AppT` ConT (mkName nameS)- , instanceD instanceConstraint clazz $- [ uniqueTypeDec mps t- , keyTypeDec- , keyToValues'- , keyFromValues'- , FunD 'entityDef [normalClause [WildP] t']- , tpf- , FunD 'fromPersistValues fpv- , toFieldNames- , utv- , puk- , DataInstD- []- ''EntityField- [ genDataType- , VarT $ mkName "typ"- ]-#if MIN_VERSION_template_haskell(2,11,0)- Nothing-#endif- (map fst fields)- []- , FunD 'persistFieldDef (map snd fields)- , TySynInstD- ''PersistEntityBackend-#if MIN_VERSION_template_haskell(2,9,0)- (TySynEqn- [genDataType]- (backendDataType mps))-#else- [genDataType]- (backendDataType mps)-#endif- , FunD 'persistIdField [normalClause [] (ConE $ keyIdName t)]- , FunD 'fieldLens lensClauses- ]- ] `mappend` lenses) `mappend` keyInstanceDecs- where- genDataType = genericDataType mps entName backendT- entName = entityHaskell t--entityText :: EntityDef -> Text-entityText = unHaskellName . entityHaskell--mkLenses :: MkPersistSettings -> EntityDef -> Q [Dec]-mkLenses mps _ | not (mpsGenerateLenses mps) = return []-mkLenses _ ent | entitySum ent = return []-mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do- let lensName' = recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field)- lensName = mkName $ unpack lensName'- fieldName = mkName $ unpack $ "_" ++ lensName'- needleN <- newName "needle"- setterN <- newName "setter"- fN <- newName "f"- aN <- newName "a"- yN <- newName "y"- let needle = VarE needleN- setter = VarE setterN- f = VarE fN- a = VarE aN- y = VarE yN- fT = mkName "f"- -- FIXME if we want to get really fancy, then: if this field is the- -- *only* Id field present, then set backend1 and backend2 to different- -- values- backend1 = backendName- backend2 = backendName- aT = maybeIdType mps field (Just backend1) Nothing- bT = maybeIdType mps field (Just backend2) Nothing- mkST backend = genericDataType mps (entityHaskell ent) (VarT backend)- sT = mkST backend1- tT = mkST backend2- t1 `arrow` t2 = ArrowT `AppT` t1 `AppT` t2- vars = PlainTV fT- : (if mpsGeneric mps then [PlainTV backend1{-, PlainTV backend2-}] else [])- return- [ SigD lensName $ ForallT vars [mkClassP ''Functor [VarT fT]] $- (aT `arrow` (VarT fT `AppT` bT)) `arrow`- (sT `arrow` (VarT fT `AppT` tT))- , FunD lensName $ return $ Clause- [VarP fN, VarP aN]- (NormalB $ fmapE- `AppE` setter- `AppE` (f `AppE` needle))- [ FunD needleN [normalClause [] (VarE fieldName `AppE` a)]- , FunD setterN $ return $ normalClause- [VarP yN]- (RecUpdE a- [ (fieldName, y)- ])- ]- ]--mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec]-mkForeignKeysComposite mps t ForeignDef {..} = do- let fieldName f = mkName $ unpack $ recName mps (entityHaskell t) f- let fname = fieldName foreignConstraintNameHaskell- let reftableString = unpack $ unHaskellName $ foreignRefTableHaskell- let reftableKeyName = mkName $ reftableString `mappend` "Key"- let tablename = mkName $ unpack $ entityText t- recordName <- newName "record"-- let fldsE = map (\((foreignName, _),_) -> VarE (fieldName $ foreignName)- `AppE` VarE recordName) foreignFields- let mkKeyE = foldl' AppE (maybeExp foreignNullable $ ConE reftableKeyName) fldsE- let fn = FunD fname [normalClause [VarP recordName] mkKeyE]-- let t2 = maybeTyp foreignNullable $ ConT ''Key `AppT` ConT (mkName reftableString)- let sig = SigD fname $ (ArrowT `AppT` (ConT tablename)) `AppT` t2- return [sig, fn]--maybeExp :: Bool -> Exp -> Exp-maybeExp may exp | may = fmapE `AppE` exp- | otherwise = exp-maybeTyp :: Bool -> Type -> Type-maybeTyp may typ | may = ConT ''Maybe `AppT` typ- | otherwise = typ------ | produce code similar to the following:------ @--- instance PersistEntity e => PersistField e where--- toPersistValue = PersistMap $ zip columNames (map toPersistValue . toPersistFields)--- fromPersistValue (PersistMap o) =--- let columns = HM.fromList o--- in fromPersistValues $ map (\name ->--- case HM.lookup name columns of--- Just v -> v--- Nothing -> PersistNull--- fromPersistValue x = Left $ "Expected PersistMap, received: " ++ show x--- sqlType _ = SqlString--- @-persistFieldFromEntity :: MkPersistSettings -> EntityDef -> Q [Dec]-persistFieldFromEntity mps e = do- ss <- [|SqlString|]- obj <- [|\ent -> PersistMap $ zip (map pack columnNames) (map toPersistValue $ toPersistFields ent)|]- fpv <- [|\x -> let columns = HM.fromList x- in fromPersistValues $ map- (\(name) ->- case HM.lookup (pack name) columns of- Just v -> v- Nothing -> PersistNull)- $ columnNames- |]-- compose <- [|(<=<)|]- getPersistMap' <- [|getPersistMap|]- return- [ persistFieldInstanceD (mpsGeneric mps) typ- [ FunD 'toPersistValue [ normalClause [] obj ]- , FunD 'fromPersistValue- [ normalClause [] (InfixE (Just fpv) compose $ Just getPersistMap')- ]- ]- , persistFieldSqlInstanceD (mpsGeneric mps) typ- [ sqlTypeFunD ss- ]- ]- where- typ = genericDataType mps (entityHaskell e) backendT- entFields = entityFields e- columnNames = map (unpack . unHaskellName . fieldHaskell) entFields---- | Apply the given list of functions to the same @EntityDef@s.------ This function is useful for cases such as:------ >>> share [mkSave "myDefs", mkPersist sqlSettings] [persistLowerCase|...|]-share :: [[EntityDef] -> Q [Dec]] -> [EntityDef] -> Q [Dec]-share fs x = fmap mconcat $ mapM ($ x) fs---- | Save the @EntityDef@s passed in under the given name.-mkSave :: String -> [EntityDef] -> Q [Dec]-mkSave name' defs' = do- let name = mkName name'- defs <- lift defs'- return [ SigD name $ ListT `AppT` ConT ''EntityDef- , FunD name [normalClause [] defs]- ]--data Dep = Dep- { depTarget :: HaskellName- , depSourceTable :: HaskellName- , depSourceField :: HaskellName- , depSourceNull :: IsNullable- }---- | Generate a 'DeleteCascade' instance for the given @EntityDef@s.-mkDeleteCascade :: MkPersistSettings -> [EntityDef] -> Q [Dec]-mkDeleteCascade mps defs = do- let deps = concatMap getDeps defs- mapM (go deps) defs- where- getDeps :: EntityDef -> [Dep]- getDeps def =- concatMap getDeps' $ entityFields $ fixEntityDef def- where- getDeps' :: FieldDef -> [Dep]- getDeps' field@FieldDef {..} =- case foreignReference field of- Just name ->- return Dep- { depTarget = name- , depSourceTable = entityHaskell def- , depSourceField = fieldHaskell- , depSourceNull = nullable fieldAttrs- }- Nothing -> []- go :: [Dep] -> EntityDef -> Q Dec- go allDeps EntityDef{entityHaskell = name} = do- let deps = filter (\x -> depTarget x == name) allDeps- key <- newName "key"- let del = VarE 'delete- let dcw = VarE 'deleteCascadeWhere- just <- [|Just|]- filt <- [|Filter|]- eq <- [|Eq|]- left <- [|Left|]- let mkStmt :: Dep -> Stmt- mkStmt dep = NoBindS- $ dcw `AppE`- ListE- [ filt `AppE` ConE filtName- `AppE` (left `AppE` val (depSourceNull dep))- `AppE` eq- ]- where- filtName = filterConName' mps (depSourceTable dep) (depSourceField dep)- val (Nullable ByMaybeAttr) = just `AppE` VarE key- val _ = VarE key---- let stmts :: [Stmt]- stmts = map mkStmt deps `mappend`- [NoBindS $ del `AppE` VarE key]-- let entityT = genericDataType mps name backendT-- return $- instanceD- [ mkClassP ''PersistQuery [backendT]- , mkEqualP (ConT ''PersistEntityBackend `AppT` entityT) backendT- ]- (ConT ''DeleteCascade `AppT` entityT `AppT` backendT)- [ FunD 'deleteCascade- [normalClause [VarP key] (DoE stmts)]- ]--mkUniqueKeys :: EntityDef -> Q Dec-mkUniqueKeys def | entitySum def =- return $ FunD 'persistUniqueKeys [normalClause [WildP] (ListE [])]-mkUniqueKeys def = do- c <- clause- return $ FunD 'persistUniqueKeys [c]- where- clause = do- xs <- forM (entityFields def) $ \fd -> do- let x = fieldHaskell fd- x' <- newName $ '_' : unpack (unHaskellName x)- return (x, x')- let pcs = map (go xs) $ entityUniques def- let pat = ConP- (mkName $ unpack $ unHaskellName $ entityHaskell def)- (map (VarP . snd) xs)- return $ normalClause [pat] (ListE pcs)-- go :: [(HaskellName, Name)] -> UniqueDef -> Exp- go xs (UniqueDef name _ cols _) =- foldl' (go' xs) (ConE (mkName $ unpack $ unHaskellName name)) (map fst cols)-- go' :: [(HaskellName, Name)] -> Exp -> HaskellName -> Exp- go' xs front col =- let Just col' = lookup col xs- in front `AppE` VarE col'--sqlTypeFunD :: Exp -> Dec-sqlTypeFunD st = FunD 'sqlType- [ normalClause [WildP] st ]--typeInstanceD :: Name- -> Bool -- ^ include PersistStore backend constraint- -> Type -> [Dec] -> Dec-typeInstanceD clazz hasBackend typ =- instanceD ctx (ConT clazz `AppT` typ)- where- ctx- | hasBackend = [mkClassP ''PersistStore [backendT]]- | otherwise = []--persistFieldInstanceD :: Bool -- ^ include PersistStore backend constraint- -> Type -> [Dec] -> Dec-persistFieldInstanceD = typeInstanceD ''PersistField--persistFieldSqlInstanceD :: Bool -- ^ include PersistStore backend constraint- -> Type -> [Dec] -> Dec-persistFieldSqlInstanceD = typeInstanceD ''PersistFieldSql---- | Automatically creates a valid 'PersistField' instance for any datatype--- that has valid 'Show' and 'Read' instances. Can be very convenient for--- 'Enum' types.-derivePersistField :: String -> Q [Dec]-derivePersistField s = do- ss <- [|SqlString|]- tpv <- [|PersistText . pack . show|]- fpv <- [|\dt v ->- case fromPersistValue v of- Left e -> Left e- Right s' ->- case reads $ unpack s' of- (x, _):_ -> Right x- [] -> Left $ pack "Invalid " ++ pack dt ++ pack ": " ++ s'|]- return- [ persistFieldInstanceD False (ConT $ mkName s)- [ FunD 'toPersistValue- [ normalClause [] tpv- ]- , FunD 'fromPersistValue- [ normalClause [] (fpv `AppE` LitE (StringL s))- ]- ]- , persistFieldSqlInstanceD False (ConT $ mkName s)- [ sqlTypeFunD ss- ]- ]---- | Automatically creates a valid 'PersistField' instance for any datatype--- that has valid 'ToJSON' and 'FromJSON' instances. For a datatype @T@ it--- generates instances similar to these:------ @--- instance PersistField T where--- toPersistValue = PersistByteString . L.toStrict . encode--- fromPersistValue = (left T.pack) . eitherDecodeStrict' <=< fromPersistValue--- instance PersistFieldSql T where--- sqlType _ = SqlString--- @-derivePersistFieldJSON :: String -> Q [Dec]-derivePersistFieldJSON s = do- ss <- [|SqlString|]- tpv <- [|PersistText . toJsonText|]- fpv <- [|\dt v -> do- text <- fromPersistValue v- let bs' = TE.encodeUtf8 text- case eitherDecodeStrict' bs' of- Left e -> Left $ pack "JSON decoding error for " ++ pack dt ++ pack ": " ++ pack e ++ pack ". On Input: " ++ decodeUtf8 bs'- Right x -> Right x|]- return- [ persistFieldInstanceD False (ConT $ mkName s)- [ FunD 'toPersistValue- [ normalClause [] tpv- ]- , FunD 'fromPersistValue- [ normalClause [] (fpv `AppE` LitE (StringL s))- ]- ]- , persistFieldSqlInstanceD False (ConT $ mkName s)- [ sqlTypeFunD ss- ]- ]---- | Creates a single function to perform all migrations for the entities--- defined here. One thing to be aware of is dependencies: if you have entities--- with foreign references, make sure to place those definitions after the--- entities they reference.-mkMigrate :: String -> [EntityDef] -> Q [Dec]-mkMigrate fun allDefs = do- body' <- body- return- [ SigD (mkName fun) typ- , FunD (mkName fun) [normalClause [] body']- ]- where- defs = filter isMigrated allDefs- isMigrated def = not $ "no-migrate" `elem` entityAttrs def- typ = ConT ''Migration- body :: Q Exp- body =- case defs of- [] -> [|return ()|]- _ -> do- defsName <- newName "defs"- defsStmt <- do- defs' <- mapM lift defs- let defsExp = ListE defs'- return $ LetS [ValD (VarP defsName) (NormalB defsExp) []]- stmts <- mapM (toStmt $ VarE defsName) defs- return (DoE $ defsStmt : stmts)- toStmt :: Exp -> EntityDef -> Q Stmt- toStmt defsExp ed = do- u <- lift ed- m <- [|migrate|]- return $ NoBindS $ m `AppE` defsExp `AppE` u--instance Lift EntityDef where- lift EntityDef{..} =- [|EntityDef- entityHaskell- entityDB- entityId- entityAttrs- entityFields- entityUniques- entityForeigns- entityDerives- entityExtra- entitySum- |]-instance Lift FieldDef where- lift (FieldDef a b c d e f g) = [|FieldDef a b c d e f g|]-instance Lift UniqueDef where- lift (UniqueDef a b c d) = [|UniqueDef a b c d|]-instance Lift CompositeDef where- lift (CompositeDef a b) = [|CompositeDef a b|]-instance Lift ForeignDef where- lift (ForeignDef a b c d e f g) = [|ForeignDef a b c d e f g|]---- | A hack to avoid orphans.-class Lift' a where- lift' :: a -> Q Exp-instance Lift' Text where- lift' = liftT-instance Lift' a => Lift' [a] where- lift' xs = do { xs' <- mapM lift' xs; return (ListE xs') }-instance (Lift' k, Lift' v) => Lift' (M.Map k v) where- lift' m = [|M.fromList $(fmap ListE $ mapM liftPair $ M.toList m)|]---- auto-lifting, means instances are overlapping-instance Lift' a => Lift a where- lift = lift'--packPTH :: String -> Text-packPTH = pack-#if !MIN_VERSION_text(0, 11, 2)-{-# NOINLINE packPTH #-}-#endif--liftT :: Text -> Q Exp-liftT t = [|packPTH $(lift (unpack t))|]--liftPair :: (Lift' k, Lift' v) => (k, v) -> Q Exp-liftPair (k, v) = [|($(lift' k), $(lift' v))|]--instance Lift HaskellName where- lift (HaskellName t) = [|HaskellName t|]-instance Lift DBName where- lift (DBName t) = [|DBName t|]-instance Lift FieldType where- lift (FTTypeCon Nothing t) = [|FTTypeCon Nothing t|]- lift (FTTypeCon (Just x) t) = [|FTTypeCon (Just x) t|]- lift (FTApp x y) = [|FTApp x y|]- lift (FTList x) = [|FTList x|]--instance Lift PersistFilter where- lift Eq = [|Eq|]- lift Ne = [|Ne|]- lift Gt = [|Gt|]- lift Lt = [|Lt|]- lift Ge = [|Ge|]- lift Le = [|Le|]- lift In = [|In|]- lift NotIn = [|NotIn|]- lift (BackendSpecificFilter x) = [|BackendSpecificFilter x|]--instance Lift PersistUpdate where- lift Assign = [|Assign|]- lift Add = [|Add|]- lift Subtract = [|Subtract|]- lift Multiply = [|Multiply|]- lift Divide = [|Divide|]- lift (BackendSpecificUpdate x) = [|BackendSpecificUpdate x|]--instance Lift SqlType where- lift SqlString = [|SqlString|]- lift SqlInt32 = [|SqlInt32|]- lift SqlInt64 = [|SqlInt64|]- lift SqlReal = [|SqlReal|]- lift (SqlNumeric x y) =- [|SqlNumeric (fromInteger x') (fromInteger y')|]- where- x' = fromIntegral x :: Integer- y' = fromIntegral y :: Integer- lift SqlBool = [|SqlBool|]- lift SqlDay = [|SqlDay|]- lift SqlTime = [|SqlTime|]- lift SqlDayTime = [|SqlDayTime|]- lift SqlBlob = [|SqlBlob|]- lift (SqlOther a) = [|SqlOther a|]---- Ent--- fieldName FieldType------ forall . typ ~ FieldType => EntFieldName------ EntFieldName = FieldDef ....-mkField :: MkPersistSettings -> EntityDef -> FieldDef -> Q (Con, Clause)-mkField mps et cd = do- let con = ForallC- []- [mkEqualP (VarT $ mkName "typ") $ maybeIdType mps cd Nothing Nothing]- $ NormalC name []- bod <- lift cd- let cla = normalClause- [ConP name []]- bod- return (con, cla)- where- name = filterConName mps et cd--maybeNullable :: FieldDef -> Bool-maybeNullable fd = nullable (fieldAttrs fd) == Nullable ByMaybeAttr--filterConName :: MkPersistSettings- -> EntityDef- -> FieldDef- -> Name-filterConName mps entity field = filterConName' mps (entityHaskell entity) (fieldHaskell field)--filterConName' :: MkPersistSettings- -> HaskellName -- ^ table- -> HaskellName -- ^ field- -> Name-filterConName' mps entity field = mkName $ unpack $ concat- [ if mpsPrefixFields mps || field == HaskellName "Id"- then unHaskellName entity- else ""- , upperFirst $ unHaskellName field- ]--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--infixr 5 ++-(++) :: Text -> Text -> Text-(++) = append--mkJSON :: MkPersistSettings -> EntityDef -> Q [Dec]-mkJSON _ def | not ("json" `elem` entityAttrs def) = return []-mkJSON mps def = do- pureE <- [|pure|]- apE' <- [|(<*>)|]- packE <- [|pack|]- dotEqualE <- [|(.=)|]- dotColonE <- [|(.:)|]- dotColonQE <- [|(.:?)|]- objectE <- [|object|]- obj <- newName "obj"- mzeroE <- [|mzero|]-- xs <- mapM (newName . unpack . unHaskellName . fieldHaskell)- $ entityFields def-- let conName = mkName $ unpack $ unHaskellName $ entityHaskell def- typ = genericDataType mps (entityHaskell def) backendT- toJSONI = typeInstanceD ''ToJSON (mpsGeneric mps) typ [toJSON']- toJSON' = FunD 'toJSON $ return $ normalClause- [ConP conName $ map VarP xs]- (objectE `AppE` ListE pairs)- pairs = zipWith toPair (entityFields def) xs- toPair f x = InfixE- (Just (packE `AppE` LitE (StringL $ unpack $ unHaskellName $ fieldHaskell f)))- dotEqualE- (Just $ VarE x)- fromJSONI = typeInstanceD ''FromJSON (mpsGeneric mps) typ [parseJSON']- parseJSON' = FunD 'parseJSON- [ normalClause [ConP 'Object [VarP obj]]- (foldl'- (\x y -> InfixE (Just x) apE' (Just y))- (pureE `AppE` ConE conName)- pulls- )- , normalClause [WildP] mzeroE- ]- pulls = map toPull $ entityFields def- toPull f = InfixE- (Just $ VarE obj)- (if maybeNullable f then dotColonQE else dotColonE)- (Just $ AppE packE $ LitE $ StringL $ unpack $ unHaskellName $ fieldHaskell f)- case mpsEntityJSON mps of- Nothing -> return [toJSONI, fromJSONI]- Just entityJSON -> do- entityJSONIs <- if mpsGeneric mps- then [d|-#if MIN_VERSION_base(4, 6, 0)- instance PersistStore backend => ToJSON (Entity $(pure typ)) where- toJSON = $(varE (entityToJSON entityJSON))- instance PersistStore backend => FromJSON (Entity $(pure typ)) where- parseJSON = $(varE (entityFromJSON entityJSON))-#endif- |]- else [d|- instance ToJSON (Entity $(pure typ)) where- toJSON = $(varE (entityToJSON entityJSON))- instance FromJSON (Entity $(pure typ)) where- parseJSON = $(varE (entityFromJSON entityJSON))- |]- return $ toJSONI : fromJSONI : entityJSONIs--mkClassP :: Name -> [Type] -> Pred-#if MIN_VERSION_template_haskell(2,10,0)-mkClassP cla tys = foldl AppT (ConT cla) tys-#else-mkClassP = ClassP-#endif--mkEqualP :: Type -> Type -> Pred-#if MIN_VERSION_template_haskell(2,10,0)-mkEqualP tleft tright = foldl AppT EqualityT [tleft, tright]-#else-mkEqualP = EqualP-#endif--#if MIN_VERSION_template_haskell(2,11,0)-notStrict :: Bang-notStrict = Bang NoSourceUnpackedness NoSourceStrictness--isStrict :: Bang-isStrict = Bang NoSourceUnpackedness SourceStrict-#else-notStrict :: Strict-notStrict = NotStrict--isStrict :: Strict-isStrict = IsStrict-#endif--instanceD :: Cxt -> Type -> [Dec] -> Dec-#if MIN_VERSION_template_haskell(2,11,0)-instanceD = InstanceD Nothing-#else-instanceD = InstanceD-#endif---- entityUpdates :: EntityDef -> [(HaskellName, FieldType, IsNullable, PersistUpdate)]--- entityUpdates =--- concatMap go . entityFields--- where--- go FieldDef {..} = map (\a -> (fieldHaskell, fieldType, nullable fieldAttrs, a)) [minBound..maxBound]---- mkToUpdate :: String -> [(String, PersistUpdate)] -> Q Dec--- mkToUpdate name pairs = do--- pairs' <- mapM go pairs--- return $ FunD (mkName name) $ degen pairs'--- where--- go (constr, pu) = do--- pu' <- lift pu--- return $ normalClause [RecP (mkName constr) []] pu'----- mkToFieldName :: String -> [(String, String)] -> Dec--- mkToFieldName func pairs =--- FunD (mkName func) $ degen $ map go pairs--- where--- go (constr, name) =--- normalClause [RecP (mkName constr) []] (LitE $ StringL name)---- mkToValue :: String -> [String] -> Dec--- mkToValue func = FunD (mkName func) . degen . map go--- where--- go constr =--- let x = mkName "x"--- in normalClause [ConP (mkName constr) [VarP x]]--- (VarE 'toPersistValue `AppE` VarE x)-
README.md view
@@ -1,3 +1,7 @@+# Begone!++This package was absorbed into `persistent` with the 2.12.0.1 release.+ ## persistent-template Provides Template Haskell helpers for persistent. For more information, see@@ -8,4 +12,18 @@ The TH.hs module contains code generators. persistent-template uses `EntityDef`s that it gets from the quasi-quoter. The quasi-quoter is in persistent Quasi.hs-Similarly mant of the types come from the persistent library+Similarly many of the types come from the persistent library++### Development tips++To get a better idea of what code you're generating, you can output the content of Template Haskell expressions to a file:++```+stack test persistent-template --ghc-options='-ddump-splices -ddump-to-file'+```++The output will be in the `.stack-work` directory. The exact path will depend on your specific setup, but if you search for files ending in `.dump-splices` you'll find the output (`find .stack-work -type f -name '*.dump-splices'`)++If you make changes to the generated code, it is highly recommended to compare the output with your changes to output from `master` (even better if this diff is included in your PR!). Seemingly small changes can have dramatic changes on the generated code. ++For example, embedding an `EntityDef` in a function that was called for every field of that `Entity` made the number of generated lines O(N^2) for that function—very bad!
persistent-template.cabal view
@@ -1,5 +1,5 @@ name: persistent-template-version: 2.1.8.1+version: 2.12.0.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -8,48 +8,17 @@ description: Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/persistent-template>. category: Database, Yesod stability: Stable-cabal-version: >= 1.8+cabal-version: >= 1.10 build-type: Simple homepage: http://www.yesodweb.com/book/persistent bug-reports: https://github.com/yesodweb/persistent/issues-extra-source-files: test/main.hs ChangeLog.md README.md+extra-source-files: ChangeLog.md README.md library- build-depends: base >= 4.6 && < 5- , template-haskell- , persistent >= 2.2.2 && < 3- , monad-control >= 0.2 && < 1.1- , bytestring >= 0.9- , text >= 0.5- , transformers >= 0.2 && < 0.6- , containers- , aeson >= 0.7 && < 0.12- , aeson-compat >= 0.3.0.0 && < 0.4- , monad-logger- , unordered-containers- , tagged- , path-pieces- , http-api-data >= 0.2 && < 0.3- , ghc-prim- exposed-modules: Database.Persist.TH+ build-depends: base >= 4.10 && < 5+ exposed-modules: ghc-options: -Wall- if impl(ghc >= 7.4)- cpp-options: -DGHC_7_4--test-suite test- type: exitcode-stdio-1.0- main-is: main.hs- hs-source-dirs: test-- build-depends: base >= 4.6 && < 5- , persistent-template- , aeson- , hspec >= 1.3- , text- , persistent- , bytestring- , QuickCheck- , transformers+ default-language: Haskell2010 source-repository head type: git
− test/main.hs
@@ -1,104 +0,0 @@-{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies, GADTs #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}-import Test.Hspec-import Test.Hspec.QuickCheck-import Data.ByteString.Lazy.Char8 ()-import Test.QuickCheck.Arbitrary-import Control.Applicative ((<$>), (<*>), Const (..))-import Data.Functor.Identity (Identity (..))--import Database.Persist-import Database.Persist.TH-import Database.Persist.Types (PersistValue(..))-import Data.Text (Text, pack)-import Data.Aeson--share [mkPersist sqlSettings { mpsGeneric = False }, mkDeleteCascade sqlSettings { mpsGeneric = False }] [persistUpperCase|-Person json- name Text- age Int Maybe- address Address- deriving Show Eq-Address json- street Text- city Text- zip Int Maybe- deriving Show Eq-NoJson- foo Text- deriving Show Eq-|]--share [mkPersist sqlSettings { mpsGeneric = False, mpsGenerateLenses = True }] [persistLowerCase|-Lperson json- name Text- age Int Maybe- address Laddress- deriving Show Eq-Laddress json- street Text- city Text- zip Int Maybe- deriving Show Eq-|]--share [mkPersist sqlSettings { mpsGeneric = True , mpsGenerateLenses = True }] [persistLowerCase|-Foo- bar Text Maybe- baz BazId-Baz- bin Int-|]--arbitraryT = pack <$> arbitrary--instance Arbitrary Person where- arbitrary = Person <$> arbitraryT <*> arbitrary <*> arbitrary-instance Arbitrary Address where- arbitrary = Address <$> arbitraryT <*> arbitraryT <*> arbitrary--main :: IO ()-main = hspec $ do- describe "JSON serialization" $ do- prop "to/from is idempotent" $ \person ->- decode (encode person) == Just (person :: Person)- it "decode" $- decode "{\"name\":\"Michael\",\"age\":27,\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}" `shouldBe` Just- (Person "Michael" (Just 27) $ Address "Narkis" "Maalot" Nothing)- describe "JSON serialization for Entity" $ do- let key = PersonKey 0- prop "to/from is idempotent" $ \person ->- decode (encode (Entity key person)) == Just (Entity key (person :: Person))- it "decode" $- decode "{\"id\": 0, \"name\":\"Michael\",\"age\":27,\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}" `shouldBe` Just- (Entity key (Person "Michael" (Just 27) $ Address "Narkis" "Maalot" Nothing))- it "lens operations" $ do- let street1 = "street1"- city1 = "city1"- city2 = "city2"- zip1 = Just 12345- address1 = Laddress street1 city1 zip1- address2 = Laddress street1 city2 zip1- name1 = "name1"- age1 = Just 27- person1 = Lperson name1 age1 address1- person2 = Lperson name1 age1 address2- (person1 ^. lpersonAddress) `shouldBe` address1- (person1 ^. (lpersonAddress . laddressCity)) `shouldBe` city1- (person1 & ((lpersonAddress . laddressCity) .~ city2)) `shouldBe` person2--x & f = f x--(^.) :: s- -> ((a -> Const a b) -> (s -> Const a t))- -> a-x ^. lens = getConst $ lens Const x--(.~) :: ((a -> Identity b) -> (s -> Identity t))- -> b- -> s- -> t-lens .~ val = runIdentity . lens (\_ -> Identity val)