diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,176 @@ +## 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.5.0.1 + +* 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 + +By default explicitly use Int64 for foreign key references. +This avoids confusion on a 32 bit system. + +## 2.1.3.1 + +Support foreign key references to composite primary keys + +## 2.1.0.1 + +Support for monad-control 1.0 diff --git a/Database/Persist/TH.hs b/Database/Persist/TH.hs deleted file mode 100644 --- a/Database/Persist/TH.hs +++ /dev/null @@ -1,1226 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-} --- | 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) -import qualified Prelude as P -import Database.Persist -import Database.Persist.Sql (Migration, SqlPersistT, migrate, SqlBackend, PersistFieldSql) -import Database.Persist.Quasi -import Language.Haskell.TH.Lib (varE) -import Language.Haskell.TH.Quote -import Language.Haskell.TH.Syntax -import Data.Char (toLower, toUpper) -import Control.Monad (forM, (<=<), mzero) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.IO.Class (MonadIO) -import qualified System.IO as SIO -import Data.Text (pack, Text, append, unpack, concat, uncons, cons) -import Data.Text.Encoding (decodeUtf8) -import qualified Data.Text.IO as TIO -import Data.List (foldl', find) -import Data.Maybe (isJust) -import Data.Monoid (mappend, mconcat) -import qualified Data.Map as M -import qualified Data.HashMap.Strict as HM -import Data.Aeson - ( ToJSON (toJSON), FromJSON (parseJSON), (.=), object - , Value (Object), (.:), (.:?) - , encode, eitherDecodeStrict' - ) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Control.Applicative (pure, (<*>)) -import Control.Monad.Logger (MonadLogger) -import Database.Persist.Sql (sqlType) - --- | 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 = parseSqlType 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 - parseSqlType ps s - -parseSqlType :: PersistSettings -> Text -> Q Exp -parseSqlType ps s = - lift $ map (getSqlType defsOrig) defsOrig - where - defsOrig = parse ps s - -getSqlType :: [EntityDef ()] -> EntityDef () -> EntityDef SqlTypeExp -getSqlType allEntities ent = - ent - { entityFields = map go $ entityFields ent - } - where - go :: FieldDef () -> FieldDef SqlTypeExp - go field = do - field - { fieldSqlType = final - , fieldEmbedded = mEmbedded (fieldType field) - } - where - -- 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. - final - | isJust (mEmbedded (fieldType field)) = SqlString' - | isReference = SqlInt64' - | otherwise = - case fieldType field 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 _ -> SqlString' - _ -> SqlTypeExp st - - mEmbedded (FTTypeCon Just{} _) = Nothing - mEmbedded (FTTypeCon Nothing n) = let name = HaskellName n in - find ((name ==) . entityHaskell) allEntities - mEmbedded (FTList x) = mEmbedded x - mEmbedded (FTApp x y) = maybe (mEmbedded y) Just (mEmbedded x) - - isReference = - case stripId $ fieldType field of - Just{} -> True - Nothing -> False - - typ = ftToType $ fieldType field - mtyp = (ConT ''Maybe `AppT` typ) - typedNothing = SigE (ConE 'Nothing) mtyp - st = VarE 'sqlType `AppE` typedNothing - -data SqlTypeExp = SqlTypeExp Exp - | SqlString' - | SqlInt64' -instance Lift SqlTypeExp where - lift (SqlTypeExp e) = return e - lift SqlString' = [|SqlString|] - lift SqlInt64' = [|SqlInt64|] - --- | Create data types and appropriate 'PersistEntity' instances for the given --- 'EntityDef's. Works well with the persist quasi-quoter. -mkPersist :: MkPersistSettings -> [EntityDef SqlType] -> 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 a -> EntityDef a -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 = True -- FIXME switch default to False in the future - , mpsPrefixFields = True - , mpsEntityJSON = Just EntityJSON - { entityToJSON = 'keyValueEntityToJSON - , entityFromJSON = 'keyValueEntityFromJSON - } - , mpsGenerateLenses = False - } - --- | Use the 'SqlPersist' backend. -sqlSettings :: MkPersistSettings -sqlSettings = mkPersistSettings $ ConT ''SqlBackend - --- | Same as 'sqlSettings', but set 'mpsGeneric' to @False@. --- --- Since 1.1.1 -sqlOnlySettings :: MkPersistSettings -sqlOnlySettings = sqlSettings { mpsGeneric = False } - -recNameNoUnderscore :: MkPersistSettings -> Text -> Text -> Text -recNameNoUnderscore mps dt f - | mpsPrefixFields mps = lowerFirst dt ++ upperFirst f - | otherwise = lowerFirst f - -recName :: MkPersistSettings -> Text -> Text -> 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 a -> Dec -dataTypeDec mps t = - DataD [] nameFinal paramsFinal constrs - $ map (mkName . unpack) $ entityDerives t - where - mkCol x FieldDef {..} = - (mkName $ unpack $ recName mps x $ unHaskellName fieldHaskell, - if fieldStrict then IsStrict else NotStrict, - pairToType mps backend (fieldType, nullable fieldAttrs) - ) - (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 $ unHaskellName $ entityHaskell t) $ entityFields t - backend = mkName "backend" - - constrs - | entitySum t = map sumCon $ entityFields t - | otherwise = [RecC name cols] - - sumCon fd = NormalC - (sumConstrName mps t fd) - [(NotStrict, pairToType mps backend (fieldType fd, NotNullable))] - -sumConstrName :: MkPersistSettings -> EntityDef a -> FieldDef b -> Name -sumConstrName mps t FieldDef {..} = mkName $ unpack $ concat - [ if mpsPrefixFields mps - then unHaskellName $ entityHaskell t - else "" - , upperFirst $ unHaskellName fieldHaskell - , "Sum" - ] - -readMay :: Read a => String -> Maybe a -readMay s = - case reads s of - (x, _):_ -> Just x - [] -> Nothing - -entityUpdates :: EntityDef a -> [(HaskellName, FieldType, IsNullable, PersistUpdate)] -entityUpdates = - concatMap go . entityFields - where - go FieldDef {..} = map (\a -> (fieldHaskell, fieldType, nullable fieldAttrs, a)) [minBound..maxBound] - -uniqueTypeDec :: MkPersistSettings -> EntityDef a -> Dec -uniqueTypeDec mps t = - DataInstD [] ''Unique - [genericDataType mps (unHaskellName $ entityHaskell t) $ VarT backend] - (map (mkUnique mps backend t) $ entityUniques t) - [] - where - backend = mkName "backend" - -mkUnique :: MkPersistSettings -> Name -> EntityDef a -> UniqueDef -> Con -mkUnique mps backend 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 :: (FieldType, IsNullable) -> (Strict, Type) - go (_, Nullable _) | not force = error nullErrMsg - go (ft, y) = (NotStrict, pairToType mps backend (ft, y)) - - lookup3 :: Text -> [FieldDef a] -> (FieldType, IsNullable) - lookup3 s [] = - error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ constr - lookup3 x (FieldDef {..}:rest) - | x == unHaskellName fieldHaskell = (fieldType, 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. ***" ] - -pairToType :: MkPersistSettings - -> Name -- ^ backend - -> (FieldType, IsNullable) - -> Type -pairToType mps backend (s, Nullable ByMaybeAttr) = - ConT ''Maybe `AppT` idType mps backend s -pairToType mps backend (s, _) = idType mps backend s - -backendDataType :: MkPersistSettings -> Type -backendDataType mps - | mpsGeneric mps = VarT $ mkName "backend" - | otherwise = mpsBackend mps - -genericDataType :: MkPersistSettings - -> Text -- ^ entity name - -> Type -- ^ backend - -> Type -genericDataType mps typ' backend - | mpsGeneric mps = ConT (mkName $ unpack $ typ' ++ "Generic") `AppT` backend - | otherwise = ConT $ mkName $ unpack typ' - -idType :: MkPersistSettings -> Name -> FieldType -> Type -idType mps backend typ = - case stripId typ of - Just typ' -> - ConT ''KeyBackend - `AppT` backend' - `AppT` genericDataType mps typ' (VarT backend) - Nothing -> ftToType typ - where - backend' - | mpsGeneric mps = VarT backend - | otherwise = mpsBackend mps - -degen :: [Clause] -> [Clause] -degen [] = - let err = VarE 'error `AppE` LitE (StringL - "Degenerate case, should never happen") - in [Clause [WildP] (NormalB err) []] -degen x = x - -mkToPersistFields :: MkPersistSettings -> String -> EntityDef a -> 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 $ Clause [pat] (NormalB bod) [] - - fieldCount = length fields - - goSum :: FieldDef a -> 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 = NormalB $ ListE $ mconcat - [ before - , [sp `AppE` VarE x] - , after - ] - return $ Clause [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 $ - Clause - [RecP (mkName $ unpack $ unHaskellName constr) []] - (NormalB names') - [] - -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 $ Clause [RecP (mkName constr) []] (NormalB pu') [] - -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 $ Clause [pat] (NormalB bod) [] - -mkToFieldName :: String -> [(String, String)] -> Dec -mkToFieldName func pairs = - FunD (mkName func) $ degen $ map go pairs - where - go (constr, name) = - Clause [RecP (mkName constr) []] (NormalB $ LitE $ StringL name) [] - -mkToValue :: String -> [String] -> Dec -mkToValue func = FunD (mkName func) . degen . map go - where - go constr = - let x = mkName "x" - in Clause [ConP (mkName constr) [VarP x]] - (NormalB $ VarE 'toPersistValue `AppE` VarE x) - [] - -isNotNull :: PersistValue -> Bool -isNotNull PersistNull = False -isNotNull _ = True - -mkFromPersistValues :: MkPersistSettings -> EntityDef a -> Q [Clause] -mkFromPersistValues mps t@(EntityDef { entitySum = False }) = do - nothing <- [|Left $(liftT $ "Invalid fromPersistValues input. Entity: " `mappend` entName)|] - let cons' = ConE $ mkName $ unpack $ entName - xs <- mapM (const $ newName "x") $ entityFields t - mkPersistValues <- mapM (mkPersistValue . unHaskellName . fieldHaskell) $ entityFields t - let xs' = map (\(pv, x) -> pv `AppE` VarE x) $ zip mkPersistValues xs - let pat = ListP $ map VarP xs - ap' <- [|(<*>)|] - just <- [|Right|] - let cons'' = just `AppE` cons' - return - [ Clause [pat] (NormalB $ foldl (go ap') cons'' xs') [] - , Clause [WildP] (NormalB nothing) [] - ] - where - mkPersistValue fieldName = [|\persistValue -> - case fromPersistValue persistValue of - Right r -> Right r - Left err -> Left $ - "field " `mappend` $(liftT fieldName) `mappend` ": " `mappend` err - |] - entName = unHaskellName $ entityHaskell t - go ap' x y = InfixE (Just x) ap' (Just y) - -mkFromPersistValues mps t@(EntityDef { entitySum = True }) = do - nothing <- [|Left $(liftT $ "Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|] - clauses <- mkClauses [] $ entityFields t - return $ clauses `mappend` [Clause [WildP] (NormalB 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 - fmap' <- [|fmap|] - fs <- [|fromPersistValue $(return $ VarE x)|] - let guard' = NormalG $ VarE 'isNotNull `AppE` VarE x - let clause = Clause [pat] (GuardedB [(guard', InfixE (Just constr) fmap' (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) - -mkLensClauses :: MkPersistSettings -> EntityDef a -> Q [Clause] -mkLensClauses mps t = do - lens' <- [|lensPTH|] - getId <- [|entityKey|] - setId <- [|\(Entity _ value) key -> Entity key value|] - getVal <- [|entityVal|] - dot <- [|(.)|] - keyName <- newName "key" - valName <- newName "value" - xName <- newName "x" - let idClause = Clause - [ConP (mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Id") []] - (NormalB $ lens' `AppE` getId `AppE` setId) - [] - if entitySum t - then return $ idClause : map (toSumClause lens' keyName valName xName) (entityFields t) - else return $ idClause : map (toClause lens' getVal dot keyName valName xName) (entityFields t) - where - toClause lens' getVal dot keyName valName xName f = Clause - [ConP (filterConName mps t f) []] - (NormalB $ lens' `AppE` getter `AppE` setter) - [] - where - fieldName = mkName $ unpack $ recName mps (unHaskellName $ entityHaskell t) (unHaskellName $ fieldHaskell f) - getter = InfixE (Just $ VarE fieldName) dot (Just getVal) - setter = LamE - [ ConP 'Entity [VarP keyName, VarP valName] - , VarP xName - ] - $ ConE 'Entity `AppE` VarE keyName `AppE` RecUpdE - (VarE valName) - [(fieldName, VarE xName)] - - toSumClause lens' keyName valName xName f = Clause - [ConP (filterConName mps t f) []] - (NormalB $ 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 keyName, WildP] - , VarP xName - ] - $ ConE 'Entity `AppE` VarE keyName `AppE` (ConE (sumConstrName mps t f) `AppE` VarE xName) - -mkEntity :: MkPersistSettings -> EntityDef SqlType -> Q [Dec] -mkEntity mps t = do - t' <- lift t - let nameT = unHaskellName $ entityHaskell t - let nameS = unpack nameT - let clazz = ConT ''PersistEntity `AppT` genericDataType mps (unHaskellName $ entityHaskell t) (VarT $ mkName "backend") - tpf <- mkToPersistFields mps nameS t - fpv <- mkFromPersistValues mps t - utv <- mkUniqueToValues $ entityUniques t - puk <- mkUniqueKeys t - fkc <- mapM (mkForeignKeysComposite mps t) $ entityForeigns t - - fields <- mapM (mkField mps t) $ FieldDef - { fieldHaskell = HaskellName "Id" - , fieldDB = entityID t - , fieldType = FTTypeCon Nothing $ unHaskellName (entityHaskell t) ++ "Id" - , fieldSqlType = SqlInt64 - , fieldEmbedded = Nothing - , fieldAttrs = [] - , fieldStrict = True - } - : entityFields t - toFieldNames <- mkToFieldNames $ entityUniques t - - let addSyn -- FIXME maybe remove this - | mpsGeneric mps = (:) $ - TySynD (mkName nameS) [] $ - genericDataType mps nameT $ mpsBackend mps - | otherwise = id - - lensClauses <- mkLensClauses mps t - - lenses <- mkLenses mps t - - return $ addSyn $ - dataTypeDec mps t : mconcat fkc `mappend` - ([ TySynD (mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Id") [] $ - ConT ''KeyBackend `AppT` mpsBackend mps `AppT` ConT (mkName nameS) - , InstanceD [] clazz $ - [ uniqueTypeDec mps t - , FunD 'entityDef [Clause [WildP] (NormalB t') []] - , tpf - , FunD 'fromPersistValues fpv - , toFieldNames - , utv - , puk - , DataInstD - [] - ''EntityField - [ genericDataType mps nameT $ VarT $ mkName "backend" - , VarT $ mkName "typ" - ] - (map fst fields) - [] - , FunD 'persistFieldDef (map snd fields) - , TySynInstD - ''PersistEntityBackend -#if MIN_VERSION_template_haskell(2,9,0) - (TySynEqn - [genericDataType mps (unHaskellName $ entityHaskell t) $ VarT $ mkName "backend"] - (backendDataType mps)) -#else - [genericDataType mps (unHaskellName $ entityHaskell t) $ VarT $ mkName "backend"] - (backendDataType mps) -#endif - , FunD 'persistIdField [Clause [] (NormalB $ ConE $ mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Id") []] - , FunD 'fieldLens lensClauses - ] - ] `mappend` lenses) - -mkLenses :: MkPersistSettings -> EntityDef a -> 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 (unHaskellName $ entityHaskell ent) (unHaskellName $ 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 = mkName "backend" - backend2 = mkName "backend" - aT = pairToType mps backend1 (fieldType field, nullable $ fieldAttrs field) - bT = pairToType mps backend2 (fieldType field, nullable $ fieldAttrs field) - mkST backend = genericDataType mps (unHaskellName $ 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 [ClassP ''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 $ VarE 'fmap - `AppE` setter - `AppE` (f `AppE` needle)) - [ FunD needleN [Clause [] (NormalB $ VarE fieldName `AppE` a) []] - , FunD setterN $ return $ Clause - [VarP yN] - (NormalB $ RecUpdE a - [ (fieldName, y) - ]) - [] - ] - ] - -mkForeignKeysComposite :: MkPersistSettings -> EntityDef a -> ForeignDef -> Q [Dec] -mkForeignKeysComposite mps t fdef = do - let fieldName f = mkName $ unpack $ recName mps (unHaskellName $ entityHaskell t) (unHaskellName f) - let fname=fieldName $ foreignConstraintNameHaskell fdef - let reftablename=mkName $ unpack $ unHaskellName $ foreignRefTableHaskell fdef - let tablename=mkName $ unpack $ unHaskellName $ entityHaskell t - entName <- newName "entname" - - let flds = map (\(a,_,_,_) -> VarE (fieldName a)) $ foreignFields fdef - let xs = ListE $ map (\a -> AppE (VarE 'toPersistValue) ((AppE a (VarE entName)))) flds - let fn = FunD fname [Clause [VarP entName] (NormalB (AppE (ConE 'Key) (AppE (ConE 'PersistList) xs))) []] - - let t2 = ConT ''KeyBackend `AppT` ConT ''SqlBackend `AppT` ConT reftablename - let sig = SigD fname $ (ArrowT `AppT` (ConT tablename)) `AppT` t2 - return [sig, fn] - - --- | 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 a -> 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 typ - [ FunD 'toPersistValue [ Clause [] (NormalB obj) [] ] - , FunD 'fromPersistValue - [ Clause [] (NormalB $ InfixE (Just fpv) compose $ Just getPersistMap') [] - ] - ] - , persistFieldSqlInstanceD typ - [ sqlTypeFunD ss - ] - ] - where - typ = genericDataType mps (pack entityName) $ VarT $ mkName "backend" - entityName = (unpack $ unHaskellName $ entityHaskell e) - 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 a] -> Q [Dec]] -> [EntityDef a] -> Q [Dec] -share fs x = fmap mconcat $ mapM ($ x) fs - --- | Save the @EntityDef@s passed in under the given name. -mkSave :: String -> [EntityDef SqlType] -> Q [Dec] -mkSave name' defs' = do - let name = mkName name' - defs <- lift defs' - return [ SigD name $ ListT `AppT` (ConT ''EntityDef `AppT` ConT ''SqlType) - , FunD name [Clause [] (NormalB defs) []] - ] - -data Dep = Dep - { depTarget :: Text - , depSourceTable :: HaskellName - , depSourceField :: HaskellName - , depSourceNull :: IsNullable - } - --- | Generate a 'DeleteCascade' instance for the given @EntityDef@s. -mkDeleteCascade :: MkPersistSettings -> [EntityDef a] -> Q [Dec] -mkDeleteCascade mps defs = do - let deps = concatMap getDeps defs - mapM (go deps) defs - where - getDeps :: EntityDef a -> [Dep] - getDeps def = - concatMap getDeps' $ entityFields $ fixEntityDef def - where - getDeps' :: FieldDef a -> [Dep] - getDeps' FieldDef {..} = - case stripId fieldType of - Just f -> - return Dep - { depTarget = f - , depSourceTable = entityHaskell def - , depSourceField = fieldHaskell - , depSourceNull = nullable fieldAttrs - } - Nothing -> [] - go :: [Dep] -> EntityDef a -> Q Dec - go allDeps EntityDef{entityHaskell = name} = do - let deps = filter (\x -> depTarget x == unHaskellName 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 (unHaskellName name) $ VarT $ mkName "backend" - - return $ - InstanceD - [ ClassP ''PersistQuery [VarT $ mkName "m"] - , EqualP (ConT ''PersistEntityBackend `AppT` entityT) (ConT ''PersistMonadBackend `AppT` VarT (mkName "m")) - ] - (ConT ''DeleteCascade `AppT` entityT `AppT` VarT (mkName "m")) - [ FunD 'deleteCascade - [Clause [VarP key] (NormalB $ DoE stmts) []] - ] - -mkUniqueKeys :: EntityDef a -> Q Dec -mkUniqueKeys def | entitySum def = - return $ FunD 'persistUniqueKeys [Clause [WildP] (NormalB $ 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 $ Clause [pat] (NormalB $ 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 - [ Clause [WildP] (NormalB st) [] ] - -persistFieldInstanceD :: Type -> [Dec] -> Dec -persistFieldInstanceD typ = - InstanceD [] (ConT ''PersistField `AppT` typ) - -persistFieldSqlInstanceD :: Type -> [Dec] -> Dec -persistFieldSqlInstanceD typ = - InstanceD [] (ConT ''PersistFieldSql `AppT` typ) - --- | 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 (ConT $ mkName s) - [ FunD 'toPersistValue - [ Clause [] (NormalB tpv) [] - ] - , FunD 'fromPersistValue - [ Clause [] (NormalB $ fpv `AppE` LitE (StringL s)) [] - ] - ] - , persistFieldSqlInstanceD (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 <- [|PersistByteString . B.concat . BL.toChunks . encode|] - fpv <- [|\dt v -> do - bs' <- fromPersistValue v - 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 (ConT $ mkName s) - [ FunD 'toPersistValue - [ Clause [] (NormalB tpv) [] - ] - , FunD 'fromPersistValue - [ Clause [] (NormalB $ fpv `AppE` LitE (StringL s)) [] - ] - ] - , persistFieldSqlInstanceD (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 :: Lift' a => String -> [EntityDef a] -> Q [Dec] -mkMigrate fun allDefs = do - body' <- body - return - [ SigD (mkName fun) typ - , FunD (mkName fun) [Clause [] (NormalB body') []] - ] - where - defs = filter isMigrated allDefs - isMigrated def = not $ "no-migrate" `elem` entityAttrs def - typ = ForallT [PlainTV $ mkName "m"] - [ ClassP ''MonadBaseControl [ConT ''IO, VarT $ mkName "m"] - , ClassP ''MonadIO [VarT $ mkName "m"] - , ClassP ''MonadLogger [VarT $ mkName "m"] - ] - $ ConT ''Migration `AppT` (ConT ''SqlPersistT `AppT` VarT (mkName "m")) - 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 :: Lift' a => Exp -> EntityDef a -> Q Stmt - toStmt defsExp ed = do - u <- lift ed - m <- [|migrate|] - return $ NoBindS $ m `AppE` defsExp `AppE` u - -instance Lift' a => Lift (EntityDef a) where - lift (EntityDef a b c d e f g h i j k) = - [|EntityDef - $(lift a) - $(lift b) - $(lift c) - $(liftTs d) - $(lift e) - $(lift f) - $(lift g) - $(lift h) - $(liftTs i) - $(liftMap j) - $(lift k) - |] -instance Lift' a => Lift (FieldDef a) where - lift (FieldDef a b c d e f g) = [|FieldDef a b c $(lift' d) $(liftTs e) f $(lift' g)|] -instance Lift UniqueDef where - lift (UniqueDef a b c d) = [|UniqueDef $(lift a) $(lift b) $(lift c) $(liftTs d)|] -instance Lift PrimaryDef where - lift (PrimaryDef a b) = [|PrimaryDef $(lift a) $(liftTs b)|] -instance Lift ForeignDef where - lift (ForeignDef a b c d e f) = [|ForeignDef $(lift a) $(lift b) $(lift c) $(lift d) $(lift e) $(liftTs f)|] - --- | A hack to avoid orphans. -class Lift' a where - lift' :: a -> Q Exp -instance Lift' SqlType where - lift' = lift -instance Lift' a => Lift' (Maybe a) where - lift' Nothing = [|Nothing|] - lift' (Just a) = [|Just $(lift' a)|] -instance Lift' a => Lift' (EntityDef a) where - lift' = lift -instance Lift' () where - lift' () = [|()|] -instance Lift' SqlTypeExp 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))|] - -liftTs :: [Text] -> Q Exp -liftTs = fmap ListE . mapM liftT - -liftTss :: [[Text]] -> Q Exp -liftTss = fmap ListE . mapM liftTs - -liftMap :: M.Map Text [[Text]] -> Q Exp -liftMap m = [|M.fromList $(fmap ListE $ mapM liftPair $ M.toList m)|] - -liftPair :: (Text, [[Text]]) -> Q Exp -liftPair (t, ts) = [|($(liftT t), $(liftTss ts))|] - -instance Lift HaskellName where - lift (HaskellName t) = [|HaskellName $(liftT t)|] -instance Lift DBName where - lift (DBName t) = [|DBName $(liftT t)|] -instance Lift FieldType where - lift (FTTypeCon Nothing t) = [|FTTypeCon Nothing $(liftT t)|] - lift (FTTypeCon (Just x) t) = [|FTTypeCon (Just $(liftT x)) $(liftT t)|] - lift (FTApp x y) = [|FTApp $(lift x) $(lift y)|] - lift (FTList x) = [|FTList $(lift 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 $(liftT x)|] - -instance Lift PersistUpdate where - lift Assign = [|Assign|] - lift Add = [|Add|] - lift Subtract = [|Subtract|] - lift Multiply = [|Multiply|] - lift Divide = [|Divide|] - -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 SqlDayTimeZoned = [|SqlDayTimeZoned|] - lift SqlBlob = [|SqlBlob|] - lift (SqlOther a) = [|SqlOther $(liftT a)|] - --- Ent --- fieldName FieldType --- --- forall . typ ~ FieldType => EntFieldName --- --- EntFieldName = FieldDef .... -mkField :: MkPersistSettings -> EntityDef a -> FieldDef SqlType -> Q (Con, Clause) -mkField mps et cd = do - let con = ForallC - [] - [EqualP (VarT $ mkName "typ") maybeTyp] - $ NormalC name [] - bod <- lift cd - let cla = Clause - [ConP name []] - (NormalB bod) - [] - return (con, cla) - where - name = filterConName mps et cd - maybeTyp = - if nullable (fieldAttrs cd) == Nullable ByMaybeAttr - then ConT ''Maybe `AppT` typ - else typ - typ = - case stripId $ fieldType cd of - Just ft -> - ConT ''KeyBackend - `AppT` (if mpsGeneric mps - then VarT $ mkName "backend" - else mpsBackend mps) - `AppT` genericDataType mps ft (VarT $ mkName "backend") - Nothing -> ftToType $ fieldType cd - -filterConName :: MkPersistSettings - -> EntityDef sqlType1 - -> FieldDef sqlType2 - -> 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 -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 a -> 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 (unHaskellName $ entityHaskell def) $ VarT $ mkName "backend" - toJSONI = InstanceD - [] - (ConT ''ToJSON `AppT` typ) - [toJSON'] - toJSON' = FunD 'toJSON $ return $ Clause - [ConP conName $ map VarP xs] - (NormalB $ 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 = InstanceD - [] - (ConT ''FromJSON `AppT` typ) - [parseJSON'] - parseJSON' = FunD 'parseJSON - [ Clause [ConP 'Object [VarP obj]] - (NormalB $ foldl' - (\x y -> InfixE (Just x) apE' (Just y)) - (pureE `AppE` ConE conName) - pulls - ) - [] - , Clause [WildP] (NormalB mzeroE) [] - ] - pulls = map toPull $ entityFields def - toPull f = InfixE - (Just $ VarE obj) - (if nullable (fieldAttrs f) == Nullable ByMaybeAttr 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 <- [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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,29 @@ +# 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 +[the chapter in the Yesod book](http://www.yesodweb.com/book/persistent). + +### code organization + +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 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! diff --git a/persistent-template.cabal b/persistent-template.cabal --- a/persistent-template.cabal +++ b/persistent-template.cabal @@ -1,50 +1,24 @@ name: persistent-template -version: 1.3.2.2 +version: 2.12.0.0 license: MIT license-file: LICENSE author: Michael Snoyman -maintainer: Michael Snoyman +maintainer: Michael Snoyman , Greg Weber synopsis: Type-safe, non-relational, multi-backend persistence. -description: This library provides just the general interface and helper functions. You must use a specific backend in order to make this useful. +description: Hackage documentation generation is not reliable. For up to date documentation, please see: . 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 +extra-source-files: ChangeLog.md README.md library - build-depends: base >= 4 && < 5 - , template-haskell - , persistent >= 1.3 && < 1.4 - , monad-control >= 0.2 && < 0.4 - , bytestring >= 0.9 - , text >= 0.5 - , transformers >= 0.2 && < 0.5 - , containers - , aeson - , monad-logger - , unordered-containers - 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 && < 5 - , persistent-template - , aeson - , hspec >= 1.3 - , text - , persistent - , bytestring - , QuickCheck - , transformers + default-language: Haskell2010 source-repository head type: git diff --git a/test/main.hs b/test/main.hs deleted file mode 100644 --- a/test/main.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies, GADTs #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# 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 -|] - --- ensure no-json works -instance ToJSON NoJson where - toJSON = undefined -instance FromJSON NoJson where - parseJSON = undefined - -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 = Key (PersistInt64 0) - prop "to/from is idempotent" $ \person -> - decode (encode (Entity key person)) == Just (Entity key (person :: Person)) - it "decode" $ - decode "{\"key\": 0, \"value\": {\"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)