beam-core 0.7.2.1 → 0.7.2.2

raw patch · 7 files changed

+212/−45 lines, 7 filesdep ~aesondep ~freePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: aeson, free

API changes (from Hackage documentation)

Files

• Database/Beam/Backend/SQL/AST.hs +2/−0
• Database/Beam/Backend/SQL/Builder.hs +4/−1
• Database/Beam/Backend/SQL/SQL92.hs +5/−1
• Database/Beam/Query.hs +10/−3
• Database/Beam/Schema/Tables.hs +80/−32
• beam-core.cabal +2/−3
• test/Database/Beam/Test/Schema.hs +109/−5

@@ -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

@@ -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 =

@@ -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

@@ -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)

@@ -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 

@@ -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-

@@ -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