groundhog-th 0.10.2 → 0.11
raw patch · 4 files changed
+26/−19 lines, 4 filesdep ~groundhogPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: groundhog
API changes (from Hackage documentation)
Files
- Database/Groundhog/TH.hs +12/−12
- Database/Groundhog/TH/CodeGen.hs +9/−5
- changelog +3/−0
- groundhog-th.cabal +2/−2
Database/Groundhog/TH.hs view
@@ -296,14 +296,14 @@ notUniqueBy :: Eq b => (a -> b) -> [a] -> [b] notUniqueBy f xs = let xs' = map f xs in nub $ xs' \\ nub xs' -assertUnique :: (Monad m, Eq b, Show b) => (a -> b) -> [a] -> String -> m ()+assertUnique :: (Eq b, Show b) => (a -> b) -> [a] -> String -> Either String () assertUnique f xs what = case notUniqueBy f xs of [] -> return ()- ys -> fail $ "All " ++ what ++ " must be unique: " ++ show ys+ ys -> Left $ "All " ++ what ++ " must be unique: " ++ show ys -- we need to validate datatype names because TH just creates unusable fields with spaces-assertSpaceFree :: Monad m => String -> String -> m ()-assertSpaceFree s what = when (any isSpace s) $ fail $ "Spaces in " ++ what ++ " are not allowed: " ++ show s+assertSpaceFree :: String -> String -> Either String ()+assertSpaceFree s what = when (any isSpace s) $ Left $ "Spaces in " ++ what ++ " are not allowed: " ++ show s validateEntity :: THEntityDef -> Either String THEntityDef validateEntity def = do@@ -318,37 +318,37 @@ mapM_ validateField fields case filter (\(THUniqueDef _ _ uFields) -> null uFields) $ thConstrUniques cdef of [] -> return ()- ys -> fail $ "Constraints must have at least one field: " ++ show ys+ ys -> Left $ "Constraints must have at least one field: " ++ show ys when (isNothing (thDbAutoKeyName cdef) /= isNothing (thAutoKey def)) $- fail $ "Presence of autokey definitions should be the same in entity and constructors definitions " ++ show (thDataName def) ++ ": " ++ show (thDbAutoKeyName cdef) ++ " - " ++ show (thAutoKey def)+ Left $ "Presence of autokey definitions should be the same in entity and constructors definitions " ++ show (thDataName def) ++ ": " ++ show (thDbAutoKeyName cdef) ++ " - " ++ show (thAutoKey def) -- check that unique keys = [] for multiple constructor datatype if length constrs > 1 && not (null $ thUniqueKeys def)- then fail $ "Unique keys may exist only for datatypes with single constructor: " ++ show (thDataName def)+ then Left $ "Unique keys may exist only for datatypes with single constructor: " ++ show (thDataName def) else -- check that all unique keys reference existing uniques let uniqueNames = map thUniqueName $ thConstrUniques $ head constrs in forM_ (thUniqueKeys def) $ \cKey -> unless (thUniqueKeyName cKey `elem` uniqueNames) $- fail $ "Unique key mentions unknown unique: " ++ thUniqueKeyName cKey ++ " in datatype " ++ show (thDataName def)+ Left $ "Unique key mentions unknown unique: " ++ thUniqueKeyName cKey ++ " in datatype " ++ show (thDataName def) let isPrimary x = case x of UniquePrimary _ -> True _ -> False primaryConstraints = length $ filter (isPrimary . thUniqueType) $ concatMap thConstrUniques constrs if length constrs > 1 then when (primaryConstraints > 0) $- fail $ "Custom primary keys may exist only for datatypes with single constructor: " ++ show (thDataName def)+ Left $ "Custom primary keys may exist only for datatypes with single constructor: " ++ show (thDataName def) else when (primaryConstraints + maybe 0 (const 1) (thAutoKey def) > 1) $- fail $ "A datatype cannot have more than one primary key constraint: " ++ show (thDataName def)+ Left $ "A datatype cannot have more than one primary key constraint: " ++ show (thDataName def) -- check that only one of the keys is default let keyDefaults = maybe id ((:) . thAutoKeyIsDef) (thAutoKey def) $ map thUniqueKeyIsDef (thUniqueKeys def) when (not (null keyDefaults) && length (filter id keyDefaults) /= 1) $- fail $ "A datatype with keys must have one default key: " ++ show (thDataName def)+ Left $ "A datatype with keys must have one default key: " ++ show (thDataName def) return def validateField :: THFieldDef -> Either String () validateField fDef = do assertSpaceFree (thExprName fDef) "field expr name" when (isJust (thDbTypeName fDef) && isJust (thEmbeddedDef fDef)) $- fail $ "A field may not have both type and embeddedType: " ++ show (thFieldName fDef)+ Left $ "A field may not have both type and embeddedType: " ++ show (thFieldName fDef) validateEmbedded :: THEmbeddedDef -> Either String THEmbeddedDef validateEmbedded def = do
Database/Groundhog/TH/CodeGen.hs view
@@ -229,7 +229,6 @@ let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) let decs = [toPrim', fromPrim'] sequence [ return $ instanceD' context (AppT (ConT ''PrimitivePersistField) keyType) decs - , return $ instanceD' context (AppT (ConT ''NeverNull) keyType) [] , mkDefaultPurePersistFieldInstance context keyType , mkDefaultSinglePersistFieldInstance context keyType] _ -> return [] @@ -321,7 +320,6 @@ fromPrim' <- funD 'fromPrimitivePersistValue [clause [varP x] (normalB [| $(conE conName) (fromPrimitivePersistValue $(varE x)) |]) []] let decs = [toPrim', fromPrim'] sequence [ return $ instanceD' context (AppT (ConT ''PrimitivePersistField) uniqKeyType) decs - , return $ instanceD' context (AppT (ConT ''NeverNull) uniqKeyType) [] , mkDefaultPurePersistFieldInstance context uniqKeyType , mkDefaultSinglePersistFieldInstance context uniqKeyType] else mkPurePersistFieldInstance uniqKeyType conName (thUniqueKeyFields unique) context @@ -791,7 +789,10 @@ mkTySynInstD :: Name -> [Type] -> Type -> Dec mkTySynInstD name ts t = -#if MIN_VERSION_template_haskell(2, 9, 0) +#if MIN_VERSION_template_haskell(2, 15, 0) + TySynInstD $ TySynEqn Nothing typ t where + typ = foldl AppT (ConT name) ts +#elif MIN_VERSION_template_haskell(2, 9, 0) TySynInstD name $ TySynEqn ts t #else TySynInstD name ts t @@ -823,7 +824,10 @@ dataInstD' :: Cxt -> Name -> [Type] -> [Con] -> [Name] -> InstanceDec dataInstD' cxt name types constrs derives = -#if MIN_VERSION_template_haskell(2, 12, 0) +#if MIN_VERSION_template_haskell(2, 15, 0) + DataInstD cxt Nothing typ Nothing constrs [DerivClause Nothing (map ConT derives)] where + typ = foldl AppT (ConT name) types +#elif MIN_VERSION_template_haskell(2, 12, 0) DataInstD cxt name types Nothing constrs [DerivClause Nothing (map ConT derives)] #elif MIN_VERSION_template_haskell(2, 11, 0) DataInstD cxt name types Nothing constrs (map ConT derives) @@ -847,4 +851,4 @@ #else notStrict' :: Strict notStrict' = NotStrict -#endif+#endif
changelog view
@@ -1,3 +1,6 @@+0.11+* Support for GHC 8.8+ 0.10.2 * Bump yaml to 0.11
groundhog-th.cabal view
@@ -1,5 +1,5 @@ name: groundhog-th-version: 0.10.2+version: 0.11 license: BSD3 license-file: LICENSE author: Boris Lykah <lykahb@gmail.com>@@ -17,7 +17,7 @@ library build-depends: base >= 4 && < 5 , bytestring >= 0.9- , groundhog >= 0.10 && < 0.11+ , groundhog >= 0.11 && < 0.12 , template-haskell , time >= 1.1.4 , containers >= 0.2