persistent 2.12.1.0 → 2.12.1.1
raw patch · 7 files changed
+350/−322 lines, 7 files
Files
- ChangeLog.md +10/−1
- Database/Persist/Class/PersistUnique.hs +31/−28
- Database/Persist/Quasi.hs +29/−57
- Database/Persist/TH.hs +195/−141
- persistent.cabal +1/−1
- test/Database/Persist/TH/OverloadedLabelSpec.hs +6/−0
- test/main.hs +78/−94
ChangeLog.md view
@@ -1,8 +1,17 @@ # Changelog for persistent +## 2.12.1.1++* [#1231](https://github.com/yesodweb/persistent/pull/1231)+ * Simplify Line type in Quasi module, always use NonEmpty+* [#1229](https://github.com/yesodweb/persistent/pull/1229)+ * The `#id` labels are now generated for entities.+ ## 2.12.1.0 -* [#1226](https://github.com/yesodweb/persistent/pull/1226)+* [#1218](https://github.com/yesodweb/persistent/pull/1218)+ * Refactoring name generating functions in TH+* [#1226](https://github.com/yesodweb/persistent/pull/1226) * Expose the `filterClause` and `filterClauseWithValues` functions to support the `upsertWhere` functionality in `persistent-postgresql`.
Database/Persist/Class/PersistUnique.hs view
@@ -3,42 +3,42 @@ {-# LANGUAGE TypeOperators #-} module Database.Persist.Class.PersistUnique- ( PersistUniqueRead(..)- , PersistUniqueWrite(..)- , OnlyOneUniqueKey(..)- , onlyOneUniqueDef- , AtLeastOneUniqueKey(..)- , atLeastOneUniqueDef- , NoUniqueKeysError- , MultipleUniqueKeysError- , getByValue- , getByValueUniques- , insertBy- , insertUniqueEntity- , replaceUnique- , checkUnique- , checkUniqueUpdateable- , onlyUnique- , defaultUpsertBy- , defaultPutMany- , persistUniqueKeyValues- )- where+ ( PersistUniqueRead(..)+ , PersistUniqueWrite(..)+ , OnlyOneUniqueKey(..)+ , onlyOneUniqueDef+ , AtLeastOneUniqueKey(..)+ , atLeastOneUniqueDef+ , NoUniqueKeysError+ , MultipleUniqueKeysError+ , getByValue+ , getByValueUniques+ , insertBy+ , insertUniqueEntity+ , replaceUnique+ , checkUnique+ , checkUniqueUpdateable+ , onlyUnique+ , defaultUpsertBy+ , defaultPutMany+ , persistUniqueKeyValues+ )+ where import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Reader (ReaderT) import Data.Function (on)-import Data.List ((\\), deleteFirstsBy)+import Data.List (deleteFirstsBy, (\\)) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map import Data.Maybe (catMaybes) import GHC.TypeLits (ErrorMessage(..)) -import Database.Persist.Types-import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistEntity+import Database.Persist.Class.PersistStore+import Database.Persist.Types -- | Queries against 'Unique' keys (other than the id 'Key'). --@@ -419,10 +419,13 @@ -- > +----+-------+-----+ insertUniqueEntity- :: forall record backend m. (MonadIO m- ,PersistRecordBackend record backend- ,PersistUniqueWrite backend)- => record -> ReaderT backend m (Maybe (Entity record))+ :: forall record backend m+ . ( MonadIO m+ , PersistRecordBackend record backend+ , PersistUniqueWrite backend+ )+ => record+ -> ReaderT backend m (Maybe (Entity record)) insertUniqueEntity datum = fmap (\key -> Entity key datum) `liftM` insertUnique datum
Database/Persist/Quasi.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-}@@ -421,12 +421,11 @@ , nullable #if TEST , Token (..)- , Line' (..)+ , Line (..) , preparse , parseLine , parseFieldType , associateLines- , skipEmpty , LinesWithComments(..) , splitExtras , takeColsEx@@ -435,15 +434,15 @@ import Prelude hiding (lines) -import Control.Applicative ( Alternative((<|>)) )+import Control.Applicative (Alternative((<|>))) import Control.Arrow ((&&&))-import Control.Monad (msum, mplus)-import Data.Char ( isLower, isSpace, isUpper, toLower )+import Control.Monad (mplus, msum)+import Data.Char (isLower, isSpace, isUpper, toLower) import Data.List (find, foldl')-import qualified Data.List.NonEmpty as NEL import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M-import Data.Maybe (mapMaybe, fromMaybe, maybeToList, listToMaybe)+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe, maybeToList) import Data.Monoid (mappend) #if !MIN_VERSION_base(4,11,0) -- This can be removed when GHC < 8.2.2 isn't supported anymore@@ -543,16 +542,9 @@ 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+parseLine txt = do+ Line (parseIndentationAmount txt) <$> NEL.nonEmpty (tokenize txt) -- | A token used by the parser. data Token = Token Text -- ^ @Token tok@ is token @tok@ already unquoted.@@ -622,46 +614,28 @@ let (x, y) = T.break (`elem` ['\\','(',')']) t' in parens count y (front . (x:)) --- | A line. We don't care about spaces in the middle of the--- line. Also, we don't care about the amount of indentation.-data Line' f- = Line+-- | A line of parsed tokens+data Line = Line { lineIndent :: Int- , tokens :: f Token- }--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)--traverseLine :: Functor t => (forall x. f x -> t (g x)) -> Line' f -> t (Line' g)-traverseLine k (Line i xs) = Line i <$> k xs+ , tokens :: NonEmpty Token+ } deriving (Eq, Show) -lineText :: Functor f => Line' f -> f Text+lineText :: Line -> NonEmpty Text lineText = fmap tokenText . tokens -type Line = Line' []--lowestIndent- :: Functor f- => Foldable f- => Functor g- => f (Line' g)- -> Int+lowestIndent :: NonEmpty Line -> Int lowestIndent = minimum . fmap lineIndent -- | Divide lines into blocks and make entity definitions. parseLines :: PersistSettings -> NonEmpty Line -> [EntityDef] parseLines ps =- fixForeignKeysAll . map mk . associateLines . skipEmpty+ fixForeignKeysAll . map mk . associateLines where mk :: LinesWithComments -> UnboundEntityDef mk lwc = let ln :| rest = lwcLines lwc (name :| entAttribs) = lineText ln- in setComments (lwcComments lwc) $ mkEntityDef ps name entAttribs (map (mapLine NEL.toList) rest)+ in setComments (lwcComments lwc) $ mkEntityDef ps name entAttribs rest isDocComment :: Token -> Maybe Text isDocComment tok =@@ -670,7 +644,7 @@ _ -> Nothing data LinesWithComments = LinesWithComments- { lwcLines :: NonEmpty (Line' NonEmpty)+ { lwcLines :: NonEmpty Line , lwcComments :: [Text] } deriving (Eq, Show) @@ -680,24 +654,24 @@ appendLwc a b = LinesWithComments (foldr NEL.cons (lwcLines b) (lwcLines a)) (lwcComments a `mappend` lwcComments b) -newLine :: Line' NonEmpty -> LinesWithComments+newLine :: Line -> LinesWithComments newLine l = LinesWithComments (pure l) [] -firstLine :: LinesWithComments -> Line' NonEmpty+firstLine :: LinesWithComments -> Line firstLine = NEL.head . lwcLines -consLine :: Line' NonEmpty -> LinesWithComments -> LinesWithComments+consLine :: Line -> LinesWithComments -> LinesWithComments consLine l lwc = lwc { lwcLines = NEL.cons l (lwcLines lwc) } consComment :: Text -> LinesWithComments -> LinesWithComments consComment l lwc = lwc { lwcComments = l : lwcComments lwc } -associateLines :: [Line' NonEmpty] -> [LinesWithComments]+associateLines :: NonEmpty Line -> [LinesWithComments] associateLines lines = foldr combine [] $ foldr toLinesWithComments [] lines where- toLinesWithComments :: Line' NonEmpty -> [LinesWithComments] -> [LinesWithComments]+ toLinesWithComments :: Line -> [LinesWithComments] -> [LinesWithComments] toLinesWithComments line linesWithComments = case linesWithComments of [] ->@@ -730,9 +704,6 @@ minimumIndentOf = lowestIndent . lwcLines -skipEmpty :: NonEmpty (Line' []) -> [Line' NonEmpty]-skipEmpty = mapMaybe (traverseLine NEL.nonEmpty) . NEL.toList- setComments :: [Text] -> UnboundEntityDef -> UnboundEntityDef setComments [] = id setComments comments =@@ -954,13 +925,14 @@ case lns of [] -> ([], M.empty) (line : rest) ->- case line of- Line indent [Token name]+ case NEL.toList (tokens line) of+ [Token name] | isCapitalizedText name ->- let (children, rest') = span ((> indent) . lineIndent) rest+ let indent = lineIndent line+ (children, rest') = span ((> indent) . lineIndent) rest (x, y) = splitExtras rest'- in (x, M.insert name (map lineText children) y)- Line _ ts ->+ in (x, M.insert name (NEL.toList . lineText <$> children) y)+ ts -> let (x, y) = splitExtras rest in (ts:x, y)
Database/Persist/TH.hs view
@@ -93,7 +93,7 @@ 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.Lib (appT, varT, conK, conT, varE, varP, conE, litT, strTyLit) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Web.PathPieces (PathPiece(..))@@ -104,16 +104,6 @@ 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@@ -256,7 +246,6 @@ ForeignRef ref _ -> Just ref _ -> Nothing - -- fieldSqlType at parse time can be an Exp -- This helps delay setting fieldSqlType until lift time data EntityDefSqlTypeExp@@ -584,9 +573,7 @@ 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 names = mkEntityDefDeriveNames mps entDef let (stocks, anyclasses) = partitionEithers (map stratFor names) let stockDerives = do@@ -614,37 +601,27 @@ ] <> [''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+ | mpsGeneric mps = (mkEntityDefGenericName entDef, [PlainTV backendName])+ | otherwise = (mkEntityDefName entDef, []) + cols :: [VarBangType]+ cols = do+ fieldDef <- entityFields entDef+ let recordName = fieldDefToRecordName mps entDef fieldDef+ strictness = if fieldStrict fieldDef then isStrict else notStrict+ fieldIdType = maybeIdType mps fieldDef Nothing Nothing+ in pure (recordName, strictness, fieldIdType)+ constrs | entitySum entDef = map sumCon $ entityFields entDef- | otherwise = [RecC name cols]+ | otherwise = [RecC (mkEntityDefName entDef) 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)@@ -662,8 +639,8 @@ #endif mkUnique :: MkPersistSettings -> EntityDef -> UniqueDef -> Con-mkUnique mps entDef (UniqueDef (ConstraintNameHS constr) _ fields attrs) =- NormalC (mkName $ unpack constr) types+mkUnique mps entDef (UniqueDef constr _ fields attrs) =+ NormalC (mkConstraintName constr) types where types = map (go . flip lookup3 (entityFields entDef) . unFieldNameHS . fst) fields@@ -676,7 +653,7 @@ lookup3 :: Text -> [FieldDef] -> (FieldDef, IsNullable) lookup3 s [] =- error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ constr+ error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ unConstraintNameHS constr lookup3 x (fd@FieldDef {..}:rest) | x == unFieldNameHS fieldHaskell = (fd, nullable fieldAttrs) | otherwise = lookup3 x rest@@ -708,13 +685,14 @@ | 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'+genericDataType+ :: MkPersistSettings+ -> EntityNameHS+ -> Type -- ^ backend+ -> Type+genericDataType mps name backend+ | mpsGeneric mps = ConT (mkEntityNameHSGenericName name) `AppT` backend+ | otherwise = ConT $ mkEntityNameHSName name idType :: MkPersistSettings -> FieldDef -> Maybe Name -> Type idType mps fieldDef mbackend =@@ -731,8 +709,8 @@ in [normalClause [WildP] err] degen x = x -mkToPersistFields :: MkPersistSettings -> String -> EntityDef -> Q Dec-mkToPersistFields mps constr ed@EntityDef { entitySum = isSum, entityFields = fields } = do+mkToPersistFields :: MkPersistSettings -> EntityDef -> Q Dec+mkToPersistFields mps ed@EntityDef { entitySum = isSum, entityFields = fields } = do clauses <- if isSum then sequence $ zipWith goSum fields [1..]@@ -742,7 +720,8 @@ go :: Q Clause go = do xs <- sequence $ replicate fieldCount $ newName "x"- let pat = ConP (mkName constr) $ map VarP xs+ let name = mkEntityDefName ed+ pat = ConP name $ map VarP xs sp <- [|SomePersistField|] let bod = ListE $ map (AppE sp . VarE) xs return $ normalClause [pat] bod@@ -776,7 +755,7 @@ names' <- lift names return $ normalClause- [RecP (mkName $ unpack $ unConstraintNameHS constr) []]+ [RecP (mkConstraintName constr) []] names' mkUniqueToValues :: [UniqueDef] -> Q Dec@@ -787,7 +766,7 @@ 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+ let pat = ConP (mkConstraintName constr) $ map VarP xs tpv <- [|toPersistValue|] let bod = ListE $ map (AppE tpv . VarE) xs return $ normalClause [pat] bod@@ -804,8 +783,7 @@ mkFromPersistValues _ entDef@(EntityDef { entitySum = False }) = fromValues entDef "fromPersistValues" entE $ entityFields entDef where- entE = ConE $ mkName $ unpack entName- entName = unEntityNameHS $ entityHaskell entDef+ entE = entityDefConE entDef mkFromPersistValues mps entDef@(EntityDef { entitySum = True }) = do nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|]@@ -854,11 +832,11 @@ 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) []]+ toClause lens' getVal dot keyVar valName xName fieldDef = normalClause+ [ConP (filterConName mps entDef fieldDef) []] (lens' `AppE` getter `AppE` setter) where- fieldName = mkName $ unpack $ recNameF mps (entityHaskell entDef) (fieldHaskell f)+ fieldName = fieldDefToRecordName mps entDef fieldDef getter = InfixE (Just $ VarE fieldName) dot (Just getVal) setter = LamE [ ConP 'Entity [VarP keyVar, VarP valName]@@ -989,39 +967,6 @@ 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@@ -1047,11 +992,6 @@ , 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@@ -1141,10 +1081,9 @@ if mpsGeneric mps then liftAndFixKeys entityMap entDef else makePersistEntityDefExp mps entityMap entDef- let nameT = unEntityNameHS entName- let nameS = unpack nameT+ let name = mkEntityDefName entDef let clazz = ConT ''PersistEntity `AppT` genDataType- tpf <- mkToPersistFields mps nameS entDef+ tpf <- mkToPersistFields mps entDef fpv <- mkFromPersistValues mps entDef utv <- mkUniqueToValues $ entityUniques entDef puk <- mkUniqueKeys entDef@@ -1160,7 +1099,7 @@ let addSyn -- FIXME maybe remove this | mpsGeneric mps = (:) $- TySynD (mkName nameS) [] $+ TySynD name [] $ genericDataType mps entName $ mpsBackend mps | otherwise = id @@ -1175,9 +1114,7 @@ Just prim -> do recordName <- newName "record" let keyCon = keyConName entDef- keyFields' =- map (mkName . T.unpack . recNameF mps entName . fieldHaskell)- (compositeFields prim)+ keyFields' = fieldDefToRecordName mps entDef <$> compositeFields prim constr = foldl' AppE@@ -1198,7 +1135,7 @@ return $ addSyn $ dtd : mconcat fkc `mappend` ([ TySynD (keyIdName entDef) [] $- ConT ''Key `AppT` ConT (mkName nameS)+ ConT ''Key `AppT` ConT name , instanceD instanceConstraint clazz [ uniqueTypeDec mps entDef , keyTypeDec@@ -1268,7 +1205,7 @@ withPersistStoreWriteCxt = if mpsGeneric mps then do- write <- [t|PersistStoreWrite $(pure (VarT $ mkName "backend")) |]+ write <- [t|PersistStoreWrite $(pure backendT) |] pure [write] else do pure []@@ -1330,9 +1267,8 @@ 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'+ let lensName = mkName $ T.unpack $ recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field)+ fieldName = fieldDefToRecordName mps ent field needleN <- newName "needle" setterN <- newName "setter" fN <- newName "f"@@ -1378,11 +1314,11 @@ 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 fieldName = fieldNameToRecordName mps entDef let fname = fieldName (constraintToField foreignConstraintNameHaskell) let reftableString = unpack $ unEntityNameHS foreignRefTableHaskell let reftableKeyName = mkName $ reftableString `mappend` "Key"- let tablename = mkName $ unpack $ entityText entDef+ let tablename = mkEntityDefName entDef recordName <- newName "record" let mkFldE ((foreignName, _),ff) = case ff of@@ -1566,8 +1502,8 @@ let entityListName = mkName entityList edefs <- fmap ListE . forM entityDefs- $ \(EntityDef { entityHaskell = EntityNameHS haskellName }) ->- let entityType = conT (mkName (T.unpack haskellName))+ $ \entDef ->+ let entityType = entityDefConT entDef in [|entityDef (Proxy :: Proxy $(entityType))|] typ <- [t|[EntityDef]|] pure@@ -1589,13 +1525,13 @@ return (x, x') let pcs = map (go xs) $ entityUniques def let pat = ConP- (mkName $ unpack $ unEntityNameHS $ entityHaskell def)+ (mkEntityDefName 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)+ foldl' (go' xs) (ConE (mkConstraintName name)) (map fst cols) go' :: [(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp go' xs front col =@@ -1799,26 +1735,6 @@ 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.@@ -1846,8 +1762,7 @@ obj <- newName "obj" mzeroE <- [|mzero|] - xs <- mapM (newName . unpack . unFieldNameHSForJSON . fieldHaskell)- $ entityFields def+ xs <- mapM fieldToJSONValName (entityFields def) let conName = mkName $ unpack $ unEntityNameHS $ entityHaskell def typ = genericDataType mps (entityHaskell def) backendT@@ -1955,18 +1870,23 @@ 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+ fmap join $ forM (keyAndEntityFields ed) $ \fieldDef -> do+ let fieldNameT :: Q Type+ fieldNameT =+ litT $ strTyLit+ $ T.unpack $ lowerFirstIfId+ $ unFieldNameHS $ fieldHaskell fieldDef - nameG = mkName $ unpack $ unEntityNameHS (entityHaskell ed) ++ "Generic"+ lowerFirstIfId "Id" = "id"+ lowerFirstIfId xs = xs + nameG = mkEntityDefGenericName ed+ recordNameT | mpsGeneric mps = conT nameG `appT` varT backendName | otherwise =- conT $ mkName $ T.unpack $ unEntityNameHS $ entityHaskell ed+ entityDefConT ed fieldTypeT = maybeIdType mps fieldDef Nothing Nothing@@ -2012,3 +1932,137 @@ where extensionToPragma ext = "{-# LANGUAGE " <> show ext <> " #-}"++-- | creates a TH Name for use in the ToJSON instance+fieldToJSONValName :: FieldDef -> Q Name+fieldToJSONValName =+ newName . T.unpack . unFieldNameHSForJSON . fieldHaskell++-- | 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++entityDefConK :: EntityDef -> Kind+entityDefConK = conK . mkEntityDefName++entityDefConT :: EntityDef -> Q Type+entityDefConT = pure . entityDefConK++entityDefConE :: EntityDef -> Exp+entityDefConE = ConE . mkEntityDefName++-- | creates a TH Name for an entity's field, based on the entity+-- name and the field name, so for example:+--+-- Customer+-- name Text+--+-- This would generate `customerName` as a TH Name+fieldNameToRecordName :: MkPersistSettings -> EntityDef -> FieldNameHS -> Name+fieldNameToRecordName mps entDef fieldName = mkName $ T.unpack $ recNameF mps (entityHaskell entDef) fieldName++-- | as above, only takes a `FieldDef`+fieldDefToRecordName :: MkPersistSettings -> EntityDef -> FieldDef -> Name+fieldDefToRecordName mps entDef fieldDef = fieldNameToRecordName mps entDef (fieldHaskell fieldDef)++-- | Construct a list of TH Names for the typeclasses of an EntityDef's `entityDerives`+mkEntityDefDeriveNames :: MkPersistSettings -> EntityDef -> [Name]+mkEntityDefDeriveNames mps entDef =+ let entityInstances = mkName . T.unpack <$> entityDerives entDef+ additionalInstances = filter (`notElem` entityInstances) $ mpsDeriveInstances mps+ in entityInstances <> additionalInstances++-- | Make a TH Name for the EntityDef's Haskell type+mkEntityNameHSName :: EntityNameHS -> Name+mkEntityNameHSName =+ mkName . T.unpack . unEntityNameHS++-- | As above only taking an `EntityDef`+mkEntityDefName :: EntityDef -> Name+mkEntityDefName =+ mkEntityNameHSName . entityHaskell++-- | Make a TH Name for the EntityDef's Haskell type, when using mpsGeneric+mkEntityDefGenericName :: EntityDef -> Name+mkEntityDefGenericName =+ mkEntityNameHSGenericName . entityHaskell++mkEntityNameHSGenericName :: EntityNameHS -> Name+mkEntityNameHSGenericName name =+ mkName $ T.unpack (unEntityNameHS name <> "Generic")++sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name+sumConstrName mps entDef FieldDef {..} = mkName $ T.unpack name+ where+ name+ | mpsPrefixFields mps = modifiedName ++ "Sum"+ | otherwise = fieldName ++ "Sum"+ modifiedName = mpsConstraintLabelModifier mps entityName fieldName+ entityName = unEntityNameHS $ entityHaskell entDef+ fieldName = upperFirst $ unFieldNameHS fieldHaskell++-- | Turn a ConstraintName into a TH Name+mkConstraintName :: ConstraintNameHS -> Name+mkConstraintName (ConstraintNameHS name) =+ mkName (T.unpack name)++keyIdName :: EntityDef -> Name+keyIdName = mkName . T.unpack . keyIdText++keyIdText :: EntityDef -> Text+keyIdText entDef = unEntityNameHS (entityHaskell entDef) `mappend` "Id"++unKeyName :: EntityDef -> Name+unKeyName entDef = mkName $ T.unpack $ "un" `mappend` keyText entDef++unKeyExp :: EntityDef -> Exp+unKeyExp = VarE . unKeyName++backendT :: Type+backendT = VarT backendName++backendName :: Name+backendName = mkName "backend"++keyConName :: EntityDef -> Name+keyConName entDef = mkName $ T.unpack $ resolveConflict $ keyText entDef+ where+ resolveConflict kn = if conflict then kn `mappend` "'" else kn+ conflict = any ((== FieldNameHS "key") . fieldHaskell) $ entityFields entDef++keyConExp :: EntityDef -> Exp+keyConExp = ConE . keyConName++keyText :: EntityDef -> Text+keyText entDef = unEntityNameHS (entityHaskell entDef) ++ "Key"++keyFieldName :: MkPersistSettings -> EntityDef -> FieldDef -> Name+keyFieldName mps entDef fieldDef+ | pkNewtype mps entDef = unKeyName entDef+ | otherwise = mkName $ T.unpack $ lowerFirst (keyText entDef) `mappend` unFieldNameHS (fieldHaskell fieldDef)++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 $ T.unpack name+ where+ name+ | field == FieldNameHS "Id" = entityName ++ fieldName+ | mpsPrefixFields mps = modifiedName+ | otherwise = fieldName+ modifiedName = mpsConstraintLabelModifier mps entityName fieldName+ entityName = unEntityNameHS entity+ fieldName = upperFirst $ unFieldNameHS field
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.12.1.0+version: 2.12.1.1 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>
test/Database/Persist/TH/OverloadedLabelSpec.hs view
@@ -52,5 +52,11 @@ compiles + it "works for id labels" $ do+ let UserId = #id+ orgId = #id :: EntityField Organization OrganizationId++ compiles+ compiles :: Expectation compiles = True `shouldBe` True
test/main.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} @@ -9,7 +9,7 @@ import qualified Data.Char as Char import qualified Data.Text as T import Data.List-import Data.List.NonEmpty (NonEmpty(..))+import Data.List.NonEmpty (NonEmpty(..), (<|)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map #if !MIN_VERSION_base(4,11,0)@@ -34,8 +34,8 @@ THSpec.spec describe "splitExtras" $ do- let helloWorldTokens = asTokens ["hello", "world"]- foobarbazTokens = asTokens ["foo", "bar", "baz"]+ let helloWorldTokens = Token "hello" :| [Token "world"]+ foobarbazTokens = Token "foo" :| [Token "bar", Token "baz"] it "works" $ do splitExtras [] `shouldBe`@@ -45,20 +45,21 @@ [ Line 0 helloWorldTokens ] `shouldBe`- ( [helloWorldTokens], mempty )+ ( [NEL.toList helloWorldTokens], mempty ) it "works3" $ do splitExtras [ Line 0 helloWorldTokens , Line 2 foobarbazTokens ] `shouldBe`- ( [helloWorldTokens, foobarbazTokens], mempty )+ ( [NEL.toList helloWorldTokens, NEL.toList foobarbazTokens], mempty ) it "works4" $ do let foobarbarz = ["foo", "Bar", "baz"]+ fbbTokens = Token <$> nonEmptyOrFail foobarbarz splitExtras- [ Line 0 [Token "Hello"]- , Line 2 (asTokens foobarbarz)- , Line 2 (asTokens foobarbarz)+ [ Line 0 (pure (Token "Hello"))+ , Line 2 fbbTokens+ , Line 2 fbbTokens ] `shouldBe` ( []@@ -68,10 +69,11 @@ ) it "works5" $ do let foobarbarz = ["foo", "Bar", "baz"]+ fbbTokens = Token <$> nonEmptyOrFail foobarbarz splitExtras- [ Line 0 (asTokens ["Hello"])- , Line 2 (asTokens foobarbarz)- , Line 4 (asTokens foobarbarz)+ [ Line 0 (pure (Token "Hello"))+ , Line 2 fbbTokens+ , Line 4 fbbTokens ] `shouldBe` ( []@@ -138,7 +140,7 @@ it "handles normal words" $ parseLine " foo bar baz" `shouldBe` Just- ( Line 1+ ( Line 1 $ nonEmptyOrFail [ Token "foo" , Token "bar" , Token "baz"@@ -148,7 +150,7 @@ it "handles quotes" $ parseLine " \"foo bar\" \"baz\"" `shouldBe` Just- ( Line 2+ ( Line 2 $ nonEmptyOrFail [ Token "foo bar" , Token "baz" ]@@ -157,7 +159,7 @@ it "handles quotes mid-token" $ parseLine " x=\"foo bar\" \"baz\"" `shouldBe` Just- ( Line 2+ ( Line 2 $ nonEmptyOrFail [ Token "x=foo bar" , Token "baz" ]@@ -166,7 +168,7 @@ it "handles escaped quote mid-token" $ parseLine " x=\\\"foo bar\" \"baz\"" `shouldBe` Just- ( Line 2+ ( Line 2 $ nonEmptyOrFail [ Token "x=\\\"foo" , Token "bar\"" , Token "baz"@@ -176,7 +178,7 @@ it "handles unnested parantheses" $ parseLine " (foo bar) (baz)" `shouldBe` Just- ( Line 2+ ( Line 2 $ nonEmptyOrFail [ Token "foo bar" , Token "baz" ]@@ -185,7 +187,7 @@ it "handles unnested parantheses mid-token" $ parseLine " x=(foo bar) (baz)" `shouldBe` Just- ( Line 2+ ( Line 2 $ nonEmptyOrFail [ Token "x=foo bar" , Token "baz" ]@@ -194,7 +196,7 @@ it "handles nested parantheses" $ parseLine " (foo (bar)) (baz)" `shouldBe` Just- ( Line 2+ ( Line 2 $ nonEmptyOrFail [ Token "foo (bar)" , Token "baz" ]@@ -203,7 +205,7 @@ it "escaping" $ parseLine " (foo \\(bar) y=\"baz\\\"\"" `shouldBe` Just- ( Line 2+ ( Line 2 $ nonEmptyOrFail [ Token "foo (bar" , Token "y=baz\"" ]@@ -212,7 +214,7 @@ it "mid-token quote in later token" $ parseLine "foo bar baz=(bin\")" `shouldBe` Just- ( Line 0+ ( Line 0 $ nonEmptyOrFail [ Token "foo" , Token "bar" , Token "baz=bin\""@@ -223,22 +225,13 @@ it "recognizes one line" $ do parseLine "-- | this is a comment" `shouldBe` Just- ( Line 0- [ DocComment "this is a comment"- ]+ ( Line 0 $ pure+ (DocComment "this is a comment") ) - it "map parseLine" $ do- mapM parseLine ["Foo", "-- | Hello"]- `shouldBe`- Just- [ Line 0 [Token "Foo"]- , Line 0 [DocComment "Hello"]- ]- it "works if comment is indented" $ do parseLine " -- | comment" `shouldBe`- Just (Line 2 [ DocComment "comment"])+ Just (Line 2 (pure (DocComment "comment"))) describe "parse" $ do let subject =@@ -415,9 +408,7 @@ it "preparse works" $ do (length <$> preparsed) `shouldBe` Just 10 - let skippedEmpty =- maybe [] skipEmpty preparsed- fooLines =+ let fooLines = [ Line { lineIndent = 0 , tokens = Token "Foo" :| []@@ -465,19 +456,11 @@ , tokens = Token "c" :| [Token "FooId"] } ]- resultLines =- concat- [ fooLines- , emptyLines- , barLines- , bazLines- ] - it "skipEmpty works" $ do- skippedEmpty `shouldBe` resultLines- let linesAssociated =- associateLines skippedEmpty+ case preparsed of+ Nothing -> error "preparsed failed"+ Just lines -> associateLines lines it "associateLines works" $ do linesAssociated `shouldMatchList` [ LinesWithComments@@ -529,20 +512,20 @@ it "recognizes entity" $ do let expected =- Line { lineIndent = 0, tokens = asTokens ["Person"] } :|- [ Line { lineIndent = 2, tokens = asTokens ["name", "String"] }- , Line { lineIndent = 2, tokens = asTokens ["age", "Int"] }+ Line { lineIndent = 0, tokens = pure (Token "Person") } :|+ [ Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] }+ , Line { lineIndent = 2, tokens = Token "age" :| [Token "Int"] } ] 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"] }+ Line { lineIndent = 0, tokens = pure (Token "Foo") } :|+ [ Line { lineIndent = 2, tokens = Token "x" :| [Token "X"] }+ , Line { lineIndent = 0, tokens = pure (DocComment "Hello") }+ , Line { lineIndent = 0, tokens = pure (Token "Bar") }+ , Line { lineIndent = 1, tokens = Token "name" :| [Token "String"] } ] preparse text `shouldBe` Just expected @@ -556,11 +539,11 @@ , " 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"] }+ Line { lineIndent = 2, tokens = pure (Token "Foo") } :|+ [ Line { lineIndent = 4, tokens = Token "x" :| [Token "X"] }+ , Line { lineIndent = 2, tokens = pure (DocComment "Comment") }+ , Line { lineIndent = 2, tokens = pure (Token "Bar") }+ , Line { lineIndent = 4, tokens = Token "name" :| [Token "String"] } ] preparse t `shouldBe` Just expected @@ -575,13 +558,13 @@ , " something" ] 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"] }+ Line { lineIndent = 0, tokens = pure (Token "LowerCaseTable") } :|+ [ Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] }+ , Line { lineIndent = 2, tokens = pure (Token "ExtraBlock") }+ , Line { lineIndent = 4, tokens = Token "foo" :| [Token "bar"] }+ , Line { lineIndent = 4, tokens = pure (Token "baz") }+ , Line { lineIndent = 2, tokens = pure (Token "ExtraBlock2") }+ , Line { lineIndent = 4, tokens = pure (Token "something") } ] preparse t `shouldBe` Just expected @@ -593,10 +576,10 @@ , " 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"] }+ Line { lineIndent = 0, tokens = pure (DocComment "Model") } :|+ [ Line { lineIndent = 0, tokens = pure (Token "Foo") }+ , Line { lineIndent = 2, tokens = pure (DocComment "Field") }+ , Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] } ] preparse text `shouldBe` Just expected @@ -618,10 +601,10 @@ } it "works" $ do associateLines- [ comment- , foo+ ( comment :|+ [ foo , name'String- ]+ ]) `shouldBe` [ LinesWithComments { lwcComments = ["comment"]@@ -631,7 +614,7 @@ let bar = Line { lineIndent = 0- , tokens = Token "Bar" :| asTokens ["sql", "=", "bars"]+ , tokens = Token "Bar" :| [Token "sql", Token "=", Token "bars"] } age'Int = Line@@ -640,12 +623,12 @@ } it "works when used consecutively" $ do associateLines- [ bar- , age'Int+ ( bar :|+ [ age'Int , comment , foo , name'String- ]+ ]) `shouldBe` [ LinesWithComments { lwcComments = []@@ -657,11 +640,9 @@ } ] it "works with textual input" $ do- let text = "Foo\n x X\n-- | Hello\nBar\n name String"- parsed = preparse text- allFull = maybe [] skipEmpty parsed- associateLines allFull- `shouldBe`+ let text = preparse "Foo\n x X\n-- | Hello\nBar\n name String"+ associateLines <$> text+ `shouldBe` Just [ LinesWithComments { lwcLines = Line {lineIndent = 0, tokens = Token "Foo" :| []}@@ -678,7 +659,7 @@ } ] it "works with extra blocks" $ do- let text = maybe [] skipEmpty . preparse . T.unlines $+ let text = preparse . T.unlines $ [ "LowerCaseTable" , " Id sql=my_id" , " fullName Text"@@ -689,7 +670,7 @@ , " ExtraBlock2" , " something" ]- associateLines text `shouldBe`+ associateLines <$> text `shouldBe` Just [ LinesWithComments { lwcLines = Line { lineIndent = 0, tokens = pure (Token "LowerCaseTable") } :|@@ -707,7 +688,7 @@ ] it "works with extra blocks twice" $ do- let text = maybe [] skipEmpty . preparse . T.unlines $+ let text = preparse . T.unlines $ [ "IdTable" , " Id Day default=CURRENT_DATE" , " name Text"@@ -722,11 +703,11 @@ , " ExtraBlock2" , " something" ]- associateLines text `shouldBe`+ associateLines <$> text `shouldBe` Just [ LinesWithComments { lwcLines = Line 0 (pure (Token "IdTable")) :|- [ Line 4 (Token "Id" :| asTokens ["Day", "default=CURRENT_DATE"])- , Line 4 (Token "name" :| asTokens ["Text"])+ [ Line 4 (Token "Id" <| Token "Day" :| [Token "default=CURRENT_DATE"])+ , Line 4 (Token "name" :| [Token "Text"]) ] , lwcComments = [] }@@ -748,13 +729,13 @@ it "works with field comments" $ do- let text = maybe [] skipEmpty . preparse . T.unlines $+ let text = preparse . T.unlines $ [ "-- | Model" , "Foo" , " -- | Field" , " name String" ]- associateLines text `shouldBe`+ associateLines <$> text `shouldBe` Just [ LinesWithComments { lwcLines = Line { lineIndent = 0, tokens = (Token "Foo") :| [] } :|@@ -829,7 +810,7 @@ , "" ] of [a, b, c] ->- [a, b, c]+ [a, b, c] :: [EntityDef] xs -> error $ "Expected 3 elements in list, got: "@@ -900,8 +881,11 @@ takePrefix (String a) = String (T.take 1 a) takePrefix a = a -asTokens :: [T.Text] -> [Token]-asTokens = fmap Token+nonEmptyOrFail :: [a] -> NonEmpty a+nonEmptyOrFail = maybe failure id . NEL.nonEmpty+ where+ failure =+ error "nonEmptyOrFail expected a non empty list" arbitraryWhiteSpaceChar :: Gen Char arbitraryWhiteSpaceChar =