diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 0.3.1.0 + +Add `Semigroup` instances to prepare for GHC 8.4 and Stackage nightly + ## 0.3.0.0 * Re-introduce backend parameter as `Database` type class diff --git a/Database/Beam/Haskell/Syntax.hs b/Database/Beam/Haskell/Syntax.hs --- a/Database/Beam/Haskell/Syntax.hs +++ b/Database/Beam/Haskell/Syntax.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} -- | Instances that allow us to use Haskell as a backend syntax. This allows us -- to use migrations defined a la 'Database.Beam.Migrate.SQL' to generate a beam @@ -22,10 +23,12 @@ import Data.List (find, nub) import qualified Data.Map as M import Data.Maybe -import Data.Monoid import qualified Data.Set as S import Data.String import qualified Data.Text as T +#if !MIN_VERSION_base(4, 11, 0) +import Data.Semigroup +#endif import qualified Language.Haskell.Exts as Hs @@ -46,6 +49,8 @@ data HsImport = HsImportAll | HsImportSome (S.Set (Hs.ImportSpec ())) deriving (Show, Eq, Generic) instance Hashable HsImport +instance Semigroup HsImport where + (<>) = mappend instance Monoid HsImport where mempty = HsImportSome mempty mappend HsImportAll _ = HsImportAll @@ -67,6 +72,8 @@ deriving (Show, Eq) instance Hashable HsImports where hashWithSalt s (HsImports a) = hashWithSalt s (M.assocs a) +instance Semigroup HsImports where + (<>) = mappend instance Monoid HsImports where mempty = HsImports mempty mappend (HsImports a) (HsImports b) = @@ -126,6 +133,8 @@ , hsSyntaxEntities :: [ HsEntity ] } +instance Semigroup HsAction where + (<>) = mappend instance Monoid HsAction where mempty = HsAction [] [] mappend (HsAction ma ea) (HsAction mb eb) = @@ -138,6 +147,8 @@ | HsBeamBackendConstrained [ HsBackendConstraint ] | HsBeamBackendNone +instance Semigroup (HsBeamBackend f) where + (<>) = mappend instance Monoid (HsBeamBackend f) where mempty = HsBeamBackendConstrained [] mappend (HsBeamBackendSingle aTy aExp) (HsBeamBackendSingle bTy _) @@ -172,6 +183,9 @@ , hsTableConstraintDecls :: [ HsDecl ] } +instance Semigroup HsTableConstraintDecls where + (<>) = mappend + instance Monoid HsTableConstraintDecls where mempty = HsTableConstraintDecls [] [] mappend (HsTableConstraintDecls ai ad) (HsTableConstraintDecls bi bd) = @@ -195,19 +209,47 @@ entityDbFieldName :: HsEntity -> String entityDbFieldName entity = "_" ++ getHsEntityName (hsEntityName entity) +derivingDecl :: [Hs.InstRule ()] -> Hs.Deriving () +derivingDecl = +#if MIN_VERSION_haskell_src_exts(1,20,0) + Hs.Deriving () Nothing +#else + Hs.Deriving () +#endif + +dataDecl :: Hs.DeclHead () + -> [Hs.QualConDecl ()] + -> Maybe (Hs.Deriving ()) + -> Hs.Decl () +dataDecl declHead cons deriving_ = +#if MIN_VERSION_haskell_src_exts(1,20,0) + Hs.DataDecl () (Hs.DataType ()) Nothing declHead cons (maybeToList deriving_) +#else + Hs.DataDecl () (Hs.DataType ()) Nothing declHead cons deriving_ +#endif + +insDataDecl :: Hs.Type () + -> [Hs.QualConDecl ()] + -> Maybe (Hs.Deriving ()) + -> Hs.InstDecl () +insDataDecl declHead cons deriving_ = +#if MIN_VERSION_haskell_src_exts(1,20,0) + Hs.InsData () (Hs.DataType ()) declHead cons (maybeToList deriving_) +#else + Hs.InsData () (Hs.DataType ()) declHead cons deriving_ +#endif + databaseTypeDecl :: [ HsEntity ] -> Hs.Decl () databaseTypeDecl entities = - Hs.DataDecl () (Hs.DataType ()) Nothing - declHead [ conDecl ] - [deriving_] + dataDecl declHead [ conDecl ] (Just deriving_) where declHead = Hs.DHApp () (Hs.DHead () (Hs.Ident () "Db")) (Hs.UnkindedVar () (Hs.Ident () "entity")) conDecl = Hs.QualConDecl () Nothing Nothing (Hs.RecDecl () (Hs.Ident () "Db") (mkField <$> entities)) - deriving_ = Hs.Deriving () Nothing [ Hs.IRule () Nothing Nothing $ - Hs.IHCon () $ Hs.UnQual () $ - Hs.Ident () "Generic" ] + deriving_ = derivingDecl [ Hs.IRule () Nothing Nothing $ + Hs.IHCon () $ Hs.UnQual () $ + Hs.Ident () "Generic" ] mkField entity = Hs.FieldDecl () [ Hs.Ident () (entityDbFieldName entity) ] (buildHsDbField (hsEntityDbDecl entity) $ @@ -381,6 +423,8 @@ data HsNone = HsNone deriving (Show, Eq, Ord, Generic) instance Hashable HsNone +instance Semigroup HsNone where + (<>) = mappend instance Monoid HsNone where mempty = HsNone mappend _ _ = HsNone @@ -472,8 +516,7 @@ imports = foldMap (\(_, ty) -> hsTypeImports (hsColumnSchemaType ty)) fields - tblDecl = Hs.DataDecl () (Hs.DataType ()) Nothing - tblDeclHead [ tblConDecl ] [deriving_] + tblDecl = dataDecl tblDeclHead [ tblConDecl ] (Just deriving_) tblDeclHead = Hs.DHApp () (Hs.DHead () (Hs.Ident () tyName)) (Hs.UnkindedVar () (Hs.Ident () "f")) tblConDecl = Hs.QualConDecl () Nothing Nothing (Hs.RecDecl () (Hs.Ident () tyConName) tyConFieldDecls) @@ -485,7 +528,7 @@ [ tyVarNamed "f" , hsTypeSyntax (hsColumnSchemaType ty) ])) fields - deriving_ = Hs.Deriving () Nothing [ inst "Generic" ] + deriving_ = derivingDecl [ inst "Generic" ] tblBeamable = hsInstance "Beamable" [ tyConNamed tyName ] [] tblPun = Hs.TypeDecl () (Hs.DHead () (Hs.Ident () tyConName)) @@ -516,7 +559,7 @@ instance IsSql92TableConstraintSyntax HsTableConstraint where primaryKeyConstraintSyntax fields = HsTableConstraint $ \tblNm tblFields -> - let primaryKeyDataDecl = Hs.InsData () (Hs.DataType ()) primaryKeyType [ primaryKeyConDecl ] [ primaryKeyDeriving ] + let primaryKeyDataDecl = insDataDecl primaryKeyType [ primaryKeyConDecl ] (Just primaryKeyDeriving) tableTypeNm = tblNm <> "T" tableTypeKeyNm = tblNm <> "Key" @@ -525,7 +568,7 @@ primaryKeyType = tyApp (tyConNamed "PrimaryKey") [ tyConNamed (T.unpack tableTypeNm), tyVarNamed "f" ] primaryKeyConDecl = Hs.QualConDecl () Nothing Nothing (Hs.ConDecl () (Hs.Ident () (T.unpack tableTypeKeyNm)) fieldTys) - primaryKeyDeriving = Hs.Deriving () Nothing [ inst "Generic" ] + primaryKeyDeriving = derivingDecl [ inst "Generic" ] primaryKeyTypeDecl = Hs.TypeDecl () (Hs.DHead () (Hs.Ident () (T.unpack tableTypeKeyNm))) (tyApp (tyConNamed "PrimaryKey") @@ -867,7 +910,12 @@ instHead = foldl (Hs.IHApp ()) (Hs.IHCon () (Hs.UnQual () (Hs.Ident () (T.unpack classNm)))) params hsDerivingInstance :: T.Text -> [ Hs.Type () ] -> Hs.Decl () -hsDerivingInstance classNm params = Hs.DerivDecl () Nothing Nothing (Hs.IRule () Nothing Nothing instHead) +hsDerivingInstance classNm params = +#if MIN_VERSION_haskell_src_exts(1,20,0) + Hs.DerivDecl () Nothing Nothing (Hs.IRule () Nothing Nothing instHead) +#else + Hs.DerivDecl () Nothing (Hs.IRule () Nothing Nothing instHead) +#endif where instHead = foldl (Hs.IHApp ()) (Hs.IHCon () (Hs.UnQual () (Hs.Ident () (T.unpack classNm)))) params @@ -958,7 +1006,9 @@ instance Hashable (Hs.ImportSpec ()) instance Hashable (Hs.Namespace ()) instance Hashable (Hs.CName ()) +#if MIN_VERSION_haskell_src_exts(1,20,0) instance Hashable (Hs.DerivStrategy ()) instance Hashable (Hs.MaybePromotedName ()) +#endif instance Hashable a => Hashable (S.Set a) where hashWithSalt s a = hashWithSalt s (S.toList a) diff --git a/Database/Beam/Migrate/Actions.hs b/Database/Beam/Migrate/Actions.hs --- a/Database/Beam/Migrate/Actions.hs +++ b/Database/Beam/Migrate/Actions.hs @@ -4,6 +4,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} -- | Data types and functions to discover sequences of DDL commands to go from -- one database state to another. Used for migration generation. @@ -101,12 +102,14 @@ import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS -import Data.Monoid import qualified Data.PQueue.Min as PQ import qualified Data.Sequence as Seq import Data.Text (Text) import qualified Data.Text as T import Data.Typeable +#if !MIN_VERSION_base(4, 11, 0) +import Data.Semigroup +#endif import GHC.Generics @@ -185,6 +188,9 @@ -- path through the graph. } +instance Semigroup (PotentialAction cmd) where + (<>) = mappend + -- | 'PotentialAction's can represent edges or paths. Monadically combining two -- 'PotentialAction's results in the path between the source of the first and -- the destination of the second. 'mempty' here returns the action that does @@ -241,6 +247,9 @@ -- in the final database. newtype ActionProvider cmd = ActionProvider { getPotentialActions :: ActionProviderFn cmd } + +instance Semigroup (ActionProvider cmd) where + (<>) = mappend instance Monoid (ActionProvider cmd) where mempty = ActionProvider (\_ _ -> []) diff --git a/Database/Beam/Migrate/Backend.hs b/Database/Beam/Migrate/Backend.hs --- a/Database/Beam/Migrate/Backend.hs +++ b/Database/Beam/Migrate/Backend.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} -- | Definitions of interest to those implement a new beam backend. -- @@ -56,7 +57,9 @@ import qualified Data.ByteString.Lazy as BL -import Data.Monoid +#if ! MIN_VERSION_base(4,11,0) +import Data.Semigroup +#endif import Data.Text (Text) import Data.Time @@ -111,6 +114,9 @@ -- backends can choose to drop any predicate (simply return 'Nothing'). newtype HaskellPredicateConverter = HaskellPredicateConverter (SomeDatabasePredicate -> Maybe SomeDatabasePredicate) + +instance Semigroup HaskellPredicateConverter where + (<>) = mappend -- | 'HaskellPredicateConverter's can be combined monoidally. instance Monoid HaskellPredicateConverter where diff --git a/Database/Beam/Migrate/Checks.hs b/Database/Beam/Migrate/Checks.hs --- a/Database/Beam/Migrate/Checks.hs +++ b/Database/Beam/Migrate/Checks.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} -- | Defines common 'DatabasePredicate's that are shared among backends module Database.Beam.Migrate.Checks where @@ -12,8 +13,10 @@ import Data.Aeson.Types (Parser, Value) import Data.Hashable (Hashable(..)) import Data.Text (Text) -import Data.Monoid ((<>)) import Data.Typeable (Typeable, cast) +#if !MIN_VERSION_base(4, 11, 0) +import Data.Semigroup +#endif import GHC.Generics (Generic) diff --git a/Database/Beam/Migrate/Log.hs b/Database/Beam/Migrate/Log.hs --- a/Database/Beam/Migrate/Log.hs +++ b/Database/Beam/Migrate/Log.hs @@ -13,7 +13,7 @@ import Data.String (fromString) import Data.Text (Text) import Data.Time (LocalTime) -import Data.UUID (UUID) +import Data.UUID.Types (UUID) data LogEntryT f = LogEntry diff --git a/Database/Beam/Migrate/SQL/Builder.hs b/Database/Beam/Migrate/SQL/Builder.hs --- a/Database/Beam/Migrate/SQL/Builder.hs +++ b/Database/Beam/Migrate/SQL/Builder.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} -- | DDL syntax instances for 'SqlSyntaxBuilder' module Database.Beam.Migrate.SQL.Builder where @@ -11,8 +12,11 @@ import Data.ByteString.Builder (Builder, byteString, toLazyByteString) import qualified Data.ByteString.Lazy.Char8 as BCL -import Data.Monoid +#if !MIN_VERSION_base(4, 11, 0) +import Data.Semigroup +#endif + -- | Options for @CREATE TABLE@. Given as a separate ADT because the options may -- go in different places syntactically. -- @@ -112,6 +116,9 @@ { _sqlConstraintAttributeTiming :: Maybe ConstraintAttributeTiming , _sqlConstraintAttributeDeferrable :: Maybe Bool } deriving (Show, Eq) + +instance Semigroup SqlConstraintAttributesBuilder where + (<>) = mappend instance Monoid SqlConstraintAttributesBuilder where mempty = SqlConstraintAttributesBuilder Nothing Nothing diff --git a/Database/Beam/Migrate/SQL/SQL92.hs b/Database/Beam/Migrate/SQL/SQL92.hs --- a/Database/Beam/Migrate/SQL/SQL92.hs +++ b/Database/Beam/Migrate/SQL/SQL92.hs @@ -1,4 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} + -- | Finally-tagless encoding of SQL92 DDL commands. -- -- If you're writing a beam backend driver and you want to support migrations, @@ -12,6 +14,9 @@ import Data.Hashable import Data.Text (Text) import Data.Typeable +#if ! MIN_VERSION_base(4,11,0) +import Data.Semigroup +#endif -- * Convenience type synonyms @@ -154,7 +159,7 @@ -> Maybe (Sql92ColumnConstraintDefinitionAttributesSyntax constraint) -> constraint -class (Monoid attrs, Typeable attrs) => IsSql92ConstraintAttributesSyntax attrs where +class (Semigroup attrs, Monoid attrs, Typeable attrs) => IsSql92ConstraintAttributesSyntax attrs where initiallyDeferredAttributeSyntax :: attrs initiallyImmediateAttributeSyntax :: attrs notDeferrableAttributeSyntax :: attrs diff --git a/Database/Beam/Migrate/Serialization.hs b/Database/Beam/Migrate/Serialization.hs --- a/Database/Beam/Migrate/Serialization.hs +++ b/Database/Beam/Migrate/Serialization.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} -- | Serialization and deserialization helpers for beam data types. -- @@ -40,10 +41,12 @@ import Data.Aeson.Types (Parser) import qualified Data.Dependent.Map as D import qualified Data.GADT.Compare as D -import Data.Monoid ((<>)) import Data.Text (Text, unpack) import Data.Typeable (Typeable, (:~:)( Refl ), eqT, typeRep, typeOf) import qualified Data.Vector as V +#if !MIN_VERSION_base(4, 11, 0) +import Data.Semigroup +#endif -- * Serialization helpers @@ -119,7 +122,7 @@ newtype BeamSerializedConstraintAttributes = BeamSerializedConstraintAttributes { fromBeamSerializedConstraintAttributes :: [ Value ] - } deriving (Show, Eq, Monoid) + } deriving (Show, Eq, Monoid, Semigroup) -- | 'IsSql92ColumnConstraintSyntax' type for JSON newtype BeamSerializedConstraint @@ -238,11 +241,17 @@ { beamArbitraryDeserializers :: D.DMap BeamDeserializerLabel BeamDeserializer } +instance Semigroup (BeamDeserializer cmd) where + (<>) = mappend + instance Monoid (BeamDeserializer cmd) where mempty = BeamDeserializer (const (const mzero)) mappend (BeamDeserializer a) (BeamDeserializer b) = BeamDeserializer $ \d o -> a d o <|> b d o + +instance Semigroup (BeamDeserializers cmd) where + (<>) = mappend instance Monoid (BeamDeserializers cmd) where mempty = BeamDeserializers mempty diff --git a/Database/Beam/Migrate/Types.hs b/Database/Beam/Migrate/Types.hs --- a/Database/Beam/Migrate/Types.hs +++ b/Database/Beam/Migrate/Types.hs @@ -2,6 +2,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} module Database.Beam.Migrate.Types ( -- * Checked database entities @@ -52,7 +53,9 @@ import Control.Arrow import Control.Category (Category) -import Data.Monoid +#if !MIN_VERSION_base(4, 11, 0) +import Data.Semigroup +#endif import Data.Text (Text) -- * Migration types @@ -90,6 +93,9 @@ -- ^ The command keeps all data deriving Show +instance Semigroup MigrationDataLoss where + (<>) = mappend + instance Monoid MigrationDataLoss where mempty = MigrationKeepsData mappend MigrationLosesData _ = MigrationLosesData @@ -145,7 +151,7 @@ -- | Given functions to render a migration step description and the underlying -- syntax, create a script for the given 'MigrationSteps'. -migrateScript :: forall syntax m a. Monoid m +migrateScript :: forall syntax m a. (Monoid m, Semigroup m) => (Text -> m) -- ^ Called at the beginning of each 'MigrationStep' with the step description -> (syntax -> m) diff --git a/beam-migrate.cabal b/beam-migrate.cabal --- a/beam-migrate.cabal +++ b/beam-migrate.cabal @@ -1,5 +1,5 @@ name: beam-migrate -version: 0.3.0.0 +version: 0.3.1.0 synopsis: SQL DDL support and migrations support library for Beam description: This package provides type classes to allow backends to implement SQL DDL support for beam. This allows you to use beam syntax to @@ -59,7 +59,7 @@ Database.Beam.Migrate.Types.CheckedEntities Database.Beam.Migrate.Types.Predicates - build-depends: base >=4.9 && <4.11, + build-depends: base >=4.9 && <5.0, beam-core >=0.7 && <0.8, text >=1.2 && <1.3, aeson >=0.11 && <1.3, @@ -76,12 +76,12 @@ deepseq >=1.4 && <1.5, ghc-prim >=0.5 && <0.6, containers >=0.5 && <0.6, - haskell-src-exts >=1.20 && <1.21, + haskell-src-exts >=1.18 && <1.21, pretty >=1.1 && <1.2, dependent-map >=0.2 && <0.3, dependent-sum >=0.4 && <0.5, pqueue >=1.3 && <1.5, - uuid >=1.3 && <1.4 + uuid-types >=1.0 && <1.1 default-language: Haskell2010 default-extensions: KindSignatures, OverloadedStrings, TypeFamilies, FlexibleContexts, StandaloneDeriving, GADTs, DeriveFunctor, RankNTypes, ScopedTypeVariables,