diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,18 @@ # Changelog for persistent +## Unreleased + +## 2.12.1.2 + +* [#1258](https://github.com/yesodweb/persistent/pull/1258) + * Support promoted types in Quasi Quoter +* [#1243](https://github.com/yesodweb/persistent/pull/1243) + * Assorted cleanup of TH module +* [#1242](https://github.com/yesodweb/persistent/pull/1242) + * Refactor setEmbedField to use do notation +* [#1237](https://github.com/yesodweb/persistent/pull/1237) + * Remove nonEmptyOrFail function from recent tests + ## 2.12.1.1 * [#1231](https://github.com/yesodweb/persistent/pull/1231) diff --git a/Database/Persist/Class/PersistUnique.hs b/Database/Persist/Class/PersistUnique.hs --- a/Database/Persist/Class/PersistUnique.hs +++ b/Database/Persist/Class/PersistUnique.hs @@ -297,7 +297,7 @@ -- | Given a proxy for a 'PersistEntity' record, this returns the sole -- 'UniqueDef' for that entity. -- --- @since 2.10.0 +-- @since TODO release me onlyOneUniqueDef :: (OnlyOneUniqueKey record, Monad proxy) => proxy record diff --git a/Database/Persist/Quasi.hs b/Database/Persist/Quasi.hs --- a/Database/Persist/Quasi.hs +++ b/Database/Persist/Quasi.hs @@ -486,21 +486,29 @@ | isSpace c -> parse1 $ T.dropWhile isSpace t' | c == '(' -> parseEnclosed ')' id t' | c == '[' -> parseEnclosed ']' FTList t' - | isUpper c -> - let (a, b) = T.break (\x -> isSpace x || x `elem` ("()[]"::String)) t - in PSSuccess (getCon a) b + | isUpper c || c == '\'' -> + let (a, b) = T.break (\x -> isSpace x || x `elem` ("()[]"::String)) t' + in PSSuccess (parseFieldTypePiece c a) b | otherwise -> PSFail $ show (c, t') - getCon t = - case T.breakOnEnd "." t of - (_, "") -> FTTypeCon Nothing t - ("", _) -> FTTypeCon Nothing t - (a, b) -> FTTypeCon (Just $ T.init a) b + goMany front t = case parse1 t of PSSuccess x t' -> goMany (front . (x:)) t' PSFail err -> PSFail err PSDone -> PSSuccess (front []) t -- _ -> + +parseFieldTypePiece :: Char -> Text -> FieldType +parseFieldTypePiece fstChar rest = + case fstChar of + '\'' -> + FTTypePromoted rest + _ -> + let t = T.cons fstChar rest + in case T.breakOnEnd "." t of + (_, "") -> FTTypeCon Nothing t + ("", _) -> FTTypeCon Nothing t + (a, b) -> FTTypeCon (Just $ T.init a) b data PersistSettings = PersistSettings { psToDBName :: !(Text -> Text) diff --git a/Database/Persist/TH.hs b/Database/Persist/TH.hs --- a/Database/Persist/TH.hs +++ b/Database/Persist/TH.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE CPP, BangPatterns #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE ViewPatterns #-} -- {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-} @@ -61,48 +61,55 @@ -- Development Tip: See persistent-template/README.md for advice on seeing generated Template Haskell code -- It's highly recommended to check the diff between master and your PR's generated code. -import Prelude hiding ((++), take, concat, splitAt, exp) +import Prelude hiding (concat, exp, splitAt, take, (++)) -import Data.Either import Control.Monad import Data.Aeson - ( ToJSON (toJSON), FromJSON (parseJSON), (.=), object - , Value (Object), (.:), (.:?) - , eitherDecodeStrict' - ) + ( FromJSON(parseJSON) + , ToJSON(toJSON) + , Value(Object) + , eitherDecodeStrict' + , object + , (.:) + , (.:?) + , (.=) + ) import qualified Data.ByteString as BS -import Data.Typeable (Typeable) -import Data.Ix (Ix) -import Data.Data (Data) import Data.Char (toLower, toUpper) +import Data.Data (Data) +import Data.Either import qualified Data.HashMap.Strict as HM import Data.Int (Int64) +import Data.Ix (Ix) import Data.List (foldl') import qualified Data.List as List import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M -import Data.Maybe (isJust, listToMaybe, mapMaybe, fromMaybe) -import Data.Monoid ((<>), mappend, mconcat) -import Data.Proxy (Proxy (Proxy)) -import Data.Text (pack, Text, append, unpack, concat, uncons, cons, stripSuffix) +import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe) +import Data.Monoid (mappend, mconcat, (<>)) +import Data.Proxy (Proxy(Proxy)) +import Data.Text (Text, append, concat, cons, pack, stripSuffix, uncons, unpack) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import qualified Data.Text.Encoding as TE +import Data.Typeable (Typeable) import GHC.Generics (Generic) import GHC.TypeLits import Instances.TH.Lift () -- Bring `Lift (Map k v)` instance into scope, as well as `Lift Text` -- instance on pre-1.2.4 versions of `text` -import Language.Haskell.TH.Lib (appT, varT, conK, conT, varE, varP, conE, litT, strTyLit) +import qualified Data.Set as Set +import Language.Haskell.TH.Lib + (appT, conE, conK, conT, litT, strTyLit, varE, varP, varT) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax +import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..)) import Web.PathPieces (PathPiece(..)) -import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..)) -import qualified Data.Set as Set import Database.Persist -import Database.Persist.Sql (Migration, PersistFieldSql, SqlBackend, migrate, sqlType) import Database.Persist.Quasi +import Database.Persist.Sql + (Migration, PersistFieldSql, SqlBackend, migrate, sqlType) -- | Converts a quasi-quoted syntax into a list of entity definitions, to be -- used as input to the template haskell generation code (mkPersist). @@ -191,7 +198,7 @@ embedEntityDefsMap :: [EntityDef] -> (M.Map EntityNameHS EmbedEntityDef, [EntityDef]) embedEntityDefsMap rawEnts = (embedEntityMap, noCycleEnts) where - noCycleEnts = map breakCycleEnt entsWithEmbeds + noCycleEnts = map breakEntDefCycle entsWithEmbeds -- every EntityDef could reference each-other (as an EmbedRef) -- let Haskell tie the knot embedEntityMap = constructEmbedEntityMap entsWithEmbeds @@ -200,12 +207,15 @@ { entityFields = map (setEmbedField (entityHaskell ent) embedEntityMap) $ entityFields ent } - -- self references are already broken - -- look at every emFieldEmbed to see if it refers to an already seen EntityNameHS - -- so start with entityHaskell ent and accumulate embeddedHaskell em - breakCycleEnt entDef = - let entName = entityHaskell entDef - in entDef { entityFields = map (breakCycleField entName) $ entityFields entDef } +-- self references are already broken +-- look at every emFieldEmbed to see if it refers to an already seen EntityNameHS +-- so start with entityHaskell ent and accumulate embeddedHaskell em +breakEntDefCycle :: EntityDef -> EntityDef +breakEntDefCycle entDef = + entDef { entityFields = breakCycleField entName <$> entityFields entDef } + where + entName = + entityHaskell entDef breakCycleField entName f = case f of FieldDef { fieldReference = EmbedRef em } -> @@ -306,6 +316,12 @@ constructEmbedEntityMap = M.fromList . fmap (\ent -> (entityHaskell ent, toEmbedEntityDef ent)) +lookupEmbedEntity :: EmbedEntityMap -> FieldDef -> Maybe EntityNameHS +lookupEmbedEntity allEntities field = do + entName <- EntityNameHS <$> stripId (fieldType field) + guard (M.member entName allEntities) -- check entity name exists in embed map + pure entName + type EntityMap = M.Map EntityNameHS EntityDef constructEntityMap :: [EntityDef] -> EntityMap @@ -333,6 +349,8 @@ Left Nothing mEmbedded ents (FTTypeCon Nothing (EntityNameHS -> name)) = maybe (Left Nothing) Right $ M.lookup name ents +mEmbedded ents (FTTypePromoted (EntityNameHS -> name)) = + Left Nothing mEmbedded ents (FTList x) = mEmbedded ents x mEmbedded ents (FTApp x y) = @@ -344,36 +362,30 @@ else mEmbedded ents y setEmbedField :: EntityNameHS -> EmbedEntityMap -> FieldDef -> FieldDef -setEmbedField entName allEntities field = field - { fieldReference = - case fieldReference field of - NoReference -> - case mEmbedded allEntities (fieldType field) of - Left _ -> - case stripId $ fieldType field of - Nothing -> - NoReference - Just name -> - case M.lookup (EntityNameHS name) allEntities of - Nothing -> - NoReference - Just _ -> - ForeignRef - (EntityNameHS name) - -- This can get corrected in mkEntityDefSqlTypeExp - (FTTypeCon (Just "Data.Int") "Int64") - Right em -> - if embeddedHaskell em /= entName - then EmbedRef em - else if maybeNullable field - then SelfReference - else case fieldType field of - FTList _ -> SelfReference - _ -> error $ unpack $ unEntityNameHS entName <> ": a self reference must be a Maybe" - existing -> - existing - } +setEmbedField entName allEntities field = + case fieldReference field of + NoReference -> setFieldReference ref field + _ -> field + where + ref = + case mEmbedded allEntities (fieldType field) of + Left _ -> fromMaybe NoReference $ do + entName <- lookupEmbedEntity allEntities field + -- This can get corrected in mkEntityDefSqlTypeExp + let placeholderIdType = FTTypeCon (Just "Data.Int") "Int64" + pure $ ForeignRef entName placeholderIdType + Right em -> + if embeddedHaskell em /= entName + then EmbedRef em + else if maybeNullable field + then SelfReference + else case fieldType field of + FTList _ -> SelfReference + _ -> error $ unpack $ unEntityNameHS entName <> ": a self reference must be a Maybe" +setFieldReference :: ReferenceDef -> FieldDef -> FieldDef +setFieldReference ref field = field { fieldReference = ref } + mkEntityDefSqlTypeExp :: EmbedEntityMap -> EntityMap -> EntityDef -> EntityDefSqlTypeExp mkEntityDefSqlTypeExp emEntities entityMap ent = EntityDefSqlTypeExp ent (getSqlType $ entityId ent) (map getSqlType $ entityFields ent) @@ -543,22 +555,6 @@ sqlSettings :: MkPersistSettings sqlSettings = mkPersistSettings $ ConT ''SqlBackend -recNameNoUnderscore :: MkPersistSettings -> EntityNameHS -> FieldNameHS -> Text -recNameNoUnderscore mps entName fieldName - | mpsPrefixFields mps = lowerFirst $ modifier (unEntityNameHS entName) (upperFirst ft) - | otherwise = lowerFirst ft - where - modifier = mpsFieldLabelModifier mps - ft = unFieldNameHS fieldName - -recNameF :: MkPersistSettings -> EntityNameHS -> FieldNameHS -> Text -recNameF mps entName fieldName = - addUnderscore $ recNameNoUnderscore mps entName fieldName - where - addUnderscore - | mpsGenerateLenses mps = ("_" ++) - | otherwise = id - lowerFirst :: Text -> Text lowerFirst t = case uncons t of @@ -668,11 +664,12 @@ , "on the end of the line that defines your uniqueness " , "constraint in order to disable this check. ***" ] -maybeIdType :: MkPersistSettings - -> FieldDef - -> Maybe Name -- ^ backend - -> Maybe IsNullable - -> Type +maybeIdType + :: MkPersistSettings + -> FieldDef + -> Maybe Name -- ^ backend + -> Maybe IsNullable + -> Type maybeIdType mps fieldDef mbackend mnull = maybeTyp mayNullable idtyp where mayNullable = case mnull of @@ -745,7 +742,6 @@ ] return $ normalClause [ConP name [VarP x]] body - mkToFieldNames :: [UniqueDef] -> Q Dec mkToFieldNames pairs = do pairs' <- mapM go pairs @@ -1077,18 +1073,18 @@ mkEntity :: EntityMap -> MkPersistSettings -> EntityDef -> Q [Dec] mkEntity entityMap mps entDef = do + fields <- mkFields mps entDef entityDefExp <- if mpsGeneric mps then liftAndFixKeys entityMap entDef else makePersistEntityDefExp mps entityMap entDef + let name = mkEntityDefName entDef let clazz = ConT ''PersistEntity `AppT` genDataType tpf <- mkToPersistFields mps entDef fpv <- mkFromPersistValues mps entDef utv <- mkUniqueToValues $ entityUniques entDef puk <- mkUniqueKeys entDef - let primaryField = entityId entDef - fields <- mapM (mkField mps entDef) $ primaryField : entityFields entDef fkc <- mapM (mkForeignKeysComposite mps entDef) $ entityForeigns entDef toFieldNames <- mkToFieldNames $ entityUniques entDef @@ -1132,9 +1128,11 @@ [d|$(varP 'keyFromRecordM) = Nothing|] dtd <- dataTypeDec mps entDef + let allEntDefs = entityFieldTHCon <$> efthAllFields fields + allEntDefClauses = entityFieldTHClause <$> efthAllFields fields return $ addSyn $ dtd : mconcat fkc `mappend` - ([ TySynD (keyIdName entDef) [] $ + ( [ TySynD (keyIdName entDef) [] $ ConT ''Key `AppT` ConT name , instanceD instanceConstraint clazz [ uniqueTypeDec mps entDef @@ -1154,7 +1152,7 @@ Nothing (AppT (AppT (ConT ''EntityField) genDataType) (VarT $ mkName "typ")) Nothing - (map fst fields) + allEntDefs [] #else , DataInstD @@ -1164,10 +1162,10 @@ , VarT $ mkName "typ" ] Nothing - (map fst fields) + allEntDefs [] #endif - , FunD 'persistFieldDef (map snd fields) + , FunD 'persistFieldDef allEntDefClauses #if MIN_VERSION_template_haskell(2,15,0) , TySynInstD (TySynEqn @@ -1189,6 +1187,20 @@ genDataType = genericDataType mps entName backendT entName = entityHaskell entDef +data EntityFieldsTH = EntityFieldsTH + { entityFieldsTHPrimary :: EntityFieldTH + , entityFieldsTHFields :: [EntityFieldTH] + } + +efthAllFields :: EntityFieldsTH -> [EntityFieldTH] +efthAllFields EntityFieldsTH{..} = entityFieldsTHPrimary : entityFieldsTHFields + +mkFields :: MkPersistSettings -> EntityDef -> Q EntityFieldsTH +mkFields mps entDef = + EntityFieldsTH + <$> mkField mps entDef (entityId entDef) + <*> mapM (mkField mps entDef) (entityFields entDef) + mkUniqueKeyInstances :: MkPersistSettings -> EntityDef -> Q [Dec] mkUniqueKeyInstances mps entDef = do requirePersistentExtensions @@ -1267,7 +1279,7 @@ mkLenses mps _ | not (mpsGenerateLenses mps) = return [] mkLenses _ ent | entitySum ent = return [] mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do - let lensName = mkName $ T.unpack $ recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field) + let lensName = mkEntityLensName mps ent field fieldName = fieldDefToRecordName mps ent field needleN <- newName "needle" setterN <- newName "setter" @@ -1344,18 +1356,17 @@ maybeTyp may typ | may = ConT ''Maybe `AppT` typ | otherwise = typ - - entityToPersistValueHelper :: (PersistEntity record) => record -> PersistValue entityToPersistValueHelper entity = PersistMap $ zip columnNames fieldsAsPersistValues where columnNames = map (unFieldNameHS . fieldHaskell) (entityFields (entityDef (Just entity))) fieldsAsPersistValues = map toPersistValue $ toPersistFields entity -entityFromPersistValueHelper :: (PersistEntity record) - => [String] -- ^ Column names, as '[String]' to avoid extra calls to "pack" in the generated code - -> PersistValue - -> Either Text record +entityFromPersistValueHelper + :: (PersistEntity record) + => [String] -- ^ Column names, as '[String]' to avoid extra calls to "pack" in the generated code + -> PersistValue + -> Either Text record entityFromPersistValueHelper columnNames pv = do (persistMap :: [(T.Text, PersistValue)]) <- getPersistMap pv @@ -1463,8 +1474,6 @@ val (Nullable ByMaybeAttr) = just `AppE` VarE key val _ = VarE key - - let stmts :: [Stmt] stmts = map mkStmt deps `mappend` [NoBindS $ del `AppE` VarE key] @@ -1542,9 +1551,12 @@ sqlTypeFunD st = FunD 'sqlType [ normalClause [WildP] st ] -typeInstanceD :: Name - -> Bool -- ^ include PersistStore backend constraint - -> Type -> [Dec] -> Dec +typeInstanceD + :: Name + -> Bool -- ^ include PersistStore backend constraint + -> Type + -> [Dec] + -> Dec typeInstanceD clazz hasBackend typ = instanceD ctx (ConT clazz `AppT` typ) where @@ -1696,29 +1708,41 @@ |] liftAndFixKey :: EntityMap -> FieldDef -> Q Exp -liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef fc mcomments fg) = - [|FieldDef a b c $(sqlTyp') e f (fieldRef') fc mcomments fg|] +liftAndFixKey entityMap fieldDef@(FieldDef a b c sqlTyp e f fieldRef fc mcomments fg) = + [|FieldDef a b c $(sqlTyp') e f fieldRef' fc mcomments fg|] where - (fieldRef', sqlTyp') = - fromMaybe (fieldRef, lift sqlTyp) $ - case fieldRef of - ForeignRef refName _ft -> do - ent <- M.lookup refName entityMap - case fieldReference $ entityId ent of - fr@(ForeignRef _ ft) -> - Just (fr, lift $ SqlTypeExp ft) - _ -> - Nothing + (fieldRef', sqlTyp') = + case extractForeignRef entityMap fieldDef of + Just (fr, ft) -> + (fr, lift (SqlTypeExp ft)) + Nothing -> + (fieldRef, lift sqlTyp) + +extractForeignRef :: EntityMap -> FieldDef -> Maybe (ReferenceDef, FieldType) +extractForeignRef entityMap fieldDef = + case fieldReference fieldDef of + ForeignRef refName _ft -> do + ent <- M.lookup refName entityMap + case fieldReference $ entityId ent of + fr@(ForeignRef _ ft) -> + Just (fr, ft) _ -> Nothing + _ -> + Nothing +data EntityFieldTH = EntityFieldTH + { entityFieldTHCon :: Con + , entityFieldTHClause :: Clause + } + -- Ent -- fieldName FieldType -- -- forall . typ ~ FieldType => EntFieldName -- -- EntFieldName = FieldDef .... -mkField :: MkPersistSettings -> EntityDef -> FieldDef -> Q (Con, Clause) +mkField :: MkPersistSettings -> EntityDef -> FieldDef -> Q EntityFieldTH mkField mps et cd = do let con = ForallC [] @@ -1728,7 +1752,7 @@ let cla = normalClause [ConP name []] bod - return (con, cla) + return $ EntityFieldTH con cla where name = filterConName mps et cd @@ -1736,13 +1760,21 @@ maybeNullable fd = nullable (fieldAttrs fd) == Nullable ByMaybeAttr ftToType :: FieldType -> Type -ftToType (FTTypeCon Nothing t) = ConT $ mkName $ unpack t --- This type is generated from the Quasi-Quoter. --- Adding this special case avoids users needing to import Data.Int -ftToType (FTTypeCon (Just "Data.Int") "Int64") = ConT ''Int64 -ftToType (FTTypeCon (Just m) t) = ConT $ mkName $ unpack $ concat [m, ".", t] -ftToType (FTApp x y) = ftToType x `AppT` ftToType y -ftToType (FTList x) = ListT `AppT` ftToType x +ftToType = \case + FTTypeCon Nothing t -> + ConT $ mkName $ T.unpack t + -- This type is generated from the Quasi-Quoter. + -- Adding this special case avoids users needing to import Data.Int + FTTypeCon (Just "Data.Int") "Int64" -> + ConT ''Int64 + FTTypeCon (Just m) t -> + ConT $ mkName $ unpack $ concat [m, ".", t] + FTTypePromoted t -> + PromotedT $ mkName $ T.unpack t + FTApp x y -> + ftToType x `AppT` ftToType y + FTList x -> + ListT `AppT` ftToType x infixr 5 ++ (++) :: Text -> Text -> Text @@ -1764,7 +1796,7 @@ xs <- mapM fieldToJSONValName (entityFields def) - let conName = mkName $ unpack $ unEntityNameHS $ entityHaskell def + let conName = mkEntityDefName def typ = genericDataType mps (entityHaskell def) backendT toJSONI = typeInstanceD ''ToJSON (mpsGeneric mps) typ [toJSON'] toJSON' = FunD 'toJSON $ return $ normalClause @@ -1838,7 +1870,6 @@ -- pu' <- lift pu -- return $ normalClause [RecP (mkName constr) []] pu' - -- mkToFieldName :: String -> [(String, String)] -> Dec -- mkToFieldName func pairs = -- FunD (mkName func) $ degen $ map go pairs @@ -1965,12 +1996,48 @@ -- -- 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 +fieldNameToRecordName mps entDef fieldName = + mkRecordName mps mUnderscore (entityHaskell entDef) fieldName + where + mUnderscore + | mpsGenerateLenses mps = Just "_" + | otherwise = Nothing -- | as above, only takes a `FieldDef` fieldDefToRecordName :: MkPersistSettings -> EntityDef -> FieldDef -> Name -fieldDefToRecordName mps entDef fieldDef = fieldNameToRecordName mps entDef (fieldHaskell fieldDef) +fieldDefToRecordName mps entDef fieldDef = + fieldNameToRecordName mps entDef (fieldHaskell fieldDef) +-- | creates a TH Name for a lens on an entity's field, based on the entity +-- name and the field name, so as above but for the Lens +-- +-- Customer +-- name Text +-- +-- Generates a lens `customerName` when `mpsGenerateLenses` is true +-- while `fieldNameToRecordName` generates a prefixed function +-- `_customerName` +mkEntityLensName :: MkPersistSettings -> EntityDef -> FieldDef -> Name +mkEntityLensName mps entDef fieldDef = + mkRecordName mps Nothing (entityHaskell entDef) (fieldHaskell fieldDef) + +mkRecordName :: MkPersistSettings -> Maybe Text -> EntityNameHS -> FieldNameHS -> Name +mkRecordName mps prefix entNameHS fieldNameHS = + mkName $ T.unpack $ fromMaybe "" prefix <> lowerFirst recName + where + recName :: Text + recName + | mpsPrefixFields mps = mpsFieldLabelModifier mps entityNameText (upperFirst fieldNameText) + | otherwise = fieldNameText + + entityNameText :: Text + entityNameText = + unEntityNameHS entNameHS + + fieldNameText :: Text + fieldNameText = + unFieldNameHS fieldNameHS + -- | Construct a list of TH Names for the typeclasses of an EntityDef's `entityDerives` mkEntityDefDeriveNames :: MkPersistSettings -> EntityDef -> [Name] mkEntityDefDeriveNames mps entDef = @@ -2047,22 +2114,25 @@ | pkNewtype mps entDef = unKeyName entDef | otherwise = mkName $ T.unpack $ lowerFirst (keyText entDef) `mappend` unFieldNameHS (fieldHaskell fieldDef) -filterConName :: MkPersistSettings - -> EntityDef - -> FieldDef - -> Name +filterConName + :: MkPersistSettings + -> EntityDef + -> FieldDef + -> Name filterConName mps entity field = filterConName' mps (entityHaskell entity) (fieldHaskell field) -filterConName' :: MkPersistSettings - -> EntityNameHS - -> FieldNameHS - -> Name +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 + entityName = unEntityNameHS entity + fieldName = upperFirst $ unFieldNameHS field diff --git a/Database/Persist/Types/Base.hs b/Database/Persist/Types/Base.hs --- a/Database/Persist/Types/Base.hs +++ b/Database/Persist/Types/Base.hs @@ -264,6 +264,7 @@ data FieldType = FTTypeCon (Maybe Text) Text -- ^ Optional module and name. + | FTTypePromoted Text | FTApp FieldType FieldType | FTList FieldType deriving (Show, Eq, Read, Ord, Lift) diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.12.1.1 +version: 2.12.1.2 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/test/Database/Persist/THSpec.hs b/test/Database/Persist/THSpec.hs --- a/test/Database/Persist/THSpec.hs +++ b/test/Database/Persist/THSpec.hs @@ -42,9 +42,10 @@ import Database.Persist.TH import TemplateTestImports -import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpec -import qualified Database.Persist.TH.SharedPrimaryKeyImportedSpec as SharedPrimaryKeyImportedSpec +import qualified Database.Persist.TH.KindEntitiesSpec as KindEntitiesSpec import qualified Database.Persist.TH.OverloadedLabelSpec as OverloadedLabelSpec +import qualified Database.Persist.TH.SharedPrimaryKeyImportedSpec as SharedPrimaryKeyImportedSpec +import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpec share [mkPersist sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] }, mkDeleteCascade sqlSettings { mpsGeneric = False }] [persistUpperCase| @@ -131,6 +132,7 @@ spec :: Spec spec = do + KindEntitiesSpec.spec OverloadedLabelSpec.spec SharedPrimaryKeySpec.spec SharedPrimaryKeyImportedSpec.spec diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -3,23 +3,23 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck import qualified Data.Char as Char -import qualified Data.Text as T import Data.List import Data.List.NonEmpty (NonEmpty(..), (<|)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map +import qualified Data.Text as T +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck #if !MIN_VERSION_base(4,11,0) -- This can be removed when GHC < 8.2.2 isn't supported anymore import Data.Semigroup ((<>)) #endif -import Data.Time -import Text.Shakespeare.Text import Data.Aeson import qualified Data.ByteString.Char8 as BS8 +import Data.Time +import Text.Shakespeare.Text import Database.Persist.Class.PersistField import Database.Persist.Quasi @@ -54,32 +54,36 @@ `shouldBe` ( [NEL.toList helloWorldTokens, NEL.toList foobarbazTokens], mempty ) it "works4" $ do - let foobarbarz = ["foo", "Bar", "baz"] - fbbTokens = Token <$> nonEmptyOrFail foobarbarz splitExtras - [ Line 0 (pure (Token "Hello")) - , Line 2 fbbTokens - , Line 2 fbbTokens + [ Line 0 [Token "Product"] + , Line 2 (Token <$> ["name", "Text"]) + , Line 2 (Token <$> ["added", "UTCTime", "default=CURRENT_TIMESTAMP"]) ] `shouldBe` ( [] , Map.fromList - [ ("Hello", [foobarbarz, foobarbarz]) - ] + [ ("Product", + [ ["name", "Text"] + , ["added", "UTCTime", "default=CURRENT_TIMESTAMP"] + ] + ) ] ) it "works5" $ do - let foobarbarz = ["foo", "Bar", "baz"] - fbbTokens = Token <$> nonEmptyOrFail foobarbarz splitExtras - [ Line 0 (pure (Token "Hello")) - , Line 2 fbbTokens - , Line 4 fbbTokens + [ Line 0 [Token "Product"] + , Line 2 (Token <$> ["name", "Text"]) + , Line 4 [Token "ExtraBlock"] + , Line 4 (Token <$> ["added", "UTCTime", "default=CURRENT_TIMESTAMP"]) ] `shouldBe` ( [] , Map.fromList - [ ("Hello", [foobarbarz, foobarbarz]) - ] + [ ("Product", + [ ["name", "Text"] + , ["ExtraBlock"] + , ["added", "UTCTime", "default=CURRENT_TIMESTAMP"] + ] + )] ) describe "takeColsEx" $ do let subject = takeColsEx upperCaseSettings @@ -140,7 +144,7 @@ it "handles normal words" $ parseLine " foo bar baz" `shouldBe` Just - ( Line 1 $ nonEmptyOrFail + ( Line 1 [ Token "foo" , Token "bar" , Token "baz" @@ -150,7 +154,7 @@ it "handles quotes" $ parseLine " \"foo bar\" \"baz\"" `shouldBe` Just - ( Line 2 $ nonEmptyOrFail + ( Line 2 [ Token "foo bar" , Token "baz" ] @@ -159,7 +163,7 @@ it "handles quotes mid-token" $ parseLine " x=\"foo bar\" \"baz\"" `shouldBe` Just - ( Line 2 $ nonEmptyOrFail + ( Line 2 [ Token "x=foo bar" , Token "baz" ] @@ -168,7 +172,7 @@ it "handles escaped quote mid-token" $ parseLine " x=\\\"foo bar\" \"baz\"" `shouldBe` Just - ( Line 2 $ nonEmptyOrFail + ( Line 2 [ Token "x=\\\"foo" , Token "bar\"" , Token "baz" @@ -178,7 +182,7 @@ it "handles unnested parantheses" $ parseLine " (foo bar) (baz)" `shouldBe` Just - ( Line 2 $ nonEmptyOrFail + ( Line 2 [ Token "foo bar" , Token "baz" ] @@ -187,7 +191,7 @@ it "handles unnested parantheses mid-token" $ parseLine " x=(foo bar) (baz)" `shouldBe` Just - ( Line 2 $ nonEmptyOrFail + ( Line 2 [ Token "x=foo bar" , Token "baz" ] @@ -196,7 +200,7 @@ it "handles nested parantheses" $ parseLine " (foo (bar)) (baz)" `shouldBe` Just - ( Line 2 $ nonEmptyOrFail + ( Line 2 [ Token "foo (bar)" , Token "baz" ] @@ -205,7 +209,7 @@ it "escaping" $ parseLine " (foo \\(bar) y=\"baz\\\"\"" `shouldBe` Just - ( Line 2 $ nonEmptyOrFail + ( Line 2 [ Token "foo (bar" , Token "y=baz\"" ] @@ -214,7 +218,7 @@ it "mid-token quote in later token" $ parseLine "foo bar baz=(bin\")" `shouldBe` Just - ( Line 0 $ nonEmptyOrFail + ( Line 0 [ Token "foo" , Token "bar" , Token "baz=bin\"" @@ -225,13 +229,14 @@ it "recognizes one line" $ do parseLine "-- | this is a comment" `shouldBe` Just - ( Line 0 $ pure - (DocComment "this is a comment") + ( Line 0 + [ DocComment "this is a comment" + ] ) it "works if comment is indented" $ do parseLine " -- | comment" `shouldBe` - Just (Line 2 (pure (DocComment "comment"))) + Just (Line 2 [DocComment "comment"]) describe "parse" $ do let subject = @@ -358,6 +363,28 @@ entityComments car `shouldBe` Just "This is a Car\n" entityComments vehicle `shouldBe` Nothing + describe "ticked types" $ do + it "should be able to parse ticked types" $ do + let simplifyField field = + (fieldHaskell field, fieldType field) + let tickedDefinition = [st| +CustomerTransfer + customerId CustomerId + moneyAmount (MoneyAmount 'Customer 'Debit) + currencyCode CurrencyCode + uuid TransferUuid +|] + let [customerTransfer] = parse lowerCaseSettings tickedDefinition + let expectedType = + FTTypeCon Nothing "MoneyAmount" `FTApp` FTTypePromoted "Customer" `FTApp` FTTypePromoted "Debit" + + (simplifyField <$> entityFields customerTransfer) `shouldBe` + [ (FieldNameHS "customerId", FTTypeCon Nothing "CustomerId") + , (FieldNameHS "moneyAmount", expectedType) + , (FieldNameHS "currencyCode", FTTypeCon Nothing "CurrencyCode") + , (FieldNameHS "uuid", FTTypeCon Nothing "TransferUuid") + ] + describe "parseFieldType" $ do it "simple types" $ parseFieldType "FooBar" `shouldBe` Right (FTTypeCon Nothing "FooBar") @@ -576,10 +603,10 @@ , " name String" ] expected = - 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"] } + Line { lineIndent = 0, tokens = [DocComment "Model"] } :| + [ Line { lineIndent = 0, tokens = [Token "Foo"] } + , Line { lineIndent = 2, tokens = [DocComment "Field"] } + , Line { lineIndent = 2, tokens = (Token <$> ["name", "String"]) } ] preparse text `shouldBe` Just expected @@ -880,12 +907,6 @@ takePrefix :: Value -> Value takePrefix (String a) = String (T.take 1 a) takePrefix a = a - -nonEmptyOrFail :: [a] -> NonEmpty a -nonEmptyOrFail = maybe failure id . NEL.nonEmpty - where - failure = - error "nonEmptyOrFail expected a non empty list" arbitraryWhiteSpaceChar :: Gen Char arbitraryWhiteSpaceChar =