persistent 2.12.0.0 → 2.12.0.1
raw patch · 13 files changed
+3487/−426 lines, 13 filesdep +QuickCheckdep +criteriondep +deepseqdep ~basedep ~conduitdep ~fast-logger
Dependencies added: QuickCheck, criterion, deepseq, deepseq-generics, file-embed, persistent, th-lift-instances
Dependency ranges changed: base, conduit, fast-logger, monad-logger, resource-pool, resourcet, template-haskell, text
Files
- ChangeLog.md +11/−1
- Database/Persist/Quasi.hs +104/−84
- Database/Persist/TH.hs +2014/−0
- Database/Persist/Types/Base.hs +94/−50
- bench/Main.hs +191/−0
- bench/Models.hs +59/−0
- persistent.cabal +67/−31
- test/Database/Persist/TH/OverloadedLabelSpec.hs +56/−0
- test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs +54/−0
- test/Database/Persist/TH/SharedPrimaryKeySpec.hs +57/−0
- test/Database/Persist/THSpec.hs +374/−0
- test/TemplateTestImports.hs +23/−0
- test/main.hs +383/−260
ChangeLog.md view
@@ -1,7 +1,10 @@ # Changelog for persistent -## 2.12 (unreleased)+## 2.12.0.1 (unreleased) +* Refactoring token parsing in quasi module [#1206](https://github.com/yesodweb/persistent/pull/1206)+* Removing duplication from TH output [#1202](https://github.com/yesodweb/persistent/pull/1202)+* Refactor [] to NonEmpty in Quasi module [#1193](https://github.com/yesodweb/persistent/pull/1193) * [#1162](https://github.com/yesodweb/persistent/pull/1162) * Replace `askLogFunc` with `askLoggerIO` * Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174)@@ -19,6 +22,13 @@ Fortunately, this doesn't affect the public API, and can be a mere bug release. * Removed the functions `unsafeAcquireSqlConnFromPool`, `acquireASqlConnFromPool`, and `acquireSqlConnFromPoolWithIsolation`. For a replacement, see `runSqlPoolNoTransaction` and `runSqlPoolWithHooks`.+* Renaming values in persistent-template [#1203](https://github.com/yesodweb/persistent/pull/1203)+* [#1214](https://github.com/yesodweb/persistent/pull/1214):+ * Absorbed the `persistent-template` package. `persistent-template` will receive a 2.12 release with a warning and a deprecation notice.+ * Remove the `nooverlap` flag. It wasn't being used anymore.+* [#1205](https://github.com/yesodweb/persistent/pull/1205)+ * Introduce the `PersistLiteral_` constructor, replacing the `PersistLiteral`, `PersistLiteralEscaped`, and `PersistDbSpecific`.+ * The old constructors are now pattern synonyms. They don't actually differentiate between the various escaping strategies when consuming them! If you pattern match on multiple of `PersistDbSpecific`, `PersistLiteral`, or `PersistLiteralEscaped` , then you should use the `PersistLiteral_` constructor to differentiate between them. ## 2.11.0.2 * Fix a bug where an empty entity definition would break parsing of `EntityDef`s. [#1176](https://github.com/yesodweb/persistent/issues/1176)
Database/Persist/Quasi.hs view
@@ -40,7 +40,7 @@ @ As with the SQL generated, the specifics of this are customizable.-See the @persistent-template@ package for details.+See the "Database.Persist.TH" module for details. = Deriving @@ -423,10 +423,8 @@ , Token (..) , Line' (..) , preparse- , tokenize+ , parseLine , parseFieldType- , empty- , removeSpaces , associateLines , skipEmpty , LinesWithComments(..)@@ -538,33 +536,51 @@ -- | Parses a quasi-quoted syntax into a list of entity definitions. parse :: PersistSettings -> Text -> [EntityDef]-parse ps = parseLines ps . preparse+parse ps = maybe [] (parseLines ps) . preparse -preparse :: Text -> [Line]-preparse =- removeSpaces- . filter (not . empty)- . map tokenize- . T.lines+preparse :: Text -> Maybe (NonEmpty Line)+preparse txt = do+ lns <- NEL.nonEmpty (T.lines txt)+ NEL.nonEmpty $ mapMaybe parseLine (NEL.toList lns) +-- TODO: refactor to return (Line' NonEmpty), made possible by+-- https://github.com/yesodweb/persistent/pull/1206 but left out+-- in order to minimize the diff+parseLine :: Text -> Maybe Line+parseLine txt =+ case tokenize txt of+ [] ->+ Nothing+ toks ->+ pure $ Line (parseIndentationAmount txt) toks+ -- | A token used by the parser.-data Token = Spaces !Int -- ^ @Spaces n@ are @n@ consecutive spaces.- | Token Text -- ^ @Token tok@ is token @tok@ already unquoted.+data Token = Token Text -- ^ @Token tok@ is token @tok@ already unquoted. | DocComment Text -- ^ @DocComment@ is a documentation comment, unmodified. deriving (Show, Eq) +tokenText :: Token -> Text+tokenText tok =+ case tok of+ Token t -> t+ DocComment t -> "-- | " <> t++parseIndentationAmount :: Text -> Int+parseIndentationAmount txt =+ let (spaces, _) = T.span isSpace txt+ in T.length spaces+ -- | Tokenize a string. tokenize :: Text -> [Token] tokenize t | T.null t = []- | "-- | " `T.isPrefixOf` t = [DocComment t]+ | Just txt <- T.stripPrefix "-- | " t = [DocComment txt] | "--" `T.isPrefixOf` t = [] -- Comment until the end of the line. | "#" `T.isPrefixOf` t = [] -- Also comment to the end of the line, needed for a CPP bug (#110) | T.head t == '"' = quotes (T.tail t) id | T.head t == '(' = parens 1 (T.tail t) id | isSpace (T.head t) =- let (spaces, rest) = T.span isSpace t- in Spaces (T.length spaces) : tokenize rest+ tokenize (T.dropWhile isSpace t) -- support mid-token quotes and parens | Just (beforeEquals, afterEquals) <- findMidToken t@@ -606,23 +622,16 @@ let (x, y) = T.break (`elem` ['\\','(',')']) t' in parens count y (front . (x:)) --- | A string of tokens is empty when it has only spaces. There--- can't be two consecutive 'Spaces', so this takes /O(1)/ time.-empty :: [Token] -> Bool-empty [] = True-empty [Spaces _] = True-empty _ = False- -- | A line. We don't care about spaces in the middle of the--- line. Also, we don't care about the ammount of indentation.+-- line. Also, we don't care about the amount of indentation. data Line' f = Line { lineIndent :: Int- , tokens :: f Text+ , tokens :: f Token } -deriving instance Show (f Text) => Show (Line' f)-deriving instance Eq (f Text) => Eq (Line' f)+deriving instance Show (f Token) => Show (Line' f)+deriving instance Eq (f Token) => Eq (Line' f) mapLine :: (forall x. f x -> g x) -> Line' f -> Line' g mapLine k (Line i t) = Line i (k t)@@ -630,41 +639,35 @@ traverseLine :: Functor t => (forall x. f x -> t (g x)) -> Line' f -> t (Line' g) traverseLine k (Line i xs) = Line i <$> k xs -type Line = Line' []---- | Remove leading spaces and remove spaces in the middle of the--- tokens.-removeSpaces :: [[Token]] -> [Line]-removeSpaces =- map toLine- where- toLine (Spaces i:rest) = toLine' i rest- toLine xs = toLine' 0 xs+lineText :: Functor f => Line' f -> f Text+lineText = fmap tokenText . tokens - toLine' i = Line i . mapMaybe fromToken+type Line = Line' [] - fromToken (Token t) = Just t- fromToken (DocComment t) = Just t- fromToken Spaces{} = Nothing+lowestIndent+ :: Functor f+ => Foldable f+ => Functor g+ => f (Line' g)+ -> Int+lowestIndent = minimum . fmap lineIndent -- | Divide lines into blocks and make entity definitions.-parseLines :: PersistSettings -> [Line] -> [EntityDef]-parseLines ps lines =- fixForeignKeysAll $ toEnts lines+parseLines :: PersistSettings -> NonEmpty Line -> [EntityDef]+parseLines ps =+ fixForeignKeysAll . map mk . associateLines . skipEmpty where- toEnts :: [Line] -> [UnboundEntityDef]- toEnts =- map mk- . associateLines- . skipEmpty mk :: LinesWithComments -> UnboundEntityDef mk lwc =- let Line _ (name :| entAttribs) :| rest = lwcLines lwc+ let ln :| rest = lwcLines lwc+ (name :| entAttribs) = lineText ln in setComments (lwcComments lwc) $ mkEntityDef ps name entAttribs (map (mapLine NEL.toList) rest) -isComment :: Text -> Maybe Text-isComment xs =- T.stripPrefix "-- | " xs+isDocComment :: Token -> Maybe Text+isDocComment tok =+ case tok of+ DocComment txt -> Just txt+ _ -> Nothing data LinesWithComments = LinesWithComments { lwcLines :: NonEmpty (Line' NonEmpty)@@ -694,24 +697,24 @@ foldr combine [] $ foldr toLinesWithComments [] lines where+ toLinesWithComments :: Line' NonEmpty -> [LinesWithComments] -> [LinesWithComments] toLinesWithComments line linesWithComments = case linesWithComments of [] -> [newLine line] (lwc : lwcs) ->- case isComment (NEL.head (tokens line)) of+ case isDocComment (NEL.head (tokens line)) of Just comment- | lineIndent line == lowestIndent ->+ | lineIndent line == lowestIndent lines -> consComment comment lwc : lwcs _ -> if lineIndent line <= lineIndent (firstLine lwc)- && lineIndent (firstLine lwc) /= lowestIndent+ && lineIndent (firstLine lwc) /= lowestIndent lines then consLine line lwc : lwcs else newLine line : lwc : lwcs - lowestIndent = minimum . fmap lineIndent $ lines combine :: LinesWithComments -> [LinesWithComments] -> [LinesWithComments] combine lwc [] = [lwc]@@ -725,10 +728,10 @@ lwc : lwc' : lwcs - minimumIndentOf = minimum . fmap lineIndent . lwcLines+ minimumIndentOf = lowestIndent . lwcLines -skipEmpty :: [Line' []] -> [Line' NonEmpty]-skipEmpty = mapMaybe (traverseLine NEL.nonEmpty)+skipEmpty :: NonEmpty (Line' []) -> [Line' NonEmpty]+skipEmpty = mapMaybe (traverseLine NEL.nonEmpty) . NEL.toList setComments :: [Text] -> UnboundEntityDef -> UnboundEntityDef setComments [] = id@@ -858,7 +861,7 @@ , entityFields = cols , entityUniques = uniqs , entityForeigns = []- , entityDerives = concat $ mapMaybe takeDerives attribs+ , entityDerives = concat $ mapMaybe takeDerives textAttribs , entityExtra = extras , entitySum = isSum , entityComments = Nothing@@ -871,6 +874,10 @@ _ -> (False, name) (attribs, extras) = splitExtras lines + textAttribs :: [[Text]]+ textAttribs =+ fmap tokenText <$> attribs+ attribPrefix = flip lookupKeyVal entattribs idName | Just _ <- attribPrefix "id" = error "id= is deprecated, ad a field named 'Id' and use sql=" | otherwise = Nothing@@ -878,21 +885,21 @@ (idField, primaryComposite, uniqs, foreigns) = foldl' (\(mid, mp, us, fs) attr -> let (i, p, u, f) = takeConstraint ps name' cols attr squish xs m = xs `mappend` maybeToList m- in (just1 mid i, just1 mp p, squish us u, squish fs f)) (Nothing, Nothing, [],[]) attribs+ in (just1 mid i, just1 mp p, squish us u, squish fs f)) (Nothing, Nothing, [],[]) textAttribs cols :: [FieldDef] cols = reverse . fst . foldr k ([], []) $ reverse attribs+ k x (!acc, !comments) =- case isComment =<< listToMaybe x of- Just comment ->+ case listToMaybe x of+ Just (DocComment comment) -> (acc, comment : comments)- Nothing ->- ( maybe id (:) (setFieldComments comments <$> takeColsEx ps x) acc- , []- )- setFieldComments [] x = x- setFieldComments xs fld =- fld { fieldComments = Just (T.unlines xs) }+ _ ->+ case (setFieldComments comments <$> takeColsEx ps (tokenText <$> x)) of+ Just sm ->+ (sm : acc, [])+ Nothing ->+ (acc, []) autoIdField = mkAutoIdField ps entName (FieldNameDB `fmap` idName) idSqlType idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite@@ -902,6 +909,11 @@ { fieldReference = CompositeRef c } +setFieldComments :: [Text] -> FieldDef -> FieldDef+setFieldComments xs fld =+ case xs of+ [] -> fld+ _ -> fld { fieldComments = Just (T.unlines xs) } just1 :: (Show x) => Maybe x -> Maybe x -> Maybe x just1 (Just x) (Just y) = error $ "expected only one of: "@@ -935,19 +947,27 @@ splitExtras :: [Line]- -> ( [[Text]]- , M.Map Text [[Text]]+ -> ( [[Token]]+ , M.Map Text [ExtraLine] )-splitExtras [] = ([], M.empty)-splitExtras (Line indent [name]:rest)- | not (T.null name) && isUpper (T.head name) =- let (children, rest') = span ((> indent) . lineIndent) rest- (x, y) = splitExtras rest'- in (x, M.insert name (map tokens children) y)-splitExtras (Line _ ts:rest) =- let (x, y) = splitExtras rest- in (ts:x, y)+splitExtras lns =+ case lns of+ [] -> ([], M.empty)+ (line : rest) ->+ case line of+ Line indent [Token name]+ | isCapitalizedText name ->+ let (children, rest') = span ((> indent) . lineIndent) rest+ (x, y) = splitExtras rest'+ in (x, M.insert name (map lineText children) y)+ Line _ ts ->+ let (x, y) = splitExtras rest+ in (ts:x, y) +isCapitalizedText :: Text -> Bool+isCapitalizedText t =+ not (T.null t) && isUpper (T.head t)+ takeColsEx :: PersistSettings -> [Text] -> Maybe FieldDef takeColsEx = takeCols@@ -998,7 +1018,7 @@ -> [FieldDef] -> [Text] -> (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef, Maybe UnboundForeignDef)-takeConstraint ps tableName defs (n:rest) | not (T.null n) && isUpper (T.head n) = takeConstraint'+takeConstraint ps tableName defs (n:rest) | isCapitalizedText n = takeConstraint' where takeConstraint' | n == "Unique" = (Nothing, Nothing, Just $ takeUniq ps tableName defs rest, Nothing)@@ -1060,7 +1080,7 @@ -> [Text] -> UniqueDef takeUniq ps tableName defs (n:rest)- | not (T.null n) && isUpper (T.head n)+ | isCapitalizedText n = UniqueDef (ConstraintNameHS n) dbName
+ Database/Persist/TH.hs view
@@ -0,0 +1,2014 @@+{-# LANGUAGE CPP, BangPatterns #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveLift #-}++-- {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-}++-- | This module provides the tools for defining your database schema and using+-- it to generate Haskell data types and migrations.+module Database.Persist.TH+ ( -- * Parse entity defs+ persistWith+ , persistUpperCase+ , persistLowerCase+ , persistFileWith+ , persistManyFileWith+ -- * Turn @EntityDef@s into types+ , mkPersist+ , MkPersistSettings+ , mpsBackend+ , mpsGeneric+ , mpsPrefixFields+ , mpsFieldLabelModifier+ , mpsConstraintLabelModifier+ , mpsEntityJSON+ , mpsGenerateLenses+ , mpsDeriveInstances+ , EntityJSON(..)+ , mkPersistSettings+ , sqlSettings+ -- * Various other TH functions+ , mkMigrate+ , mkSave+ , mkDeleteCascade+ , mkEntityDefList+ , share+ , derivePersistField+ , derivePersistFieldJSON+ , persistFieldFromEntity+ -- * Internal+ , lensPTH+ , parseReferences+ , embedEntityDefs+ , fieldError+ , AtLeastOneUniqueKey(..)+ , OnlyOneUniqueKey(..)+ , pkNewtype+ ) where++-- Development Tip: See persistent-template/README.md for advice on seeing generated Template Haskell code+-- It's highly recommended to check the diff between master and your PR's generated code.++import Prelude hiding ((++), take, concat, splitAt, exp)++import Data.Either+import Control.Monad+import Data.Aeson+ ( ToJSON (toJSON), FromJSON (parseJSON), (.=), object+ , Value (Object), (.:), (.:?)+ , eitherDecodeStrict'+ )+import qualified Data.ByteString as BS+import Data.Typeable (Typeable)+import Data.Ix (Ix)+import Data.Data (Data)+import Data.Char (toLower, toUpper)+import qualified Data.HashMap.Strict as HM+import Data.Int (Int64)+import Data.List (foldl')+import qualified Data.List as List+import qualified Data.List.NonEmpty as NEL+import qualified Data.Map as M+import Data.Maybe (isJust, listToMaybe, mapMaybe, fromMaybe)+import Data.Monoid ((<>), mappend, mconcat)+import Data.Proxy (Proxy (Proxy))+import Data.Text (pack, Text, append, unpack, concat, uncons, cons, stripSuffix)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import qualified Data.Text.Encoding as TE+import GHC.Generics (Generic)+import GHC.TypeLits+import Instances.TH.Lift ()+ -- Bring `Lift (Map k v)` instance into scope, as well as `Lift Text`+ -- instance on pre-1.2.4 versions of `text`+import Language.Haskell.TH.Lib (appT, varT, conT, varE, varP, conE, litT, strTyLit)+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Web.PathPieces (PathPiece(..))+import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..))+import qualified Data.Set as Set++import Database.Persist+import Database.Persist.Sql (Migration, PersistFieldSql, SqlBackend, migrate, sqlType)+import Database.Persist.Quasi++-- | This special-cases "type_" and strips out its underscore. When+-- used for JSON serialization and deserialization, it works around+-- <https://github.com/yesodweb/persistent/issues/412>+unFieldNameHSForJSON :: FieldNameHS -> Text+unFieldNameHSForJSON = fixTypeUnderscore . unFieldNameHS+ where+ fixTypeUnderscore = \case+ "type" -> "type_"+ name -> name++-- | 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. The recommended file extension is @.persistentmodels@.+persistFileWith :: PersistSettings -> FilePath -> Q Exp+persistFileWith ps fp = persistManyFileWith ps [fp]++-- | Same as 'persistFileWith', but uses several external files instead of+-- one. Splitting your Persistent definitions into multiple modules can+-- potentially dramatically speed up compile times.+--+-- The recommended file extension is @.persistentmodels@.+--+-- ==== __Examples__+--+-- Split your Persistent definitions into multiple files (@models1@, @models2@),+-- then create a new module for each new file and run 'mkPersist' there:+--+-- @+-- -- Model1.hs+-- 'share'+-- ['mkPersist' 'sqlSettings']+-- $('persistFileWith' 'lowerCaseSettings' "models1")+-- @+-- @+-- -- Model2.hs+-- 'share'+-- ['mkPersist' 'sqlSettings']+-- $('persistFileWith' 'lowerCaseSettings' "models2")+-- @+--+-- Use 'persistManyFileWith' to create your migrations:+--+-- @+-- -- Migrate.hs+-- 'share'+-- ['mkMigrate' "migrateAll"]+-- $('persistManyFileWith' 'lowerCaseSettings' ["models1.persistentmodels","models2.persistentmodels"])+-- @+--+-- Tip: To get the same import behavior as if you were declaring all your models in+-- one file, import your new files @as Name@ into another file, then export @module Name@.+--+-- This approach may be used in the future to reduce memory usage during compilation,+-- but so far we've only seen mild reductions.+--+-- See <https://github.com/yesodweb/persistent/issues/778 persistent#778> and+-- <https://github.com/yesodweb/persistent/pull/791 persistent#791> for more details.+--+-- @since 2.5.4+persistManyFileWith :: PersistSettings -> [FilePath] -> Q Exp+persistManyFileWith ps fps = do+ mapM_ qAddDependentFile fps+ ss <- mapM (qRunIO . getFileContents) fps+ let s = T.intercalate "\n" ss -- be tolerant of the user forgetting to put a line-break at EOF.+ parseReferences ps s++getFileContents :: FilePath -> IO Text+getFileContents = fmap decodeUtf8 . BS.readFile++-- | Takes a list of (potentially) independently defined entities and properly+-- links all foreign keys to reference the right 'EntityDef', tying the knot+-- between entities.+--+-- Allows users to define entities indepedently or in separate modules and then+-- fix the cross-references between them at runtime to create a 'Migration'.+--+-- @since 2.7.2+embedEntityDefs :: [EntityDef] -> [EntityDef]+embedEntityDefs = snd . embedEntityDefsMap++embedEntityDefsMap :: [EntityDef] -> (M.Map EntityNameHS EmbedEntityDef, [EntityDef])+embedEntityDefsMap rawEnts = (embedEntityMap, noCycleEnts)+ where+ noCycleEnts = map breakCycleEnt entsWithEmbeds+ -- every EntityDef could reference each-other (as an EmbedRef)+ -- let Haskell tie the knot+ embedEntityMap = constructEmbedEntityMap entsWithEmbeds+ entsWithEmbeds = map setEmbedEntity rawEnts+ setEmbedEntity ent = ent+ { entityFields = map (setEmbedField (entityHaskell ent) embedEntityMap) $ entityFields ent+ }++ -- self references are already broken+ -- look at every emFieldEmbed to see if it refers to an already seen EntityNameHS+ -- so start with entityHaskell ent and accumulate embeddedHaskell em+ breakCycleEnt entDef =+ let entName = entityHaskell entDef+ in entDef { entityFields = map (breakCycleField entName) $ entityFields entDef }++ breakCycleField entName f = case f of+ FieldDef { fieldReference = EmbedRef em } ->+ f { fieldReference = EmbedRef $ breakCycleEmbed [entName] em }+ _ ->+ f++ breakCycleEmbed ancestors em =+ em { embeddedFields = 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++-- calls parse to Quasi.parse individual entities in isolation+-- afterwards, sets references to other entities+-- | @since 2.5.3+parseReferences :: PersistSettings -> Text -> Q Exp+parseReferences ps s = lift $+ map (mkEntityDefSqlTypeExp embedEntityMap entityMap) noCycleEnts+ where+ (embedEntityMap, noCycleEnts) = embedEntityDefsMap $ parse ps s+ entityMap = constructEntityMap noCycleEnts++stripId :: FieldType -> Maybe Text+stripId (FTTypeCon Nothing t) = stripSuffix "Id" t+stripId _ = Nothing++foreignReference :: FieldDef -> Maybe EntityNameHS+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+#if MIN_VERSION_template_haskell(2,16,0)+ liftTyped = unsafeTExpCoerce . lift+#endif++data FieldsSqlTypeExp = FieldsSqlTypeExp [FieldDef] [SqlTypeExp]++instance Lift FieldsSqlTypeExp where+ lift (FieldsSqlTypeExp fields sqlTypeExps) =+ lift $ zipWith FieldSqlTypeExp fields sqlTypeExps+#if MIN_VERSION_template_haskell(2,16,0)+ liftTyped = unsafeTExpCoerce . lift+#endif++data FieldSqlTypeExp = FieldSqlTypeExp FieldDef SqlTypeExp++instance Lift FieldSqlTypeExp where+ lift (FieldSqlTypeExp FieldDef{..} sqlTypeExp) =+ [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs fieldStrict fieldReference fieldCascade fieldComments fieldGenerated|]+ where+ FieldDef _x _ _ _ _ _ _ _ _ _ =+ error "need to update this record wildcard match"+#if MIN_VERSION_template_haskell(2,16,0)+ liftTyped = unsafeTExpCoerce . lift+#endif++instance Lift EntityDefSqlTypeExp where+ lift (EntityDefSqlTypeExp ent sqlTypeExp sqlTypeExps) =+ [|ent { entityFields = $(lift $ FieldsSqlTypeExp (entityFields ent) sqlTypeExps)+ , entityId = $(lift $ FieldSqlTypeExp (entityId ent) sqlTypeExp)+ }+ |]+#if MIN_VERSION_template_haskell(2,16,0)+ liftTyped = unsafeTExpCoerce . lift+#endif++type EmbedEntityMap = M.Map EntityNameHS EmbedEntityDef++constructEmbedEntityMap :: [EntityDef] -> EmbedEntityMap+constructEmbedEntityMap =+ M.fromList . fmap (\ent -> (entityHaskell ent, toEmbedEntityDef ent))++type EntityMap = M.Map EntityNameHS EntityDef++constructEntityMap :: [EntityDef] -> EntityMap+constructEntityMap =+ M.fromList . fmap (\ent -> (entityHaskell ent, ent))++data FTTypeConDescr = FTKeyCon+ deriving Show++-- | Recurses through the 'FieldType'. Returns a 'Right' with the+-- 'EmbedEntityDef' if the 'FieldType' corresponds to an unqualified use of+-- a name and that name is present in the 'EmbedEntityMap' provided as+-- a first argument.+--+-- If the 'FieldType' represents a @Key something@, this returns a @'Left+-- ('Just' 'FTKeyCon')@.+--+-- If the 'FieldType' has a module qualified value, then it returns @'Left'+-- 'Nothing'@.+mEmbedded+ :: EmbedEntityMap+ -> FieldType+ -> Either (Maybe FTTypeConDescr) EmbedEntityDef+mEmbedded _ (FTTypeCon Just{} _) =+ Left Nothing+mEmbedded ents (FTTypeCon Nothing (EntityNameHS -> name)) =+ maybe (Left Nothing) Right $ M.lookup name ents+mEmbedded ents (FTList x) =+ mEmbedded ents x+mEmbedded ents (FTApp x y) =+ -- Key converts an Record to a RecordId+ -- special casing this is obviously a hack+ -- 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 :: EntityNameHS -> EmbedEntityMap -> FieldDef -> FieldDef+setEmbedField entName allEntities field = field+ { fieldReference =+ case fieldReference field of+ NoReference ->+ case mEmbedded allEntities (fieldType field) of+ Left _ ->+ case stripId $ fieldType field of+ Nothing ->+ NoReference+ Just name ->+ case M.lookup (EntityNameHS name) allEntities of+ Nothing ->+ NoReference+ Just _ ->+ ForeignRef+ (EntityNameHS name)+ -- This can get corrected in mkEntityDefSqlTypeExp+ (FTTypeCon (Just "Data.Int") "Int64")+ Right em ->+ if embeddedHaskell em /= entName+ then EmbedRef em+ else if maybeNullable field+ then SelfReference+ else case fieldType field of+ FTList _ -> SelfReference+ _ -> error $ unpack $ unEntityNameHS entName <> ": a self reference must be a Maybe"+ existing ->+ existing+ }++mkEntityDefSqlTypeExp :: EmbedEntityMap -> EntityMap -> EntityDef -> EntityDefSqlTypeExp+mkEntityDefSqlTypeExp emEntities entityMap ent =+ EntityDefSqlTypeExp ent (getSqlType $ entityId ent) (map getSqlType $ entityFields ent)+ where+ getSqlType field =+ maybe+ (defaultSqlTypeExp field)+ (SqlType' . SqlOther)+ (listToMaybe $ mapMaybe (\case {FieldAttrSqltype x -> Just x; _ -> Nothing}) $ fieldAttrs field)++ -- In the case of embedding, there won't be any datatype created yet.+ -- We just use SqlString, as the data will be serialized to JSON.+ defaultSqlTypeExp field =+ case mEmbedded emEntities ftype of+ Right _ ->+ SqlType' SqlString+ Left (Just FTKeyCon) ->+ SqlType' SqlString+ Left Nothing ->+ case fieldReference field of+ ForeignRef refName ft ->+ case M.lookup refName entityMap of+ Nothing -> SqlTypeExp ft+ -- A ForeignRef is blindly set to an Int64 in setEmbedField+ -- correct that now+ Just ent' ->+ case entityPrimary ent' of+ Nothing -> SqlTypeExp ft+ Just pdef ->+ case compositeFields pdef of+ [] -> error "mkEntityDefSqlTypeExp: no composite fields"+ [x] -> SqlTypeExp $ fieldType x+ _ -> SqlType' $ SqlOther "Composite Reference"+ CompositeRef _ ->+ SqlType' $ SqlOther "Composite Reference"+ _ ->+ case ftype of+ -- In the case of lists, we always serialize to a string+ -- value (via JSON).+ --+ -- Normally, this would be determined automatically by+ -- SqlTypeExp. However, there's one corner case: if there's+ -- a list of entity IDs, the datatype for the ID has not+ -- yet been created, so the compiler will fail. This extra+ -- clause works around this limitation.+ FTList _ -> SqlType' SqlString+ _ -> SqlTypeExp ftype+ 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+ requireExtensions+ [ [TypeFamilies], [GADTs, ExistentialQuantification]+ , [DerivingStrategies], [GeneralizedNewtypeDeriving], [StandaloneDeriving]+ , [UndecidableInstances], [DataKinds], [FlexibleInstances]+ ]+ persistFieldDecs <- fmap mconcat $ mapM (persistFieldFromEntity mps) ents+ entityDecs <- fmap mconcat $ mapM (mkEntity entityMap mps) ents+ jsonDecs <- fmap mconcat $ mapM (mkJSON mps) ents+ uniqueKeyInstances <- fmap mconcat $ mapM (mkUniqueKeyInstances mps) ents+ symbolToFieldInstances <- fmap mconcat $ mapM (mkSymbolToFieldInstances mps) ents+ return $ mconcat+ [ persistFieldDecs+ , entityDecs+ , jsonDecs+ , uniqueKeyInstances+ , symbolToFieldInstances+ ]+ where+ ents = map fixEntityDef ents'+ entityMap = constructEntityMap 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 = FieldAttrMigrationOnly `notElem` fieldAttrs fd &&+ FieldAttrSafeToRemove `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:+ -- False.+ , mpsPrefixFields :: Bool+ -- ^ Prefix field names with the model name. Default: True.+ --+ -- Note: this field is deprecated. Use the mpsFieldLabelModifier and mpsConstraintLabelModifier instead.+ , mpsFieldLabelModifier :: Text -> Text -> Text+ -- ^ Customise the field accessors and lens names using the entity and field name.+ -- Both arguments are upper cased.+ --+ -- Default: appends entity and field.+ --+ -- Note: this setting is ignored if mpsPrefixFields is set to False.+ -- @since 2.11.0.0+ , mpsConstraintLabelModifier :: Text -> Text -> Text+ -- ^ Customise the Constraint names using the entity and field name. The result+ -- should be a valid haskell type (start with an upper cased letter).+ --+ -- Default: appends entity and field+ --+ -- Note: this setting is ignored if mpsPrefixFields is set to False.+ -- @since 2.11.0.0+ , mpsEntityJSON :: Maybe EntityJSON+ -- ^ Generate @ToJSON@/@FromJSON@ instances for each model types. If it's+ -- @Nothing@, no instances will be generated. Default:+ --+ -- @+ -- Just EntityJSON+ -- { entityToJSON = 'entityIdToJSON+ -- , entityFromJSON = 'entityIdFromJSON+ -- }+ -- @+ , mpsGenerateLenses :: !Bool+ -- ^ Instead of generating normal field accessors, generator lens-style accessors.+ --+ -- Default: False+ --+ -- @since 1.3.1+ , mpsDeriveInstances :: ![Name]+ -- ^ Automatically derive these typeclass instances for all record and key types.+ --+ -- Default: []+ --+ -- @since 2.8.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 backend = MkPersistSettings+ { mpsBackend = backend+ , mpsGeneric = False+ , mpsPrefixFields = True+ , mpsFieldLabelModifier = (++)+ , mpsConstraintLabelModifier = (++)+ , mpsEntityJSON = Just EntityJSON+ { entityToJSON = 'entityIdToJSON+ , entityFromJSON = 'entityIdFromJSON+ }+ , mpsGenerateLenses = False+ , mpsDeriveInstances = []+ }++-- | Use the 'SqlPersist' backend.+sqlSettings :: MkPersistSettings+sqlSettings = mkPersistSettings $ ConT ''SqlBackend++recNameNoUnderscore :: MkPersistSettings -> EntityNameHS -> FieldNameHS -> Text+recNameNoUnderscore mps entName fieldName+ | mpsPrefixFields mps = lowerFirst $ modifier (unEntityNameHS entName) (upperFirst ft)+ | otherwise = lowerFirst ft+ where+ modifier = mpsFieldLabelModifier mps+ ft = unFieldNameHS fieldName++recNameF :: MkPersistSettings -> EntityNameHS -> FieldNameHS -> Text+recNameF mps entName fieldName =+ addUnderscore $ recNameNoUnderscore mps entName fieldName+ where+ addUnderscore+ | mpsGenerateLenses mps = ("_" ++)+ | otherwise = id++lowerFirst :: Text -> Text+lowerFirst t =+ case uncons t of+ 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 entDef = do+ let entityInstances = map (mkName . unpack) $ entityDerives entDef+ additionalInstances = filter (`notElem` entityInstances) $ mpsDeriveInstances mps+ names = entityInstances <> additionalInstances++ let (stocks, anyclasses) = partitionEithers (map stratFor names)+ let stockDerives = do+ guard (not (null stocks))+ pure (DerivClause (Just StockStrategy) (map ConT stocks))+ anyclassDerives = do+ guard (not (null anyclasses))+ pure (DerivClause (Just AnyclassStrategy) (map ConT anyclasses))+ unless (null anyclassDerives) $ do+ requireExtensions [[DeriveAnyClass]]+ pure $ DataD [] nameFinal paramsFinal+ Nothing+ constrs+ (stockDerives <> anyclassDerives)+ where+ stratFor n =+ if n `elem` stockClasses then+ Left n+ else+ Right n++ stockClasses =+ Set.fromList (map mkName+ [ "Eq", "Ord", "Show", "Read", "Bounded", "Enum", "Ix", "Generic", "Data", "Typeable"+ ] <> [''Eq, ''Ord, ''Show, ''Read, ''Bounded, ''Enum, ''Ix, ''Generic, ''Data, ''Typeable+ ]+ )+ mkCol x fd@FieldDef {..} =+ (mkName $ unpack $ recNameF 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 $ unEntityNameHS (entityHaskell entDef) ++ "Generic"+ name = mkName $ unpack $ unEntityNameHS $ entityHaskell entDef+ cols = map (mkCol $ entityHaskell entDef) $ entityFields entDef+ backend = backendName++ constrs+ | entitySum entDef = map sumCon $ entityFields entDef+ | otherwise = [RecC name cols]++ sumCon fieldDef = NormalC+ (sumConstrName mps entDef fieldDef)+ [(notStrict, maybeIdType mps fieldDef Nothing Nothing)]++sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name+sumConstrName mps entDef FieldDef {..} = mkName $ unpack name+ where+ name+ | mpsPrefixFields mps = modifiedName ++ "Sum"+ | otherwise = fieldName ++ "Sum"+ modifiedName = mpsConstraintLabelModifier mps entityName fieldName+ entityName = unEntityNameHS $ entityHaskell entDef+ fieldName = upperFirst $ unFieldNameHS fieldHaskell++uniqueTypeDec :: MkPersistSettings -> EntityDef -> Dec+uniqueTypeDec mps entDef =+#if MIN_VERSION_template_haskell(2,15,0)+ DataInstD [] Nothing+ (AppT (ConT ''Unique) (genericDataType mps (entityHaskell entDef) backendT))+ Nothing+ (map (mkUnique mps entDef) $ entityUniques entDef)+ []+#else+ DataInstD [] ''Unique+ [genericDataType mps (entityHaskell entDef) backendT]+ Nothing+ (map (mkUnique mps entDef) $ entityUniques entDef)+ []+#endif++mkUnique :: MkPersistSettings -> EntityDef -> UniqueDef -> Con+mkUnique mps entDef (UniqueDef (ConstraintNameHS constr) _ fields attrs) =+ NormalC (mkName $ unpack constr) types+ where+ types =+ map (go . flip lookup3 (entityFields entDef) . unFieldNameHS . 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 == unFieldNameHS 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 fieldDef mbackend mnull = maybeTyp mayNullable idtyp+ where+ mayNullable = case mnull of+ (Just (Nullable ByMaybeAttr)) -> True+ _ -> maybeNullable fieldDef+ idtyp = idType mps fieldDef mbackend++backendDataType :: MkPersistSettings -> Type+backendDataType mps+ | mpsGeneric mps = backendT+ | otherwise = mpsBackend mps++genericDataType :: MkPersistSettings+ -> EntityNameHS+ -> Type -- ^ backend+ -> Type+genericDataType mps (EntityNameHS typ') backend+ | mpsGeneric mps = ConT (mkName $ unpack $ typ' ++ "Generic") `AppT` backend+ | otherwise = ConT $ mkName $ unpack typ'++idType :: MkPersistSettings -> FieldDef -> Maybe Name -> Type+idType mps fieldDef mbackend =+ case foreignReference fieldDef of+ Just typ ->+ ConT ''Key+ `AppT` genericDataType mps typ (VarT $ fromMaybe backendName mbackend)+ Nothing -> ftToType $ fieldType fieldDef++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 fieldDef idx = do+ let name = sumConstrName mps ed fieldDef+ 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 $ unConstraintNameHS 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 $ unConstraintNameHS 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)++mkFromPersistValues :: MkPersistSettings -> EntityDef -> Q [Clause]+mkFromPersistValues _ entDef@(EntityDef { entitySum = False }) =+ fromValues entDef "fromPersistValues" entE $ entityFields entDef+ where+ entE = ConE $ mkName $ unpack entName+ entName = unEntityNameHS $ entityHaskell entDef++mkFromPersistValues mps entDef@(EntityDef { entitySum = True }) = do+ nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|]+ clauses <- mkClauses [] $ entityFields entDef+ return $ clauses `mappend` [normalClause [WildP] nothing]+ where+ entName = unEntityNameHS $ entityHaskell entDef+ 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 entDef 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 entDef = 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 entDef) []]+ (lens' `AppE` getId `AppE` setId)+ if entitySum entDef+ then return $ idClause : map (toSumClause lens' keyVar valName xName) (entityFields entDef)+ else return $ idClause : map (toClause lens' getVal dot keyVar valName xName) (entityFields entDef)+ where+ toClause lens' getVal dot keyVar valName xName f = normalClause+ [ConP (filterConName mps entDef f) []]+ (lens' `AppE` getter `AppE` setter)+ where+ fieldName = mkName $ unpack $ recNameF mps (entityHaskell entDef) (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 fieldDef = normalClause+ [ConP (filterConName mps entDef fieldDef) []]+ (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 entDef fieldDef) [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 entDef) > 1 then [emptyMatch] else []+ setter = LamE+ [ ConP 'Entity [VarP keyVar, WildP]+ , VarP xName+ ]+ $ ConE 'Entity `AppE` VarE keyVar `AppE` (ConE (sumConstrName mps entDef fieldDef) `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 entDef = do+ (instDecs, i) <-+ if mpsGeneric mps+ then if not useNewtype+ then do pfDec <- pfInstD+ return (pfDec, supplement [''Generic])+ else do gi <- genericNewtypeInstances+ return (gi, supplement [])+ else if not useNewtype+ then do pfDec <- pfInstD+ return (pfDec, supplement [''Show, ''Read, ''Eq, ''Ord, ''Generic])+ else do+ let allInstances = supplement [''Show, ''Read, ''Eq, ''Ord, ''PathPiece, ''ToHttpApiData, ''FromHttpApiData, ''PersistField, ''PersistFieldSql, ''ToJSON, ''FromJSON]+ if customKeyType+ then return ([], allInstances)+ else do+ bi <- backendKeyI+ return (bi, allInstances)++ requirePersistentExtensions++ -- Always use StockStrategy for Show/Read. This means e.g. (FooKey 1) shows as ("FooKey 1"), rather than just "1"+ -- This is much better for debugging/logging purposes+ -- cf. https://github.com/yesodweb/persistent/issues/1104+ let alwaysStockStrategyTypeclasses = [''Show, ''Read]+ deriveClauses = map (\typeclass ->+ if (not useNewtype || typeclass `elem` alwaysStockStrategyTypeclasses)+ then DerivClause (Just StockStrategy) [(ConT typeclass)]+ else DerivClause (Just NewtypeStrategy) [(ConT typeclass)]+ ) i++#if MIN_VERSION_template_haskell(2,15,0)+ let kd = if useNewtype+ then NewtypeInstD [] Nothing (AppT (ConT k) recordType) Nothing dec deriveClauses+ else DataInstD [] Nothing (AppT (ConT k) recordType) Nothing [dec] deriveClauses+#else+ let kd = if useNewtype+ then NewtypeInstD [] k [recordType] Nothing dec deriveClauses+ else DataInstD [] k [recordType] Nothing [dec] deriveClauses+#endif+ return (kd, instDecs)+ where+ keyConE = keyConExp entDef+ unKeyE = unKeyExp entDef+ dec = RecC (keyConName entDef) (keyFields mps entDef)+ k = ''Key+ recordType = genericDataType mps (entityHaskell entDef) 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))+ |]++ 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)+ |]++ genericNewtypeInstances = do+ requirePersistentExtensions++ instances <- do+ alwaysInstances <-+ -- See the "Always use StockStrategy" comment above, on why Show/Read use "stock" here+ [d|deriving stock instance Show (BackendKey $(pure backendT)) => Show (Key $(pure recordType))+ deriving stock instance Read (BackendKey $(pure backendT)) => Read (Key $(pure recordType))+ deriving newtype instance Eq (BackendKey $(pure backendT)) => Eq (Key $(pure recordType))+ deriving newtype instance Ord (BackendKey $(pure backendT)) => Ord (Key $(pure recordType))+ deriving newtype instance ToHttpApiData (BackendKey $(pure backendT)) => ToHttpApiData (Key $(pure recordType))+ deriving newtype instance FromHttpApiData (BackendKey $(pure backendT)) => FromHttpApiData(Key $(pure recordType))+ deriving newtype instance PathPiece (BackendKey $(pure backendT)) => PathPiece (Key $(pure recordType))+ deriving newtype instance PersistField (BackendKey $(pure backendT)) => PersistField (Key $(pure recordType))+ deriving newtype instance PersistFieldSql (BackendKey $(pure backendT)) => PersistFieldSql (Key $(pure recordType))+ deriving newtype instance ToJSON (BackendKey $(pure backendT)) => ToJSON (Key $(pure recordType))+ deriving newtype instance FromJSON (BackendKey $(pure backendT)) => FromJSON (Key $(pure recordType))+ |]++ if customKeyType then return alwaysInstances+ else fmap (alwaysInstances `mappend`) backendKeyGenericI+ return instances++ useNewtype = pkNewtype mps entDef+ customKeyType = not (defaultIdType entDef) || not useNewtype || isJust (entityPrimary entDef)++ supplement :: [Name] -> [Name]+ supplement names = names <> (filter (`notElem` names) $ mpsDeriveInstances mps)++keyIdName :: EntityDef -> Name+keyIdName = mkName . unpack . keyIdText++keyIdText :: EntityDef -> Text+keyIdText entDef = unEntityNameHS (entityHaskell entDef) `mappend` "Id"++unKeyName :: EntityDef -> Name+unKeyName entDef = mkName $ "un" `mappend` keyString entDef++unKeyExp :: EntityDef -> Exp+unKeyExp = VarE . unKeyName++backendT :: Type+backendT = VarT backendName++backendName :: Name+backendName = mkName "backend"++keyConName :: EntityDef -> Name+keyConName entDef = mkName $ resolveConflict $ keyString entDef+ where+ resolveConflict kn = if conflict then kn `mappend` "'" else kn+ conflict = any ((== FieldNameHS "key") . fieldHaskell) $ entityFields entDef++keyConExp :: EntityDef -> Exp+keyConExp = ConE . keyConName++keyString :: EntityDef -> String+keyString = unpack . keyText++keyText :: EntityDef -> Text+keyText entDef = unEntityNameHS (entityHaskell entDef) ++ "Key"++-- | Returns 'True' if the key definition has more than 1 field.+--+-- @since 2.11.0.0+pkNewtype :: MkPersistSettings -> EntityDef -> Bool+pkNewtype mps entDef = length (keyFields mps entDef) < 2++defaultIdType :: EntityDef -> Bool+defaultIdType entDef = fieldType (entityId entDef) == FTTypeCon Nothing (keyIdText entDef)++keyFields :: MkPersistSettings -> EntityDef -> [(Name, Strict, Type)]+keyFields mps entDef = case entityPrimary entDef of+ Just pdef -> map primaryKeyVar (compositeFields pdef)+ Nothing -> if defaultIdType entDef+ then [idKeyVar backendKeyType]+ else [idKeyVar $ ftToType $ fieldType $ entityId entDef]+ where+ backendKeyType+ | mpsGeneric mps = ConT ''BackendKey `AppT` backendT+ | otherwise = ConT ''BackendKey `AppT` mpsBackend mps+ idKeyVar ft = (unKeyName entDef, notStrict, ft)+ primaryKeyVar fieldDef = ( keyFieldName mps entDef fieldDef+ , notStrict+ , ftToType $ fieldType fieldDef+ )++keyFieldName :: MkPersistSettings -> EntityDef -> FieldDef -> Name+keyFieldName mps entDef fieldDef+ | pkNewtype mps entDef = unKeyName entDef+ | otherwise = mkName $ unpack $ lowerFirst (keyText entDef) `mappend` unFieldNameHS (fieldHaskell fieldDef)++mkKeyToValues :: MkPersistSettings -> EntityDef -> Q Dec+mkKeyToValues mps entDef = do+ (p, e) <- case entityPrimary entDef of+ Nothing ->+ ([],) <$> [|(:[]) . toPersistValue . $(return $ unKeyExp entDef)|]+ Just pdef ->+ return $ toValuesPrimary pdef+ return $ FunD 'keyToValues $ return $ normalClause p e+ where+ toValuesPrimary pdef =+ ( [VarP recordName]+ , ListE $ map (\fieldDef -> VarE 'toPersistValue `AppE` (VarE (keyFieldName mps entDef fieldDef) `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 entDef = do+ clauses <- case entityPrimary entDef of+ Nothing -> do+ e <- [|fmap $(return keyConE) . fromPersistValue . headNote|]+ return [normalClause [] e]+ Just pdef ->+ fromValues entDef "keyFromValues" keyConE (compositeFields pdef)+ return $ FunD 'keyFromValues clauses+ where+ keyConE = keyConExp entDef++headNote :: [PersistValue] -> PersistValue+headNote = \case+ [x] -> x+ xs -> error $ "mkKeyFromValues: expected a list of one element, got: " `mappend` show xs++fromValues :: EntityDef -> Text -> Exp -> [FieldDef] -> Q [Clause]+fromValues entDef funName conE fields = do+ x <- newName "x"+ let funMsg = entityText entDef `mappend` ": " `mappend` funName `mappend` " failed on: "+ patternMatchFailure <- [|Left $ mappend funMsg (pack $ show $(return $ VarE x))|]+ suc <- patternSuccess+ return [ suc, normalClause [VarP x] patternMatchFailure ]+ where+ tableName = unEntityNameDB (entityDB entDef)+ patternSuccess =+ case fields of+ [] -> do+ rightE <- [|Right|]+ return $ normalClause [ListP []] (rightE `AppE` conE)+ _ -> do+ x1 <- newName "x1"+ restNames <- mapM (\i -> newName $ "x" `mappend` show i) [2..length fields]+ (fpv1:mkPersistValues) <- mapM mkPersistValue fields+ 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))++ infixFromPersistValue applyE fpv exp name =+ UInfixE exp applyE (fpv `AppE` VarE name)++ mkPersistValue field =+ let fieldName = (unFieldNameHS (fieldHaskell field))+ in [|mapLeft (fieldError tableName fieldName) . fromPersistValue|]++-- | Render an error message based on the @tableName@ and @fieldName@ with+-- the provided message.+--+-- @since 2.8.2+fieldError :: Text -> Text -> Text -> Text+fieldError tableName fieldName err = mconcat+ [ "Couldn't parse field `"+ , fieldName+ , "` from table `"+ , tableName+ , "`. "+ , err+ ]++mkEntity :: EntityMap -> MkPersistSettings -> EntityDef -> Q [Dec]+mkEntity entityMap mps entDef = do+ entityDefExp <-+ if mpsGeneric mps+ then liftAndFixKeys entityMap entDef+ else makePersistEntityDefExp mps entityMap entDef+ let nameT = unEntityNameHS entName+ let nameS = unpack nameT+ let clazz = ConT ''PersistEntity `AppT` genDataType+ tpf <- mkToPersistFields mps nameS entDef+ fpv <- mkFromPersistValues mps entDef+ utv <- mkUniqueToValues $ entityUniques entDef+ puk <- mkUniqueKeys entDef+ let primaryField = entityId entDef+ fields <- mapM (mkField mps entDef) $ primaryField : entityFields entDef+ fkc <- mapM (mkForeignKeysComposite mps entDef) $ entityForeigns entDef++ toFieldNames <- mkToFieldNames $ entityUniques entDef++ (keyTypeDec, keyInstanceDecs) <- mkKeyTypeDec mps entDef+ keyToValues' <- mkKeyToValues mps entDef+ keyFromValues' <- mkKeyFromValues mps entDef++ let addSyn -- FIXME maybe remove this+ | mpsGeneric mps = (:) $+ TySynD (mkName nameS) [] $+ genericDataType mps entName $ mpsBackend mps+ | otherwise = id++ lensClauses <- mkLensClauses mps entDef++ lenses <- mkLenses mps entDef+ let instanceConstraint = if not (mpsGeneric mps) then [] else+ [mkClassP ''PersistStore [backendT]]++ [keyFromRecordM'] <-+ case entityPrimary entDef of+ Just prim -> do+ recordName <- newName "record"+ let keyCon = keyConName entDef+ keyFields' =+ map (mkName . T.unpack . recNameF mps entName . fieldHaskell)+ (compositeFields prim)+ constr =+ foldl'+ AppE+ (ConE keyCon)+ (map+ (\n ->+ VarE n `AppE` VarE recordName+ )+ keyFields'+ )+ keyFromRec = varP 'keyFromRecordM+ [d|$(keyFromRec) = Just ( \ $(varP recordName) -> $(pure constr)) |]++ Nothing ->+ [d|$(varP 'keyFromRecordM) = Nothing|]++ dtd <- dataTypeDec mps entDef+ return $ addSyn $+ dtd : mconcat fkc `mappend`+ ([ TySynD (keyIdName entDef) [] $+ ConT ''Key `AppT` ConT (mkName nameS)+ , instanceD instanceConstraint clazz+ [ uniqueTypeDec mps entDef+ , keyTypeDec+ , keyToValues'+ , keyFromValues'+ , keyFromRecordM'+ , FunD 'entityDef [normalClause [WildP] entityDefExp]+ , tpf+ , FunD 'fromPersistValues fpv+ , toFieldNames+ , utv+ , puk+#if MIN_VERSION_template_haskell(2,15,0)+ , DataInstD+ []+ Nothing+ (AppT (AppT (ConT ''EntityField) genDataType) (VarT $ mkName "typ"))+ Nothing+ (map fst fields)+ []+#else+ , DataInstD+ []+ ''EntityField+ [ genDataType+ , VarT $ mkName "typ"+ ]+ Nothing+ (map fst fields)+ []+#endif+ , FunD 'persistFieldDef (map snd fields)+#if MIN_VERSION_template_haskell(2,15,0)+ , TySynInstD+ (TySynEqn+ Nothing+ (AppT (ConT ''PersistEntityBackend) genDataType)+ (backendDataType mps))+#else+ , TySynInstD+ ''PersistEntityBackend+ (TySynEqn+ [genDataType]+ (backendDataType mps))+#endif+ , FunD 'persistIdField [normalClause [] (ConE $ keyIdName entDef)]+ , FunD 'fieldLens lensClauses+ ]+ ] `mappend` lenses) `mappend` keyInstanceDecs+ where+ genDataType = genericDataType mps entName backendT+ entName = entityHaskell entDef++mkUniqueKeyInstances :: MkPersistSettings -> EntityDef -> Q [Dec]+mkUniqueKeyInstances mps entDef = do+ requirePersistentExtensions+ case entityUniques entDef of+ [] -> mappend <$> typeErrorSingle <*> typeErrorAtLeastOne+ [_] -> mappend <$> singleUniqueKey <*> atLeastOneKey+ (_:_) -> mappend <$> typeErrorMultiple <*> atLeastOneKey+ where+ requireUniquesPName = 'requireUniquesP+ onlyUniquePName = 'onlyUniqueP+ typeErrorSingle = mkOnlyUniqueError typeErrorNoneCtx+ typeErrorMultiple = mkOnlyUniqueError typeErrorMultipleCtx++ withPersistStoreWriteCxt =+ if mpsGeneric mps+ then do+ write <- [t|PersistStoreWrite $(pure (VarT $ mkName "backend")) |]+ pure [write]+ else do+ pure []++ typeErrorNoneCtx = do+ tyErr <- [t|TypeError (NoUniqueKeysError $(pure genDataType))|]+ (tyErr :) <$> withPersistStoreWriteCxt++ typeErrorMultipleCtx = do+ tyErr <- [t|TypeError (MultipleUniqueKeysError $(pure genDataType))|]+ (tyErr :) <$> withPersistStoreWriteCxt++ mkOnlyUniqueError :: Q Cxt -> Q [Dec]+ mkOnlyUniqueError mkCtx = do+ ctx <- mkCtx+ let impl = mkImpossible onlyUniquePName+ pure [instanceD ctx onlyOneUniqueKeyClass impl]++ mkImpossible name =+ [ FunD name+ [ Clause+ [ WildP ]+ (NormalB+ (VarE 'error `AppE` LitE (StringL "impossible"))+ )+ []+ ]+ ]++ typeErrorAtLeastOne :: Q [Dec]+ typeErrorAtLeastOne = do+ let impl = mkImpossible requireUniquesPName+ cxt <- typeErrorMultipleCtx+ pure [instanceD cxt atLeastOneUniqueKeyClass impl]++ singleUniqueKey :: Q [Dec]+ singleUniqueKey = do+ expr <- [e| head . persistUniqueKeys|]+ let impl = [FunD onlyUniquePName [Clause [] (NormalB expr) []]]+ cxt <- withPersistStoreWriteCxt+ pure [instanceD cxt onlyOneUniqueKeyClass impl]++ atLeastOneUniqueKeyClass = ConT ''AtLeastOneUniqueKey `AppT` genDataType+ onlyOneUniqueKeyClass = ConT ''OnlyOneUniqueKey `AppT` genDataType++ atLeastOneKey :: Q [Dec]+ atLeastOneKey = do+ expr <- [e| NEL.fromList . persistUniqueKeys|]+ let impl = [FunD requireUniquesPName [Clause [] (NormalB expr) []]]+ cxt <- withPersistStoreWriteCxt+ pure [instanceD cxt atLeastOneUniqueKeyClass impl]++ genDataType = genericDataType mps (entityHaskell entDef) backendT++entityText :: EntityDef -> Text+entityText = unEntityNameHS . 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 entDef ForeignDef {..} =+ if not foreignToPrimary then return [] else do+ let fieldName f = mkName $ unpack $ recNameF mps (entityHaskell entDef) f+ let fname = fieldName (constraintToField foreignConstraintNameHaskell)+ let reftableString = unpack $ unEntityNameHS foreignRefTableHaskell+ let reftableKeyName = mkName $ reftableString `mappend` "Key"+ let tablename = mkName $ unpack $ entityText entDef+ recordName <- newName "record"++ let mkFldE ((foreignName, _),ff) = case ff of+ (FieldNameHS {unFieldNameHS = "Id"}, FieldNameDB {unFieldNameDB = "id"})+ -> AppE (VarE $ mkName "toBackendKey") $+ VarE (fieldName foreignName) `AppE` VarE recordName+ _ -> VarE (fieldName foreignName) `AppE` VarE recordName+ let fldsE = map mkFldE foreignFields+ let mkKeyE = foldl' AppE (maybeExp foreignNullable $ ConE reftableKeyName) fldsE+ let fn = FunD fname [normalClause [VarP recordName] mkKeyE]++ let t2 = maybeTyp foreignNullable $ ConT ''Key `AppT` ConT (mkName reftableString)+ let sig = SigD fname $ (ArrowT `AppT` (ConT tablename)) `AppT` t2+ return [sig, fn]++ where+ constraintToField = FieldNameHS . unConstraintNameHS++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++++entityToPersistValueHelper :: (PersistEntity record) => record -> PersistValue+entityToPersistValueHelper entity = PersistMap $ zip columnNames fieldsAsPersistValues+ where+ columnNames = map (unFieldNameHS . fieldHaskell) (entityFields (entityDef (Just entity)))+ fieldsAsPersistValues = map toPersistValue $ toPersistFields entity++entityFromPersistValueHelper :: (PersistEntity record)+ => [String] -- ^ Column names, as '[String]' to avoid extra calls to "pack" in the generated code+ -> PersistValue+ -> Either Text record+entityFromPersistValueHelper columnNames pv = do+ (persistMap :: [(T.Text, PersistValue)]) <- getPersistMap pv++ let columnMap = HM.fromList persistMap+ lookupPersistValueByColumnName :: String -> PersistValue+ lookupPersistValueByColumnName columnName =+ fromMaybe PersistNull (HM.lookup (pack columnName) columnMap)++ fromPersistValues $ map lookupPersistValueByColumnName columnNames++-- | Produce code similar to the following:+--+-- @+-- instance PersistEntity e => PersistField e where+-- toPersistValue = entityToPersistValueHelper+-- fromPersistValue = entityFromPersistValueHelper ["col1", "col2"]+-- sqlType _ = SqlString+-- @+persistFieldFromEntity :: MkPersistSettings -> EntityDef -> Q [Dec]+persistFieldFromEntity mps entDef = do+ sqlStringConstructor' <- [|SqlString|]+ toPersistValueImplementation <- [|entityToPersistValueHelper|]+ fromPersistValueImplementation <- [|entityFromPersistValueHelper columnNames|]++ return+ [ persistFieldInstanceD (mpsGeneric mps) typ+ [ FunD 'toPersistValue [ normalClause [] toPersistValueImplementation ]+ , FunD 'fromPersistValue+ [ normalClause [] fromPersistValueImplementation ]+ ]+ , persistFieldSqlInstanceD (mpsGeneric mps) typ+ [ sqlTypeFunD sqlStringConstructor'+ ]+ ]+ where+ typ = genericDataType mps (entityHaskell entDef) backendT+ entFields = entityFields entDef+ columnNames = map (unpack . unFieldNameHS . 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 = 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 :: EntityNameHS+ , depSourceTable :: EntityNameHS+ , depSourceField :: FieldNameHS+ , 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|]+ value <- [|FilterValue|]+ let mkStmt :: Dep -> Stmt+ mkStmt dep = NoBindS+ $ dcw `AppE`+ ListE+ [ filt `AppE` ConE filtName+ `AppE` (value `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) (ConT ''BaseBackend `AppT` backendT)+ ]+ (ConT ''DeleteCascade `AppT` entityT `AppT` backendT)+ [ FunD 'deleteCascade+ [normalClause [VarP key] (DoE stmts)]+ ]++-- | Creates a declaration for the @['EntityDef']@ from the @persistent@+-- schema. This is necessary because the Persistent QuasiQuoter is unable+-- to know the correct type of ID fields, and assumes that they are all+-- Int64.+--+-- Provide this in the list you give to 'share', much like @'mkMigrate'@.+--+-- @+-- 'share' ['mkMigrate' "migrateAll", 'mkEntityDefList' "entityDefs"] [...]+-- @+--+-- @since 2.7.1+mkEntityDefList+ :: String+ -- ^ The name that will be given to the 'EntityDef' list.+ -> [EntityDef]+ -> Q [Dec]+mkEntityDefList entityList entityDefs = do+ let entityListName = mkName entityList+ edefs <- fmap ListE+ . forM entityDefs+ $ \(EntityDef { entityHaskell = EntityNameHS haskellName }) ->+ let entityType = conT (mkName (T.unpack haskellName))+ in [|entityDef (Proxy :: Proxy $(entityType))|]+ typ <- [t|[EntityDef]|]+ pure+ [ SigD entityListName typ+ , ValD (VarP entityListName) (NormalB edefs) []+ ]++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) $ \fieldDef -> do+ let x = fieldHaskell fieldDef+ x' <- newName $ '_' : unpack (unFieldNameHS x)+ return (x, x')+ let pcs = map (go xs) $ entityUniques def+ let pat = ConP+ (mkName $ unpack $ unEntityNameHS $ entityHaskell def)+ (map (VarP . snd) xs)+ return $ normalClause [pat] (ListE pcs)++ go :: [(FieldNameHS, Name)] -> UniqueDef -> Exp+ go xs (UniqueDef name _ cols _) =+ foldl' (go' xs) (ConE (mkName $ unpack $ unConstraintNameHS name)) (map fst cols)++ go' :: [(FieldNameHS, Name)] -> Exp -> FieldNameHS -> 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 = "no-migrate" `notElem` entityAttrs def+ typ = ConT ''Migration+ entityMap = constructEntityMap allDefs+ body :: Q Exp+ body =+ case defs of+ [] -> [|return ()|]+ _ -> do+ defsName <- newName "defs"+ defsStmt <- do+ defs' <- mapM (liftAndFixKeys entityMap) 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 <- liftAndFixKeys entityMap ed+ m <- [|migrate|]+ return $ NoBindS $ m `AppE` defsExp `AppE` u++makePersistEntityDefExp :: MkPersistSettings -> EntityMap -> EntityDef -> Q Exp+makePersistEntityDefExp mps entityMap entDef@EntityDef{..} =+ [|EntityDef+ entityHaskell+ entityDB+ $(liftAndFixKey entityMap entityId)+ entityAttrs+ $(fieldDefReferences mps entDef entityFields)+ entityUniques+ entityForeigns+ entityDerives+ entityExtra+ entitySum+ entityComments+ |]++fieldDefReferences :: MkPersistSettings -> EntityDef -> [FieldDef] -> Q Exp+fieldDefReferences mps entDef fieldDefs =+ fmap ListE $ forM fieldDefs $ \fieldDef -> do+ let fieldDefConE = ConE (filterConName mps entDef fieldDef)+ pure $ VarE 'persistFieldDef `AppE` fieldDefConE++liftAndFixKeys :: EntityMap -> EntityDef -> Q Exp+liftAndFixKeys entityMap EntityDef{..} =+ [|EntityDef+ entityHaskell+ entityDB+ $(liftAndFixKey entityMap entityId)+ entityAttrs+ $(ListE <$> mapM (liftAndFixKey entityMap) entityFields)+ entityUniques+ entityForeigns+ entityDerives+ entityExtra+ entitySum+ entityComments+ |]++liftAndFixKey :: EntityMap -> FieldDef -> Q Exp+liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef fc mcomments fg) =+ [|FieldDef a b c $(sqlTyp') e f (fieldRef') fc mcomments fg|]+ where+ (fieldRef', sqlTyp') =+ fromMaybe (fieldRef, lift sqlTyp) $+ case fieldRef of+ ForeignRef refName _ft -> do+ ent <- M.lookup refName entityMap+ case fieldReference $ entityId ent of+ fr@(ForeignRef _ ft) ->+ Just (fr, lift $ SqlTypeExp ft)+ _ ->+ Nothing+ _ ->+ Nothing++-- 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+ -> EntityNameHS+ -> FieldNameHS+ -> Name+filterConName' mps entity field = mkName $ unpack name+ where+ name+ | field == FieldNameHS "Id" = entityName ++ fieldName+ | mpsPrefixFields mps = modifiedName+ | otherwise = fieldName+ modifiedName = mpsConstraintLabelModifier mps entityName fieldName+ entityName = unEntityNameHS entity+ fieldName = upperFirst $ unFieldNameHS field++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 | ("json" `notElem` entityAttrs def) = return []+mkJSON mps def = do+ requireExtensions [[FlexibleInstances]]+ pureE <- [|pure|]+ apE' <- [|(<*>)|]+ packE <- [|pack|]+ dotEqualE <- [|(.=)|]+ dotColonE <- [|(.:)|]+ dotColonQE <- [|(.:?)|]+ objectE <- [|object|]+ obj <- newName "obj"+ mzeroE <- [|mzero|]++ xs <- mapM (newName . unpack . unFieldNameHSForJSON . fieldHaskell)+ $ entityFields def++ let conName = mkName $ unpack $ unEntityNameHS $ 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 $ unFieldNameHS $ 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 $ unFieldNameHS $ fieldHaskell f)+ case mpsEntityJSON mps of+ Nothing -> return [toJSONI, fromJSONI]+ Just entityJSON -> do+ entityJSONIs <- if mpsGeneric mps+ then [d|+ instance PersistStore $(pure backendT) => ToJSON (Entity $(pure typ)) where+ toJSON = $(varE (entityToJSON entityJSON))+ instance PersistStore $(pure backendT) => FromJSON (Entity $(pure typ)) where+ parseJSON = $(varE (entityFromJSON entityJSON))+ |]+ 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+mkClassP cla tys = foldl AppT (ConT cla) tys++mkEqualP :: Type -> Type -> Pred+mkEqualP tleft tright = foldl AppT EqualityT [tleft, tright]++notStrict :: Bang+notStrict = Bang NoSourceUnpackedness NoSourceStrictness++isStrict :: Bang+isStrict = Bang NoSourceUnpackedness SourceStrict++instanceD :: Cxt -> Type -> [Dec] -> Dec+instanceD = InstanceD Nothing++-- entityUpdates :: EntityDef -> [(EntityNameHS, 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)++-- | Check that all of Persistent's required extensions are enabled, or else fail compilation+--+-- This function should be called before any code that depends on one of the required extensions being enabled.+requirePersistentExtensions :: Q ()+requirePersistentExtensions = requireExtensions requiredExtensions+ where+ requiredExtensions = map pure+ [ DerivingStrategies+ , GeneralizedNewtypeDeriving+ , StandaloneDeriving+ , UndecidableInstances+ , MultiParamTypeClasses+ ]++mkSymbolToFieldInstances :: MkPersistSettings -> EntityDef -> Q [Dec]+mkSymbolToFieldInstances mps ed = do+ fmap join $ forM (entityFields ed) $ \fieldDef -> do+ let fieldNameT =+ litT $ strTyLit $ T.unpack $ unFieldNameHS $ fieldHaskell fieldDef+ :: Q Type++ nameG = mkName $ unpack $ unEntityNameHS (entityHaskell ed) ++ "Generic"++ recordNameT+ | mpsGeneric mps =+ conT nameG `appT` varT backendName+ | otherwise =+ conT $ mkName $ T.unpack $ unEntityNameHS $ entityHaskell ed++ fieldTypeT =+ maybeIdType mps fieldDef Nothing Nothing+ entityFieldConstr =+ conE $ filterConName mps ed fieldDef+ :: Q Exp+ [d|+ instance SymbolToField $(fieldNameT) $(recordNameT) $(pure fieldTypeT) where+ symbolToField = $(entityFieldConstr)+ |]++-- | Pass in a list of lists of extensions, where any of the given+-- extensions will satisfy it. For example, you might need either GADTs or+-- ExistentialQuantification, so you'd write:+--+-- > requireExtensions [[GADTs, ExistentialQuantification]]+--+-- But if you need TypeFamilies and MultiParamTypeClasses, then you'd+-- write:+--+-- > requireExtensions [[TypeFamilies], [MultiParamTypeClasses]]+requireExtensions :: [[Extension]] -> Q ()+requireExtensions requiredExtensions = do+ -- isExtEnabled breaks the persistent-template benchmark with the following error:+ -- Template Haskell error: Can't do `isExtEnabled' in the IO monad+ -- You can workaround this by replacing isExtEnabled with (pure . const True)+ unenabledExtensions <- filterM (fmap (not . or) . traverse isExtEnabled) requiredExtensions++ case mapMaybe listToMaybe unenabledExtensions of+ [] -> pure ()+ [extension] -> fail $ mconcat+ [ "Generating Persistent entities now requires the "+ , show extension+ , " language extension. Please enable it by copy/pasting this line to the top of your file:\n\n"+ , extensionToPragma extension+ ]+ extensions -> fail $ mconcat+ [ "Generating Persistent entities now requires the following language extensions:\n\n"+ , List.intercalate "\n" (map show extensions)+ , "\n\nPlease enable the extensions by copy/pasting these lines into the top of your file:\n\n"+ , List.intercalate "\n" (map extensionToPragma extensions)+ ]++ where+ extensionToPragma ext = "{-# LANGUAGE " <> show ext <> " #-}"
Database/Persist/Types/Base.hs view
@@ -1,7 +1,12 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LambdaCase, PatternSynonyms #-}+{-# LANGUAGE DeriveLift #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} -- usage of Error typeclass-module Database.Persist.Types.Base where+module Database.Persist.Types.Base+ ( module Database.Persist.Types.Base+ , PersistValue(.., PersistLiteral, PersistLiteralEscaped, PersistDbSpecific)+ , LiteralType(..)+ ) where import Control.Arrow (second) import Control.Exception (Exception)@@ -32,7 +37,10 @@ import Numeric (showHex, readHex) import Web.PathPieces (PathPiece(..)) import Web.HttpApiData (ToHttpApiData (..), FromHttpApiData (..), parseUrlPieceMaybe, showTextData, readTextData, parseBoundedTextData)-+import Language.Haskell.TH.Syntax (Lift(..))+ -- Bring `Lift (Map k v)` instance into scope, as well as `Lift Text`+ -- instance on pre-1.2.4 versions of `text`+import Instances.TH.Lift () -- | A 'Checkmark' should be used as a field type whenever a -- uniqueness constraint should guarantee that a certain kind of@@ -123,7 +131,7 @@ -- -- @since 2.12.0.0 newtype EntityNameDB = EntityNameDB { unEntityNameDB :: Text }- deriving (Show, Eq, Read, Ord)+ deriving (Show, Eq, Read, Ord, Lift) instance DatabaseName EntityNameDB where escapeWith f (EntityNameDB n) = f n@@ -133,7 +141,7 @@ -- -- @since 2.12.0.0 newtype EntityNameHS = EntityNameHS { unEntityNameHS :: Text }- deriving (Show, Eq, Read, Ord)+ deriving (Show, Eq, Read, Ord, Lift) -- | An 'EntityDef' represents the information that @persistent@ knows -- about an Entity. It uses this information to generate the Haskell@@ -168,7 +176,7 @@ -- -- @since 2.10.0 }- deriving (Show, Eq, Read, Ord)+ deriving (Show, Eq, Read, Ord, Lift) entitiesPrimary :: EntityDef -> Maybe [FieldDef] entitiesPrimary t = case fieldReference primaryField of@@ -217,7 +225,7 @@ | FieldAttrSqltype Text | FieldAttrMaxlen Integer | FieldAttrOther Text- deriving (Show, Eq, Read, Ord)+ deriving (Show, Eq, Read, Ord, Lift) -- | Parse raw field attributes into structured form. Any unrecognized -- attributes will be preserved, identically as they are encountered,@@ -258,25 +266,25 @@ -- ^ Optional module and name. | FTApp FieldType FieldType | FTList FieldType- deriving (Show, Eq, Read, Ord)+ deriving (Show, Eq, Read, Ord, Lift) -- | An 'EntityNameDB' represents the datastore-side name that @persistent@ -- will use for an entity. -- -- @since 2.12.0.0 newtype FieldNameDB = FieldNameDB { unFieldNameDB :: Text }- deriving (Show, Eq, Read, Ord)+ deriving (Show, Eq, Read, Ord, Lift) -- | @since 2.12.0.0 instance DatabaseName FieldNameDB where- escapeWith f (FieldNameDB n) = f n+ escapeWith f (FieldNameDB n) = f n -- | A 'FieldNameHS' represents the Haskell-side name that @persistent@ -- will use for a field. -- -- @since 2.12.0.0 newtype FieldNameHS = FieldNameHS { unFieldNameHS :: Text }- deriving (Show, Eq, Read, Ord)+ deriving (Show, Eq, Read, Ord, Lift) -- | A 'FieldDef' represents the inormation that @persistent@ knows about -- a field of a datatype. This includes information used to parse the field@@ -320,7 +328,7 @@ -- -- @since 2.11.0.0 }- deriving (Show, Eq, Read, Ord)+ deriving (Show, Eq, Read, Ord, Lift) isFieldNotGenerated :: FieldDef -> Bool isFieldNotGenerated = isNothing . fieldGenerated@@ -336,7 +344,7 @@ | CompositeRef CompositeDef | SelfReference -- ^ A SelfReference stops an immediate cycle which causes non-termination at compile-time (issue #311).- deriving (Show, Eq, Read, Ord)+ deriving (Show, Eq, Read, Ord, Lift) -- | An EmbedEntityDef is the same as an EntityDef -- But it is only used for fieldReference@@ -344,7 +352,7 @@ data EmbedEntityDef = EmbedEntityDef { embeddedHaskell :: !EntityNameHS , embeddedFields :: ![EmbedFieldDef]- } deriving (Show, Eq, Read, Ord)+ } deriving (Show, Eq, Read, Ord, Lift) -- | An EmbedFieldDef is the same as a FieldDef -- But it is only used for embeddedFields@@ -357,7 +365,7 @@ -- when a cycle is detected, 'emFieldEmbed' will be Nothing -- and 'emFieldCycle' will be Just }- deriving (Show, Eq, Read, Ord)+ deriving (Show, Eq, Read, Ord, Lift) toEmbedEntityDef :: EntityDef -> EmbedEntityDef toEmbedEntityDef ent = embDef@@ -383,7 +391,7 @@ -- -- @since 2.12.0.0 newtype ConstraintNameDB = ConstraintNameDB { unConstraintNameDB :: Text }- deriving (Show, Eq, Read, Ord)+ deriving (Show, Eq, Read, Ord, Lift) -- | @since 2.12.0.0 instance DatabaseName ConstraintNameDB where@@ -394,7 +402,7 @@ -- -- @since 2.12.0.0 newtype ConstraintNameHS = ConstraintNameHS { unConstraintNameHS :: Text }- deriving (Show, Eq, Read, Ord)+ deriving (Show, Eq, Read, Ord, Lift) -- Type for storing the Uniqueness constraint in the Schema. -- Assume you have the following schema with a uniqueness@@ -414,13 +422,13 @@ , uniqueFields :: ![(FieldNameHS, FieldNameDB)] , uniqueAttrs :: ![Attr] }- deriving (Show, Eq, Read, Ord)+ deriving (Show, Eq, Read, Ord, Lift) data CompositeDef = CompositeDef { compositeFields :: ![FieldDef] , compositeAttrs :: ![Attr] }- deriving (Show, Eq, Read, Ord)+ deriving (Show, Eq, Read, Ord, Lift) -- | Used instead of FieldDef -- to generate a smaller amount of code@@ -443,7 +451,7 @@ -- -- @since 2.11.0 }- deriving (Show, Eq, Read, Ord)+ deriving (Show, Eq, Read, Ord, Lift) -- | This datatype describes how a foreign reference field cascades deletes -- or updates.@@ -458,7 +466,7 @@ { fcOnUpdate :: !(Maybe CascadeAction) , fcOnDelete :: !(Maybe CascadeAction) }- deriving (Show, Eq, Read, Ord)+ deriving (Show, Eq, Read, Ord, Lift) -- | A 'FieldCascade' that does nothing. --@@ -482,7 +490,7 @@ -- -- @since 2.11.0 data CascadeAction = Cascade | Restrict | SetNull | SetDefault- deriving (Show, Eq, Read, Ord)+ deriving (Show, Eq, Read, Ord, Lift) -- | Render a 'CascadeAction' to 'Text' such that it can be used in a SQL -- command.@@ -525,37 +533,73 @@ | PersistMap [(Text, PersistValue)] | PersistObjectId ByteString -- ^ Intended especially for MongoDB backend | PersistArray [PersistValue] -- ^ Intended especially for PostgreSQL backend for text arrays- | PersistLiteral ByteString -- ^ Using 'PersistLiteral' allows you to use types or keywords specific to a particular backend.- | PersistLiteralEscaped ByteString -- ^ Similar to 'PersistLiteral', but escapes the @ByteString@.- | PersistDbSpecific ByteString -- ^ Using 'PersistDbSpecific' allows you to use types specific to a particular backend.--- For example, below is a simple example of the PostGIS geography type:------ @--- data Geo = Geo ByteString------ instance PersistField Geo where--- toPersistValue (Geo t) = PersistDbSpecific t------ fromPersistValue (PersistDbSpecific t) = Right $ Geo $ Data.ByteString.concat ["'", t, "'"]--- fromPersistValue _ = Left "Geo values must be converted from PersistDbSpecific"+ | PersistLiteral_ LiteralType ByteString+ -- ^ This constructor is used to specify some raw literal value for the+ -- backend. The 'LiteralType' value specifies how the value should be+ -- escaped. This can be used to make special, custom types avaialable+ -- in the back end.+ --+ -- @since 2.12.0.0+ deriving (Show, Read, Eq, Ord)++-- | A type that determines how a backend should handle the literal. ----- instance PersistFieldSql Geo where--- sqlType _ = SqlOther "GEOGRAPHY(POINT,4326)"+-- @since 2.12.0.0+data LiteralType+ = Escaped+ -- ^ The accompanying value will be escaped before inserting into the+ -- database. This is the correct default choice to use.+ --+ -- @since 2.12.0.0+ | Unescaped+ -- ^ The accompanying value will not be escaped when inserting into the+ -- database. This is potentially dangerous - use this with care.+ --+ -- @since 2.12.0.0+ | DbSpecific+ -- ^ The 'DbSpecific' constructor corresponds to the legacy+ -- 'PersistDbSpecific' constructor. We need to keep this around because+ -- old databases may have serialized JSON representations that+ -- reference this. We don't want to break the ability of a database to+ -- load rows.+ --+ -- @since 2.12.0.0+ deriving (Show, Read, Eq, Ord)++-- | This pattern synonym used to be a data constructor for the+-- 'PersistValue' type. It was changed to be a pattern so that JSON-encoded+-- database values could be parsed into their corresponding values. You+-- should not use this, and instead prefer to pattern match on+-- `PersistLiteral_` directly. ----- toPoint :: Double -> Double -> Geo--- toPoint lat lon = Geo $ Data.ByteString.concat ["'POINT(", ps $ lon, " ", ps $ lat, ")'"]--- where ps = Data.Text.pack . show--- @+-- If you use this, it will overlap a patern match on the 'PersistLiteral_,+-- 'PersistLiteral', and 'PersistLiteralEscaped' patterns. If you need to+-- disambiguate between these constructors, pattern match on+-- 'PersistLiteral_' directly. ----- If Foo has a geography field, we can then perform insertions like the following:+-- @since 2.12.0.0+pattern PersistDbSpecific bs <- PersistLiteral_ _ bs where+ PersistDbSpecific bs = PersistLiteral_ DbSpecific bs++-- | This pattern synonym used to be a data constructor on 'PersistValue',+-- but was changed into a catch-all pattern synonym to allow backwards+-- compatiblity with database types. See the documentation on+-- 'PersistDbSpecific' for more details. ----- @--- insert $ Foo (toPoint 44 44)--- @+-- @since 2.12.0.0+pattern PersistLiteralEscaped bs <- PersistLiteral_ _ bs where+ PersistLiteralEscaped bs = PersistLiteral_ Escaped bs++-- | This pattern synonym used to be a data constructor on 'PersistValue',+-- but was changed into a catch-all pattern synonym to allow backwards+-- compatiblity with database types. See the documentation on+-- 'PersistDbSpecific' for more details. --- deriving (Show, Read, Eq, Ord)+-- @since 2.12.0.0+pattern PersistLiteral bs <- PersistLiteral_ _ bs where+ PersistLiteral bs = PersistLiteral_ Unescaped bs -{-# DEPRECATED PersistDbSpecific "Deprecated since 2.11 because of inconsistent escaping behavior across backends. The Postgres backend escapes these values, while the MySQL backend does not. If you are using this, please switch to 'PersistLiteral' or 'PersistLiteralEscaped' based on your needs." #-}+{-# DEPRECATED PersistDbSpecific "Deprecated since 2.11 because of inconsistent escaping behavior across backends. The Postgres backend escapes these values, while the MySQL backend does not. If you are using this, please switch to 'PersistLiteral_' and provide a relevant 'LiteralType' for your conversion." #-} instance ToHttpApiData PersistValue where toUrlPiece val =@@ -694,11 +738,11 @@ | SqlDayTime -- ^ Always uses UTC timezone | SqlBlob | SqlOther T.Text -- ^ a backend-specific name- deriving (Show, Read, Eq, Ord)+ deriving (Show, Read, Eq, Ord, Lift) data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le | In | NotIn | BackendSpecificFilter T.Text- deriving (Read, Show)+ deriving (Read, Show, Lift) data UpdateException = KeyNotFound String | UpsertError String@@ -716,4 +760,4 @@ data PersistUpdate = Assign | Add | Subtract | Multiply | Divide | BackendSpecificUpdate T.Text- deriving (Read, Show)+ deriving (Read, Show, Lift)
+ bench/Main.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Main (main) where++import Control.DeepSeq+import Control.DeepSeq.Generics+import Criterion.Main+import Data.Text (Text)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax++import Database.Persist.Quasi+import Database.Persist.TH+import Models++main :: IO ()+main = defaultMain+ [ bgroup "mkPersist"+ [ bench "From File" $ nfIO $ mkPersist' $(persistFileWith lowerCaseSettings "bench/models-slowly")+ -- , bgroup "Non-Null Fields"+ -- [ bgroup "Increasing model count"+ -- [ bench "1x10" $ nfIO $ mkPersist' $( parseReferencesQ (mkModels 10 10))+ -- , bench "10x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 10))+ -- , bench "100x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 100 10))+ -- -- , bench "1000x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 1000 10))+ -- ]+ -- , bgroup "Increasing field count"+ -- [ bench "10x1" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 1))+ -- , bench "10x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 10))+ -- , bench "10x100" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 100))+ -- -- , bench "10x1000" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 1000))+ -- ]+ -- ]+ -- , bgroup "Nullable"+ -- [ bgroup "Increasing model count"+ -- [ bench "20x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 20 10))+ -- , bench "40x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 40 10))+ -- , bench "60x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 60 10))+ -- , bench "80x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 80 10))+ -- , bench "100x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 100 10))+ -- -- , bench "1000x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 1000 10))+ -- ]+ -- , bgroup "Increasing field count"+ -- [ bench "10x20" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 20))+ -- , bench "10x40" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 40))+ -- , bench "10x60" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 60))+ -- , bench "10x80" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 80))+ -- , bench "10x100" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 100))+ -- -- , bench "10x1000" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 1000))+ -- ]+ -- ]+ ]+ ]++-- Orphan instances for NFData Template Haskell types+instance NFData Overlap where+ rnf = genericRnf++instance NFData AnnTarget where+ rnf = genericRnf+instance NFData RuleBndr where+ rnf = genericRnf++instance NFData Role where+ rnf = genericRnf++instance NFData Phases where+ rnf = genericRnf++instance NFData InjectivityAnn where+ rnf = genericRnf++instance NFData FamilyResultSig where+ rnf = genericRnf++instance NFData RuleMatch where+ rnf = genericRnf++instance NFData TypeFamilyHead where+ rnf = genericRnf++instance NFData TySynEqn where+ rnf = genericRnf++instance NFData Inline where+ rnf = genericRnf++instance NFData Pragma where+ rnf = genericRnf++instance NFData FixityDirection where+ rnf = genericRnf++instance NFData Safety where+ rnf = genericRnf++instance NFData Fixity where+ rnf = genericRnf++instance NFData Callconv where+ rnf = genericRnf++instance NFData Foreign where+ rnf = genericRnf++instance NFData SourceStrictness where+ rnf = genericRnf++instance NFData SourceUnpackedness where+ rnf = genericRnf++instance NFData FunDep where+ rnf = genericRnf++instance NFData Bang where+ rnf = genericRnf++#if MIN_VERSION_template_haskell(2,12,0)+instance NFData PatSynDir where+ rnf = genericRnf++instance NFData PatSynArgs where+ rnf = genericRnf++instance NFData DerivStrategy where+ rnf = genericRnf++instance NFData DerivClause where+ rnf = genericRnf+#endif++instance NFData Con where+ rnf = genericRnf++instance NFData Range where+ rnf = genericRnf++instance NFData Clause where+ rnf = genericRnf++instance NFData PkgName where+ rnf = genericRnf++instance NFData Dec where+ rnf = genericRnf++instance NFData Stmt where+ rnf = genericRnf++instance NFData TyLit where+ rnf = genericRnf++instance NFData NameSpace where+ rnf = genericRnf++instance NFData Body where+ rnf = genericRnf++instance NFData Guard where+ rnf = genericRnf++instance NFData Match where+ rnf = genericRnf++instance NFData ModName where+ rnf = genericRnf++instance NFData Pat where+ rnf = genericRnf++instance NFData TyVarBndr where+ rnf = genericRnf++instance NFData NameFlavour where+ rnf = genericRnf++instance NFData Type where+ rnf = genericRnf++instance NFData Exp where+ rnf = genericRnf++instance NFData Lit where+ rnf = genericRnf++instance NFData OccName where+ rnf = genericRnf++instance NFData Name where+ rnf = genericRnf
+ bench/Models.hs view
@@ -0,0 +1,59 @@+module Models where++import Data.Monoid+import Language.Haskell.TH+import qualified Data.Text as Text++import Database.Persist.Quasi+import Database.Persist.TH+import Database.Persist.Sql++mkPersist' :: [EntityDef] -> IO [Dec]+mkPersist' = runQ . mkPersist sqlSettings++parseReferences' :: String -> IO Exp+parseReferences' = runQ . parseReferencesQ++parseReferencesQ :: String -> Q Exp+parseReferencesQ = parseReferences lowerCaseSettings . Text.pack++-- | # of models, # of fields+mkModels :: Int -> Int -> String+mkModels = mkModelsWithFieldModifier id++mkNullableModels :: Int -> Int -> String+mkNullableModels = mkModelsWithFieldModifier maybeFields++mkModelsWithFieldModifier :: (String -> String) -> Int -> Int -> String+mkModelsWithFieldModifier k i f =+ unlines . fmap unlines . take i . map mkModel . zip [0..] . cycle $+ [ "Model"+ , "Foobar"+ , "User"+ , "King"+ , "Queen"+ , "Dog"+ , "Cat"+ ]+ where+ mkModel :: (Int, String) -> [String]+ mkModel (i', m) =+ (m <> show i') : indent 4 (map k (mkFields f))++indent :: Int -> [String] -> [String]+indent i = map (replicate i ' ' ++)++mkFields :: Int -> [String]+mkFields i = take i $ map mkField $ zip [0..] $ cycle+ [ "Bool"+ , "Int"+ , "String"+ , "Double"+ , "Text"+ ]+ where+ mkField :: (Int, String) -> String+ mkField (i', typ) = "field" <> show i' <> "\t\t" <> typ++maybeFields :: String -> String+maybeFields = (++ " Maybe")
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.12.0.0+version: 2.12.0.1 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -14,14 +14,7 @@ bug-reports: https://github.com/yesodweb/persistent/issues extra-source-files: ChangeLog.md README.md -flag nooverlap- default: False- description: test out our assumption that OverlappingInstances is just for String- library- if flag(nooverlap)- cpp-options: -DNO_OVERLAP- build-depends: base >= 4.9 && < 5 , aeson >= 1.0 , attoparsec@@ -39,13 +32,14 @@ , resourcet >= 1.1.10 , scientific , silently- , template-haskell >= 2.4+ , template-haskell >= 2.11 , text >= 1.2 , time >= 1.6 , transformers >= 0.5 , unliftio-core , unliftio , unordered-containers+ , th-lift-instances >= 0.1.14 && < 0.2 , vector default-extensions: FlexibleContexts@@ -55,6 +49,7 @@ exposed-modules: Database.Persist Database.Persist.Quasi+ Database.Persist.TH Database.Persist.Types Database.Persist.Class@@ -94,24 +89,43 @@ type: exitcode-stdio-1.0 main-is: test/main.hs - build-depends: base >= 4.9 && < 5- , aeson- , attoparsec- , base64-bytestring- , blaze-html- , bytestring- , containers- , hspec >= 2.4- , http-api-data- , path-pieces- , scientific- , shakespeare- , text- , time- , transformers- , unordered-containers- , vector+ build-depends: + base >= 4.9 && < 5+ , aeson+ , attoparsec+ , base64-bytestring+ , blaze-html+ , bytestring+ , containers+ , hspec >= 2.4+ , http-api-data+ , path-pieces+ , scientific+ , shakespeare+ , text+ , time+ , transformers+ , unordered-containers+ , vector+ , QuickCheck+ -- needed because of the `source-dirs: .`+ -- TODO: factor the internal modules out so we can use them in tests+ -- maybe in another package+ , template-haskell >= 2.4+ , unliftio-core+ , mtl+ , resourcet+ , conduit+ , monad-logger+ , fast-logger+ , resource-pool+ , unliftio+ , silently+ , th-lift-instances + hs-source-dirs:+ ./+ test/ cpp-options: -DTEST default-extensions: FlexibleContexts@@ -119,13 +133,35 @@ , OverloadedStrings , TypeFamilies - other-modules: Database.Persist.Class.PersistEntity- Database.Persist.Class.PersistField- Database.Persist.Quasi- Database.Persist.Types- Database.Persist.Types.Base+ other-modules: + Database.Persist.Class.PersistEntity+ Database.Persist.Class.PersistField+ Database.Persist.Quasi+ Database.Persist.Types+ Database.Persist.Types.Base+ Database.Persist.THSpec+ TemplateTestImports+ Database.Persist.TH.SharedPrimaryKeySpec+ Database.Persist.TH.SharedPrimaryKeyImportedSpec+ Database.Persist.TH.OverloadedLabelSpec default-language: Haskell2010 source-repository head type: git location: git://github.com/yesodweb/persistent.git++benchmark persistent-th-bench+ ghc-options: -O2+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: bench+ build-depends: base+ , persistent+ , criterion+ , deepseq+ , deepseq-generics+ , file-embed+ , text+ , template-haskell+ other-modules: Models+ default-language: Haskell2010
+ test/Database/Persist/TH/OverloadedLabelSpec.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Database.Persist.TH.OverloadedLabelSpec where++import TemplateTestImports++mkPersist sqlSettings [persistUpperCase|++User+ name String+ age Int++Dog+ userId UserId+ name String+ age Int++Organization+ name String++|]++spec :: Spec+spec = describe "OverloadedLabels" $ do+ it "works for monomorphic labels" $ do+ let UserName = #name+ OrganizationName = #name+ DogName = #name++ compiles++ it "works for polymorphic labels" $ do+ let name :: _ => EntityField rec a+ name = #name++ UserName = name+ OrganizationName = name+ DogName = name++ compiles++compiles :: Expectation+compiles = True `shouldBe` True
@@ -0,0 +1,54 @@+{-# LANGUAGE TypeApplications, DeriveGeneric #-}+{-# LANGUAGE DataKinds, ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}++module Database.Persist.TH.SharedPrimaryKeyImportedSpec where++import TemplateTestImports++import Data.Proxy+import Test.Hspec+import Database.Persist+import Database.Persist.Sql+import Database.Persist.Sql.Util+import Database.Persist.TH++import Database.Persist.TH.SharedPrimaryKeySpec (User, UserId)++share [ mkPersist sqlSettings ] [persistLowerCase|++Profile+ Id UserId+ email String++|]++-- This test is very similar to the one in SharedPrimaryKeyTest, but it is+-- able to use 'UserId' directly, since the type is imported from another+-- module.+spec :: Spec+spec = describe "Shared Primary Keys Imported" $ do++ describe "PersistFieldSql" $ do+ it "should match underlying key" $ do+ sqlType (Proxy @UserId)+ `shouldBe`+ sqlType (Proxy @ProfileId)++ describe "entityId FieldDef" $ do+ it "should match underlying primary key" $ do+ let getSqlType :: PersistEntity a => Proxy a -> SqlType+ getSqlType =+ fieldSqlType . entityId . entityDef+ getSqlType (Proxy @User)+ `shouldBe`+ getSqlType (Proxy @Profile)
@@ -0,0 +1,57 @@+{-# LANGUAGE TypeApplications, DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DataKinds, FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}++module Database.Persist.TH.SharedPrimaryKeySpec where++import TemplateTestImports++import Data.Proxy+import Test.Hspec+import Database.Persist+import Database.Persist.Sql+import Database.Persist.Sql.Util+import Database.Persist.TH++share [ mkPersist sqlSettings ] [persistLowerCase|++User+ name String++-- TODO: uncomment this out https://github.com/yesodweb/persistent/issues/1149+-- Profile+-- Id UserId+-- email String++Profile+ Id (Key User)+ email String++|]++spec :: Spec+spec = describe "Shared Primary Keys" $ do++ describe "PersistFieldSql" $ do+ it "should match underlying key" $ do+ sqlType (Proxy @UserId)+ `shouldBe`+ sqlType (Proxy @ProfileId)++ describe "entityId FieldDef" $ do+ it "should match underlying primary key" $ do+ let getSqlType :: PersistEntity a => Proxy a -> SqlType+ getSqlType =+ fieldSqlType . entityId . entityDef+ getSqlType (Proxy @User)+ `shouldBe`+ getSqlType (Proxy @Profile)
+ test/Database/Persist/THSpec.hs view
@@ -0,0 +1,374 @@+{-# LANGUAGE TypeApplications, DeriveGeneric, RecordWildCards #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# language DataKinds #-}+--+-- DeriveAnyClass is not actually used by persistent-template+-- But a long standing bug was that if it was enabled, it was used to derive instead of GeneralizedNewtypeDeriving+-- This was fixed by using DerivingStrategies to specify newtype deriving should be used.+-- This pragma is left here as a "test" that deriving works when DeriveAnyClass is enabled.+-- See https://github.com/yesodweb/persistent/issues/578+{-# LANGUAGE DeriveAnyClass #-}++module Database.Persist.THSpec where++import Data.Int+import Data.Proxy+import Control.Applicative (Const (..))+import Data.Aeson+import Data.ByteString.Lazy.Char8 ()+import Data.Functor.Identity (Identity (..))+import Data.Text (Text, pack)+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Gen (Gen)+import GHC.Generics (Generic)+import qualified Data.List as List+import Data.Coerce++import Database.Persist+import Database.Persist.Sql+import Database.Persist.Sql.Util+import Database.Persist.TH+import TemplateTestImports++import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpec+import qualified Database.Persist.TH.SharedPrimaryKeyImportedSpec as SharedPrimaryKeyImportedSpec+import qualified Database.Persist.TH.OverloadedLabelSpec as OverloadedLabelSpec++share [mkPersist sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] }, mkDeleteCascade sqlSettings { mpsGeneric = False }] [persistUpperCase|++Person json+ name Text+ age Int Maybe+ foo Foo+ address Address+ deriving Show Eq++HasSimpleCascadeRef+ person PersonId OnDeleteCascade+ deriving Show Eq++Address json+ street Text+ city Text+ zip Int Maybe+ deriving Show Eq+NoJson+ foo Text+ deriving Show Eq+|]++mkPersist sqlSettings [persistLowerCase|+HasPrimaryDef+ userId Int+ name String+ Primary userId++HasMultipleColPrimaryDef+ foobar Int+ barbaz String+ Primary foobar barbaz++HasIdDef+ Id Int+ name String++HasDefaultId+ name String++HasCustomSqlId+ Id String sql=my_id+ name String++SharedPrimaryKey+ Id (Key HasDefaultId)+ name String++SharedPrimaryKeyWithCascade+ Id (Key HasDefaultId) OnDeleteCascade+ name String++SharedPrimaryKeyWithCascadeAndCustomName+ Id (Key HasDefaultId) OnDeleteCascade sql=my_id+ name String+|]++share [mkPersist sqlSettings { mpsGeneric = False, mpsGenerateLenses = True }] [persistLowerCase|+Lperson json+ name Text+ age Int Maybe+ address Laddress+ deriving Show Eq+Laddress json+ street Text+ city Text+ zip Int Maybe+ deriving Show Eq+CustomPrimaryKey+ anInt Int+ Primary anInt+|]++arbitraryT :: Gen Text+arbitraryT = pack <$> arbitrary++instance Arbitrary Person where+ arbitrary = Person <$> arbitraryT <*> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary Address where+ arbitrary = Address <$> arbitraryT <*> arbitraryT <*> arbitrary++spec :: Spec+spec = do+ OverloadedLabelSpec.spec+ SharedPrimaryKeySpec.spec+ SharedPrimaryKeyImportedSpec.spec+ describe "HasDefaultId" $ do+ let FieldDef{..} =+ entityId (entityDef (Proxy @HasDefaultId))+ it "should have usual db name" $ do+ fieldDB `shouldBe` FieldNameDB "id"+ it "should have usual haskell name" $ do+ fieldHaskell `shouldBe` FieldNameHS "Id"+ it "should have correct underlying sql type" $ do+ fieldSqlType `shouldBe` SqlInt64+ it "persistfieldsql should be right" $ do+ sqlType (Proxy @HasDefaultIdId) `shouldBe` SqlInt64+ it "should have correct haskell type" $ do+ fieldType `shouldBe` FTTypeCon Nothing "HasDefaultIdId"++ describe "HasCustomSqlId" $ do+ let FieldDef{..} =+ entityId (entityDef (Proxy @HasCustomSqlId))+ it "should have custom db name" $ do+ fieldDB `shouldBe` FieldNameDB "my_id"+ it "should have usual haskell name" $ do+ fieldHaskell `shouldBe` FieldNameHS "id"+ it "should have correct underlying sql type" $ do+ fieldSqlType `shouldBe` SqlString+ it "should have correct haskell type" $ do+ fieldType `shouldBe` FTTypeCon Nothing "String"+ describe "HasIdDef" $ do+ let FieldDef{..} =+ entityId (entityDef (Proxy @HasIdDef))+ it "should have usual db name" $ do+ fieldDB `shouldBe` FieldNameDB "id"+ it "should have usual haskell name" $ do+ fieldHaskell `shouldBe` FieldNameHS "id"+ it "should have correct underlying sql type" $ do+ fieldSqlType `shouldBe` SqlInt64+ it "should have correct haskell type" $ do+ fieldType `shouldBe` FTTypeCon Nothing "Int"++ describe "SharedPrimaryKey" $ do+ let sharedDef = entityDef (Proxy @SharedPrimaryKey)+ FieldDef{..} =+ entityId sharedDef+ it "should have usual db name" $ do+ fieldDB `shouldBe` FieldNameDB "id"+ it "should have usual haskell name" $ do+ fieldHaskell `shouldBe` FieldNameHS "id"+ it "should have correct underlying sql type" $ do+ fieldSqlType `shouldBe` SqlInt64+ it "should have correct haskell type" $ do+ fieldType `shouldBe` FTApp (FTTypeCon Nothing "Key") (FTTypeCon Nothing "HasDefaultId")+ it "should have correct sql type from PersistFieldSql" $ do+ sqlType (Proxy @SharedPrimaryKeyId)+ `shouldBe`+ SqlInt64+ it "should have same sqlType as underlying record" $ do+ sqlType (Proxy @SharedPrimaryKeyId)+ `shouldBe`+ sqlType (Proxy @HasDefaultIdId)+ it "should be a coercible newtype" $ do+ coerce @Int64 3+ `shouldBe`+ SharedPrimaryKeyKey (toSqlKey 3)++ it "is a newtype" $ do+ pkNewtype sqlSettings sharedDef+ `shouldBe`+ True++ describe "SharedPrimaryKeyWithCascade" $ do+ let FieldDef{..} =+ entityId (entityDef (Proxy @SharedPrimaryKeyWithCascade))+ it "should have usual db name" $ do+ fieldDB `shouldBe` FieldNameDB "id"+ it "should have usual haskell name" $ do+ fieldHaskell `shouldBe` FieldNameHS "id"+ it "should have correct underlying sql type" $ do+ fieldSqlType `shouldBe` SqlInt64+ it "should have correct haskell type" $ do+ fieldType+ `shouldBe`+ FTApp (FTTypeCon Nothing "Key") (FTTypeCon Nothing "HasDefaultId")+ it "should have cascade in field def" $ do+ fieldCascade `shouldBe` noCascade { fcOnDelete = Just Cascade }++ describe "OnCascadeDelete" $ do+ let subject :: FieldDef+ Just subject =+ List.find ((FieldNameHS "person" ==) . fieldHaskell)+ $ entityFields+ $ simpleCascadeDef+ simpleCascadeDef =+ entityDef (Proxy :: Proxy HasSimpleCascadeRef)+ expected =+ FieldCascade+ { fcOnDelete = Just Cascade+ , fcOnUpdate = Nothing+ }+ describe "entityDef" $ do+ it "works" $ do+ simpleCascadeDef+ `shouldBe`+ EntityDef+ { entityHaskell = EntityNameHS "HasSimpleCascadeRef"+ , entityDB = EntityNameDB "HasSimpleCascadeRef"+ , entityId =+ FieldDef+ { fieldHaskell = FieldNameHS "Id"+ , fieldDB = FieldNameDB "id"+ , fieldType = FTTypeCon Nothing "HasSimpleCascadeRefId"+ , fieldSqlType = SqlInt64+ , fieldReference =+ ForeignRef (EntityNameHS "HasSimpleCascadeRef") (FTTypeCon (Just "Data.Int") "Int64")+ , fieldAttrs = []+ , fieldStrict = True+ , fieldComments = Nothing+ , fieldCascade = noCascade+ , fieldGenerated = Nothing+ }+ , entityAttrs = []+ , entityFields =+ [ FieldDef+ { fieldHaskell = FieldNameHS "person"+ , fieldDB = FieldNameDB "person"+ , fieldType = FTTypeCon Nothing "PersonId"+ , fieldSqlType = SqlInt64+ , fieldAttrs = []+ , fieldStrict = True+ , fieldReference =+ ForeignRef+ (EntityNameHS "Person")+ (FTTypeCon (Just "Data.Int") "Int64")+ , fieldCascade =+ FieldCascade { fcOnUpdate = Nothing, fcOnDelete = Just Cascade }+ , fieldComments = Nothing+ , fieldGenerated = Nothing+ }+ ]+ , entityUniques = []+ , entityForeigns = []+ , entityDerives = ["Show", "Eq"]+ , entityExtra = mempty+ , entitySum = False+ , entityComments = Nothing+ }+ it "has the cascade on the field def" $ do+ fieldCascade subject `shouldBe` expected+ it "doesn't have any extras" $ do+ entityExtra simpleCascadeDef+ `shouldBe`+ mempty++ describe "hasNaturalKey" $ do+ let subject :: PersistEntity a => Proxy a -> Bool+ subject p = hasNaturalKey (entityDef p)+ it "is True for Primary keyword" $ do+ subject (Proxy @HasPrimaryDef)+ `shouldBe`+ True+ it "is True for multiple Primary columns " $ do+ subject (Proxy @HasMultipleColPrimaryDef)+ `shouldBe`+ True+ it "is False for Id keyword" $ do+ subject (Proxy @HasIdDef)+ `shouldBe`+ False+ it "is False for unspecified/default id" $ do+ subject (Proxy @HasDefaultId)+ `shouldBe`+ False+ describe "hasCompositePrimaryKey" $ do+ let subject :: PersistEntity a => Proxy a -> Bool+ subject p = hasCompositePrimaryKey (entityDef p)+ it "is False for Primary with single column" $ do+ subject (Proxy @HasPrimaryDef)+ `shouldBe`+ False+ it "is True for multiple Primary columns " $ do+ subject (Proxy @HasMultipleColPrimaryDef)+ `shouldBe`+ True+ it "is False for Id keyword" $ do+ subject (Proxy @HasIdDef)+ `shouldBe`+ False+ it "is False for unspecified/default id" $ do+ subject (Proxy @HasDefaultId)+ `shouldBe`+ False++ describe "JSON serialization" $ do+ prop "to/from is idempotent" $ \person ->+ decode (encode person) == Just (person :: Person)+ it "decode" $+ decode "{\"name\":\"Michael\",\"age\":27,\"foo\":\"Bar\",\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}" `shouldBe` Just+ (Person "Michael" (Just 27) Bar $ 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,\"foo\":\"Bar\",\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}" `shouldBe` Just+ (Entity key (Person "Michael" (Just 27) Bar $ 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+ describe "Derived Show/Read instances" $ do+ -- This tests confirms https://github.com/yesodweb/persistent/issues/1104 remains fixed+ it "includes the name of the newtype when showing/reading a Key, i.e. uses the stock strategy when deriving Show/Read" $ do+ show (PersonKey 0) `shouldBe` "PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 0}}"+ read (show (PersonKey 0)) `shouldBe` PersonKey 0++ show (CustomPrimaryKeyKey 0) `shouldBe` "CustomPrimaryKeyKey {unCustomPrimaryKeyKey = 0}"+ read (show (CustomPrimaryKeyKey 0)) `shouldBe` CustomPrimaryKeyKey 0++(&) :: a -> (a -> b) -> b+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)
+ test/TemplateTestImports.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TemplateHaskell #-}++module TemplateTestImports+ ( module TemplateTestImports+ , module X+ ) where++import Data.Aeson.TH+import Test.QuickCheck++import Test.Hspec as X+import Database.Persist.Sql as X+import Database.Persist.TH as X++data Foo = Bar | Baz+ deriving (Show, Eq)++deriveJSON defaultOptions ''Foo++derivePersistFieldJSON "Foo"++instance Arbitrary Foo where+ arbitrary = elements [Bar, Baz]
test/main.hs view
@@ -4,6 +4,8 @@ {-# LANGUAGE RecordWildCards #-} import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck import qualified Data.Char as Char import qualified Data.Text as T import Data.List@@ -21,32 +23,40 @@ import Database.Persist.Quasi import Database.Persist.Types +import qualified Database.Persist.THSpec as THSpec+ main :: IO () main = hspec $ do+ describe "Database.Persist" $ do+ describe "THSpec" THSpec.spec++ THSpec.spec describe "splitExtras" $ do+ let helloWorldTokens = asTokens ["hello", "world"]+ foobarbazTokens = asTokens ["foo", "bar", "baz"] it "works" $ do splitExtras [] `shouldBe` mempty it "works2" $ do splitExtras- [ Line 0 ["hello", "world"]+ [ Line 0 helloWorldTokens ] `shouldBe`- ( [["hello", "world"]], mempty )+ ( [helloWorldTokens], mempty ) it "works3" $ do splitExtras- [ Line 0 ["hello", "world"]- , Line 2 ["foo", "bar", "baz"]+ [ Line 0 helloWorldTokens+ , Line 2 foobarbazTokens ] `shouldBe`- ( [["hello", "world"], ["foo", "bar", "baz"]], mempty )+ ( [helloWorldTokens, foobarbazTokens], mempty ) it "works4" $ do let foobarbarz = ["foo", "Bar", "baz"] splitExtras- [ Line 0 ["Hello"]- , Line 2 foobarbarz- , Line 2 foobarbarz+ [ Line 0 [Token "Hello"]+ , Line 2 (asTokens foobarbarz)+ , Line 2 (asTokens foobarbarz) ] `shouldBe` ( []@@ -57,9 +67,9 @@ it "works5" $ do let foobarbarz = ["foo", "Bar", "baz"] splitExtras- [ Line 0 ["Hello"]- , Line 2 foobarbarz- , Line 4 foobarbarz+ [ Line 0 (asTokens ["Hello"])+ , Line 2 (asTokens foobarbarz)+ , Line 4 (asTokens foobarbarz) ] `shouldBe` ( []@@ -119,90 +129,240 @@ , fieldGenerated = Nothing } - describe "tokenization" $ do+ describe "parseLine" $ do+ it "returns nothing when line is just whitespace" $+ parseLine " " `shouldBe` Nothing+ it "handles normal words" $- tokenize " foo bar baz" `shouldBe`- [ Spaces 1- , Token "foo"- , Spaces 3- , Token "bar"- , Spaces 2- , Token "baz"- ]+ parseLine " foo bar baz" `shouldBe`+ Just+ ( Line 1+ [ Token "foo"+ , Token "bar"+ , Token "baz"+ ]+ )+ it "handles quotes" $- tokenize " \"foo bar\" \"baz\"" `shouldBe`- [ Spaces 2- , Token "foo bar"- , Spaces 2- , Token "baz"- ]+ parseLine " \"foo bar\" \"baz\"" `shouldBe`+ Just+ ( Line 2+ [ Token "foo bar"+ , Token "baz"+ ]+ )+ it "handles quotes mid-token" $- tokenize " x=\"foo bar\" \"baz\"" `shouldBe`- [ Spaces 2- , Token "x=foo bar"- , Spaces 2- , Token "baz"- ]+ parseLine " x=\"foo bar\" \"baz\"" `shouldBe`+ Just+ ( Line 2+ [ Token "x=foo bar"+ , Token "baz"+ ]+ )+ it "handles escaped quote mid-token" $- tokenize " x=\\\"foo bar\" \"baz\"" `shouldBe`- [ Spaces 2- , Token "x=\\\"foo"- , Spaces 1- , Token "bar\""- , Spaces 2- , Token "baz"- ]+ parseLine " x=\\\"foo bar\" \"baz\"" `shouldBe`+ Just+ ( Line 2+ [ Token "x=\\\"foo"+ , Token "bar\""+ , Token "baz"+ ]+ )+ it "handles unnested parantheses" $- tokenize " (foo bar) (baz)" `shouldBe`- [ Spaces 2- , Token "foo bar"- , Spaces 2- , Token "baz"- ]+ parseLine " (foo bar) (baz)" `shouldBe`+ Just+ ( Line 2+ [ Token "foo bar"+ , Token "baz"+ ]+ )+ it "handles unnested parantheses mid-token" $- tokenize " x=(foo bar) (baz)" `shouldBe`- [ Spaces 2- , Token "x=foo bar"- , Spaces 2- , Token "baz"- ]+ parseLine " x=(foo bar) (baz)" `shouldBe`+ Just+ ( Line 2+ [ Token "x=foo bar"+ , Token "baz"+ ]+ )+ it "handles nested parantheses" $- tokenize " (foo (bar)) (baz)" `shouldBe`- [ Spaces 2- , Token "foo (bar)"- , Spaces 2- , Token "baz"- ]+ parseLine " (foo (bar)) (baz)" `shouldBe`+ Just+ ( Line 2+ [ Token "foo (bar)"+ , Token "baz"+ ]+ )+ it "escaping" $- tokenize " (foo \\(bar) y=\"baz\\\"\"" `shouldBe`- [ Spaces 2- , Token "foo (bar"- , Spaces 2- , Token "y=baz\""- ]+ parseLine " (foo \\(bar) y=\"baz\\\"\"" `shouldBe`+ Just+ ( Line 2+ [ Token "foo (bar"+ , Token "y=baz\""+ ]+ )+ it "mid-token quote in later token" $- tokenize "foo bar baz=(bin\")" `shouldBe`- [ Token "foo"- , Spaces 1- , Token "bar"- , Spaces 1- , Token "baz=bin\""- ]+ parseLine "foo bar baz=(bin\")" `shouldBe`+ Just+ ( Line 0+ [ Token "foo"+ , Token "bar"+ , Token "baz=bin\""+ ]+ )+ describe "comments" $ do it "recognizes one line" $ do- tokenize "-- | this is a comment" `shouldBe`- [ DocComment "-- | this is a comment"- ]- it "map tokenize" $ do- map tokenize ["Foo", "-- | Hello"]+ parseLine "-- | this is a comment" `shouldBe`+ Just+ ( Line 0+ [ DocComment "this is a comment"+ ]+ )++ it "map parseLine" $ do+ mapM parseLine ["Foo", "-- | Hello"] `shouldBe`- [ [Token "Foo"]- , [DocComment "-- | Hello"]- ]+ Just+ [ Line 0 [Token "Foo"]+ , Line 0 [DocComment "Hello"]+ ]+ it "works if comment is indented" $ do- tokenize " -- | comment" `shouldBe`- [ Spaces 2, DocComment "-- | comment"- ]+ parseLine " -- | comment" `shouldBe`+ Just (Line 2 [ DocComment "comment"])++ describe "parse" $ do+ let subject =+ [st|+Bicycle -- | this is a bike+ brand String -- | the brand of the bike+ ExtraBike+ foo bar -- | this is a foo bar+ baz+ deriving Eq+-- | This is a Car+Car+ -- | the make of the Car+ make String+ -- | the model of the Car+ model String+ UniqueModel model+ deriving Eq Show++Vehicle+ bicycle BicycleId -- | the bike reference+ car CarId -- | the car reference++ |]+ let [bicycle, car, vehicle] = parse lowerCaseSettings subject++ it "should parse the `entityHaskell` field" $ do+ entityHaskell bicycle `shouldBe` EntityNameHS "Bicycle"+ entityHaskell car `shouldBe` EntityNameHS "Car"+ entityHaskell vehicle `shouldBe` EntityNameHS "Vehicle"++ it "should parse the `entityDB` field" $ do+ entityDB bicycle `shouldBe` EntityNameDB "bicycle"+ entityDB car `shouldBe` EntityNameDB "car"+ entityDB vehicle `shouldBe` EntityNameDB "vehicle"++ it "should parse the `entityId` field" $ do+ fieldHaskell (entityId bicycle) `shouldBe` FieldNameHS "Id"+ fieldComments (entityId bicycle) `shouldBe` Nothing+ fieldHaskell (entityId car) `shouldBe` FieldNameHS "Id"+ fieldComments (entityId car) `shouldBe` Nothing+ fieldHaskell (entityId vehicle) `shouldBe` FieldNameHS "Id"+ fieldComments (entityId vehicle) `shouldBe` Nothing++ it "should parse the `entityAttrs` field" $ do+ entityAttrs bicycle `shouldBe` ["-- | this is a bike"]+ entityAttrs car `shouldBe` []+ entityAttrs vehicle `shouldBe` []++ it "should parse the `entityFields` field" $ do+ let simplifyField field =+ (fieldHaskell field, fieldDB field, fieldComments field)+ (simplifyField <$> entityFields bicycle) `shouldBe`+ [ (FieldNameHS "brand", FieldNameDB "brand", Nothing)+ ]+ (simplifyField <$> entityFields car) `shouldBe`+ [ (FieldNameHS "make", FieldNameDB "make", Just "the make of the Car\n")+ , (FieldNameHS "model", FieldNameDB "model", Just "the model of the Car\n")+ ]+ (simplifyField <$> entityFields vehicle) `shouldBe`+ [ (FieldNameHS "bicycle", FieldNameDB "bicycle", Nothing)+ , (FieldNameHS "car", FieldNameDB "car", Nothing)+ ]++ it "should parse the `entityUniques` field" $ do+ let simplifyUnique unique =+ (uniqueHaskell unique, uniqueFields unique)+ (simplifyUnique <$> entityUniques bicycle) `shouldBe` []+ (simplifyUnique <$> entityUniques car) `shouldBe`+ [ (ConstraintNameHS "UniqueModel", [(FieldNameHS "model", FieldNameDB "model")])+ ]+ (simplifyUnique <$> entityUniques vehicle) `shouldBe` []++ it "should parse the `entityForeigns` field" $ do+ let [user, notification] = parse lowerCaseSettings [st|+User+ name Text+ emailFirst Text+ emailSecond Text++ UniqueEmail emailFirst emailSecond++Notification+ content Text+ sentToFirst Text+ sentToSecond Text++ Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond+|]+ entityForeigns user `shouldBe` []+ entityForeigns notification `shouldBe`+ [ ForeignDef+ { foreignRefTableHaskell = EntityNameHS "User"+ , foreignRefTableDBName = EntityNameDB "user"+ , foreignConstraintNameHaskell = ConstraintNameHS "fk_noti_user"+ , foreignConstraintNameDBName = ConstraintNameDB "notificationfk_noti_user"+ , foreignFieldCascade = FieldCascade Nothing Nothing+ , foreignFields =+ [ ((FieldNameHS "sentToFirst", FieldNameDB "sent_to_first"), (FieldNameHS "emailFirst", FieldNameDB "email_first"))+ , ((FieldNameHS "sentToSecond", FieldNameDB "sent_to_second"), (FieldNameHS "emailSecond", FieldNameDB "email_second"))+ ]+ , foreignAttrs = []+ , foreignNullable = False+ , foreignToPrimary = False+ }+ ]++ it "should parse the `entityDerives` field" $ do+ entityDerives bicycle `shouldBe` ["Eq"]+ entityDerives car `shouldBe` ["Eq", "Show"]+ entityDerives vehicle `shouldBe` []++ it "should parse the `entityEntities` field" $ do+ entityExtra bicycle `shouldBe` Map.singleton "ExtraBike" [["foo", "bar", "-- | this is a foo bar"], ["baz"]]+ entityExtra car `shouldBe` mempty+ entityExtra vehicle `shouldBe` mempty++ it "should parse the `entitySum` field" $ do+ entitySum bicycle `shouldBe` False+ entitySum car `shouldBe` False+ entitySum vehicle `shouldBe` True++ it "should parse the `entityComments` field" $ do+ entityComments bicycle `shouldBe` Nothing+ entityComments car `shouldBe` Just "This is a Car\n"+ entityComments vehicle `shouldBe` Nothing+ describe "parseFieldType" $ do it "simple types" $ parseFieldType "FooBar" `shouldBe` Right (FTTypeCon Nothing "FooBar")@@ -251,59 +411,56 @@ let preparsed = preparse subject it "preparse works" $ do- length preparsed- `shouldBe` do- length . filter (not . T.all Char.isSpace) . T.lines- $ subject+ (length <$> preparsed) `shouldBe` Just 10 let skippedEmpty =- skipEmpty preparsed+ maybe [] skipEmpty preparsed fooLines = [ Line { lineIndent = 0- , tokens = "Foo" :| []+ , tokens = Token "Foo" :| [] } , Line { lineIndent = 4- , tokens = "name" :| ["String"]+ , tokens = Token "name" :| [Token "String"] } , Line { lineIndent = 4- , tokens = "age" :| ["Int"]+ , tokens = Token "age" :| [Token "Int"] } ] emptyLines = [ Line { lineIndent = 0- , tokens = "EmptyEntity" :| []+ , tokens = Token "EmptyEntity" :| [] } ] barLines = [ Line { lineIndent = 0- , tokens = "Bar" :| []+ , tokens = Token "Bar" :| [] } , Line { lineIndent = 4- , tokens = "name" :| ["String"]+ , tokens = Token "name" :| [Token "String"] } ] bazLines = [ Line { lineIndent = 0- , tokens = "Baz" :| []+ , tokens = Token "Baz" :| [] } , Line { lineIndent = 4- , tokens = "a" :| ["Int"]+ , tokens = Token "a" :| [Token "Int"] } , Line { lineIndent = 4- , tokens = "b" :| ["String"]+ , tokens = Token "b" :| [Token "String"] } , Line { lineIndent = 4- , tokens = "c" :| ["FooId"]+ , tokens = Token "c" :| [Token "FooId"] } ] resultLines =@@ -364,148 +521,99 @@ describe "preparse" $ do+ prop "omits lines that are only whitespace" $ \len -> do+ ws <- vectorOf len arbitraryWhiteSpaceChar+ pure $ preparse (T.pack ws) === Nothing+ it "recognizes entity" $ do- preparse "Person\n name String\n age Int" `shouldBe`- [ Line { lineIndent = 0, tokens = ["Person"] }- , Line { lineIndent = 2, tokens = ["name", "String"] }- , Line { lineIndent = 2, tokens = ["age", "Int"] }- ]- describe "recognizes comments" $ do- let text = "Foo\n x X\n-- | Hello\nBar\n name String"- linesText = T.lines text- it "T.lines" $ do- linesText- `shouldBe`- [ "Foo"- , " x X"- , "-- | Hello"- , "Bar"- , " name String"- ]- let tokens = map tokenize linesText- it "map tokenize" $ do- tokens `shouldBe`- [ [ Token "Foo" ]- , [ Spaces 2, Token "x", Spaces 1, Token "X"]- , [ DocComment "-- | Hello" ]- , [ Token "Bar" ]- , [ Spaces 1, Token "name", Spaces 1, Token "String" ]- ]- let filtered = filter (not . empty) tokens- it "filter (not . empty)" $ do- filtered `shouldBe`- [ [ Token "Foo" ]- , [ Spaces 2, Token "x", Spaces 1, Token "X"]- , [ DocComment "-- | Hello" ]- , [ Token "Bar" ]- , [ Spaces 1, Token "name", Spaces 1, Token "String" ]+ let expected =+ Line { lineIndent = 0, tokens = asTokens ["Person"] } :|+ [ Line { lineIndent = 2, tokens = asTokens ["name", "String"] }+ , Line { lineIndent = 2, tokens = asTokens ["age", "Int"] } ]- let spacesRemoved = removeSpaces filtered- it "removeSpaces" $ do- spacesRemoved `shouldBe`- [ Line { lineIndent = 0, tokens = ["Foo"] }- , Line { lineIndent = 2, tokens = ["x", "X"] }- , Line { lineIndent = 0, tokens = ["-- | Hello"] }- , Line { lineIndent = 0, tokens = ["Bar"] }- , Line { lineIndent = 1, tokens = ["name", "String"] }+ preparse "Person\n name String\n age Int" `shouldBe` Just expected++ it "recognizes comments" $ do+ let text = "Foo\n x X\n-- | Hello\nBar\n name String"+ let expected =+ Line { lineIndent = 0, tokens = asTokens ["Foo"] } :|+ [ Line { lineIndent = 2, tokens = asTokens ["x", "X"] }+ , Line { lineIndent = 0, tokens = [DocComment "Hello"] }+ , Line { lineIndent = 0, tokens = asTokens ["Bar"] }+ , Line { lineIndent = 1, tokens = asTokens ["name", "String"] } ]+ preparse text `shouldBe` Just expected - it "preparse" $ do- preparse text `shouldBe`- [ Line { lineIndent = 0, tokens = ["Foo"] }- , Line { lineIndent = 2, tokens = ["x", "X"] }- , Line { lineIndent = 0, tokens = ["-- | Hello"] }- , Line { lineIndent = 0, tokens = ["Bar"] }- , Line { lineIndent = 1, tokens = ["name", "String"] }+ it "preparse indented" $ do+ let t = T.unlines+ [ " Foo"+ , " x X"+ , " -- | Comment"+ , " -- hidden comment"+ , " Bar"+ , " name String" ]- it "preparse indented" $ do- let t = T.unlines- [ " Foo"- , " x X"- , " -- | Comment"- , " -- hidden comment"- , " Bar"- , " name String"- ]- preparse t `shouldBe`- [ Line { lineIndent = 2, tokens = ["Foo"] }- , Line { lineIndent = 4, tokens = ["x", "X"] }- , Line { lineIndent = 2, tokens = ["-- | Comment"] }- , Line { lineIndent = 2, tokens = ["Bar"] }- , Line { lineIndent = 4, tokens = ["name", "String"] }+ expected =+ Line { lineIndent = 2, tokens = asTokens ["Foo"] } :|+ [ Line { lineIndent = 4, tokens = asTokens ["x", "X"] }+ , Line { lineIndent = 2, tokens = [DocComment "Comment"] }+ , Line { lineIndent = 2, tokens = asTokens ["Bar"] }+ , Line { lineIndent = 4, tokens = asTokens ["name", "String"] } ]- it "preparse extra blocks" $ do- let t = T.unlines- [ "LowerCaseTable"- , " name String"- , " ExtraBlock"- , " foo bar"- , " baz"- , " ExtraBlock2"- , " something"- ]- preparse t `shouldBe`- [ Line { lineIndent = 0, tokens = ["LowerCaseTable"] }- , Line { lineIndent = 2, tokens = ["name", "String"] }- , Line { lineIndent = 2, tokens = ["ExtraBlock"] }- , Line { lineIndent = 4, tokens = ["foo", "bar"] }- , Line { lineIndent = 4, tokens = ["baz"] }- , Line { lineIndent = 2, tokens = ["ExtraBlock2"] }- , Line { lineIndent = 4, tokens = ["something"] }+ preparse t `shouldBe` Just expected++ it "preparse extra blocks" $ do+ let t = T.unlines+ [ "LowerCaseTable"+ , " name String"+ , " ExtraBlock"+ , " foo bar"+ , " baz"+ , " ExtraBlock2"+ , " something" ]- it "field comments" $ do- let text = T.unlines- [ "-- | Model"- , "Foo"- , " -- | Field"- , " name String"- ]- preparse text `shouldBe`- [ Line { lineIndent = 0, tokens = ["-- | Model"] }- , Line { lineIndent = 0, tokens = ["Foo"] }- , Line { lineIndent = 2, tokens = ["-- | Field"] }- , Line { lineIndent = 2, tokens = ["name", "String"] }+ expected =+ Line { lineIndent = 0, tokens = asTokens ["LowerCaseTable"] } :|+ [ Line { lineIndent = 2, tokens = asTokens ["name", "String"] }+ , Line { lineIndent = 2, tokens = asTokens ["ExtraBlock"] }+ , Line { lineIndent = 4, tokens = asTokens ["foo", "bar"] }+ , Line { lineIndent = 4, tokens = asTokens ["baz"] }+ , Line { lineIndent = 2, tokens = asTokens ["ExtraBlock2"] }+ , Line { lineIndent = 4, tokens = asTokens ["something"] } ]-- describe "empty" $ do- it "doesn't dispatch comments" $ do- [DocComment "-- | hello"] `shouldSatisfy` (not . empty)- it "removes spaces" $ do- [Spaces 3] `shouldSatisfy` empty-- describe "filter (not . empty)" $ do- let subject = filter (not . empty)- it "keeps comments" $ do- subject [[DocComment "-- | Hello"]]- `shouldBe`- [[DocComment "-- | Hello"]]- it "omits lines with only spaces" $ do- subject [[Spaces 3, Token "indented"], [Spaces 2]]- `shouldBe`- [[Spaces 3, Token "indented"]]+ preparse t `shouldBe` Just expected - describe "removeSpaces" $ do- it "sets indentation level for a line" $ do- removeSpaces [[Spaces 3, Token "hello", Spaces 1, Token "goodbye"]]- `shouldBe`- [ Line { lineIndent = 3, tokens = ["hello", "goodbye"] }+ it "field comments" $ do+ let text = T.unlines+ [ "-- | Model"+ , "Foo"+ , " -- | Field"+ , " name String" ]- it "does not remove comments" $ do- removeSpaces- [ [ DocComment "-- | asdf" ]- , [ Token "Foo" ]- , [ Spaces 2, Token "name", Spaces 1, Token "String" ]- ]- `shouldBe`- [ Line { lineIndent = 0, tokens = ["-- | asdf"] }- , Line { lineIndent = 0, tokens = ["Foo"] }- , Line { lineIndent = 2, tokens = ["name", "String"] }+ expected =+ Line { lineIndent = 0, tokens = [DocComment "Model"] } :|+ [ Line { lineIndent = 0, tokens = asTokens ["Foo"] }+ , Line { lineIndent = 2, tokens = [DocComment "Field"] }+ , Line { lineIndent = 2, tokens = asTokens ["name", "String"] } ]+ preparse text `shouldBe` Just expected describe "associateLines" $ do- let foo = Line { lineIndent = 0, tokens = pure "Foo" }- name'String = Line { lineIndent = 2, tokens = "name" :| ["String"] }- comment = Line { lineIndent = 0, tokens = pure "-- | comment" }+ let foo =+ Line+ { lineIndent = 0+ , tokens = pure (Token "Foo")+ }+ name'String =+ Line+ { lineIndent = 2+ , tokens = Token "name" :| [Token "String"]+ }+ comment =+ Line+ { lineIndent = 0+ , tokens = pure (DocComment "comment")+ } it "works" $ do associateLines [ comment@@ -518,8 +626,16 @@ , lwcLines = foo :| [name'String] } ]- let bar = Line { lineIndent = 0, tokens = "Bar" :| ["sql", "=", "bars"] }- age'Int = Line { lineIndent = 1, tokens = "age" :| ["Int"] }+ let bar =+ Line+ { lineIndent = 0+ , tokens = Token "Bar" :| asTokens ["sql", "=", "bars"]+ }+ age'Int =+ Line+ { lineIndent = 1+ , tokens = Token "age" :| [Token "Int"]+ } it "works when used consecutively" $ do associateLines [ bar@@ -541,26 +657,26 @@ it "works with textual input" $ do let text = "Foo\n x X\n-- | Hello\nBar\n name String" parsed = preparse text- allFull = skipEmpty parsed+ allFull = maybe [] skipEmpty parsed associateLines allFull `shouldBe` [ LinesWithComments { lwcLines =- Line {lineIndent = 0, tokens = "Foo" :| []}- :| [ Line {lineIndent = 2, tokens = "x" :| ["X"]} ]+ Line {lineIndent = 0, tokens = Token "Foo" :| []}+ :| [ Line {lineIndent = 2, tokens = Token "x" :| [Token "X"]} ] , lwcComments = [] } , LinesWithComments { lwcLines =- Line {lineIndent = 0, tokens = "Bar" :| []}- :| [ Line {lineIndent = 1, tokens = "name" :| ["String"]}]+ Line {lineIndent = 0, tokens = Token "Bar" :| []}+ :| [ Line {lineIndent = 1, tokens = Token "name" :| [Token "String"]}] , lwcComments = ["Hello"] } ] it "works with extra blocks" $ do- let text = skipEmpty . preparse . T.unlines $+ let text = maybe [] skipEmpty . preparse . T.unlines $ [ "LowerCaseTable" , " Id sql=my_id" , " fullName Text"@@ -574,22 +690,22 @@ associateLines text `shouldBe` [ LinesWithComments { lwcLines =- Line { lineIndent = 0, tokens = pure "LowerCaseTable" } :|- [ Line { lineIndent = 4, tokens = "Id" :| ["sql=my_id"] }- , Line { lineIndent = 4, tokens = "fullName" :| ["Text"] }- , Line { lineIndent = 4, tokens = pure "ExtraBlock" }- , Line { lineIndent = 8, tokens = "foo" :| ["bar"] }- , Line { lineIndent = 8, tokens = pure "baz" }- , Line { lineIndent = 8, tokens = pure "bin" }- , Line { lineIndent = 4, tokens = pure "ExtraBlock2" }- , Line { lineIndent = 8, tokens = pure "something" }+ Line { lineIndent = 0, tokens = pure (Token "LowerCaseTable") } :|+ [ Line { lineIndent = 4, tokens = Token "Id" :| [Token "sql=my_id"] }+ , Line { lineIndent = 4, tokens = Token "fullName" :| [Token "Text"] }+ , Line { lineIndent = 4, tokens = pure (Token "ExtraBlock") }+ , Line { lineIndent = 8, tokens = Token "foo" :| [Token "bar"] }+ , Line { lineIndent = 8, tokens = pure (Token "baz") }+ , Line { lineIndent = 8, tokens = pure (Token "bin") }+ , Line { lineIndent = 4, tokens = pure (Token "ExtraBlock2") }+ , Line { lineIndent = 8, tokens = pure (Token "something") } ] , lwcComments = [] } ] it "works with extra blocks twice" $ do- let text = skipEmpty . preparse . T.unlines $+ let text = maybe [] skipEmpty . preparse . T.unlines $ [ "IdTable" , " Id Day default=CURRENT_DATE" , " name Text"@@ -606,23 +722,23 @@ ] associateLines text `shouldBe` [ LinesWithComments- { lwcLines = Line 0 (pure "IdTable") :|- [ Line 4 ("Id" :| ["Day", "default=CURRENT_DATE"])- , Line 4 ("name" :| ["Text"])+ { lwcLines = Line 0 (pure (Token "IdTable")) :|+ [ Line 4 (Token "Id" :| asTokens ["Day", "default=CURRENT_DATE"])+ , Line 4 (Token "name" :| asTokens ["Text"]) ] , lwcComments = [] } , LinesWithComments { lwcLines =- Line { lineIndent = 0, tokens = pure "LowerCaseTable" } :|- [ Line { lineIndent = 4, tokens = "Id" :| ["sql=my_id"] }- , Line { lineIndent = 4, tokens = "fullName" :| ["Text"] }- , Line { lineIndent = 4, tokens = pure "ExtraBlock" }- , Line { lineIndent = 8, tokens = "foo" :| ["bar"] }- , Line { lineIndent = 8, tokens = pure "baz" }- , Line { lineIndent = 8, tokens = pure "bin" }- , Line { lineIndent = 4, tokens = pure "ExtraBlock2" }- , Line { lineIndent = 8, tokens = pure "something" }+ Line { lineIndent = 0, tokens = pure (Token "LowerCaseTable") } :|+ [ Line { lineIndent = 4, tokens = Token "Id" :| [Token "sql=my_id"] }+ , Line { lineIndent = 4, tokens = Token "fullName" :| [Token "Text"] }+ , Line { lineIndent = 4, tokens = pure (Token "ExtraBlock") }+ , Line { lineIndent = 8, tokens = Token "foo" :| [Token "bar"] }+ , Line { lineIndent = 8, tokens = pure (Token "baz") }+ , Line { lineIndent = 8, tokens = pure (Token "bin") }+ , Line { lineIndent = 4, tokens = pure (Token "ExtraBlock2") }+ , Line { lineIndent = 8, tokens = pure (Token "something") } ] , lwcComments = [] }@@ -630,7 +746,7 @@ it "works with field comments" $ do- let text = skipEmpty . preparse . T.unlines $+ let text = maybe [] skipEmpty . preparse . T.unlines $ [ "-- | Model" , "Foo" , " -- | Field"@@ -639,9 +755,9 @@ associateLines text `shouldBe` [ LinesWithComments { lwcLines =- Line { lineIndent = 0, tokens = "Foo" :| [] } :|- [ Line { lineIndent = 2, tokens = pure "-- | Field" }- , Line { lineIndent = 2, tokens = "name" :| ["String"] }+ Line { lineIndent = 0, tokens = (Token "Foo") :| [] } :|+ [ Line { lineIndent = 2, tokens = pure (DocComment "Field") }+ , Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] } ] , lwcComments = ["Model"]@@ -753,3 +869,10 @@ it "works with format" $ fromPersistValue (PersistText "2018-02-27 10:49:42.123") `shouldBe` Right (UTCTime (fromGregorian 2018 02 27) (timeOfDayToTime (TimeOfDay 10 49 42.123)))++asTokens :: [T.Text] -> [Token]+asTokens = fmap Token++arbitraryWhiteSpaceChar :: Gen Char+arbitraryWhiteSpaceChar =+ oneof $ pure <$> [' ', '\t', '\n', '\r']