1{-# LANGUAGE CPP #-} 2{-# LANGUAGE FlexibleInstances #-} 3{-# LANGUAGE LambdaCase #-} 4{-# LANGUAGE OverloadedStrings #-} 5{-# LANGUAGE RankNTypes #-} 6{-# LANGUAGE RecordWildCards #-} 7{-# LANGUAGE TemplateHaskell #-} 8{-# LANGUAGE TupleSections #-} 9{-# LANGUAGE UndecidableInstances #-} 10{-# LANGUAGE StandaloneDeriving #-} 11{-# LANGUAGE DerivingStrategies #-} 12{-# LANGUAGE GeneralizedNewtypeDeriving #-} 13{-# LANGUAGE ScopedTypeVariables #-} 14{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-} 15 16-- | This module provides the tools for defining your database schema and using 17-- it to generate Haskell data types and migrations. 18module Database.Persist.TH 19 ( -- * Parse entity defs 20 persistWith 21 , persistUpperCase 22 , persistLowerCase 23 , persistFileWith 24 , persistManyFileWith 25 -- * Turn @EntityDef@s into types 26 , mkPersist 27 , MkPersistSettings 28 , mpsBackend 29 , mpsGeneric 30 , mpsPrefixFields 31 , mpsEntityJSON 32 , mpsGenerateLenses 33 , mpsDeriveInstances 34 , EntityJSON(..) 35 , mkPersistSettings 36 , sqlSettings 37 -- * Various other TH functions 38 , mkMigrate 39 , mkSave 40 , mkDeleteCascade 41 , mkEntityDefList 42 , share 43 , derivePersistField 44 , derivePersistFieldJSON 45 , persistFieldFromEntity 46 -- * Internal 47 , lensPTH 48 , parseReferences 49 , embedEntityDefs 50 , fieldError 51 , AtLeastOneUniqueKey(..) 52 , OnlyOneUniqueKey(..) 53 ) where 54 55-- Development Tip: See persistent-template/README.md for advice on seeing generated Template Haskell code 56-- It's highly recommended to check the diff between master and your PR's generated code. 57 58import Prelude hiding ((++), take, concat, splitAt, exp) 59 60import Data.Either 61import Control.Monad (forM, mzero, filterM, guard, unless) 62import Data.Aeson 63 ( ToJSON (toJSON), FromJSON (parseJSON), (.=), object 64 , Value (Object), (.:), (.:?) 65 , eitherDecodeStrict' 66 ) 67import qualified Data.ByteString as BS 68import Data.Char (toLower, toUpper) 69import qualified Data.HashMap.Strict as HM 70import Data.Int (Int64) 71import Data.List (foldl') 72import qualified Data.List as List 73import qualified Data.List.NonEmpty as NEL 74import qualified Data.Map as M 75import Data.Maybe (isJust, listToMaybe, mapMaybe, fromMaybe) 76import Data.Monoid ((<>), mappend, mconcat) 77import Data.Proxy (Proxy (Proxy)) 78import Data.Text (pack, Text, append, unpack, concat, uncons, cons, stripPrefix, stripSuffix) 79import qualified Data.Text as T 80import Data.Text.Encoding (decodeUtf8) 81import qualified Data.Text.Encoding as TE 82import GHC.Generics (Generic) 83import GHC.TypeLits 84import Instances.TH.Lift () 85 -- Bring `Lift (Map k v)` instance into scope, as well as `Lift Text` 86 -- instance on pre-1.2.4 versions of `text` 87import Language.Haskell.TH.Lib (conT, varE) 88import Language.Haskell.TH.Quote 89import Language.Haskell.TH.Syntax 90import Web.PathPieces (PathPiece(..)) 91import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..)) 92import qualified Data.Set as Set 93 94import Database.Persist 95import Database.Persist.Sql (Migration, PersistFieldSql, SqlBackend, migrate, sqlType) 96import Database.Persist.Quasi 97 98-- | This special-cases "type_" and strips out its underscore. When 99-- used for JSON serialization and deserialization, it works around 100-- <https://github.com/yesodweb/persistent/issues/412> 101unHaskellNameForJSON :: HaskellName -> Text 102unHaskellNameForJSON = fixTypeUnderscore . unHaskellName 103 where 104 fixTypeUnderscore = \case 105 "type" -> "type_" 106 name -> name 107 108-- | Converts a quasi-quoted syntax into a list of entity definitions, to be 109-- used as input to the template haskell generation code (mkPersist). 110persistWith :: PersistSettings -> QuasiQuoter 111persistWith ps = QuasiQuoter 112 { quoteExp = parseReferences ps . pack 113 } 114 115-- | Apply 'persistWith' to 'upperCaseSettings'. 116persistUpperCase :: QuasiQuoter 117persistUpperCase = persistWith upperCaseSettings 118 119-- | Apply 'persistWith' to 'lowerCaseSettings'. 120persistLowerCase :: QuasiQuoter 121persistLowerCase = persistWith lowerCaseSettings 122 123-- | Same as 'persistWith', but uses an external file instead of a 124-- quasiquotation. The recommended file extension is @.persistentmodels@. 125persistFileWith :: PersistSettings -> FilePath -> Q Exp 126persistFileWith ps fp = persistManyFileWith ps [fp] 127 128-- | Same as 'persistFileWith', but uses several external files instead of 129-- one. Splitting your Persistent definitions into multiple modules can 130-- potentially dramatically speed up compile times. 131-- 132-- The recommended file extension is @.persistentmodels@. 133-- 134-- ==== __Examples__ 135-- 136-- Split your Persistent definitions into multiple files (@models1@, @models2@), 137-- then create a new module for each new file and run 'mkPersist' there: 138-- 139-- @ 140-- -- Model1.hs 141-- 'share' 142-- ['mkPersist' 'sqlSettings'] 143-- $('persistFileWith' 'lowerCaseSettings' "models1") 144-- @ 145-- @ 146-- -- Model2.hs 147-- 'share' 148-- ['mkPersist' 'sqlSettings'] 149-- $('persistFileWith' 'lowerCaseSettings' "models2") 150-- @ 151-- 152-- Use 'persistManyFileWith' to create your migrations: 153-- 154-- @ 155-- -- Migrate.hs 156-- 'share' 157-- ['mkMigrate' "migrateAll"] 158-- $('persistManyFileWith' 'lowerCaseSettings' ["models1.persistentmodels","models2.persistentmodels"]) 159-- @ 160-- 161-- Tip: To get the same import behavior as if you were declaring all your models in 162-- one file, import your new files @as Name@ into another file, then export @module Name@. 163-- 164-- This approach may be used in the future to reduce memory usage during compilation, 165-- but so far we've only seen mild reductions. 166-- 167-- See <https://github.com/yesodweb/persistent/issues/778 persistent#778> and 168-- <https://github.com/yesodweb/persistent/pull/791 persistent#791> for more details. 169-- 170-- @since 2.5.4 171persistManyFileWith :: PersistSettings -> [FilePath] -> Q Exp 172persistManyFileWith ps fps = do 173 mapM_ qAddDependentFile fps 174 ss <- mapM (qRunIO . getFileContents) fps 175 let s = T.intercalate "\n" ss -- be tolerant of the user forgetting to put a line-break at EOF. 176 parseReferences ps s 177 178getFileContents :: FilePath -> IO Text 179getFileContents = fmap decodeUtf8 . BS.readFile 180 181-- | Takes a list of (potentially) independently defined entities and properly 182-- links all foreign keys to reference the right 'EntityDef', tying the knot 183-- between entities. 184-- 185-- Allows users to define entities indepedently or in separate modules and then 186-- fix the cross-references between them at runtime to create a 'Migration'. 187-- 188-- @since 2.7.2 189embedEntityDefs :: [EntityDef] -> [EntityDef] 190embedEntityDefs = snd . embedEntityDefsMap 191 192embedEntityDefsMap :: [EntityDef] -> (M.Map HaskellName EmbedEntityDef, [EntityDef]) 193embedEntityDefsMap rawEnts = (embedEntityMap, noCycleEnts) 194 where 195 noCycleEnts = map breakCycleEnt entsWithEmbeds 196 -- every EntityDef could reference each-other (as an EmbedRef) 197 -- let Haskell tie the knot 198 embedEntityMap = constructEmbedEntityMap entsWithEmbeds 199 entsWithEmbeds = map setEmbedEntity rawEnts 200 setEmbedEntity ent = ent 201 { entityFields = map (setEmbedField (entityHaskell ent) embedEntityMap) $ entityFields ent 202 } 203 204 -- self references are already broken 205 -- look at every emFieldEmbed to see if it refers to an already seen HaskellName 206 -- so start with entityHaskell ent and accumulate embeddedHaskell em 207 breakCycleEnt entDef = 208 let entName = entityHaskell entDef 209 in entDef { entityFields = map (breakCycleField entName) $ entityFields entDef } 210 211 breakCycleField entName f = case f of 212 FieldDef { fieldReference = EmbedRef em } -> 213 f { fieldReference = EmbedRef $ breakCycleEmbed [entName] em } 214 _ -> 215 f 216 217 breakCycleEmbed ancestors em = 218 em { embeddedFields = breakCycleEmField (emName : ancestors) <$> embeddedFields em 219 } 220 where 221 emName = embeddedHaskell em 222 223 breakCycleEmField ancestors emf = case embeddedHaskell <$> membed of 224 Nothing -> emf 225 Just embName -> if embName `elem` ancestors 226 then emf { emFieldEmbed = Nothing, emFieldCycle = Just embName } 227 else emf { emFieldEmbed = breakCycleEmbed ancestors <$> membed } 228 where 229 membed = emFieldEmbed emf 230 231-- calls parse to Quasi.parse individual entities in isolation 232-- afterwards, sets references to other entities 233-- | @since 2.5.3 234parseReferences :: PersistSettings -> Text -> Q Exp 235parseReferences ps s = lift $ 236 map (mkEntityDefSqlTypeExp embedEntityMap entityMap) noCycleEnts 237 where 238 (embedEntityMap, noCycleEnts) = embedEntityDefsMap $ parse ps s 239 entityMap = constructEntityMap noCycleEnts 240 241stripId :: FieldType -> Maybe Text 242stripId (FTTypeCon Nothing t) = stripSuffix "Id" t 243stripId _ = Nothing 244 245foreignReference :: FieldDef -> Maybe HaskellName 246foreignReference field = case fieldReference field of 247 ForeignRef ref _ -> Just ref 248 _ -> Nothing 249 250 251-- fieldSqlType at parse time can be an Exp 252-- This helps delay setting fieldSqlType until lift time 253data EntityDefSqlTypeExp 254 = EntityDefSqlTypeExp EntityDef SqlTypeExp [SqlTypeExp] 255 deriving Show 256 257data SqlTypeExp 258 = SqlTypeExp FieldType 259 | SqlType' SqlType 260 deriving Show 261 262instance Lift SqlTypeExp where 263 lift (SqlType' t) = lift t 264 lift (SqlTypeExp ftype) = return st 265 where 266 typ = ftToType ftype 267 mtyp = ConT ''Proxy `AppT` typ 268 typedNothing = SigE (ConE 'Proxy) mtyp 269 st = VarE 'sqlType `AppE` typedNothing 270 271data FieldsSqlTypeExp = FieldsSqlTypeExp [FieldDef] [SqlTypeExp] 272 273instance Lift FieldsSqlTypeExp where 274 lift (FieldsSqlTypeExp fields sqlTypeExps) = 275 lift $ zipWith FieldSqlTypeExp fields sqlTypeExps 276 277data FieldSqlTypeExp = FieldSqlTypeExp FieldDef SqlTypeExp 278 279instance Lift FieldSqlTypeExp where 280 lift (FieldSqlTypeExp FieldDef{..} sqlTypeExp) = 281 [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs fieldStrict fieldReference fieldComments|] 282 283instance Lift EntityDefSqlTypeExp where 284 lift (EntityDefSqlTypeExp ent sqlTypeExp sqlTypeExps) = 285 [|ent { entityFields = $(lift $ FieldsSqlTypeExp (entityFields ent) sqlTypeExps) 286 , entityId = $(lift $ FieldSqlTypeExp (entityId ent) sqlTypeExp) 287 } 288 |] 289 290instance Lift ReferenceDef where 291 lift NoReference = [|NoReference|] 292 lift (ForeignRef name ft) = [|ForeignRef name ft|] 293 lift (EmbedRef em) = [|EmbedRef em|] 294 lift (CompositeRef cdef) = [|CompositeRef cdef|] 295 lift SelfReference = [|SelfReference|] 296 297instance Lift EmbedEntityDef where 298 lift (EmbedEntityDef name fields) = [|EmbedEntityDef name fields|] 299 300instance Lift EmbedFieldDef where 301 lift (EmbedFieldDef name em cyc) = [|EmbedFieldDef name em cyc|] 302 303type EmbedEntityMap = M.Map HaskellName EmbedEntityDef 304 305constructEmbedEntityMap :: [EntityDef] -> EmbedEntityMap 306constructEmbedEntityMap = 307 M.fromList . fmap (\ent -> (entityHaskell ent, toEmbedEntityDef ent)) 308 309type EntityMap = M.Map HaskellName EntityDef 310 311constructEntityMap :: [EntityDef] -> EntityMap 312constructEntityMap = 313 M.fromList . fmap (\ent -> (entityHaskell ent, ent)) 314 315data FTTypeConDescr = FTKeyCon deriving Show 316 317mEmbedded :: EmbedEntityMap -> FieldType -> Either (Maybe FTTypeConDescr) EmbedEntityDef 318mEmbedded _ (FTTypeCon Just{} _) = Left Nothing 319mEmbedded ents (FTTypeCon Nothing n) = 320 let name = HaskellName n 321 in maybe (Left Nothing) Right $ M.lookup name ents 322mEmbedded ents (FTList x) = mEmbedded ents x 323mEmbedded ents (FTApp x y) = 324 -- Key converts an Record to a RecordId 325 -- special casing this is obviously a hack 326 -- This problem may not be solvable with the current QuasiQuoted approach though 327 if x == FTTypeCon Nothing "Key" 328 then Left $ Just FTKeyCon 329 else mEmbedded ents y 330 331setEmbedField :: HaskellName -> EmbedEntityMap -> FieldDef -> FieldDef 332setEmbedField entName allEntities field = field 333 { fieldReference = 334 case fieldReference field of 335 NoReference -> 336 case mEmbedded allEntities (fieldType field) of 337 Left _ -> 338 case stripId $ fieldType field of 339 Nothing -> NoReference 340 Just name -> 341 case M.lookup (HaskellName name) allEntities of 342 Nothing -> NoReference 343 Just _ -> ForeignRef (HaskellName name) 344 -- This can get corrected in mkEntityDefSqlTypeExp 345 (FTTypeCon (Just "Data.Int") "Int64") 346 Right em -> 347 if embeddedHaskell em /= entName 348 then EmbedRef em 349 else if maybeNullable field 350 then SelfReference 351 else case fieldType field of 352 FTList _ -> SelfReference 353 _ -> error $ unpack $ unHaskellName entName <> ": a self reference must be a Maybe" 354 existing -> existing 355 } 356 357mkEntityDefSqlTypeExp :: EmbedEntityMap -> EntityMap -> EntityDef -> EntityDefSqlTypeExp 358mkEntityDefSqlTypeExp emEntities entityMap ent = 359 EntityDefSqlTypeExp ent (getSqlType $ entityId ent) (map getSqlType $ entityFields ent) 360 where 361 getSqlType field = 362 maybe 363 (defaultSqlTypeExp field) 364 (SqlType' . SqlOther) 365 (listToMaybe $ mapMaybe (stripPrefix "sqltype=") $ fieldAttrs field) 366 367 -- In the case of embedding, there won't be any datatype created yet. 368 -- We just use SqlString, as the data will be serialized to JSON. 369 defaultSqlTypeExp field = 370 case mEmbedded emEntities ftype of 371 Right _ -> SqlType' SqlString 372 Left (Just FTKeyCon) -> SqlType' SqlString 373 Left Nothing -> case fieldReference field of 374 ForeignRef refName ft -> case M.lookup refName entityMap of 375 Nothing -> SqlTypeExp ft 376 -- A ForeignRef is blindly set to an Int64 in setEmbedField 377 -- correct that now 378 Just ent' -> case entityPrimary ent' of 379 Nothing -> SqlTypeExp ft 380 Just pdef -> case compositeFields pdef of 381 [] -> error "mkEntityDefSqlTypeExp: no composite fields" 382 [x] -> SqlTypeExp $ fieldType x 383 _ -> SqlType' $ SqlOther "Composite Reference" 384 CompositeRef _ -> SqlType' $ SqlOther "Composite Reference" 385 _ -> 386 case ftype of 387 -- In the case of lists, we always serialize to a string 388 -- value (via JSON). 389 -- 390 -- Normally, this would be determined automatically by 391 -- SqlTypeExp. However, there's one corner case: if there's 392 -- a list of entity IDs, the datatype for the ID has not 393 -- yet been created, so the compiler will fail. This extra 394 -- clause works around this limitation. 395 FTList _ -> SqlType' SqlString 396 _ -> SqlTypeExp ftype 397 where 398 ftype = fieldType field 399 400-- | Create data types and appropriate 'PersistEntity' instances for the given 401-- 'EntityDef's. Works well with the persist quasi-quoter. 402mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec] 403mkPersist mps ents' = do 404 requireExtensions [[TypeFamilies], [GADTs, ExistentialQuantification]] 405 x <- fmap Data.Monoid.mconcat $ mapM (persistFieldFromEntity mps) ents 406 y <- fmap mconcat $ mapM (mkEntity entityMap mps) ents 407 z <- fmap mconcat $ mapM (mkJSON mps) ents 408 uniqueKeyInstances <- fmap mconcat $ mapM (mkUniqueKeyInstances mps) ents 409 return $ mconcat [x, y, z, uniqueKeyInstances] 410 where 411 ents = map fixEntityDef ents' 412 entityMap = constructEntityMap ents 413 414-- | Implement special preprocessing on EntityDef as necessary for 'mkPersist'. 415-- For example, strip out any fields marked as MigrationOnly. 416fixEntityDef :: EntityDef -> EntityDef 417fixEntityDef ed = 418 ed { entityFields = filter keepField $ entityFields ed } 419 where 420 keepField fd = "MigrationOnly" `notElem` fieldAttrs fd && 421 "SafeToRemove" `notElem` fieldAttrs fd 422 423-- | Settings to be passed to the 'mkPersist' function. 424data MkPersistSettings = MkPersistSettings 425 { mpsBackend :: Type 426 -- ^ Which database backend we\'re using. 427 -- 428 -- When generating data types, each type is given a generic version- which 429 -- works with any backend- and a type synonym for the commonly used 430 -- backend. This is where you specify that commonly used backend. 431 , mpsGeneric :: Bool 432 -- ^ Create generic types that can be used with multiple backends. Good for 433 -- reusable code, but makes error messages harder to understand. Default: 434 -- False. 435 , mpsPrefixFields :: Bool 436 -- ^ Prefix field names with the model name. Default: True. 437 , mpsEntityJSON :: Maybe EntityJSON 438 -- ^ Generate @ToJSON@/@FromJSON@ instances for each model types. If it's 439 -- @Nothing@, no instances will be generated. Default: 440 -- 441 -- @ 442 -- Just EntityJSON 443 -- { entityToJSON = 'keyValueEntityToJSON 444 -- , entityFromJSON = 'keyValueEntityFromJSON 445 -- } 446 -- @ 447 , mpsGenerateLenses :: !Bool 448 -- ^ Instead of generating normal field accessors, generator lens-style accessors. 449 -- 450 -- Default: False 451 -- 452 -- @since 1.3.1 453 , mpsDeriveInstances :: ![Name] 454 -- ^ Automatically derive these typeclass instances for all record and key types. 455 -- 456 -- Default: [] 457 -- 458 -- @since 2.8.1 459 } 460 461data EntityJSON = EntityJSON 462 { entityToJSON :: Name 463 -- ^ Name of the @toJSON@ implementation for @Entity a@. 464 , entityFromJSON :: Name 465 -- ^ Name of the @fromJSON@ implementation for @Entity a@. 466 } 467 468-- | Create an @MkPersistSettings@ with default values. 469mkPersistSettings 470 :: Type -- ^ Value for 'mpsBackend' 471 -> MkPersistSettings 472mkPersistSettings t = MkPersistSettings 473 { mpsBackend = t 474 , mpsGeneric = False 475 , mpsPrefixFields = True 476 , mpsEntityJSON = Just EntityJSON 477 { entityToJSON = 'entityIdToJSON 478 , entityFromJSON = 'entityIdFromJSON 479 } 480 , mpsGenerateLenses = False 481 , mpsDeriveInstances = [] 482 } 483 484-- | Use the 'SqlPersist' backend. 485sqlSettings :: MkPersistSettings 486sqlSettings = mkPersistSettings $ ConT ''SqlBackend 487 488recNameNoUnderscore :: MkPersistSettings -> HaskellName -> HaskellName -> Text 489recNameNoUnderscore mps dt f 490 | mpsPrefixFields mps = lowerFirst (unHaskellName dt) ++ upperFirst ft 491 | otherwise = lowerFirst ft 492 where 493 ft = unHaskellName f 494 495recName :: MkPersistSettings -> HaskellName -> HaskellName -> Text 496recName mps dt f = 497 addUnderscore $ recNameNoUnderscore mps dt f 498 where 499 addUnderscore 500 | mpsGenerateLenses mps = ("_" ++) 501 | otherwise = id 502 503lowerFirst :: Text -> Text 504lowerFirst t = 505 case uncons t of 506 Just (a, b) -> cons (toLower a) b 507 Nothing -> t 508 509upperFirst :: Text -> Text 510upperFirst t = 511 case uncons t of 512 Just (a, b) -> cons (toUpper a) b 513 Nothing -> t 514 515dataTypeDec :: MkPersistSettings -> EntityDef -> Q Dec 516dataTypeDec mps t = do 517 let entityInstances = map (mkName . unpack) $ entityDerives t 518 additionalInstances = filter (`notElem` entityInstances) $ mpsDeriveInstances mps 519 names = entityInstances <> additionalInstances 520 521 let (stocks, anyclasses) = partitionEithers (map stratFor names) 522 let stockDerives = do 523 guard (not (null stocks)) 524 pure (DerivClause (Just StockStrategy) (map ConT stocks)) 525 anyclassDerives = do 526 guard (not (null anyclasses)) 527 pure (DerivClause (Just AnyclassStrategy) (map ConT anyclasses)) 528 unless (null anyclassDerives) $ do 529 requireExtensions [[DeriveAnyClass]] 530 pure $ DataD [] nameFinal paramsFinal 531 Nothing 532 constrs 533 (stockDerives <> anyclassDerives) 534 where 535 stratFor n = 536 if n `elem` stockClasses then 537 Left n 538 else 539 Right n 540 541 stockClasses = Set.fromList . map mkName $ 542 [ "Eq", "Ord", "Show", "Read", "Bounded", "Enum", "Ix", "Generic", "Data", "Typeable" 543 ] 544 mkCol x fd@FieldDef {..} = 545 (mkName $ unpack $ recName mps x fieldHaskell, 546 if fieldStrict then isStrict else notStrict, 547 maybeIdType mps fd Nothing Nothing 548 ) 549 (nameFinal, paramsFinal) 550 | mpsGeneric mps = (nameG, [PlainTV backend]) 551 | otherwise = (name, []) 552 nameG = mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Generic" 553 name = mkName $ unpack $ unHaskellName $ entityHaskell t 554 cols = map (mkCol $ entityHaskell t) $ entityFields t 555 backend = backendName 556 557 constrs 558 | entitySum t = map sumCon $ entityFields t 559 | otherwise = [RecC name cols] 560 561 sumCon fd = NormalC 562 (sumConstrName mps t fd) 563 [(notStrict, maybeIdType mps fd Nothing Nothing)] 564 565sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name 566sumConstrName mps t FieldDef {..} = mkName $ unpack $ concat 567 [ if mpsPrefixFields mps 568 then unHaskellName $ entityHaskell t 569 else "" 570 , upperFirst $ unHaskellName fieldHaskell 571 , "Sum" 572 ] 573 574uniqueTypeDec :: MkPersistSettings -> EntityDef -> Dec 575uniqueTypeDec mps t = 576#if MIN_VERSION_template_haskell(2,15,0) 577 DataInstD [] Nothing 578 (AppT (ConT ''Unique) (genericDataType mps (entityHaskell t) backendT)) 579 Nothing 580 (map (mkUnique mps t) $ entityUniques t) 581 (derivClause $ entityUniques t) 582#else 583 DataInstD [] ''Unique 584 [genericDataType mps (entityHaskell t) backendT] 585 Nothing 586 (map (mkUnique mps t) $ entityUniques t) 587 (derivClause $ entityUniques t) 588#endif 589 where 590 derivClause [] = [] 591 derivClause _ = [DerivClause Nothing [ConT ''Show]] 592 593mkUnique :: MkPersistSettings -> EntityDef -> UniqueDef -> Con 594mkUnique mps t (UniqueDef (HaskellName constr) _ fields attrs) = 595 NormalC (mkName $ unpack constr) types 596 where 597 types = 598 map (go . flip lookup3 (entityFields t) . unHaskellName . fst) fields 599 600 force = "!force" `elem` attrs 601 602 go :: (FieldDef, IsNullable) -> (Strict, Type) 603 go (_, Nullable _) | not force = error nullErrMsg 604 go (fd, y) = (notStrict, maybeIdType mps fd Nothing (Just y)) 605 606 lookup3 :: Text -> [FieldDef] -> (FieldDef, IsNullable) 607 lookup3 s [] = 608 error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ constr 609 lookup3 x (fd@FieldDef {..}:rest) 610 | x == unHaskellName fieldHaskell = (fd, nullable fieldAttrs) 611 | otherwise = lookup3 x rest 612 613 nullErrMsg = 614 mconcat [ "Error: By default we disallow NULLables in an uniqueness " 615 , "constraint. The semantics of how NULL interacts with those " 616 , "constraints is non-trivial: two NULL values are not " 617 , "considered equal for the purposes of an uniqueness " 618 , "constraint. If you understand this feature, it is possible " 619 , "to use it your advantage. *** Use a \"!force\" attribute " 620 , "on the end of the line that defines your uniqueness " 621 , "constraint in order to disable this check. ***" ] 622 623maybeIdType :: MkPersistSettings 624 -> FieldDef 625 -> Maybe Name -- ^ backend 626 -> Maybe IsNullable 627 -> Type 628maybeIdType mps fd mbackend mnull = maybeTyp mayNullable idtyp 629 where 630 mayNullable = case mnull of 631 (Just (Nullable ByMaybeAttr)) -> True 632 _ -> maybeNullable fd 633 idtyp = idType mps fd mbackend 634 635backendDataType :: MkPersistSettings -> Type 636backendDataType mps 637 | mpsGeneric mps = backendT 638 | otherwise = mpsBackend mps 639 640genericDataType :: MkPersistSettings 641 -> HaskellName -- ^ entity name 642 -> Type -- ^ backend 643 -> Type 644genericDataType mps (HaskellName typ') backend 645 | mpsGeneric mps = ConT (mkName $ unpack $ typ' ++ "Generic") `AppT` backend 646 | otherwise = ConT $ mkName $ unpack typ' 647 648idType :: MkPersistSettings -> FieldDef -> Maybe Name -> Type 649idType mps fd mbackend = 650 case foreignReference fd of 651 Just typ -> 652 ConT ''Key 653 `AppT` genericDataType mps typ (VarT $ fromMaybe backendName mbackend) 654 Nothing -> ftToType $ fieldType fd 655 656degen :: [Clause] -> [Clause] 657degen [] = 658 let err = VarE 'error `AppE` LitE (StringL 659 "Degenerate case, should never happen") 660 in [normalClause [WildP] err] 661degen x = x 662 663mkToPersistFields :: MkPersistSettings -> String -> EntityDef -> Q Dec 664mkToPersistFields mps constr ed@EntityDef { entitySum = isSum, entityFields = fields } = do 665 clauses <- 666 if isSum 667 then sequence $ zipWith goSum fields [1..] 668 else fmap return go 669 return $ FunD 'toPersistFields clauses 670 where 671 go :: Q Clause 672 go = do 673 xs <- sequence $ replicate fieldCount $ newName "x" 674 let pat = ConP (mkName constr) $ map VarP xs 675 sp <- [|SomePersistField|] 676 let bod = ListE $ map (AppE sp . VarE) xs 677 return $ normalClause [pat] bod 678 679 fieldCount = length fields 680 681 goSum :: FieldDef -> Int -> Q Clause 682 goSum fd idx = do 683 let name = sumConstrName mps ed fd 684 enull <- [|SomePersistField PersistNull|] 685 let beforeCount = idx - 1 686 afterCount = fieldCount - idx 687 before = replicate beforeCount enull 688 after = replicate afterCount enull 689 x <- newName "x" 690 sp <- [|SomePersistField|] 691 let body = ListE $ mconcat 692 [ before 693 , [sp `AppE` VarE x] 694 , after 695 ] 696 return $ normalClause [ConP name [VarP x]] body 697 698 699mkToFieldNames :: [UniqueDef] -> Q Dec 700mkToFieldNames pairs = do 701 pairs' <- mapM go pairs 702 return $ FunD 'persistUniqueToFieldNames $ degen pairs' 703 where 704 go (UniqueDef constr _ names _) = do 705 names' <- lift names 706 return $ 707 normalClause 708 [RecP (mkName $ unpack $ unHaskellName constr) []] 709 names' 710 711mkUniqueToValues :: [UniqueDef] -> Q Dec 712mkUniqueToValues pairs = do 713 pairs' <- mapM go pairs 714 return $ FunD 'persistUniqueToValues $ degen pairs' 715 where 716 go :: UniqueDef -> Q Clause 717 go (UniqueDef constr _ names _) = do 718 xs <- mapM (const $ newName "x") names 719 let pat = ConP (mkName $ unpack $ unHaskellName constr) $ map VarP xs 720 tpv <- [|toPersistValue|] 721 let bod = ListE $ map (AppE tpv . VarE) xs 722 return $ normalClause [pat] bod 723 724isNotNull :: PersistValue -> Bool 725isNotNull PersistNull = False 726isNotNull _ = True 727 728mapLeft :: (a -> c) -> Either a b -> Either c b 729mapLeft _ (Right r) = Right r 730mapLeft f (Left l) = Left (f l) 731 732mkFromPersistValues :: MkPersistSettings -> EntityDef -> Q [Clause] 733mkFromPersistValues _ t@(EntityDef { entitySum = False }) = 734 fromValues t "fromPersistValues" entE $ entityFields t 735 where 736 entE = ConE $ mkName $ unpack entName 737 entName = unHaskellName $ entityHaskell t 738 739mkFromPersistValues mps t@(EntityDef { entitySum = True }) = do 740 nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|] 741 clauses <- mkClauses [] $ entityFields t 742 return $ clauses `mappend` [normalClause [WildP] nothing] 743 where 744 entName = unHaskellName $ entityHaskell t 745 mkClauses _ [] = return [] 746 mkClauses before (field:after) = do 747 x <- newName "x" 748 let null' = ConP 'PersistNull [] 749 pat = ListP $ mconcat 750 [ map (const null') before 751 , [VarP x] 752 , map (const null') after 753 ] 754 constr = ConE $ sumConstrName mps t field 755 fs <- [|fromPersistValue $(return $ VarE x)|] 756 let guard' = NormalG $ VarE 'isNotNull `AppE` VarE x 757 let clause = Clause [pat] (GuardedB [(guard', InfixE (Just constr) fmapE (Just fs))]) [] 758 clauses <- mkClauses (field : before) after 759 return $ clause : clauses 760 761type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t 762 763lensPTH :: (s -> a) -> (s -> b -> t) -> Lens s t a b 764lensPTH sa sbt afb s = fmap (sbt s) (afb $ sa s) 765 766fmapE :: Exp 767fmapE = VarE 'fmap 768 769mkLensClauses :: MkPersistSettings -> EntityDef -> Q [Clause] 770mkLensClauses mps t = do 771 lens' <- [|lensPTH|] 772 getId <- [|entityKey|] 773 setId <- [|\(Entity _ value) key -> Entity key value|] 774 getVal <- [|entityVal|] 775 dot <- [|(.)|] 776 keyVar <- newName "key" 777 valName <- newName "value" 778 xName <- newName "x" 779 let idClause = normalClause 780 [ConP (keyIdName t) []] 781 (lens' `AppE` getId `AppE` setId) 782 if entitySum t 783 then return $ idClause : map (toSumClause lens' keyVar valName xName) (entityFields t) 784 else return $ idClause : map (toClause lens' getVal dot keyVar valName xName) (entityFields t) 785 where 786 toClause lens' getVal dot keyVar valName xName f = normalClause 787 [ConP (filterConName mps t f) []] 788 (lens' `AppE` getter `AppE` setter) 789 where 790 fieldName = mkName $ unpack $ recName mps (entityHaskell t) (fieldHaskell f) 791 getter = InfixE (Just $ VarE fieldName) dot (Just getVal) 792 setter = LamE 793 [ ConP 'Entity [VarP keyVar, VarP valName] 794 , VarP xName 795 ] 796 $ ConE 'Entity `AppE` VarE keyVar `AppE` RecUpdE 797 (VarE valName) 798 [(fieldName, VarE xName)] 799 800 toSumClause lens' keyVar valName xName f = normalClause 801 [ConP (filterConName mps t f) []] 802 (lens' `AppE` getter `AppE` setter) 803 where 804 emptyMatch = Match WildP (NormalB $ VarE 'error `AppE` LitE (StringL "Tried to use fieldLens on a Sum type")) [] 805 getter = LamE 806 [ ConP 'Entity [WildP, VarP valName] 807 ] $ CaseE (VarE valName) 808 $ Match (ConP (sumConstrName mps t f) [VarP xName]) (NormalB $ VarE xName) [] 809 810 -- FIXME It would be nice if the types expressed that the Field is 811 -- a sum type and therefore could result in Maybe. 812 : if length (entityFields t) > 1 then [emptyMatch] else [] 813 setter = LamE 814 [ ConP 'Entity [VarP keyVar, WildP] 815 , VarP xName 816 ] 817 $ ConE 'Entity `AppE` VarE keyVar `AppE` (ConE (sumConstrName mps t f) `AppE` VarE xName) 818 819-- | declare the key type and associated instances 820-- @'PathPiece'@, @'ToHttpApiData'@ and @'FromHttpApiData'@ instances are only generated for a Key with one field 821mkKeyTypeDec :: MkPersistSettings -> EntityDef -> Q (Dec, [Dec]) 822mkKeyTypeDec mps t = do 823 (instDecs, i) <- 824 if mpsGeneric mps 825 then if not useNewtype 826 then do pfDec <- pfInstD 827 return (pfDec, supplement [''Generic]) 828 else do gi <- genericNewtypeInstances 829 return (gi, supplement []) 830 else if not useNewtype 831 then do pfDec <- pfInstD 832 return (pfDec, supplement [''Show, ''Read, ''Eq, ''Ord, ''Generic]) 833 else do 834 let allInstances = supplement [''Show, ''Read, ''Eq, ''Ord, ''PathPiece, ''ToHttpApiData, ''FromHttpApiData, ''PersistField, ''PersistFieldSql, ''ToJSON, ''FromJSON] 835 if customKeyType 836 then return ([], allInstances) 837 else do 838 bi <- backendKeyI 839 return (bi, allInstances) 840 841 requirePersistentExtensions 842 843#if MIN_VERSION_template_haskell(2,15,0) 844 cxti <- mapM conT i 845 let kd = if useNewtype 846 then NewtypeInstD [] Nothing (AppT (ConT k) recordType) Nothing dec [DerivClause (Just NewtypeStrategy) cxti] 847 else DataInstD [] Nothing (AppT (ConT k) recordType) Nothing [dec] [DerivClause (Just StockStrategy) cxti] 848#else 849 cxti <- mapM conT i 850 let kd = if useNewtype 851 then NewtypeInstD [] k [recordType] Nothing dec [DerivClause (Just NewtypeStrategy) cxti] 852 else DataInstD [] k [recordType] Nothing [dec] [DerivClause (Just StockStrategy) cxti] 853#endif 854 return (kd, instDecs) 855 where 856 keyConE = keyConExp t 857 unKeyE = unKeyExp t 858 dec = RecC (keyConName t) (keyFields mps t) 859 k = ''Key 860 recordType = genericDataType mps (entityHaskell t) backendT 861 pfInstD = -- FIXME: generate a PersistMap instead of PersistList 862 [d|instance PersistField (Key $(pure recordType)) where 863 toPersistValue = PersistList . keyToValues 864 fromPersistValue (PersistList l) = keyFromValues l 865 fromPersistValue got = error $ "fromPersistValue: expected PersistList, got: " `mappend` show got 866 instance PersistFieldSql (Key $(pure recordType)) where 867 sqlType _ = SqlString 868 instance ToJSON (Key $(pure recordType)) 869 instance FromJSON (Key $(pure recordType)) 870 |] 871 872 backendKeyGenericI = 873 [d| instance PersistStore $(pure backendT) => 874 ToBackendKey $(pure backendT) $(pure recordType) where 875 toBackendKey = $(return unKeyE) 876 fromBackendKey = $(return keyConE) 877 |] 878 backendKeyI = let bdt = backendDataType mps in 879 [d| instance ToBackendKey $(pure bdt) $(pure recordType) where 880 toBackendKey = $(return unKeyE) 881 fromBackendKey = $(return keyConE) 882 |] 883 884 genericNewtypeInstances = do 885 requirePersistentExtensions 886 887 instances <- do 888 alwaysInstances <- 889 [d|deriving newtype instance Show (BackendKey $(pure backendT)) => Show (Key $(pure recordType)) 890 deriving newtype instance Read (BackendKey $(pure backendT)) => Read (Key $(pure recordType)) 891 deriving newtype instance Eq (BackendKey $(pure backendT)) => Eq (Key $(pure recordType)) 892 deriving newtype instance Ord (BackendKey $(pure backendT)) => Ord (Key $(pure recordType)) 893 deriving newtype instance ToHttpApiData (BackendKey $(pure backendT)) => ToHttpApiData (Key $(pure recordType)) 894 deriving newtype instance FromHttpApiData (BackendKey $(pure backendT)) => FromHttpApiData(Key $(pure recordType)) 895 deriving newtype instance PathPiece (BackendKey $(pure backendT)) => PathPiece (Key $(pure recordType)) 896 deriving newtype instance PersistField (BackendKey $(pure backendT)) => PersistField (Key $(pure recordType)) 897 deriving newtype instance PersistFieldSql (BackendKey $(pure backendT)) => PersistFieldSql (Key $(pure recordType)) 898 deriving newtype instance ToJSON (BackendKey $(pure backendT)) => ToJSON (Key $(pure recordType)) 899 deriving newtype instance FromJSON (BackendKey $(pure backendT)) => FromJSON (Key $(pure recordType)) 900 |] 901 902 if customKeyType then return alwaysInstances 903 else fmap (alwaysInstances `mappend`) backendKeyGenericI 904 return instances 905 906 useNewtype = pkNewtype mps t 907 customKeyType = not (defaultIdType t) || not useNewtype || isJust (entityPrimary t) 908 909 supplement :: [Name] -> [Name] 910 supplement names = names <> (filter (`notElem` names) $ mpsDeriveInstances mps) 911 912keyIdName :: EntityDef -> Name 913keyIdName = mkName . unpack . keyIdText 914 915keyIdText :: EntityDef -> Text 916keyIdText t = unHaskellName (entityHaskell t) `mappend` "Id" 917 918unKeyName :: EntityDef -> Name 919unKeyName t = mkName $ "un" `mappend` keyString t 920 921unKeyExp :: EntityDef -> Exp 922unKeyExp = VarE . unKeyName 923 924backendT :: Type 925backendT = VarT backendName 926 927backendName :: Name 928backendName = mkName "backend" 929 930keyConName :: EntityDef -> Name 931keyConName t = mkName $ resolveConflict $ keyString t 932 where 933 resolveConflict kn = if conflict then kn `mappend` "'" else kn 934 conflict = any ((== HaskellName "key") . fieldHaskell) $ entityFields t 935 936keyConExp :: EntityDef -> Exp 937keyConExp = ConE . keyConName 938 939keyString :: EntityDef -> String 940keyString = unpack . keyText 941 942keyText :: EntityDef -> Text 943keyText t = unHaskellName (entityHaskell t) ++ "Key" 944 945pkNewtype :: MkPersistSettings -> EntityDef -> Bool 946pkNewtype mps t = length (keyFields mps t) < 2 947 948defaultIdType :: EntityDef -> Bool 949defaultIdType t = fieldType (entityId t) == FTTypeCon Nothing (keyIdText t) 950 951keyFields :: MkPersistSettings -> EntityDef -> [(Name, Strict, Type)] 952keyFields mps t = case entityPrimary t of 953 Just pdef -> map primaryKeyVar (compositeFields pdef) 954 Nothing -> if defaultIdType t 955 then [idKeyVar backendKeyType] 956 else [idKeyVar $ ftToType $ fieldType $ entityId t] 957 where 958 backendKeyType 959 | mpsGeneric mps = ConT ''BackendKey `AppT` backendT 960 | otherwise = ConT ''BackendKey `AppT` mpsBackend mps 961 idKeyVar ft = (unKeyName t, notStrict, ft) 962 primaryKeyVar fd = ( keyFieldName mps t fd 963 , notStrict 964 , ftToType $ fieldType fd 965 ) 966 967keyFieldName :: MkPersistSettings -> EntityDef -> FieldDef -> Name 968keyFieldName mps t fd 969 | pkNewtype mps t = unKeyName t 970 | otherwise = mkName $ unpack $ lowerFirst (keyText t) `mappend` unHaskellName (fieldHaskell fd) 971 972mkKeyToValues :: MkPersistSettings -> EntityDef -> Q Dec 973mkKeyToValues mps t = do 974 (p, e) <- case entityPrimary t of 975 Nothing -> 976 ([],) <$> [|(:[]) . toPersistValue . $(return $ unKeyExp t)|] 977 Just pdef -> 978 return $ toValuesPrimary pdef 979 return $ FunD 'keyToValues $ return $ normalClause p e 980 where 981 toValuesPrimary pdef = 982 ( [VarP recordName] 983 , ListE $ map (\fd -> VarE 'toPersistValue `AppE` (VarE (keyFieldName mps t fd) `AppE` VarE recordName)) $ compositeFields pdef 984 ) 985 recordName = mkName "record" 986 987normalClause :: [Pat] -> Exp -> Clause 988normalClause p e = Clause p (NormalB e) [] 989 990mkKeyFromValues :: MkPersistSettings -> EntityDef -> Q Dec 991mkKeyFromValues _mps t = do 992 clauses <- case entityPrimary t of 993 Nothing -> do 994 e <- [|fmap $(return keyConE) . fromPersistValue . headNote|] 995 return [normalClause [] e] 996 Just pdef -> 997 fromValues t "keyFromValues" keyConE (compositeFields pdef) 998 return $ FunD 'keyFromValues clauses 999 where 1000 keyConE = keyConExp t 1001 1002headNote :: [PersistValue] -> PersistValue 1003headNote = \case 1004 [x] -> x 1005 xs -> error $ "mkKeyFromValues: expected a list of one element, got: " `mappend` show xs 1006 1007fromValues :: EntityDef -> Text -> Exp -> [FieldDef] -> Q [Clause] 1008fromValues t funName conE fields = do 1009 x <- newName "x" 1010 let funMsg = entityText t `mappend` ": " `mappend` funName `mappend` " failed on: " 1011 patternMatchFailure <- [|Left $ mappend funMsg (pack $ show $(return $ VarE x))|] 1012 suc <- patternSuccess 1013 return [ suc, normalClause [VarP x] patternMatchFailure ] 1014 where 1015 tableName = unDBName (entityDB t) 1016 patternSuccess = 1017 case fields of 1018 [] -> do 1019 rightE <- [|Right|] 1020 return $ normalClause [ListP []] (rightE `AppE` conE) 1021 _ -> do 1022 x1 <- newName "x1" 1023 restNames <- mapM (\i -> newName $ "x" `mappend` show i) [2..length fields] 1024 (fpv1:mkPersistValues) <- mapM mkPersistValue fields 1025 app1E <- [|(<$>)|] 1026 let conApp = infixFromPersistValue app1E fpv1 conE x1 1027 applyE <- [|(<*>)|] 1028 let applyFromPersistValue = infixFromPersistValue applyE 1029 1030 return $ normalClause 1031 [ListP $ map VarP (x1:restNames)] 1032 (foldl' (\exp (name, fpv) -> applyFromPersistValue fpv exp name) conApp (zip restNames mkPersistValues)) 1033 1034 infixFromPersistValue applyE fpv exp name = 1035 UInfixE exp applyE (fpv `AppE` VarE name) 1036 1037 mkPersistValue field = 1038 let fieldName = (unHaskellName (fieldHaskell field)) 1039 in [|mapLeft (fieldError tableName fieldName) . fromPersistValue|] 1040 1041-- | Render an error message based on the @tableName@ and @fieldName@ with 1042-- the provided message. 1043-- 1044-- @since 2.8.2 1045fieldError :: Text -> Text -> Text -> Text 1046fieldError tableName fieldName err = mconcat 1047 [ "Couldn't parse field `" 1048 , fieldName 1049 , "` from table `" 1050 , tableName 1051 , "`. " 1052 , err 1053 ] 1054 1055mkEntity :: EntityMap -> MkPersistSettings -> EntityDef -> Q [Dec] 1056mkEntity entityMap mps t = do 1057 t' <- liftAndFixKeys entityMap t 1058 let nameT = unHaskellName entName 1059 let nameS = unpack nameT 1060 let clazz = ConT ''PersistEntity `AppT` genDataType 1061 tpf <- mkToPersistFields mps nameS t 1062 fpv <- mkFromPersistValues mps t 1063 utv <- mkUniqueToValues $ entityUniques t 1064 puk <- mkUniqueKeys t 1065 fkc <- mapM (mkForeignKeysComposite mps t) $ entityForeigns t 1066 1067 let primaryField = entityId t 1068 1069 fields <- mapM (mkField mps t) $ primaryField : entityFields t 1070 toFieldNames <- mkToFieldNames $ entityUniques t 1071 1072 (keyTypeDec, keyInstanceDecs) <- mkKeyTypeDec mps t 1073 keyToValues' <- mkKeyToValues mps t 1074 keyFromValues' <- mkKeyFromValues mps t 1075 1076 let addSyn -- FIXME maybe remove this 1077 | mpsGeneric mps = (:) $ 1078 TySynD (mkName nameS) [] $ 1079 genericDataType mps entName $ mpsBackend mps 1080 | otherwise = id 1081 1082 lensClauses <- mkLensClauses mps t 1083 1084 lenses <- mkLenses mps t 1085 let instanceConstraint = if not (mpsGeneric mps) then [] else 1086 [mkClassP ''PersistStore [backendT]] 1087 1088 dtd <- dataTypeDec mps t 1089 return $ addSyn $ 1090 dtd : mconcat fkc `mappend` 1091 ([ TySynD (keyIdName t) [] $ 1092 ConT ''Key `AppT` ConT (mkName nameS) 1093 , instanceD instanceConstraint clazz 1094 [ uniqueTypeDec mps t 1095 , keyTypeDec 1096 , keyToValues' 1097 , keyFromValues' 1098 , FunD 'entityDef [normalClause [WildP] t'] 1099 , tpf 1100 , FunD 'fromPersistValues fpv 1101 , toFieldNames 1102 , utv 1103 , puk 1104#if MIN_VERSION_template_haskell(2,15,0) 1105 , DataInstD 1106 [] 1107 Nothing 1108 (AppT (AppT (ConT ''EntityField) genDataType) (VarT $ mkName "typ")) 1109 Nothing 1110 (map fst fields) 1111 [] 1112#else 1113 , DataInstD 1114 [] 1115 ''EntityField 1116 [ genDataType 1117 , VarT $ mkName "typ" 1118 ] 1119 Nothing 1120 (map fst fields) 1121 [] 1122#endif 1123 , FunD 'persistFieldDef (map snd fields) 1124#if MIN_VERSION_template_haskell(2,15,0) 1125 , TySynInstD 1126 (TySynEqn 1127 Nothing 1128 (AppT (ConT ''PersistEntityBackend) genDataType) 1129 (backendDataType mps)) 1130#else 1131 , TySynInstD 1132 ''PersistEntityBackend 1133 (TySynEqn 1134 [genDataType] 1135 (backendDataType mps)) 1136#endif 1137 , FunD 'persistIdField [normalClause [] (ConE $ keyIdName t)] 1138 , FunD 'fieldLens lensClauses 1139 ] 1140 ] `mappend` lenses) `mappend` keyInstanceDecs 1141 where 1142 genDataType = genericDataType mps entName backendT 1143 entName = entityHaskell t 1144 1145mkUniqueKeyInstances :: MkPersistSettings -> EntityDef -> Q [Dec] 1146mkUniqueKeyInstances mps t = do 1147 requirePersistentExtensions 1148 case entityUniques t of 1149 [] -> mappend <$> typeErrorSingle <*> typeErrorAtLeastOne 1150 [_] -> mappend <$> singleUniqueKey <*> atLeastOneKey 1151 (_:_) -> mappend <$> typeErrorMultiple <*> atLeastOneKey 1152 where 1153 requireUniquesPName = 'requireUniquesP 1154 onlyUniquePName = 'onlyUniqueP 1155 typeErrorSingle = mkOnlyUniqueError typeErrorNoneCtx 1156 typeErrorMultiple = mkOnlyUniqueError typeErrorMultipleCtx 1157 1158 withPersistStoreWriteCxt = 1159 if mpsGeneric mps 1160 then do 1161 write <- [t|PersistStoreWrite $(pure (VarT $ mkName "backend")) |] 1162 pure [write] 1163 else do 1164 pure [] 1165 1166 typeErrorNoneCtx = do 1167 tyErr <- [t|TypeError (NoUniqueKeysError $(pure genDataType))|] 1168 (tyErr :) <$> withPersistStoreWriteCxt 1169 1170 typeErrorMultipleCtx = do 1171 tyErr <- [t|TypeError (MultipleUniqueKeysError $(pure genDataType))|] 1172 (tyErr :) <$> withPersistStoreWriteCxt 1173 1174 mkOnlyUniqueError :: Q Cxt -> Q [Dec] 1175 mkOnlyUniqueError mkCtx = do 1176 ctx <- mkCtx 1177 let impl = mkImpossible onlyUniquePName 1178 pure [instanceD ctx onlyOneUniqueKeyClass impl] 1179 1180 mkImpossible name = 1181 [ FunD name 1182 [ Clause 1183 [ WildP ] 1184 (NormalB 1185 (VarE 'error `AppE` LitE (StringL "impossible")) 1186 ) 1187 [] 1188 ] 1189 ] 1190 1191 typeErrorAtLeastOne :: Q [Dec] 1192 typeErrorAtLeastOne = do 1193 let impl = mkImpossible requireUniquesPName 1194 cxt <- typeErrorMultipleCtx 1195 pure [instanceD cxt atLeastOneUniqueKeyClass impl] 1196 1197 singleUniqueKey :: Q [Dec] 1198 singleUniqueKey = do 1199 expr <- [e| head . persistUniqueKeys|] 1200 let impl = [FunD onlyUniquePName [Clause [] (NormalB expr) []]] 1201 cxt <- withPersistStoreWriteCxt 1202 pure [instanceD cxt onlyOneUniqueKeyClass impl] 1203 1204 atLeastOneUniqueKeyClass = ConT ''AtLeastOneUniqueKey `AppT` genDataType 1205 onlyOneUniqueKeyClass = ConT ''OnlyOneUniqueKey `AppT` genDataType 1206 1207 atLeastOneKey :: Q [Dec] 1208 atLeastOneKey = do 1209 expr <- [e| NEL.fromList . persistUniqueKeys|] 1210 let impl = [FunD requireUniquesPName [Clause [] (NormalB expr) []]] 1211 cxt <- withPersistStoreWriteCxt 1212 pure [instanceD cxt atLeastOneUniqueKeyClass impl] 1213 1214 genDataType = genericDataType mps (entityHaskell t) backendT 1215 1216 1217entityText :: EntityDef -> Text 1218entityText = unHaskellName . entityHaskell 1219 1220mkLenses :: MkPersistSettings -> EntityDef -> Q [Dec] 1221mkLenses mps _ | not (mpsGenerateLenses mps) = return [] 1222mkLenses _ ent | entitySum ent = return [] 1223mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do 1224 let lensName' = recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field) 1225 lensName = mkName $ unpack lensName' 1226 fieldName = mkName $ unpack $ "_" ++ lensName' 1227 needleN <- newName "needle" 1228 setterN <- newName "setter" 1229 fN <- newName "f" 1230 aN <- newName "a" 1231 yN <- newName "y" 1232 let needle = VarE needleN 1233 setter = VarE setterN 1234 f = VarE fN 1235 a = VarE aN 1236 y = VarE yN 1237 fT = mkName "f" 1238 -- FIXME if we want to get really fancy, then: if this field is the 1239 -- *only* Id field present, then set backend1 and backend2 to different 1240 -- values 1241 backend1 = backendName 1242 backend2 = backendName 1243 aT = maybeIdType mps field (Just backend1) Nothing 1244 bT = maybeIdType mps field (Just backend2) Nothing 1245 mkST backend = genericDataType mps (entityHaskell ent) (VarT backend) 1246 sT = mkST backend1 1247 tT = mkST backend2 1248 t1 `arrow` t2 = ArrowT `AppT` t1 `AppT` t2 1249 vars = PlainTV fT 1250 : (if mpsGeneric mps then [PlainTV backend1{-, PlainTV backend2-}] else []) 1251 return 1252 [ SigD lensName $ ForallT vars [mkClassP ''Functor [VarT fT]] $ 1253 (aT `arrow` (VarT fT `AppT` bT)) `arrow` 1254 (sT `arrow` (VarT fT `AppT` tT)) 1255 , FunD lensName $ return $ Clause 1256 [VarP fN, VarP aN] 1257 (NormalB $ fmapE 1258 `AppE` setter 1259 `AppE` (f `AppE` needle)) 1260 [ FunD needleN [normalClause [] (VarE fieldName `AppE` a)] 1261 , FunD setterN $ return $ normalClause 1262 [VarP yN] 1263 (RecUpdE a 1264 [ (fieldName, y) 1265 ]) 1266 ] 1267 ] 1268 1269mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec] 1270mkForeignKeysComposite mps t ForeignDef {..} = do 1271 let fieldName f = mkName $ unpack $ recName mps (entityHaskell t) f 1272 let fname = fieldName foreignConstraintNameHaskell 1273 let reftableString = unpack $ unHaskellName foreignRefTableHaskell 1274 let reftableKeyName = mkName $ reftableString `mappend` "Key" 1275 let tablename = mkName $ unpack $ entityText t 1276 recordName <- newName "record" 1277 1278 let fldsE = map (\((foreignName, _),_) -> VarE (fieldName foreignName) 1279 `AppE` VarE recordName) foreignFields 1280 let mkKeyE = foldl' AppE (maybeExp foreignNullable $ ConE reftableKeyName) fldsE 1281 let fn = FunD fname [normalClause [VarP recordName] mkKeyE] 1282 1283 let t2 = maybeTyp foreignNullable $ ConT ''Key `AppT` ConT (mkName reftableString) 1284 let sig = SigD fname $ (ArrowT `AppT` (ConT tablename)) `AppT` t2 1285 return [sig, fn] 1286 1287maybeExp :: Bool -> Exp -> Exp 1288maybeExp may exp | may = fmapE `AppE` exp 1289 | otherwise = exp 1290maybeTyp :: Bool -> Type -> Type 1291maybeTyp may typ | may = ConT ''Maybe `AppT` typ 1292 | otherwise = typ 1293 1294 1295 1296entityToPersistValueHelper :: (PersistEntity record) => record -> PersistValue 1297entityToPersistValueHelper entity = PersistMap $ zip columnNames fieldsAsPersistValues 1298 where 1299 columnNames = map (unHaskellName . fieldHaskell) (entityFields (entityDef (Just entity))) 1300 fieldsAsPersistValues = map toPersistValue $ toPersistFields entity 1301 1302entityFromPersistValueHelper :: (PersistEntity record) 1303 => [String] -- ^ Column names, as '[String]' to avoid extra calls to "pack" in the generated code 1304 -> PersistValue 1305 -> Either Text record 1306entityFromPersistValueHelper columnNames pv = do 1307 (persistMap :: [(T.Text, PersistValue)]) <- getPersistMap pv 1308 1309 let columnMap = HM.fromList persistMap 1310 lookupPersistValueByColumnName :: String -> PersistValue 1311 lookupPersistValueByColumnName columnName = 1312 fromMaybe PersistNull (HM.lookup (pack columnName) columnMap) 1313 1314 fromPersistValues $ map lookupPersistValueByColumnName columnNames 1315 1316-- | Produce code similar to the following: 1317-- 1318-- @ 1319-- instance PersistEntity e => PersistField e where 1320-- toPersistValue = entityToPersistValueHelper 1321-- fromPersistValue = entityFromPersistValueHelper ["col1", "col2"] 1322-- sqlType _ = SqlString 1323-- @ 1324persistFieldFromEntity :: MkPersistSettings -> EntityDef -> Q [Dec] 1325persistFieldFromEntity mps entDef = do 1326 sqlStringConstructor' <- [|SqlString|] 1327 toPersistValueImplementation <- [|entityToPersistValueHelper|] 1328 fromPersistValueImplementation <- [|entityFromPersistValueHelper columnNames|] 1329 1330 return 1331 [ persistFieldInstanceD (mpsGeneric mps) typ 1332 [ FunD 'toPersistValue [ normalClause [] toPersistValueImplementation ] 1333 , FunD 'fromPersistValue 1334 [ normalClause [] fromPersistValueImplementation ] 1335 ] 1336 , persistFieldSqlInstanceD (mpsGeneric mps) typ 1337 [ sqlTypeFunD sqlStringConstructor' 1338 ] 1339 ] 1340 where 1341 typ = genericDataType mps (entityHaskell entDef) backendT 1342 entFields = entityFields entDef 1343 columnNames = map (unpack . unHaskellName . fieldHaskell) entFields 1344 1345-- | Apply the given list of functions to the same @EntityDef@s. 1346-- 1347-- This function is useful for cases such as: 1348-- 1349-- >>> share [mkSave "myDefs", mkPersist sqlSettings] [persistLowerCase|...|] 1350share :: [[EntityDef] -> Q [Dec]] -> [EntityDef] -> Q [Dec] 1351share fs x = mconcat <$> mapM ($ x) fs 1352 1353-- | Save the @EntityDef@s passed in under the given name. 1354mkSave :: String -> [EntityDef] -> Q [Dec] 1355mkSave name' defs' = do 1356 let name = mkName name' 1357 defs <- lift defs' 1358 return [ SigD name $ ListT `AppT` ConT ''EntityDef 1359 , FunD name [normalClause [] defs] 1360 ] 1361 1362data Dep = Dep 1363 { depTarget :: HaskellName 1364 , depSourceTable :: HaskellName 1365 , depSourceField :: HaskellName 1366 , depSourceNull :: IsNullable 1367 } 1368 1369-- | Generate a 'DeleteCascade' instance for the given @EntityDef@s. 1370mkDeleteCascade :: MkPersistSettings -> [EntityDef] -> Q [Dec] 1371mkDeleteCascade mps defs = do 1372 let deps = concatMap getDeps defs 1373 mapM (go deps) defs 1374 where 1375 getDeps :: EntityDef -> [Dep] 1376 getDeps def = 1377 concatMap getDeps' $ entityFields $ fixEntityDef def 1378 where 1379 getDeps' :: FieldDef -> [Dep] 1380 getDeps' field@FieldDef {..} = 1381 case foreignReference field of 1382 Just name -> 1383 return Dep 1384 { depTarget = name 1385 , depSourceTable = entityHaskell def 1386 , depSourceField = fieldHaskell 1387 , depSourceNull = nullable fieldAttrs 1388 } 1389 Nothing -> [] 1390 go :: [Dep] -> EntityDef -> Q Dec 1391 go allDeps EntityDef{entityHaskell = name} = do 1392 let deps = filter (\x -> depTarget x == name) allDeps 1393 key <- newName "key" 1394 let del = VarE 'delete 1395 let dcw = VarE 'deleteCascadeWhere 1396 just <- [|Just|] 1397 filt <- [|Filter|] 1398 eq <- [|Eq|] 1399 value <- [|FilterValue|] 1400 let mkStmt :: Dep -> Stmt 1401 mkStmt dep = NoBindS 1402 $ dcw `AppE` 1403 ListE 1404 [ filt `AppE` ConE filtName 1405 `AppE` (value `AppE` val (depSourceNull dep)) 1406 `AppE` eq 1407 ] 1408 where 1409 filtName = filterConName' mps (depSourceTable dep) (depSourceField dep) 1410 val (Nullable ByMaybeAttr) = just `AppE` VarE key 1411 val _ = VarE key 1412 1413 1414 1415 let stmts :: [Stmt] 1416 stmts = map mkStmt deps `mappend` 1417 [NoBindS $ del `AppE` VarE key] 1418 1419 let entityT = genericDataType mps name backendT 1420 1421 return $ 1422 instanceD 1423 [ mkClassP ''PersistQuery [backendT] 1424 , mkEqualP (ConT ''PersistEntityBackend `AppT` entityT) (ConT ''BaseBackend `AppT` backendT) 1425 ] 1426 (ConT ''DeleteCascade `AppT` entityT `AppT` backendT) 1427 [ FunD 'deleteCascade 1428 [normalClause [VarP key] (DoE stmts)] 1429 ] 1430 1431-- | Creates a declaration for the @['EntityDef']@ from the @persistent@ 1432-- schema. This is necessary because the Persistent QuasiQuoter is unable 1433-- to know the correct type of ID fields, and assumes that they are all 1434-- Int64. 1435-- 1436-- Provide this in the list you give to 'share', much like @'mkMigrate'@. 1437-- 1438-- @ 1439-- 'share' ['mkMigrate' "migrateAll", 'mkEntityDefList' "entityDefs"] [...] 1440-- @ 1441-- 1442-- @since 2.7.1 1443mkEntityDefList 1444 :: String 1445 -- ^ The name that will be given to the 'EntityDef' list. 1446 -> [EntityDef] 1447 -> Q [Dec] 1448mkEntityDefList entityList entityDefs = do 1449 let entityListName = mkName entityList 1450 edefs <- fmap ListE 1451 . forM entityDefs 1452 $ \(EntityDef { entityHaskell = HaskellName haskellName }) -> 1453 let entityType = conT (mkName (T.unpack haskellName)) 1454 in [|entityDef (Proxy :: Proxy $(entityType))|] 1455 typ <- [t|[EntityDef]|] 1456 pure 1457 [ SigD entityListName typ 1458 , ValD (VarP entityListName) (NormalB edefs) [] 1459 ] 1460 1461mkUniqueKeys :: EntityDef -> Q Dec 1462mkUniqueKeys def | entitySum def = 1463 return $ FunD 'persistUniqueKeys [normalClause [WildP] (ListE [])] 1464mkUniqueKeys def = do 1465 c <- clause 1466 return $ FunD 'persistUniqueKeys [c] 1467 where 1468 clause = do 1469 xs <- forM (entityFields def) $ \fd -> do 1470 let x = fieldHaskell fd 1471 x' <- newName $ '_' : unpack (unHaskellName x) 1472 return (x, x') 1473 let pcs = map (go xs) $ entityUniques def 1474 let pat = ConP 1475 (mkName $ unpack $ unHaskellName $ entityHaskell def) 1476 (map (VarP . snd) xs) 1477 return $ normalClause [pat] (ListE pcs) 1478 1479 go :: [(HaskellName, Name)] -> UniqueDef -> Exp 1480 go xs (UniqueDef name _ cols _) = 1481 foldl' (go' xs) (ConE (mkName $ unpack $ unHaskellName name)) (map fst cols) 1482 1483 go' :: [(HaskellName, Name)] -> Exp -> HaskellName -> Exp 1484 go' xs front col = 1485 let Just col' = lookup col xs 1486 in front `AppE` VarE col' 1487 1488sqlTypeFunD :: Exp -> Dec 1489sqlTypeFunD st = FunD 'sqlType 1490 [ normalClause [WildP] st ] 1491 1492typeInstanceD :: Name 1493 -> Bool -- ^ include PersistStore backend constraint 1494 -> Type -> [Dec] -> Dec 1495typeInstanceD clazz hasBackend typ = 1496 instanceD ctx (ConT clazz `AppT` typ) 1497 where 1498 ctx 1499 | hasBackend = [mkClassP ''PersistStore [backendT]] 1500 | otherwise = [] 1501 1502persistFieldInstanceD :: Bool -- ^ include PersistStore backend constraint 1503 -> Type -> [Dec] -> Dec 1504persistFieldInstanceD = typeInstanceD ''PersistField 1505 1506persistFieldSqlInstanceD :: Bool -- ^ include PersistStore backend constraint 1507 -> Type -> [Dec] -> Dec 1508persistFieldSqlInstanceD = typeInstanceD ''PersistFieldSql 1509 1510-- | Automatically creates a valid 'PersistField' instance for any datatype 1511-- that has valid 'Show' and 'Read' instances. Can be very convenient for 1512-- 'Enum' types. 1513derivePersistField :: String -> Q [Dec] 1514derivePersistField s = do 1515 ss <- [|SqlString|] 1516 tpv <- [|PersistText . pack . show|] 1517 fpv <- [|\dt v -> 1518 case fromPersistValue v of 1519 Left e -> Left e 1520 Right s' -> 1521 case reads $ unpack s' of 1522 (x, _):_ -> Right x 1523 [] -> Left $ pack "Invalid " ++ pack dt ++ pack ": " ++ s'|] 1524 return 1525 [ persistFieldInstanceD False (ConT $ mkName s) 1526 [ FunD 'toPersistValue 1527 [ normalClause [] tpv 1528 ] 1529 , FunD 'fromPersistValue 1530 [ normalClause [] (fpv `AppE` LitE (StringL s)) 1531 ] 1532 ] 1533 , persistFieldSqlInstanceD False (ConT $ mkName s) 1534 [ sqlTypeFunD ss 1535 ] 1536 ] 1537 1538-- | Automatically creates a valid 'PersistField' instance for any datatype 1539-- that has valid 'ToJSON' and 'FromJSON' instances. For a datatype @T@ it 1540-- generates instances similar to these: 1541-- 1542-- @ 1543-- instance PersistField T where 1544-- toPersistValue = PersistByteString . L.toStrict . encode 1545-- fromPersistValue = (left T.pack) . eitherDecodeStrict' <=< fromPersistValue 1546-- instance PersistFieldSql T where 1547-- sqlType _ = SqlString 1548-- @ 1549derivePersistFieldJSON :: String -> Q [Dec] 1550derivePersistFieldJSON s = do 1551 ss <- [|SqlString|] 1552 tpv <- [|PersistText . toJsonText|] 1553 fpv <- [|\dt v -> do 1554 text <- fromPersistValue v 1555 let bs' = TE.encodeUtf8 text 1556 case eitherDecodeStrict' bs' of 1557 Left e -> Left $ pack "JSON decoding error for " ++ pack dt ++ pack ": " ++ pack e ++ pack ". On Input: " ++ decodeUtf8 bs' 1558 Right x -> Right x|] 1559 return 1560 [ persistFieldInstanceD False (ConT $ mkName s) 1561 [ FunD 'toPersistValue 1562 [ normalClause [] tpv 1563 ] 1564 , FunD 'fromPersistValue 1565 [ normalClause [] (fpv `AppE` LitE (StringL s)) 1566 ] 1567 ] 1568 , persistFieldSqlInstanceD False (ConT $ mkName s) 1569 [ sqlTypeFunD ss 1570 ] 1571 ] 1572 1573-- | Creates a single function to perform all migrations for the entities 1574-- defined here. One thing to be aware of is dependencies: if you have entities 1575-- with foreign references, make sure to place those definitions after the 1576-- entities they reference. 1577mkMigrate :: String -> [EntityDef] -> Q [Dec] 1578mkMigrate fun allDefs = do 1579 body' <- body 1580 return 1581 [ SigD (mkName fun) typ 1582 , FunD (mkName fun) [normalClause [] body'] 1583 ] 1584 where 1585 defs = filter isMigrated allDefs 1586 isMigrated def = "no-migrate" `notElem` entityAttrs def 1587 typ = ConT ''Migration 1588 entityMap = constructEntityMap allDefs 1589 body :: Q Exp 1590 body = 1591 case defs of 1592 [] -> [|return ()|] 1593 _ -> do 1594 defsName <- newName "defs" 1595 defsStmt <- do 1596 defs' <- mapM (liftAndFixKeys entityMap) defs 1597 let defsExp = ListE defs' 1598 return $ LetS [ValD (VarP defsName) (NormalB defsExp) []] 1599 stmts <- mapM (toStmt $ VarE defsName) defs 1600 return (DoE $ defsStmt : stmts) 1601 toStmt :: Exp -> EntityDef -> Q Stmt 1602 toStmt defsExp ed = do 1603 u <- liftAndFixKeys entityMap ed 1604 m <- [|migrate|] 1605 return $ NoBindS $ m `AppE` defsExp `AppE` u 1606 1607liftAndFixKeys :: EntityMap -> EntityDef -> Q Exp 1608liftAndFixKeys entityMap EntityDef{..} = 1609 [|EntityDef 1610 entityHaskell 1611 entityDB 1612 entityId 1613 entityAttrs 1614 $(ListE <$> mapM (liftAndFixKey entityMap) entityFields) 1615 entityUniques 1616 entityForeigns 1617 entityDerives 1618 entityExtra 1619 entitySum 1620 entityComments 1621 |] 1622 1623liftAndFixKey :: EntityMap -> FieldDef -> Q Exp 1624liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef mcomments) = 1625 [|FieldDef a b c $(sqlTyp') e f fieldRef' mcomments|] 1626 where 1627 (fieldRef', sqlTyp') = fromMaybe (fieldRef, lift sqlTyp) $ 1628 case fieldRef of 1629 ForeignRef refName _ft -> case M.lookup refName entityMap of 1630 Nothing -> Nothing 1631 Just ent -> 1632 case fieldReference $ entityId ent of 1633 fr@(ForeignRef _Name ft) -> Just (fr, lift $ SqlTypeExp ft) 1634 _ -> Nothing 1635 _ -> Nothing 1636 1637instance Lift EntityDef where 1638 lift EntityDef{..} = 1639 [|EntityDef 1640 entityHaskell 1641 entityDB 1642 entityId 1643 entityAttrs 1644 entityFields 1645 entityUniques 1646 entityForeigns 1647 entityDerives 1648 entityExtra 1649 entitySum 1650 entityComments 1651 |] 1652 1653instance Lift FieldDef where 1654 lift (FieldDef a b c d e f g h) = [|FieldDef a b c d e f g h|] 1655 1656instance Lift UniqueDef where 1657 lift (UniqueDef a b c d) = [|UniqueDef a b c d|] 1658 1659instance Lift CompositeDef where 1660 lift (CompositeDef a b) = [|CompositeDef a b|] 1661 1662instance Lift ForeignDef where 1663 lift (ForeignDef a b c d e f g) = [|ForeignDef a b c d e f g|] 1664 1665instance Lift HaskellName where 1666 lift (HaskellName t) = [|HaskellName t|] 1667instance Lift DBName where 1668 lift (DBName t) = [|DBName t|] 1669instance Lift FieldType where 1670 lift (FTTypeCon Nothing t) = [|FTTypeCon Nothing t|] 1671 lift (FTTypeCon (Just x) t) = [|FTTypeCon (Just x) t|] 1672 lift (FTApp x y) = [|FTApp x y|] 1673 lift (FTList x) = [|FTList x|] 1674 1675instance Lift PersistFilter where 1676 lift Eq = [|Eq|] 1677 lift Ne = [|Ne|] 1678 lift Gt = [|Gt|] 1679 lift Lt = [|Lt|] 1680 lift Ge = [|Ge|] 1681 lift Le = [|Le|] 1682 lift In = [|In|] 1683 lift NotIn = [|NotIn|] 1684 lift (BackendSpecificFilter x) = [|BackendSpecificFilter x|] 1685 1686instance Lift PersistUpdate where 1687 lift Assign = [|Assign|] 1688 lift Add = [|Add|] 1689 lift Subtract = [|Subtract|] 1690 lift Multiply = [|Multiply|] 1691 lift Divide = [|Divide|] 1692 lift (BackendSpecificUpdate x) = [|BackendSpecificUpdate x|] 1693 1694instance Lift SqlType where 1695 lift SqlString = [|SqlString|] 1696 lift SqlInt32 = [|SqlInt32|] 1697 lift SqlInt64 = [|SqlInt64|] 1698 lift SqlReal = [|SqlReal|] 1699 lift (SqlNumeric x y) = 1700 [|SqlNumeric (fromInteger x') (fromInteger y')|] 1701 where 1702 x' = fromIntegral x :: Integer 1703 y' = fromIntegral y :: Integer 1704 lift SqlBool = [|SqlBool|] 1705 lift SqlDay = [|SqlDay|] 1706 lift SqlTime = [|SqlTime|] 1707 lift SqlDayTime = [|SqlDayTime|] 1708 lift SqlBlob = [|SqlBlob|] 1709 lift (SqlOther a) = [|SqlOther a|] 1710 1711-- Ent 1712-- fieldName FieldType 1713-- 1714-- forall . typ ~ FieldType => EntFieldName 1715-- 1716-- EntFieldName = FieldDef .... 1717mkField :: MkPersistSettings -> EntityDef -> FieldDef -> Q (Con, Clause) 1718mkField mps et cd = do 1719 let con = ForallC 1720 [] 1721 [mkEqualP (VarT $ mkName "typ") $ maybeIdType mps cd Nothing Nothing] 1722 $ NormalC name [] 1723 bod <- lift cd 1724 let cla = normalClause 1725 [ConP name []] 1726 bod 1727 return (con, cla) 1728 where 1729 name = filterConName mps et cd 1730 1731maybeNullable :: FieldDef -> Bool 1732maybeNullable fd = nullable (fieldAttrs fd) == Nullable ByMaybeAttr 1733 1734filterConName :: MkPersistSettings 1735 -> EntityDef 1736 -> FieldDef 1737 -> Name 1738filterConName mps entity field = filterConName' mps (entityHaskell entity) (fieldHaskell field) 1739 1740filterConName' :: MkPersistSettings 1741 -> HaskellName -- ^ table 1742 -> HaskellName -- ^ field 1743 -> Name 1744filterConName' mps entity field = mkName $ unpack $ concat 1745 [ if mpsPrefixFields mps || field == HaskellName "Id" 1746 then unHaskellName entity 1747 else "" 1748 , upperFirst $ unHaskellName field 1749 ] 1750 1751ftToType :: FieldType -> Type 1752ftToType (FTTypeCon Nothing t) = ConT $ mkName $ unpack t 1753-- This type is generated from the Quasi-Quoter. 1754-- Adding this special case avoids users needing to import Data.Int 1755ftToType (FTTypeCon (Just "Data.Int") "Int64") = ConT ''Int64 1756ftToType (FTTypeCon (Just m) t) = ConT $ mkName $ unpack $ concat [m, ".", t] 1757ftToType (FTApp x y) = ftToType x `AppT` ftToType y 1758ftToType (FTList x) = ListT `AppT` ftToType x 1759 1760infixr 5 ++ 1761(++) :: Text -> Text -> Text 1762(++) = append 1763 1764mkJSON :: MkPersistSettings -> EntityDef -> Q [Dec] 1765mkJSON _ def | ("json" `notElem` entityAttrs def) = return [] 1766mkJSON mps def = do 1767 requireExtensions [[FlexibleInstances]] 1768 pureE <- [|pure|] 1769 apE' <- [|(<*>)|] 1770 packE <- [|pack|] 1771 dotEqualE <- [|(.=)|] 1772 dotColonE <- [|(.:)|] 1773 dotColonQE <- [|(.:?)|] 1774 objectE <- [|object|] 1775 obj <- newName "obj" 1776 mzeroE <- [|mzero|] 1777 1778 xs <- mapM (newName . unpack . unHaskellNameForJSON . fieldHaskell) 1779 $ entityFields def 1780 1781 let conName = mkName $ unpack $ unHaskellName $ entityHaskell def 1782 typ = genericDataType mps (entityHaskell def) backendT 1783 toJSONI = typeInstanceD ''ToJSON (mpsGeneric mps) typ [toJSON'] 1784 toJSON' = FunD 'toJSON $ return $ normalClause 1785 [ConP conName $ map VarP xs] 1786 (objectE `AppE` ListE pairs) 1787 pairs = zipWith toPair (entityFields def) xs 1788 toPair f x = InfixE 1789 (Just (packE `AppE` LitE (StringL $ unpack $ unHaskellName $ fieldHaskell f))) 1790 dotEqualE 1791 (Just $ VarE x) 1792 fromJSONI = typeInstanceD ''FromJSON (mpsGeneric mps) typ [parseJSON'] 1793 parseJSON' = FunD 'parseJSON 1794 [ normalClause [ConP 'Object [VarP obj]] 1795 (foldl' 1796 (\x y -> InfixE (Just x) apE' (Just y)) 1797 (pureE `AppE` ConE conName) 1798 pulls 1799 ) 1800 , normalClause [WildP] mzeroE 1801 ] 1802 pulls = map toPull $ entityFields def 1803 toPull f = InfixE 1804 (Just $ VarE obj) 1805 (if maybeNullable f then dotColonQE else dotColonE) 1806 (Just $ AppE packE $ LitE $ StringL $ unpack $ unHaskellName $ fieldHaskell f) 1807 case mpsEntityJSON mps of 1808 Nothing -> return [toJSONI, fromJSONI] 1809 Just entityJSON -> do 1810 entityJSONIs <- if mpsGeneric mps 1811 then [d| 1812 instance PersistStore $(pure backendT) => ToJSON (Entity $(pure typ)) where 1813 toJSON = $(varE (entityToJSON entityJSON)) 1814 instance PersistStore $(pure backendT) => FromJSON (Entity $(pure typ)) where 1815 parseJSON = $(varE (entityFromJSON entityJSON)) 1816 |] 1817 else [d| 1818 instance ToJSON (Entity $(pure typ)) where 1819 toJSON = $(varE (entityToJSON entityJSON)) 1820 instance FromJSON (Entity $(pure typ)) where 1821 parseJSON = $(varE (entityFromJSON entityJSON)) 1822 |] 1823 return $ toJSONI : fromJSONI : entityJSONIs 1824 1825mkClassP :: Name -> [Type] -> Pred 1826mkClassP cla tys = foldl AppT (ConT cla) tys 1827 1828mkEqualP :: Type -> Type -> Pred 1829mkEqualP tleft tright = foldl AppT EqualityT [tleft, tright] 1830 1831notStrict :: Bang 1832notStrict = Bang NoSourceUnpackedness NoSourceStrictness 1833 1834isStrict :: Bang 1835isStrict = Bang NoSourceUnpackedness SourceStrict 1836 1837instanceD :: Cxt -> Type -> [Dec] -> Dec 1838instanceD = InstanceD Nothing 1839 1840-- entityUpdates :: EntityDef -> [(HaskellName, FieldType, IsNullable, PersistUpdate)] 1841-- entityUpdates = 1842-- concatMap go . entityFields 1843-- where 1844-- go FieldDef {..} = map (\a -> (fieldHaskell, fieldType, nullable fieldAttrs, a)) [minBound..maxBound] 1845 1846-- mkToUpdate :: String -> [(String, PersistUpdate)] -> Q Dec 1847-- mkToUpdate name pairs = do 1848-- pairs' <- mapM go pairs 1849-- return $ FunD (mkName name) $ degen pairs' 1850-- where 1851-- go (constr, pu) = do 1852-- pu' <- lift pu 1853-- return $ normalClause [RecP (mkName constr) []] pu' 1854 1855 1856-- mkToFieldName :: String -> [(String, String)] -> Dec 1857-- mkToFieldName func pairs = 1858-- FunD (mkName func) $ degen $ map go pairs 1859-- where 1860-- go (constr, name) = 1861-- normalClause [RecP (mkName constr) []] (LitE $ StringL name) 1862 1863-- mkToValue :: String -> [String] -> Dec 1864-- mkToValue func = FunD (mkName func) . degen . map go 1865-- where 1866-- go constr = 1867-- let x = mkName "x" 1868-- in normalClause [ConP (mkName constr) [VarP x]] 1869-- (VarE 'toPersistValue `AppE` VarE x) 1870 1871-- | Check that all of Persistent's required extensions are enabled, or else fail compilation 1872-- 1873-- This function should be called before any code that depends on one of the required extensions being enabled. 1874requirePersistentExtensions :: Q () 1875requirePersistentExtensions = requireExtensions requiredExtensions 1876 where 1877 requiredExtensions = map pure 1878 [ DerivingStrategies 1879 , GeneralizedNewtypeDeriving 1880 , StandaloneDeriving 1881 , UndecidableInstances 1882 ] 1883 1884-- | Pass in a list of lists of extensions, where any of the given 1885-- extensions will satisfy it. For example, you might need either GADTs or 1886-- ExistentialQuantification, so you'd write: 1887-- 1888-- > requireExtensions [[GADTs, ExistentialQuantification]] 1889-- 1890-- But if you need TypeFamilies and MultiParamTypeClasses, then you'd 1891-- write: 1892-- 1893-- > requireExtensions [[TypeFamilies], [MultiParamTypeClasses]] 1894requireExtensions :: [[Extension]] -> Q () 1895requireExtensions requiredExtensions = do 1896 -- isExtEnabled breaks the persistent-template benchmark with the following error: 1897 -- Template Haskell error: Can't do `isExtEnabled' in the IO monad 1898 -- You can workaround this by replacing isExtEnabled with (pure . const True) 1899 unenabledExtensions <- filterM (fmap (not . or) . traverse isExtEnabled) requiredExtensions 1900 1901 case mapMaybe listToMaybe unenabledExtensions of 1902 [] -> pure () 1903 [extension] -> fail $ mconcat 1904 [ "Generating Persistent entities now requires the " 1905 , show extension 1906 , " language extension. Please enable it by copy/pasting this line to the top of your file:\n\n" 1907 , extensionToPragma extension 1908 ] 1909 extensions -> fail $ mconcat 1910 [ "Generating Persistent entities now requires the following language extensions:\n\n" 1911 , List.intercalate "\n" (map show extensions) 1912 , "\n\nPlease enable the extensions by copy/pasting these lines into the top of your file:\n\n" 1913 , List.intercalate "\n" (map extensionToPragma extensions) 1914 ] 1915 1916 where 1917 extensionToPragma ext = "{-# LANGUAGE " <> show ext <> " #-}" 1918