diff --git a/Database/Beam/Backend/SQL/AST.hs b/Database/Beam/Backend/SQL/AST.hs --- a/Database/Beam/Backend/SQL/AST.hs +++ b/Database/Beam/Backend/SQL/AST.hs @@ -117,6 +117,7 @@ data Delete = Delete { deleteTable :: Text + , deleteAlias :: Maybe Text , deleteWhere :: Maybe Expression } deriving (Show, Eq) @@ -124,6 +125,7 @@ type Sql92DeleteExpressionSyntax Delete = Expression deleteStmt = Delete + deleteSupportsAlias _ = True data FieldName = QualifiedField Text Text diff --git a/Database/Beam/Backend/SQL/Builder.hs b/Database/Beam/Backend/SQL/Builder.hs --- a/Database/Beam/Backend/SQL/Builder.hs +++ b/Database/Beam/Backend/SQL/Builder.hs @@ -162,10 +162,13 @@ instance IsSql92DeleteSyntax SqlSyntaxBuilder where type Sql92DeleteExpressionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder - deleteStmt tbl where_ = + deleteStmt tbl alias where_ = SqlSyntaxBuilder $ byteString "DELETE FROM " <> quoteSql tbl <> + maybe mempty (\alias_ -> byteString " AS " <> quoteSql alias_) alias <> maybe mempty (\where_ -> byteString " WHERE " <> buildSql where_) where_ + + deleteSupportsAlias _ = True instance IsSql92FieldNameSyntax SqlSyntaxBuilder where qualifiedField a b = diff --git a/Database/Beam/Backend/SQL/SQL92.hs b/Database/Beam/Backend/SQL/SQL92.hs --- a/Database/Beam/Backend/SQL/SQL92.hs +++ b/Database/Beam/Backend/SQL/SQL92.hs @@ -151,9 +151,13 @@ IsSql92DeleteSyntax delete where type Sql92DeleteExpressionSyntax delete :: * - deleteStmt :: Text + deleteStmt :: Text -> Maybe Text -> Maybe (Sql92DeleteExpressionSyntax delete) -> delete + + -- | Whether or not the @DELETE@ command supports aliases + deleteSupportsAlias :: Proxy delete -> Bool + deleteSupportsAlias _ = False -- Delete aliases are a non-standard feature class IsSql92FieldNameSyntax fn where qualifiedField :: Text -> Text -> fn diff --git a/Database/Beam/Query.hs b/Database/Beam/Query.hs --- a/Database/Beam/Query.hs +++ b/Database/Beam/Query.hs @@ -352,16 +352,23 @@ newtype SqlDelete syntax (table :: (* -> *) -> *) = SqlDelete syntax -- | Build a 'SqlDelete' from a table and a way to build a @WHERE@ clause -delete :: IsSql92DeleteSyntax delete +delete :: forall be db delete table + . IsSql92DeleteSyntax delete => DatabaseEntity be db (TableEntity table) -- ^ Table to delete from -> (forall s. (forall s'. table (QExpr (Sql92DeleteExpressionSyntax delete) s')) -> QExpr (Sql92DeleteExpressionSyntax delete) s Bool) -- ^ Build a @WHERE@ clause given a table containing expressions -> SqlDelete delete table delete (DatabaseEntity (DatabaseTable tblNm tblSettings)) mkWhere = - SqlDelete (deleteStmt tblNm (Just (where_ "t"))) + SqlDelete (deleteStmt tblNm alias (Just (where_ "t"))) where - QExpr where_ = mkWhere (changeBeamRep (\(Columnar' (TableField name)) -> Columnar' (QExpr (pure (fieldE (unqualifiedField name))))) tblSettings) + supportsAlias = deleteSupportsAlias (Proxy @delete) + + tgtName = "delete_target" + alias = if supportsAlias then Just tgtName else Nothing + mkField = if supportsAlias then qualifiedField tgtName else unqualifiedField + + QExpr where_ = mkWhere (changeBeamRep (\(Columnar' (TableField name)) -> Columnar' (QExpr (pure (fieldE (mkField name))))) tblSettings) -- | Run a 'SqlDelete' in a 'MonadBeam' runDelete :: (IsSql92Syntax cmd, MonadBeam cmd be hdl m) diff --git a/Database/Beam/Schema/Tables.hs b/Database/Beam/Schema/Tables.hs --- a/Database/Beam/Schema/Tables.hs +++ b/Database/Beam/Schema/Tables.hs @@ -477,9 +477,16 @@ to' :: Generic x => Rep x () -> x to' = to -type HasBeamFields table f g h = ( GZipTables f g h (Rep (table Exposed)) (Rep (table f)) (Rep (table g)) (Rep (table h)) - , Generic (table f), Generic (table g), Generic (table h) ) +type HasBeamFields table f g h = ( GZipTables f g h (Rep (table Exposed)) + (Rep (table f)) + (Rep (table g)) + (Rep (table h)) + , Generic (table f) + , Generic (table g) + , Generic (table h) + ) + -- | The big Kahuna! All beam tables implement this class. -- -- The kind of all table types is '(* -> *) -> *'. This is because all table types are actually /table type constructors/. @@ -531,15 +538,24 @@ class Beamable table where zipBeamFieldsM :: Applicative m => (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) -> table f -> table g -> m (table h) + default zipBeamFieldsM :: ( HasBeamFields table f g h - , Applicative m ) => - (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) -> table f -> table g -> m (table h) + , Applicative m + + ) => (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) + -> table f + -> table g + -> m (table h) + zipBeamFieldsM combine (f :: table f) g = to' <$> gZipTables (Proxy :: Proxy (Rep (table Exposed))) combine (from' f) (from' g) tblSkeleton :: TableSkeleton table + default tblSkeleton :: ( Generic (TableSkeleton table) - , GTableSkeleton (Rep (TableSkeleton table)) ) => TableSkeleton table + , GTableSkeleton (Rep (TableSkeleton table)) + ) => TableSkeleton table + tblSkeleton = withProxy $ \proxy -> to' (gTblSkeleton proxy) where withProxy :: (Proxy (Rep (TableSkeleton table)) -> TableSkeleton table) -> TableSkeleton table withProxy f = f Proxy @@ -700,45 +716,62 @@ withProxy f = f Proxy class GZipTables f g h (exposedRep :: * -> *) fRep gRep hRep where - gZipTables :: Applicative m => Proxy exposedRep -> (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) -> fRep () -> gRep () -> m (hRep ()) + gZipTables :: Applicative m => Proxy exposedRep + -> (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) + -> fRep () + -> gRep () + -> m (hRep ()) + instance ( GZipTables f g h exp1 f1 g1 h1 - , GZipTables f g h exp2 f2 g2 h2) => - GZipTables f g h (exp1 :*: exp2) (f1 :*: f2) (g1 :*: g2) (h1 :*: h2) where + , GZipTables f g h exp2 f2 g2 h2 + ) => GZipTables f g h (exp1 :*: exp2) (f1 :*: f2) (g1 :*: g2) (h1 :*: h2) + where gZipTables _ combine ~(f1 :*: f2) ~(g1 :*: g2) = (:*:) <$> gZipTables (Proxy :: Proxy exp1) combine f1 g1 <*> gZipTables (Proxy :: Proxy exp2) combine f2 g2 + instance GZipTables f g h exp fRep gRep hRep => GZipTables f g h (M1 x y exp) (M1 x y fRep) (M1 x y gRep) (M1 x y hRep) where gZipTables _ combine ~(M1 f) ~(M1 g) = M1 <$> gZipTables (Proxy :: Proxy exp) combine f g + instance ( fa ~ Columnar f a , ga ~ Columnar g a + , ha ~ Columnar h a , ha ~ Columnar h a) => GZipTables f g h (K1 Generic.R (Exposed a)) (K1 Generic.R fa) (K1 Generic.R ga) (K1 Generic.R ha) where gZipTables _ combine ~(K1 f) ~(K1 g) = (\(Columnar' h) -> K1 h) <$> combine (Columnar' f :: Columnar' f a) (Columnar' g :: Columnar' g a) -instance ( Generic (tbl f) - , Generic (tbl g) - , Generic (tbl h) - , GZipTables f g h (Rep (tbl Exposed)) (Rep (tbl f)) (Rep (tbl g)) (Rep (tbl h))) => - GZipTables f g h (K1 Generic.R (tbl Exposed)) (K1 Generic.R (tbl f)) (K1 Generic.R (tbl g)) (K1 Generic.R (tbl h)) where - gZipTables _ combine ~(K1 f) ~(K1 g) = K1 . to' <$> gZipTables (Proxy :: Proxy (Rep (tbl Exposed))) combine (from' f) (from' g) +instance ( Beamable tbl + ) => GZipTables f g h (K1 Generic.R (tbl Exposed)) (K1 Generic.R (tbl f)) + (K1 Generic.R (tbl g)) + (K1 Generic.R (tbl h)) + where + gZipTables _ combine ~(K1 f) ~(K1 g) = K1 <$> zipBeamFieldsM combine f g + instance GZipTables f g h U1 U1 U1 U1 where gZipTables _ _ _ _ = pure U1 -instance ( Generic (tbl (Nullable f)) - , Generic (tbl (Nullable g)) - , Generic (tbl (Nullable h)) +instance ( Beamable tbl + ) => GZipTables f g h (K1 Generic.R (tbl (Nullable Exposed))) + (K1 Generic.R (tbl (Nullable f))) + (K1 Generic.R (tbl (Nullable g))) + (K1 Generic.R (tbl (Nullable h))) + where - , GZipTables f g h (Rep (tbl (Nullable Exposed))) (Rep (tbl (Nullable f))) (Rep (tbl (Nullable g))) (Rep (tbl (Nullable h)))) => - GZipTables f g h - (K1 Generic.R (tbl (Nullable Exposed))) - (K1 Generic.R (tbl (Nullable f))) - (K1 Generic.R (tbl (Nullable g))) - (K1 Generic.R (tbl (Nullable h))) where - gZipTables _ combine ~(K1 f) ~(K1 g) = K1 . to' <$> gZipTables (Proxy :: Proxy (Rep (tbl (Nullable Exposed)))) combine (from' f) (from' g) + gZipTables _ combine ~(K1 f) ~(K1 g) = K1 <$> zipBeamFieldsM (adapt combine) f g + where + adapt :: Applicative m => (forall a . Columnar' f a -> Columnar' g a -> m (Columnar' h a) ) + -> (forall a . Columnar' (Nullable f) a -> Columnar' (Nullable g) a -> m (Columnar' (Nullable h) a)) + adapt func x y = toNullable <$> func ( fromNullable x ) ( fromNullable y ) + fromNullable :: Columnar' (Nullable w) a -> Columnar' w (Maybe a) + fromNullable ~(Columnar' x) = Columnar' x + + toNullable :: Columnar' w (Maybe a) -> Columnar' (Nullable w) a + toNullable ~(Columnar' x) = Columnar' x + class GDefaultTableFieldSettings x where gDefTblFieldSettings :: Proxy x -> x instance GDefaultTableFieldSettings (p x) => GDefaultTableFieldSettings (D1 f p x) where @@ -836,23 +869,38 @@ class GTableSkeleton x where gTblSkeleton :: Proxy x -> x () + instance GTableSkeleton p => GTableSkeleton (M1 t f p) where gTblSkeleton (_ :: Proxy (M1 t f p)) = M1 (gTblSkeleton (Proxy :: Proxy p)) + instance GTableSkeleton U1 where gTblSkeleton _ = U1 + instance (GTableSkeleton a, GTableSkeleton b) => GTableSkeleton (a :*: b) where gTblSkeleton _ = gTblSkeleton (Proxy :: Proxy a) :*: gTblSkeleton (Proxy :: Proxy b) + instance GTableSkeleton (K1 Generic.R (Ignored field)) where gTblSkeleton _ = K1 Ignored -instance ( Generic (tbl Ignored) - , GTableSkeleton (Rep (tbl Ignored)) ) => - GTableSkeleton (K1 Generic.R (tbl Ignored)) where - gTblSkeleton _ = K1 (to' (gTblSkeleton (Proxy :: Proxy (Rep (tbl Ignored))))) -instance ( Generic (tbl (Nullable Ignored)) - , GTableSkeleton (Rep (tbl (Nullable Ignored))) ) => - GTableSkeleton (K1 Generic.R (tbl (Nullable Ignored))) where - gTblSkeleton _ = K1 (to' (gTblSkeleton (Proxy :: Proxy (Rep (tbl (Nullable Ignored)))))) + +instance ( Beamable tbl + ) => GTableSkeleton (K1 Generic.R (tbl Ignored)) + where + gTblSkeleton _ = K1 (tblSkeleton :: TableSkeleton tbl) + +instance ( Beamable tbl + ) => GTableSkeleton (K1 Generic.R (tbl (Nullable Ignored))) + where + gTblSkeleton _ = K1 . runIdentity + $ zipBeamFieldsM transform + (tblSkeleton :: TableSkeleton tbl) + (tblSkeleton :: TableSkeleton tbl) + where + transform :: Columnar' Ignored a + -> Columnar' Ignored a + -> Identity (Columnar' (Nullable Ignored) a) + transform _ _ = Identity (Columnar' Ignored) + -- * Internal functions diff --git a/beam-core.cabal b/beam-core.cabal --- a/beam-core.cabal +++ b/beam-core.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: beam-core -version: 0.7.2.1 +version: 0.7.2.2 synopsis: Type-safe, feature-complete SQL query and manipulation interface for Haskell description: Beam is a Haskell library for type-safe querying and manipulation of SQL databases. Beam is modular and supports various backends. In order to use beam, you will need to use @@ -52,7 +52,7 @@ Database.Beam.Schema.Lenses build-depends: base >=4.7 && <5.0, - aeson >=0.11 && <1.4, + aeson >=0.11 && <1.5, text >=1.0 && <1.3, bytestring >=0.10 && <0.11, mtl >=2.1 && <2.3, @@ -95,4 +95,3 @@ type: git location: https://github.com/tathougies/beam.git subdir: beam-core - diff --git a/test/Database/Beam/Test/Schema.hs b/test/Database/Beam/Test/Schema.hs --- a/test/Database/Beam/Test/Schema.hs +++ b/test/Database/Beam/Test/Schema.hs @@ -31,6 +31,8 @@ tests = testGroup "Schema Tests" [ basicSchemaGeneration , ruleBasedRenaming + , parametricBeamSchemaGeneration + , parametricAndFixedNestedBeamsAreEquivalent -- , automaticNestedFieldsAreUnset -- , nullableForeignKeysGivenMaybeType , underscoresAreHandledGracefully ] @@ -192,15 +194,117 @@ deptFieldNames @?= [ "name", "head__first_name", "head__last_name", "head__created" ] +-- * Ensure it is possible to use nested paremetric beams +parametricBeamSchemaGeneration :: TestTree +parametricBeamSchemaGeneration = + testCase "Parametric schema generation" $ + do let (DatabaseEntity (DatabaseTable _ deptVehiculesA)) = _departmentVehiculesA employeeDbSettings + deptVehiculesFieldNamesA = allBeamValues (\(Columnar' f) -> _fieldName f) deptVehiculesA + + deptVehiculesFieldNamesA @?= [ "departament__name" + , "relates_to__id" + , "relates_to__type" + , "relates_to__of_wheels" + , "meta_info__price" + ] + +-- * Ensure it doesn't matter whether we abstract over a beam's parameters, or if we them fixed. +parametricAndFixedNestedBeamsAreEquivalent :: TestTree +parametricAndFixedNestedBeamsAreEquivalent = + testCase "Parametric and fixed nested beams are equivalent" $ + do let (DatabaseEntity (DatabaseTable _ deptVehiculesA)) = _departmentVehiculesA employeeDbSettings + (DatabaseEntity (DatabaseTable _ deptVehiculesB)) = _departmentVehiculesB employeeDbSettings + deptVehiculesFieldNamesA = allBeamValues (\(Columnar' f) -> _fieldName f) deptVehiculesA + deptVehiculesFieldNamesB = allBeamValues (\(Columnar' f) -> _fieldName f) deptVehiculesB + + deptVehiculesFieldNamesB @?= deptVehiculesFieldNamesA + + +-- `ADepartmentVehiculeT` and `BDepartmentVehiculeT` are equivalent, but one was using params while +-- the other had its sub-beams fixed. + +type ADepartmentVehicule = ADepartmentVehiculeT Identity +type ADepartmentVehiculeT = DepartamentRelatedT VehiculeInformationT VehiculeT +data DepartamentRelatedT metaInfo prop f = DepartamentProperty + { _aDepartament :: PrimaryKey DepartmentT f + , _aRelatesTo :: prop f -- checking we can nest both, nullable and non-nullable beams. + , _aMetaInfo :: metaInfo (Nullable f) + } deriving Generic + +type BDepartmentVehicule = BDepartmentVehiculeT Identity +data BDepartmentVehiculeT f = BDepartmentVehicule + { _bDepartament :: PrimaryKey DepartmentT f + , _bRelatesTo :: VehiculeT f + , _bMetaInfo :: VehiculeInformationT (Nullable f) + } deriving Generic +-- +-- ["departament__name","relates_to__id","relates_to__type","relates_to__of_wheels","meta_info__price"] + + + +instance (Beamable metaInfo, Beamable prop) => Beamable (DepartamentRelatedT metaInfo prop) + + +instance (Table metaInfo, Table prop) => Table (DepartamentRelatedT metaInfo prop) where + data PrimaryKey (DepartamentRelatedT metaInfo prop) f = DepReKeyA (PrimaryKey DepartmentT f) + (PrimaryKey prop f) + deriving(Generic) + primaryKey = DepReKeyA <$> _aDepartament <*> (primaryKey._aRelatesTo) + +instance (Table metaInfo, Table prop) => Beamable (PrimaryKey (DepartamentRelatedT metaInfo prop)) + + + +data VehiculeT f = VehiculeT + { _vehiculeId :: C f Text + , _vehiculeType :: C f Text + , _numberOfWheels :: C f Int + } deriving Generic + +instance Beamable VehiculeT +instance Beamable (PrimaryKey VehiculeT) + +instance Table VehiculeT where + data PrimaryKey VehiculeT f = VehiculeId (C f Text) deriving(Generic) + primaryKey = VehiculeId <$> _vehiculeId + +data VehiculeInformationT f = VehiculeInformationT + { _price :: C f Double + } deriving Generic + + +instance Beamable VehiculeInformationT +instance Beamable (PrimaryKey VehiculeInformationT) + +instance Table VehiculeInformationT where + data PrimaryKey VehiculeInformationT f = VehiculeInformationKey deriving(Generic) + primaryKey _ = VehiculeInformationKey + + + + + +instance Beamable BDepartmentVehiculeT +instance Beamable (PrimaryKey BDepartmentVehiculeT) +instance Table BDepartmentVehiculeT where + data PrimaryKey BDepartmentVehiculeT f = DepReKeyB (PrimaryKey DepartmentT f) + (PrimaryKey VehiculeT f) + deriving(Generic) + primaryKey = DepReKeyB <$> _bDepartament <*> (primaryKey._bRelatesTo) + + + -- * Database schema is derived correctly data EmployeeDb f = EmployeeDb - { _employees :: f (TableEntity EmployeeT) - , _departments :: f (TableEntity DepartmentT) - , _roles :: f (TableEntity RoleT) - , _funny :: f (TableEntity FunnyT) } - deriving Generic + { _employees :: f (TableEntity EmployeeT) + , _departments :: f (TableEntity DepartmentT) + , _roles :: f (TableEntity RoleT) + , _funny :: f (TableEntity FunnyT) + , _departmentVehiculesA :: f (TableEntity ADepartmentVehiculeT) + , _departmentVehiculesB :: f (TableEntity BDepartmentVehiculeT) + } deriving Generic instance Database be EmployeeDb employeeDbSettings :: DatabaseSettings be EmployeeDb