diff --git a/Database/Beam/Backend/SQL.hs b/Database/Beam/Backend/SQL.hs --- a/Database/Beam/Backend/SQL.hs +++ b/Database/Beam/Backend/SQL.hs @@ -10,6 +10,7 @@ import Database.Beam.Backend.Types import Control.Monad.IO.Class +import Control.Monad.Fail (MonadFail) -- * MonadBeam class @@ -29,7 +30,7 @@ -- strategies. More complicated strategies (for example, Postgres's @COPY@) -- are supported in individual backends. See the documentation of those -- backends for more details. -class (BeamBackend be, Monad m, MonadIO m, Sql92SanityCheck syntax) => +class (BeamBackend be, Monad m, MonadIO m, MonadFail m, Sql92SanityCheck syntax) => MonadBeam syntax be handle m | m -> syntax be handle where {-# MINIMAL withDatabaseDebug, runReturningMany #-} 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 @@ -33,6 +33,7 @@ import Data.Hashable import Data.Int import Data.String +import qualified Control.Monad.Fail as Fail #if !MIN_VERSION_base(4, 11, 0) import Data.Semigroup #endif @@ -507,8 +508,10 @@ type BackendFromField SqlSyntaxBackend = Trivial newtype SqlSyntaxM a = SqlSyntaxM (IO a) - deriving (Applicative, Functor, Monad, MonadIO) + deriving (Applicative, Functor, Monad, MonadIO, Fail.MonadFail) instance MonadBeam SqlSyntaxBuilder SqlSyntaxBackend SqlSyntaxBackend SqlSyntaxM where - withDatabaseDebug _ _ _ = fail "absurd" - runReturningMany _ _ = fail "absurd" + withDatabaseDebug _ _ _ = Fail.fail "absurd" + runReturningMany _ _ = Fail.fail "absurd" + + diff --git a/Database/Beam/Backend/Types.hs b/Database/Beam/Backend/Types.hs --- a/Database/Beam/Backend/Types.hs +++ b/Database/Beam/Backend/Types.hs @@ -54,7 +54,7 @@ valuesNeeded :: Proxy be -> Proxy a -> Int valuesNeeded _ _ = 1 --- | newtype mainly used to inspect tho tag structure of a particular +-- | newtype mainly used to inspect the tag structure of a particular -- 'Beamable'. Prevents overlapping instances in some case. Usually not used -- in end-user code. data Exposed x diff --git a/Database/Beam/Query/Combinators.hs b/Database/Beam/Query/Combinators.hs --- a/Database/Beam/Query/Combinators.hs +++ b/Database/Beam/Query/Combinators.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE UndecidableInstances #-} module Database.Beam.Query.Combinators @@ -36,6 +37,7 @@ , SqlDeconstructMaybe(..) , SqlOrderable , QIfCond, QIfElse + , (<|>.) , limit_, offset_ @@ -72,7 +74,9 @@ import Database.Beam.Schema.Tables +#if !MIN_VERSION_base(4, 11, 0) import Control.Monad.Writer +#endif import Control.Monad.Identity import Control.Monad.Free import Control.Applicative @@ -899,3 +903,12 @@ let QExpr onJust' = onJust (changeBeamRep (\(Columnar' (QExpr e)) -> Columnar' (QExpr e)) tbl) QExpr cond = isJust_ tbl in QExpr (\tblPfx -> caseE [(cond tblPfx, onJust' tblPfx)] (onNothing tblPfx)) + +infixl 3 <|>. +(<|>.) :: ( SqlJustable a (QGenExpr ctxt syntax s y) + , SqlDeconstructMaybe syntax (QGenExpr ctxt syntax s y) a s + ) + => QGenExpr ctxt syntax s y + -> QGenExpr ctxt syntax s y + -> QGenExpr ctxt syntax s y +l <|>. r = maybe_ r just_ l diff --git a/Database/Beam/Query/SQL92.hs b/Database/Beam/Query/SQL92.hs --- a/Database/Beam/Query/SQL92.hs +++ b/Database/Beam/Query/SQL92.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} module Database.Beam.Query.SQL92 ( buildSql92Query' ) where @@ -11,7 +12,9 @@ import Control.Monad.Free.Church import Control.Monad.Free +#if !MIN_VERSION_base(4, 11, 0) import Control.Monad.Writer +#endif import Data.Maybe import Data.String diff --git a/Database/Beam/Schema/Lenses.hs b/Database/Beam/Schema/Lenses.hs --- a/Database/Beam/Schema/Lenses.hs +++ b/Database/Beam/Schema/Lenses.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE UndecidableInstances #-} module Database.Beam.Schema.Lenses ( tableLenses , TableLens(..) 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.2 +version: 0.7.2.3 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 @@ -58,13 +58,13 @@ mtl >=2.1 && <2.3, microlens >=0.4 && <0.5, ghc-prim >=0.5 && <0.6, - free >=4.12 && <5.1, + free >=4.12 && <5.2, dlist >=0.7.1.2 && <0.9, time >=1.6 && <1.10, hashable >=1.1 && <1.3, network-uri >=2.6 && <2.7, - containers >=0.5 && <0.6, - vector-sized >=0.5 && <1.1, + containers >=0.5 && <0.7, + vector-sized >=0.5 && <1.3, tagged >=0.8 && <0.9 Default-language: Haskell2010 default-extensions: ScopedTypeVariables, OverloadedStrings, GADTs, RecursiveDo, FlexibleInstances, FlexibleContexts, TypeFamilies, 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 @@ -234,20 +234,16 @@ type BDepartmentVehicule = BDepartmentVehiculeT Identity data BDepartmentVehiculeT f = BDepartmentVehicule { _bDepartament :: PrimaryKey DepartmentT f - , _bRelatesTo :: VehiculeT 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) + data PrimaryKey (DepartamentRelatedT metaInfo prop) f = DepReKeyA (PrimaryKey DepartmentT f) + (PrimaryKey prop f) deriving(Generic) primaryKey = DepReKeyA <$> _aDepartament <*> (primaryKey._aRelatesTo) @@ -280,19 +276,25 @@ data PrimaryKey VehiculeInformationT f = VehiculeInformationKey deriving(Generic) primaryKey _ = VehiculeInformationKey - - - - -instance Beamable BDepartmentVehiculeT +instance Beamable BDepartmentVehiculeT instance Beamable (PrimaryKey BDepartmentVehiculeT) instance Table BDepartmentVehiculeT where - data PrimaryKey BDepartmentVehiculeT f = DepReKeyB (PrimaryKey DepartmentT f) - (PrimaryKey VehiculeT f) + data PrimaryKey BDepartmentVehiculeT f = DepReKeyB (PrimaryKey DepartmentT f) + (PrimaryKey VehiculeT f) deriving(Generic) primaryKey = DepReKeyB <$> _bDepartament <*> (primaryKey._bRelatesTo) - +data NoPrimaryKeyT f + = NoPrimaryKeyT + { _npkField1 :: C f Text + , _npkField2 :: C f Double + } deriving Generic +instance Beamable NoPrimaryKeyT +instance Table NoPrimaryKeyT where + data PrimaryKey NoPrimaryKeyT f = NoPrimaryKey + deriving Generic + primaryKey _ = NoPrimaryKey +instance Beamable (PrimaryKey NoPrimaryKeyT) -- * Database schema is derived correctly @@ -301,9 +303,10 @@ { _employees :: f (TableEntity EmployeeT) , _departments :: f (TableEntity DepartmentT) , _roles :: f (TableEntity RoleT) - , _funny :: f (TableEntity FunnyT) + , _funny :: f (TableEntity FunnyT) , _departmentVehiculesA :: f (TableEntity ADepartmentVehiculeT) , _departmentVehiculesB :: f (TableEntity BDepartmentVehiculeT) + , _noPrimaryKey :: f (TableEntity NoPrimaryKeyT) } deriving Generic instance Database be EmployeeDb