groundhog 0.5.0 → 0.5.1
raw patch · 7 files changed
+92/−61 lines, 7 filesdep ~basedep ~blaze-builderdep ~monad-controlPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: base, blaze-builder, monad-control, monad-logger, transformers
API changes (from Hackage documentation)
- Database.Groundhog.Core: instance HasSelectOptions (SelectOptions db r hasLimit hasOffset hasOrder) db r
+ Database.Groundhog.Core: class (Projection p a, ProjectionDb p db, ProjectionRestriction p r) => Projection' p db r a
+ Database.Groundhog.Core: dbSpecificOptions :: SelectOptions db r hasLimit hasOffset hasOrder hasDistinct -> [(String, QueryRaw db r)]
+ Database.Groundhog.Core: distinct :: (HasSelectOptions a db r, HasDistinct a ~ HFalse) => a -> SelectOptions db r (HasLimit a) (HasOffset a) (HasOrder a) HTrue
+ Database.Groundhog.Core: distinctOptions :: SelectOptions db r hasLimit hasOffset hasOrder hasDistinct -> Bool
+ Database.Groundhog.Core: instance (Projection p a, ProjectionDb p db, ProjectionRestriction p r) => Projection' p db r a
+ Database.Groundhog.Core: instance HasSelectOptions (SelectOptions db r hasLimit hasOffset hasOrder hasDistinct) db r
+ Database.Groundhog.Core: instance Ord UniqueType
+ Database.Groundhog.Generic.Migration: getCurrentSchema :: SchemaAnalyzer m => m (Maybe String)
+ Database.Groundhog.Generic.Migration: instance Eq UniqueDef'
+ Database.Groundhog.Generic.Migration: instance Ord UniqueDef'
- Database.Groundhog: limitTo :: (HasSelectOptions a db r, HasLimit a ~ HFalse) => a -> Int -> SelectOptions db r HTrue (HasOffset a) (HasOrder a)
+ Database.Groundhog: limitTo :: (HasSelectOptions a db r, HasLimit a ~ HFalse) => a -> Int -> SelectOptions db r HTrue (HasOffset a) (HasOrder a) (HasDistinct a)
- Database.Groundhog: offsetBy :: (HasSelectOptions a db r, HasOffset a ~ HFalse) => a -> Int -> SelectOptions db r (HasLimit a) HTrue (HasOrder a)
+ Database.Groundhog: offsetBy :: (HasSelectOptions a db r, HasOffset a ~ HFalse) => a -> Int -> SelectOptions db r (HasLimit a) HTrue (HasOrder a) (HasDistinct a)
- Database.Groundhog: orderBy :: (HasSelectOptions a db r, HasOrder a ~ HFalse) => a -> [Order db r] -> SelectOptions db r (HasLimit a) (HasOffset a) HTrue
+ Database.Groundhog: orderBy :: (HasSelectOptions a db r, HasOrder a ~ HFalse) => a -> [Order db r] -> SelectOptions db r (HasLimit a) (HasOffset a) HTrue (HasDistinct a)
- Database.Groundhog: project :: (PersistBackend m, PersistEntity v, EntityConstr v c, Projection p a, ProjectionDb p (PhantomDb m), ProjectionRestriction p (RestrictionHolder v c), HasSelectOptions opts (PhantomDb m) (RestrictionHolder v c)) => p -> opts -> m [a]
+ Database.Groundhog: project :: (PersistBackend m, PersistEntity v, EntityConstr v c, Projection' p (PhantomDb m) (RestrictionHolder v c) a, HasSelectOptions opts (PhantomDb m) (RestrictionHolder v c)) => p -> opts -> m [a]
- Database.Groundhog.Core: SelectOptions :: Cond db r -> Maybe Int -> Maybe Int -> [Order db r] -> SelectOptions db r hasLimit hasOffset hasOrder
+ Database.Groundhog.Core: SelectOptions :: Cond db r -> Maybe Int -> Maybe Int -> [Order db r] -> Bool -> [(String, QueryRaw db r)] -> SelectOptions db r hasLimit hasOffset hasOrder hasDistinct
- Database.Groundhog.Core: UniquePrimary :: UniqueType
+ Database.Groundhog.Core: UniquePrimary :: Bool -> UniqueType
- Database.Groundhog.Core: class HasSelectOptions a db r | a -> db r where type family HasLimit a type family HasOffset a type family HasOrder a
+ Database.Groundhog.Core: class HasSelectOptions a db r | a -> db r where type family HasLimit a type family HasOffset a type family HasOrder a type family HasDistinct a
- Database.Groundhog.Core: condOptions :: SelectOptions db r hasLimit hasOffset hasOrder -> Cond db r
+ Database.Groundhog.Core: condOptions :: SelectOptions db r hasLimit hasOffset hasOrder hasDistinct -> Cond db r
- Database.Groundhog.Core: data SelectOptions db r hasLimit hasOffset hasOrder
+ Database.Groundhog.Core: data SelectOptions db r hasLimit hasOffset hasOrder hasDistinct
- Database.Groundhog.Core: getSelectOptions :: HasSelectOptions a db r => a -> SelectOptions db r (HasLimit a) (HasOffset a) (HasOrder a)
+ Database.Groundhog.Core: getSelectOptions :: HasSelectOptions a db r => a -> SelectOptions db r (HasLimit a) (HasOffset a) (HasOrder a) (HasDistinct a)
- Database.Groundhog.Core: limitOptions :: SelectOptions db r hasLimit hasOffset hasOrder -> Maybe Int
+ Database.Groundhog.Core: limitOptions :: SelectOptions db r hasLimit hasOffset hasOrder hasDistinct -> Maybe Int
- Database.Groundhog.Core: limitTo :: (HasSelectOptions a db r, HasLimit a ~ HFalse) => a -> Int -> SelectOptions db r HTrue (HasOffset a) (HasOrder a)
+ Database.Groundhog.Core: limitTo :: (HasSelectOptions a db r, HasLimit a ~ HFalse) => a -> Int -> SelectOptions db r HTrue (HasOffset a) (HasOrder a) (HasDistinct a)
- Database.Groundhog.Core: offsetBy :: (HasSelectOptions a db r, HasOffset a ~ HFalse) => a -> Int -> SelectOptions db r (HasLimit a) HTrue (HasOrder a)
+ Database.Groundhog.Core: offsetBy :: (HasSelectOptions a db r, HasOffset a ~ HFalse) => a -> Int -> SelectOptions db r (HasLimit a) HTrue (HasOrder a) (HasDistinct a)
- Database.Groundhog.Core: offsetOptions :: SelectOptions db r hasLimit hasOffset hasOrder -> Maybe Int
+ Database.Groundhog.Core: offsetOptions :: SelectOptions db r hasLimit hasOffset hasOrder hasDistinct -> Maybe Int
- Database.Groundhog.Core: orderBy :: (HasSelectOptions a db r, HasOrder a ~ HFalse) => a -> [Order db r] -> SelectOptions db r (HasLimit a) (HasOffset a) HTrue
+ Database.Groundhog.Core: orderBy :: (HasSelectOptions a db r, HasOrder a ~ HFalse) => a -> [Order db r] -> SelectOptions db r (HasLimit a) (HasOffset a) HTrue (HasDistinct a)
- Database.Groundhog.Core: orderOptions :: SelectOptions db r hasLimit hasOffset hasOrder -> [Order db r]
+ Database.Groundhog.Core: orderOptions :: SelectOptions db r hasLimit hasOffset hasOrder hasDistinct -> [Order db r]
- Database.Groundhog.Core: project :: (PersistBackend m, PersistEntity v, EntityConstr v c, Projection p a, ProjectionDb p (PhantomDb m), ProjectionRestriction p (RestrictionHolder v c), HasSelectOptions opts (PhantomDb m) (RestrictionHolder v c)) => p -> opts -> m [a]
+ Database.Groundhog.Core: project :: (PersistBackend m, PersistEntity v, EntityConstr v c, Projection' p (PhantomDb m) (RestrictionHolder v c) a, HasSelectOptions opts (PhantomDb m) (RestrictionHolder v c)) => p -> opts -> m [a]
- Database.Groundhog.Generic.Migration: class Monad m => SchemaAnalyzer m
+ Database.Groundhog.Generic.Migration: class (Applicative m, Monad m) => SchemaAnalyzer m
- Database.Groundhog.Generic.Migration: defaultMigConstr :: (Monad m, SchemaAnalyzer m) => MigrationPack m -> EntityDef -> ConstructorDef -> m (Bool, SingleMigration)
+ Database.Groundhog.Generic.Migration: defaultMigConstr :: SchemaAnalyzer m => MigrationPack m -> EntityDef -> ConstructorDef -> m (Bool, SingleMigration)
- Database.Groundhog.Generic.Migration: migrateEntity :: (Monad m, SchemaAnalyzer m) => MigrationPack m -> EntityDef -> m SingleMigration
+ Database.Groundhog.Generic.Migration: migrateEntity :: SchemaAnalyzer m => MigrationPack m -> EntityDef -> m SingleMigration
- Database.Groundhog.Generic.Migration: migrateList :: (Monad m, SchemaAnalyzer m) => MigrationPack m -> DbType -> m SingleMigration
+ Database.Groundhog.Generic.Migration: migrateList :: SchemaAnalyzer m => MigrationPack m -> DbType -> m SingleMigration
- Database.Groundhog.Generic.Migration: migrateSchema :: (Monad m, SchemaAnalyzer m) => MigrationPack m -> String -> m SingleMigration
+ Database.Groundhog.Generic.Migration: migrateSchema :: SchemaAnalyzer m => MigrationPack m -> String -> m SingleMigration
- Database.Groundhog.Generic.PersistBackendHelpers: project :: (SqlDb db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c, Projection p a', ProjectionDb p db, ProjectionRestriction p r, HasSelectOptions opts db r) => RenderConfig -> (forall a. Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Utf8 -> p -> opts -> m [a']
+ Database.Groundhog.Generic.PersistBackendHelpers: project :: (SqlDb db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c, Projection p a', ProjectionDb p db, ProjectionRestriction p r, HasSelectOptions opts db r) => RenderConfig -> (forall a. Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> (opts -> RenderS db r) -> Utf8 -> p -> opts -> m [a']
- Database.Groundhog.Generic.PersistBackendHelpers: select :: (SqlDb db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c, HasSelectOptions opts db r) => RenderConfig -> (forall a. Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Utf8 -> opts -> m [v]
+ Database.Groundhog.Generic.PersistBackendHelpers: select :: (SqlDb db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c, HasSelectOptions opts db r) => RenderConfig -> (forall a. Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> (opts -> RenderS db r) -> Utf8 -> opts -> m [v]
Files
- Database/Groundhog/Core.hs +42/−25
- Database/Groundhog/Generic/Migration.hs +26/−21
- Database/Groundhog/Generic/PersistBackendHelpers.hs +10/−8
- Database/Groundhog/Generic/Sql.hs +2/−0
- Database/Groundhog/Generic/Sql/Functions.hs +1/−1
- changelog +5/−0
- groundhog.cabal +6/−6
Database/Groundhog/Core.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs, TypeFamilies, ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, EmptyDataDecls, ConstraintKinds #-}+{-# LANGUAGE UndecidableInstances #-} -- Required for Projection' -- | This module defines the functions and datatypes used throughout the framework. -- Most of them are for the internal use module Database.Groundhog.Core@@ -12,6 +13,7 @@ , PrimitivePersistField(..) , Embedded(..) , Projection(..)+ , Projection' , RestrictionHolder , Unique , KeyForBackend(..)@@ -44,6 +46,7 @@ , limitTo , offsetBy , orderBy+ , distinct -- * Type description , DbTypePrimitive(..) , DbType(..)@@ -147,11 +150,11 @@ data ExprRelation = Eq | Ne | Gt | Lt | Ge | Le deriving Show -data Update db r = forall f a . (Assignable f a, ProjectionDb f db, ProjectionRestriction f r) => Update f (UntypedExpr db r)+data Update db r = forall f a . (Assignable f a, Projection' f db r a) => Update f (UntypedExpr db r) -- | Defines sort order of a result-set-data Order db r = forall a f . (Projection f a, ProjectionDb f db, ProjectionRestriction f r) => Asc f- | forall a f . (Projection f a, ProjectionDb f db, ProjectionRestriction f r) => Desc f+data Order db r = forall a f . (Projection' f db r a) => Asc f+ | forall a f . (Projection' f db r a) => Desc f -- | It is used to map field to column names. It can be either a column name for a regular field of non-embedded type or a list of this field and the outer fields in reverse order. Eg, fieldChain $ SomeField ~> Tuple2_0Selector may result in [(\"val0\", DbString), (\"some\", DbEmbedded False [dbType \"\", dbType True])]. type FieldChain = ((String, DbType), [(String, EmbeddedDef)])@@ -165,6 +168,9 @@ -- | It is like 'fromPersistValues'. However, we cannot use it for projections in all cases. For the 'PersistEntity' instances 'fromPersistValues' expects entity id instead of the entity values. projectionResult :: PersistBackend m => p -> [PersistValue] -> m (a, [PersistValue]) +class (Projection p a, ProjectionDb p db, ProjectionRestriction p r) => Projection' p db r a+instance (Projection p a, ProjectionDb p db, ProjectionRestriction p r) => Projection' p db r a+ -- | This subset of Projection instances is for things that behave like fields. Namely, they can occur in condition expressions (for example, Field and SubField) and on the left side of update statements. For example \"lower(field)\" is a valid Projection, but not Field like because it cannot be on the left side. Datatypes that index PostgreSQL arrays \"arr[5]\" or access composites \"(comp).subfield\" are valid instances of Assignable. class Projection f a => Assignable f a | f -> a @@ -194,11 +200,15 @@ data RestrictionHolder v (c :: (* -> *) -> *) -data SelectOptions db r hasLimit hasOffset hasOrder = SelectOptions {- condOptions :: Cond db r- , limitOptions :: Maybe Int- , offsetOptions :: Maybe Int- , orderOptions :: [Order db r]+data SelectOptions db r hasLimit hasOffset hasOrder hasDistinct = SelectOptions {+ condOptions :: Cond db r+ , limitOptions :: Maybe Int+ , offsetOptions :: Maybe Int+ , orderOptions :: [Order db r]+ -- ^ False - no DISTINCT, True - DISTINCT+ , distinctOptions :: Bool+ -- ^ The name of the option and part of the SQL which will be put later+ , dbSpecificOptions :: [(String, QueryRaw db r)] } -- | This class helps to check that limit, offset, or order clauses are added to condition only once.@@ -206,32 +216,36 @@ type HasLimit a type HasOffset a type HasOrder a- getSelectOptions :: a -> SelectOptions db r (HasLimit a) (HasOffset a) (HasOrder a)+ type HasDistinct a+ getSelectOptions :: a -> SelectOptions db r (HasLimit a) (HasOffset a) (HasOrder a) (HasDistinct a) instance HasSelectOptions (Cond db r) db r where type HasLimit (Cond db r) = HFalse type HasOffset (Cond db r) = HFalse type HasOrder (Cond db r) = HFalse- getSelectOptions a = SelectOptions a Nothing Nothing []+ type HasDistinct (Cond db r) = HFalse+ getSelectOptions a = SelectOptions a Nothing Nothing [] False [] -instance HasSelectOptions (SelectOptions db r hasLimit hasOffset hasOrder) db r where- type HasLimit (SelectOptions db r hasLimit hasOffset hasOrder) = hasLimit- type HasOffset (SelectOptions db r hasLimit hasOffset hasOrder) = hasOffset- type HasOrder (SelectOptions db r hasLimit hasOffset hasOrder) = hasOrder+instance HasSelectOptions (SelectOptions db r hasLimit hasOffset hasOrder hasDistinct) db r where+ type HasLimit (SelectOptions db r hasLimit hasOffset hasOrder hasDistinct) = hasLimit+ type HasOffset (SelectOptions db r hasLimit hasOffset hasOrder hasDistinct) = hasOffset+ type HasOrder (SelectOptions db r hasLimit hasOffset hasOrder hasDistinct) = hasOrder+ type HasDistinct (SelectOptions db r hasLimit hasOffset hasOrder hasDistinct) = hasDistinct getSelectOptions = id -limitTo :: (HasSelectOptions a db r, HasLimit a ~ HFalse) => a -> Int -> SelectOptions db r HTrue (HasOffset a) (HasOrder a)-limitTo opts lim = case getSelectOptions opts of- SelectOptions c _ off ord -> SelectOptions c (Just lim) off ord+limitTo :: (HasSelectOptions a db r, HasLimit a ~ HFalse) => a -> Int -> SelectOptions db r HTrue (HasOffset a) (HasOrder a) (HasDistinct a)+limitTo opts lim = (getSelectOptions opts) {limitOptions = Just lim} -offsetBy :: (HasSelectOptions a db r, HasOffset a ~ HFalse) => a -> Int -> SelectOptions db r (HasLimit a) HTrue (HasOrder a)-offsetBy opts off = case getSelectOptions opts of- SelectOptions c lim _ ord -> SelectOptions c lim (Just off) ord+offsetBy :: (HasSelectOptions a db r, HasOffset a ~ HFalse) => a -> Int -> SelectOptions db r (HasLimit a) HTrue (HasOrder a) (HasDistinct a)+offsetBy opts off = (getSelectOptions opts) {offsetOptions = Just off} -orderBy :: (HasSelectOptions a db r, HasOrder a ~ HFalse) => a -> [Order db r] -> SelectOptions db r (HasLimit a) (HasOffset a) HTrue-orderBy opts ord = case getSelectOptions opts of- SelectOptions c lim off _ -> SelectOptions c lim off ord+orderBy :: (HasSelectOptions a db r, HasOrder a ~ HFalse) => a -> [Order db r] -> SelectOptions db r (HasLimit a) (HasOffset a) HTrue (HasDistinct a)+orderBy opts ord = (getSelectOptions opts) {orderOptions = ord} +-- | Select DISTINCT rows. @select $ distinct CondEmpty@+distinct :: (HasSelectOptions a db r, HasDistinct a ~ HFalse) => a -> SelectOptions db r (HasLimit a) (HasOffset a) (HasOrder a) HTrue+distinct opts = (getSelectOptions opts) {distinctOptions = True}+ newtype DbPersist conn m a = DbPersist { unDbPersist :: ReaderT conn m a } deriving (Monad, MonadIO, Functor, Applicative, MonadTrans, MonadReader conn) @@ -301,7 +315,7 @@ -- | Count total number of records with all constructors. The entity parameter is used only for type inference countAll :: PersistEntity v => v -> m Int -- | Fetch projection of some fields. Example: @project (SecondField, ThirdField) $ (FirstField ==. \"abc\" &&. SecondField >. \"def\") \`orderBy\` [Asc ThirdField] \`offsetBy\` 100@- project :: (PersistEntity v, EntityConstr v c, Projection p a, ProjectionDb p (PhantomDb m), ProjectionRestriction p (RestrictionHolder v c), HasSelectOptions opts (PhantomDb m) (RestrictionHolder v c))+ project :: (PersistEntity v, EntityConstr v c, Projection' p (PhantomDb m) (RestrictionHolder v c) a, HasSelectOptions opts (PhantomDb m) (RestrictionHolder v c)) => p -> opts -> m [a]@@ -385,7 +399,10 @@ } deriving (Show, Eq) -- | Defines how to treat the unique set of fields for a datatype-data UniqueType = UniqueConstraint | UniqueIndex | UniquePrimary deriving (Show, Eq)+data UniqueType = UniqueConstraint+ | UniqueIndex+ | UniquePrimary Bool -- ^ is autoincremented+ deriving (Show, Eq, Ord) data ReferenceActionType = NoAction | Restrict
Database/Groundhog/Generic/Migration.hs view
@@ -25,6 +25,7 @@ import Database.Groundhog.Generic import Database.Groundhog.Generic.Sql (mainTableName, tableName) +import Control.Applicative (Applicative) import Control.Arrow ((***), (&&&)) import Control.Monad (liftM, when) import Control.Monad.Trans.Class (lift)@@ -89,7 +90,7 @@ uniqueDefName :: Maybe String , uniqueDefType :: UniqueType , uniqueDefColumns :: [String]-} deriving Show+} deriving (Show, Eq, Ord) data MigrationPack m = MigrationPack { compareTypes :: DbTypePrimitive -> DbTypePrimitive -> Bool@@ -178,19 +179,19 @@ when (v == Nothing) $ lift mig >>= modify . Map.insert name >> cont -migrateSchema :: (Monad m, SchemaAnalyzer m) => MigrationPack m -> String -> m SingleMigration+migrateSchema :: SchemaAnalyzer m => MigrationPack m -> String -> m SingleMigration migrateSchema MigrationPack{..} schema = do x <- schemaExists schema return $ if x then Right [] else showAlterDb $ CreateSchema schema False -migrateEntity :: (Monad m, SchemaAnalyzer m) => MigrationPack m -> EntityDef -> m SingleMigration+migrateEntity :: SchemaAnalyzer m => MigrationPack m -> EntityDef -> m SingleMigration migrateEntity m@MigrationPack{..} e = do let name = entityName e constrs = constructors e mainTableQuery = "CREATE TABLE " ++ escape name ++ " (" ++ mainTableId ++ " " ++ primaryKeyTypeName ++ ", discr INTEGER NOT NULL)"- expectedMainStructure = TableInfo [Column "id" False DbAutoKey Nothing, Column "discr" False DbInt32 Nothing] [UniqueDef' Nothing UniquePrimary ["id"]] []+ expectedMainStructure = TableInfo [Column "id" False DbAutoKey Nothing, Column "discr" False DbInt32 Nothing] [UniqueDef' Nothing (UniquePrimary True) ["id"]] [] if isSimple constrs then do@@ -222,12 +223,12 @@ in mergeMigrations $ Right updateDiscriminators: map snd res else Left ["Unexpected structure of main table for Datatype: " ++ name ++ ". Table info: " ++ show mainStructure'] -migrateList :: (Monad m, SchemaAnalyzer m) => MigrationPack m -> DbType -> m SingleMigration+migrateList :: SchemaAnalyzer m => MigrationPack m -> DbType -> m SingleMigration migrateList m@MigrationPack{..} (DbList mainName t) = do let valuesName = mainName ++ delim : "values" (valueCols, valueRefs) = (($ []) . mkColumns) &&& mkReferences $ ("value", t) refs' = Reference Nothing mainName [("id", "id")] (Just Cascade) Nothing : valueRefs- expectedMainStructure = TableInfo [Column "id" False DbAutoKey Nothing] [UniqueDef' Nothing UniquePrimary ["id"]] []+ expectedMainStructure = TableInfo [Column "id" False DbAutoKey Nothing] [UniqueDef' Nothing (UniquePrimary True) ["id"]] [] mainQuery = "CREATE TABLE " ++ escape mainName ++ " (id " ++ primaryKeyTypeName ++ ")" (addInCreate, addInAlters) = addUniquesReferences [] refs' expectedValuesStructure = TableInfo valueColumns [] (map (\x -> (Nothing, x)) refs')@@ -261,7 +262,7 @@ (oldOnlyColumns, newOnlyColumns, commonColumns) = matchElements ((==) `on` colName) oldColumns newColumns (oldOnlyUniques, newOnlyUniques, commonUniques) = matchElements compareUniqs oldUniques newUniques (oldOnlyRefs, newOnlyRefs, _) = matchElements compareRefs oldRefs newRefs- primaryColumns = concatMap uniqueDefColumns $ filter ((== UniquePrimary) . uniqueDefType) oldUniques+ primaryColumns = concatMap uniqueDefColumns $ filter ((== UniquePrimary True) . uniqueDefType) oldUniques colAlters = mapMaybe (\(a, b) -> mkAlterColumn b $ migrateColumn m a b) (filter ((`notElem` primaryColumns) . colName . fst) commonColumns) mkAlterColumn col alters = if null alters then Nothing else Just $ AlterColumn col alters@@ -300,10 +301,10 @@ dropUnique (UniqueDef' name typ _) = (case typ of UniqueConstraint -> DropConstraint name' UniqueIndex -> DropIndex name'- UniquePrimary -> DropConstraint name') where+ UniquePrimary _ -> DropConstraint name') where name' = fromMaybe (error $ "dropUnique: constraint which should be dropped does not have a name") name -defaultMigConstr :: (Monad m, SchemaAnalyzer m) => MigrationPack m -> EntityDef -> ConstructorDef -> m (Bool, SingleMigration)+defaultMigConstr :: SchemaAnalyzer m => MigrationPack m -> EntityDef -> ConstructorDef -> m (Bool, SingleMigration) defaultMigConstr migPack@MigrationPack{..} e constr = do let simple = isSimple $ constructors e name = entityName e@@ -314,23 +315,23 @@ (triggerExisted, delTrigger) <- migTriggerOnDelete schema cName dels updTriggers <- liftM (concatMap snd) $ migTriggerOnUpdate schema cName dels - let (columns, refs) = foldr mkColumns [] &&& concatMap mkReferences $ constrParams constr- (expectedTableStructure, (addTable, addInAlters)) = case constrAutoKeyName constr of+ let (expectedTableStructure, (addTable, addInAlters)) = (case constrAutoKeyName constr of Nothing -> (TableInfo columns uniques (mkRefs refs), f [] columns uniques refs) Just keyName -> let keyColumn = Column keyName False DbAutoKey Nothing in if simple- then (TableInfo (keyColumn:columns) (uniques ++ [UniqueDef' Nothing UniquePrimary [keyName]]) (mkRefs refs)+ then (TableInfo (keyColumn:columns) (uniques ++ [UniqueDef' Nothing (UniquePrimary True) [keyName]]) (mkRefs refs) , f [escape keyName ++ " " ++ primaryKeyTypeName] columns uniques refs) else let columns' = keyColumn:columns refs' = refs ++ [Reference schema name [(keyName, mainTableId)] (Just Cascade) Nothing] uniques' = uniques ++ [UniqueDef' Nothing UniqueConstraint [keyName]]- in (TableInfo columns' uniques' (mkRefs refs'), f [] columns' uniques' refs')- uniques = map (\(UniqueDef uName uType cols) -> UniqueDef' (Just uName) uType (map colName $ foldr mkColumns [] cols)) $ constrUniques constr- f autoKey cols uniqs refs' = (addTable', addInAlters') where- (addInCreate, addInAlters') = addUniquesReferences uniqs refs'- items = autoKey ++ map showColumn cols ++ addInCreate- addTable' = "CREATE TABLE " ++ tableName escape e constr ++ " (" ++ intercalate ", " items ++ ")"- mkRefs = map (\r -> (Nothing, r))+ in (TableInfo columns' uniques' (mkRefs refs'), f [] columns' uniques' refs')) where+ (columns, refs) = foldr mkColumns [] &&& concatMap mkReferences $ constrParams constr+ uniques = map (\(UniqueDef uName uType cols) -> UniqueDef' (Just uName) uType (map colName $ foldr mkColumns [] cols)) $ constrUniques constr+ f autoKey cols uniqs refs' = (addTable', addInAlters') where+ (addInCreate, addInAlters') = addUniquesReferences uniqs refs'+ items = autoKey ++ map showColumn cols ++ addInCreate+ addTable' = "CREATE TABLE " ++ tableName escape e constr ++ " (" ++ intercalate ", " items ++ ")"+ mkRefs = map (\r -> (Nothing, r)) (migErrs, constrExisted, mig) = case tableStructure of Nothing -> let@@ -338,7 +339,10 @@ in ([], False, [AddTable addTable, rest]) Just oldTableStructure -> let alters = getAlters migPack oldTableStructure expectedTableStructure- in ([], True, [AlterTable schema cName addTable oldTableStructure expectedTableStructure alters])+ alterTable = if null alters+ then []+ else [AlterTable schema cName addTable oldTableStructure expectedTableStructure alters]+ in ([], True, alterTable) -- this can happen when an ephemeral field was added. Consider doing something else except throwing an error allErrs = if constrExisted == triggerExisted || (constrExisted && null dels) then migErrs@@ -370,9 +374,10 @@ "SET DEFAULT" -> Just SetDefault _ -> Nothing -class Monad m => SchemaAnalyzer m where+class (Applicative m, Monad m) => SchemaAnalyzer m where schemaExists :: String -- ^ Schema name -> m Bool+ getCurrentSchema :: m (Maybe String) listTables :: Maybe String -- ^ Schema name -> m [String] listTableTriggers :: Maybe String -- ^ Schema name
Database/Groundhog/Generic/PersistBackendHelpers.hs view
@@ -62,9 +62,9 @@ Nothing -> return Nothing select :: forall m db r v c opts . (SqlDb db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c, HasSelectOptions opts db r)- => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Utf8 -> opts -> m [v]-select conf@RenderConfig{..} queryFunc noLimit options = doSelectQuery where- SelectOptions cond limit offset ords = getSelectOptions options+ => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> (opts -> RenderS db r) -> Utf8 -> opts -> m [v]+select conf@RenderConfig{..} queryFunc preColumns noLimit options = doSelectQuery where+ SelectOptions cond limit offset ords dist _ = getSelectOptions options e = entityDef (undefined :: v) proxy = undefined :: proxy (PhantomDb m)@@ -76,7 +76,8 @@ (l, o) -> RenderS " LIMIT ? OFFSET ?" (toPurePersistValues proxy (l, o)) cond' = renderCond conf cond fields = RenderS (renderFields esc (constrParams constr)) id- RenderS query binds = "SELECT " <> fields <> " FROM " <> RenderS (tableName esc e constr) id <> whereClause <> orders <> lim+ distinctClause = if dist then "DISTINCT " else mempty+ RenderS query binds = "SELECT " <> distinctClause <> preColumns options <> fields <> " FROM " <> RenderS (tableName esc e constr) id <> whereClause <> orders <> lim whereClause = maybe "" (" WHERE " <>) cond' doSelectQuery = queryFunc query (binds []) $ mapAllRows $ liftM fst . fromEntityPersistValues . (toPrimitivePersistValue proxy cNum:) cNum = entityConstrNum (undefined :: proxy v) (undefined :: c a)@@ -118,9 +119,9 @@ Nothing -> return Nothing project :: forall m db r v c p opts a'. (SqlDb db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v c, Projection p a', ProjectionDb p db, ProjectionRestriction p r, HasSelectOptions opts db r)- => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Utf8 -> p -> opts -> m [a']-project conf@RenderConfig{..} queryFunc noLimit p options = doSelectQuery where- SelectOptions cond limit offset ords = getSelectOptions options+ => RenderConfig -> (forall a . Utf8 -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> (opts -> RenderS db r) -> Utf8 -> p -> opts -> m [a']+project conf@RenderConfig{..} queryFunc preColumns noLimit p options = doSelectQuery where+ SelectOptions cond limit offset ords dist _ = getSelectOptions options e = entityDef (undefined :: v) proxy = undefined :: proxy (PhantomDb m) orders = renderOrders conf ords@@ -132,7 +133,8 @@ cond' = renderCond conf cond chains = projectionExprs p [] fields = commasJoin $ concatMap (renderExprExtended conf 0) chains- RenderS query binds = "SELECT " <> fields <> " FROM " <> RenderS (tableName esc e constr) id <> whereClause <> orders <> lim+ distinctClause = if dist then "DISTINCT " else mempty+ RenderS query binds = "SELECT " <> distinctClause <> preColumns options <> fields <> " FROM " <> RenderS (tableName esc e constr) id <> whereClause <> orders <> lim whereClause = maybe "" (" WHERE " <>) cond' doSelectQuery = queryFunc query (binds []) $ mapAllRows $ liftM fst . projectionResult p constr = constructors e !! entityConstrNum (undefined :: proxy v) (undefined :: c a)
Database/Groundhog/Generic/Sql.hs view
@@ -186,6 +186,7 @@ renderCondPriority conf@RenderConfig{..} priority cond = go cond priority where go (And a b) p = perhaps andP p " AND " a b go (Or a b) p = perhaps orP p " OR " a b+ go (Not CondEmpty) _ = Just "(1=0)" -- special case for False go (Not a) p = fmap (\a' -> parens notP p $ "NOT " <> a') $ go a notP go (Compare compOp f1 f2) p = (case compOp of Eq -> renderComp andP " AND " 37 equalsOperator f1 f2@@ -206,6 +207,7 @@ [a] -> Just a _ -> error "renderCond: cannot render CondRaw with many elements" go CondEmpty _ = Nothing+ notP = 35 andP = 30 orP = 20
Database/Groundhog/Generic/Sql/Functions.hs view
@@ -25,7 +25,7 @@ in_ :: (SqlDb db, Expression db r a, Expression db r b, PrimitivePersistField b, Unifiable a b) => a -> [b] -> Cond db r-in_ _ [] = CondEmpty+in_ _ [] = Not CondEmpty in_ a bs = CondRaw $ Snippet $ \conf p -> [parens 45 p $ renderExpr conf (toExpr a) <> " IN (" <> commasJoin (map (renderExpr conf . toExpr) bs) <> ")"] notIn_ :: (SqlDb db, Expression db r a, Expression db r b, PrimitivePersistField b, Unifiable a b) =>
changelog view
@@ -1,3 +1,8 @@+0.5.1+* DISTINCT select option+* Support entities with no fields+* Add getCurrentSchema function into SchemaAnalyzer+ 0.5.0 * Reimplemented projections with constraint kinds * Moved QueryRaw constraint into class SqlDb simplifying SQL function signatures
groundhog.cabal view
@@ -1,5 +1,5 @@ name: groundhog-version: 0.5.0+version: 0.5.1 license: BSD3 license-file: LICENSE author: Boris Lykah <lykahb@gmail.com>@@ -16,16 +16,16 @@ changelog library- build-depends: base >= 4 && < 5+ build-depends: base >= 4 && < 5 , bytestring >= 0.9- , transformers >= 0.2.1+ , transformers >= 0.2.1 && < 0.5 , mtl >= 2.0 , time >= 1.1.4 , text >= 0.8- , blaze-builder >= 0.3.0.0+ , blaze-builder >= 0.3.0.0 && < 0.4 , containers >= 0.2- , monad-control >= 0.3- , monad-logger >= 0.3+ , monad-control >= 0.3 && < 0.4+ , monad-logger >= 0.3 && < 0.4 , transformers-base exposed-modules: Database.Groundhog Database.Groundhog.Core