diff --git a/flake.lock b/flake.lock index b9f80e71..f869ddb2 100644 --- a/flake.lock +++ b/flake.lock @@ -138,11 +138,11 @@ "hackage": { "flake": false, "locked": { - "lastModified": 1746663969, - "narHash": "sha256-SnVSxxxX+J1hVI7sFh3nBUPEI5ql8ieNwE9xFm4uizk=", + "lastModified": 1754872896, + "narHash": "sha256-epuK2yBDK5OsCmUF+LhebD7vStvvuxuBudatM81TcSs=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "cc4e4c0d1b0c76dad98de5eaf1e9065516caf6dc", + "rev": "c4a48706ea09797bca224e175bf3645925be999d", "type": "github" }, "original": { @@ -154,11 +154,11 @@ "hackage-for-stackage": { "flake": false, "locked": { - "lastModified": 1746663959, - "narHash": "sha256-sv0/0CmiQWHqsWlcwhSNlnux8YPMJx2Y3FxAalvB54s=", + "lastModified": 1754872152, + "narHash": "sha256-23psWtbbdtEF2Ybl6sn6YgDqIE+NCw12OqpKn8mUUH8=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "a4f96c31bebc5cbee31b7ea079bc7ffeb5d35957", + "rev": "31a91b344e3b09b1a4511f29129aac79c9914954", "type": "github" }, "original": { @@ -168,6 +168,22 @@ "type": "github" } }, + "hackage-internal": { + "flake": false, + "locked": { + "lastModified": 1750307553, + "narHash": "sha256-iiafNoeLHwlSLQTyvy8nPe2t6g5AV4PPcpMeH/2/DLs=", + "owner": "input-output-hk", + "repo": "hackage.nix", + "rev": "f7867baa8817fab296528f4a4ec39d1c7c4da4f3", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "hackage.nix", + "type": "github" + } + }, "haskellNix": { "inputs": { "HTTP": "HTTP", @@ -179,10 +195,12 @@ "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", "hackage": "hackage", "hackage-for-stackage": "hackage-for-stackage", + "hackage-internal": "hackage-internal", "hls": "hls", "hls-1.10": "hls-1.10", "hls-2.0": "hls-2.0", "hls-2.10": "hls-2.10", + "hls-2.11": "hls-2.11", "hls-2.2": "hls-2.2", "hls-2.3": "hls-2.3", "hls-2.4": "hls-2.4", @@ -201,16 +219,17 @@ "nixpkgs-2311": "nixpkgs-2311", "nixpkgs-2405": "nixpkgs-2405", "nixpkgs-2411": "nixpkgs-2411", + "nixpkgs-2505": "nixpkgs-2505", "nixpkgs-unstable": "nixpkgs-unstable", "old-ghc-nix": "old-ghc-nix", "stackage": "stackage" }, "locked": { - "lastModified": 1746665528, - "narHash": "sha256-Pztdz0tTbCvnsq9vgbFTiFtXuQ6NCdUXDJCaRq1l9bE=", + "lastModified": 1754873549, + "narHash": "sha256-7XATFloSwGZtXqDP671qMYoHqIJgLW/rJHZxbgh8Yfk=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "f98f6bf207d8344c0b043ae4ccbac8a9f887f3a4", + "rev": "a052991c7956e2ea64df6ea092893c51df832899", "type": "github" }, "original": { @@ -286,6 +305,23 @@ "type": "github" } }, + "hls-2.11": { + "flake": false, + "locked": { + "lastModified": 1747306193, + "narHash": "sha256-/MmtpF8+FyQlwfKHqHK05BdsxC9LHV70d/FiMM7pzBM=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "46ef4523ea4949f47f6d2752476239f1c6d806fe", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.11.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, "hls-2.2": { "flake": false, "locked": { @@ -441,11 +477,11 @@ "iserv-proxy": { "flake": false, "locked": { - "lastModified": 1742121966, - "narHash": "sha256-x4bg4OoKAPnayom0nWc0BmlxgRMMHk6lEPvbiyFBq1s=", + "lastModified": 1750543273, + "narHash": "sha256-WaswH0Y+Fmupvv8AkIlQBlUy/IdD3Inx9PDuE+5iRYY=", "owner": "stable-haskell", "repo": "iserv-proxy", - "rev": "e9dc86ed6ad71f0368c16672081c8f26406c3a7e", + "rev": "a53c57c9a8d22a66a2f0c4c969e806da03f08c28", "type": "github" }, "original": { @@ -505,11 +541,11 @@ }, "nixpkgs-2411": { "locked": { - "lastModified": 1739151041, - "narHash": "sha256-uNszcul7y++oBiyYXjHEDw/AHeLNp8B6pyWOB+RLA/4=", + "lastModified": 1748037224, + "narHash": "sha256-92vihpZr6dwEMV6g98M5kHZIttrWahb9iRPBm1atcPk=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "94792ab2a6beaec81424445bf917ca2556fbeade", + "rev": "f09dede81861f3a83f7f06641ead34f02f37597f", "type": "github" }, "original": { @@ -519,13 +555,29 @@ "type": "github" } }, + "nixpkgs-2505": { + "locked": { + "lastModified": 1748852332, + "narHash": "sha256-r/wVJWmLYEqvrJKnL48r90Wn9HWX9SHFt6s4LhuTh7k=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "a8167f3cc2f991dd4d0055746df53dae5fd0c953", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-25.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, "nixpkgs-unstable": { "locked": { - "lastModified": 1737110817, - "narHash": "sha256-DSenga8XjPaUV5KUFW/i3rNkN7jm9XmguW+qQ1ZJTR4=", + "lastModified": 1748856973, + "narHash": "sha256-RlTsJUvvr8ErjPBsiwrGbbHYW8XbB/oek0Gi78XdWKg=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "041c867bad68dfe34b78b2813028a2e2ea70a23c", + "rev": "e4b09e47ace7d87de083786b404bf232eb6c89d8", "type": "github" }, "original": { @@ -565,11 +617,11 @@ "stackage": { "flake": false, "locked": { - "lastModified": 1746663191, - "narHash": "sha256-s1Yln2DNZp1aJyNuCQm3/vvW8W6wgDWG5L5L5HOx3j8=", + "lastModified": 1754698413, + "narHash": "sha256-Fx26qhhNAH4Od9qTUnaBslqiCS0M3A9IQZ+SzXFTUe0=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "b9b32646970b0f8ea5e399ff948aaa9d212aca91", + "rev": "be626862d9d8f112e0159161848da1d87cd5e4f9", "type": "github" }, "original": { diff --git a/rel8.cabal b/rel8.cabal index 6aa8de77..c1981dea 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -30,9 +30,10 @@ library , comonad , containers , contravariant - , hasql >= 1.8 && < 1.10 + , hasql >= 1.9.3 && < 1.10 , iproute ^>= 1.7 , opaleye ^>= 0.10.2.1 + , postgresql-binary >= 0.14.2 && < 0.15 , pretty , profunctors , product-profunctors @@ -221,6 +222,7 @@ library Rel8.Type.Array Rel8.Type.Builder.ByteString Rel8.Type.Builder.Fold + Rel8.Type.Builder.Range Rel8.Type.Builder.Time Rel8.Type.Composite Rel8.Type.Decimal @@ -238,6 +240,7 @@ library Rel8.Type.Ord Rel8.Type.Parser Rel8.Type.Parser.ByteString + Rel8.Type.Parser.Range Rel8.Type.Parser.Time Rel8.Type.ReadShow Rel8.Type.Semigroup diff --git a/src/Rel8/Type.hs b/src/Rel8/Type.hs index f49835ba..77a0662c 100644 --- a/src/Rel8/Type.hs +++ b/src/Rel8/Type.hs @@ -57,6 +57,9 @@ import Data.IP (IPRange) import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote ) +-- postgresql-binary +import qualified PostgreSQL.Binary.Range as Range + -- rel8 import Rel8.Schema.Null ( NotNull, Sql, nullable ) import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation ) @@ -68,7 +71,9 @@ import Rel8.Type.Name (TypeName (..)) import Rel8.Type.Parser (parse) import qualified Rel8.Type.Builder.ByteString as Builder import qualified Rel8.Type.Parser.ByteString as Parser +import qualified Rel8.Type.Builder.Range as Builder import qualified Rel8.Type.Builder.Time as Builder +import qualified Rel8.Type.Parser.Range as Parser import qualified Rel8.Type.Parser.Time as Parser -- scientific @@ -543,6 +548,124 @@ instance DBType IPRange where } +-- | Corresponds to @int4range@ +instance DBType (Range.Range Int32) where + typeInformation = TypeInformation + { encode = + Encoder + { binary = Encoders.int4range + , text = Builder.int4range + , quote = quoteBuilder . Builder.int4range + } + , decode = + Decoder + { binary = Decoders.int4range + , text = parse Parser.int4range + } + , delimiter = ',' + , typeName = "int4range" + } + + +-- | Corresponds to @int8range@ +instance DBType (Range.Range Int64) where + typeInformation = TypeInformation + { encode = + Encoder + { binary = Encoders.int8range + , text = Builder.int8range + , quote = quoteBuilder . Builder.int8range + } + , decode = + Decoder + { binary = Decoders.int8range + , text = parse Parser.int8range + } + , delimiter = ',' + , typeName = "int8range" + } + + +-- | Corresponds to @numrange@ +instance DBType (Range.Range Scientific) where + typeInformation = TypeInformation + { encode = + Encoder + { binary = Encoders.numrange + , text = Builder.numrange + , quote = quoteBuilder . Builder.numrange + } + , decode = + Decoder + { binary = Decoders.numrange + , text = parse Parser.numrange + } + , delimiter = ',' + , typeName = "numrange" + } + + +-- | Corresponds to @tsrange@ +instance DBType (Range.Range LocalTime) where + typeInformation = TypeInformation + { encode = + Encoder + { binary = Encoders.tsrange + , text = Builder.tsrange + , quote = quoteBuilder . Builder.tsrange + } + , decode = + Decoder + { binary = Decoders.tsrange + , text = parse Parser.tsrange + } + , delimiter = ',' + , typeName = "tsrange" + } + + +-- | Corresponds to @tstzrange@ +instance DBType (Range.Range UTCTime) where + typeInformation = TypeInformation + { encode = + Encoder + { binary = Encoders.tstzrange + , text = Builder.tstzrange + , quote = quoteBuilder . Builder.tstzrange + } + , decode = + Decoder + { binary = Decoders.tstzrange + , text = parse Parser.tstzrange + } + , delimiter = ',' + , typeName = "tstzrange" + } + +-- | Corresponds to @daterange@ +instance DBType (Range.Range Day) where + typeInformation = TypeInformation + { encode = + Encoder + { binary = Encoders.daterange + , text = Builder.daterange + , quote = quoteBuilder . Builder.daterange + } + , decode = + Decoder + { binary = Decoders.daterange + , text = parse Parser.daterange + } + , delimiter = ',' + , typeName = "daterange" + } + + +quoteBuilder :: B.Builder -> Opaleye.PrimExpr +quoteBuilder = + Opaleye.ConstExpr . Opaleye.OtherLit . BS8.unpack . ByteString.toStrict . B.toLazyByteString + + instance Sql DBType a => DBType [a] where typeInformation = listTypeInformation nullable typeInformation diff --git a/src/Rel8/Type/Builder/Range.hs b/src/Rel8/Type/Builder/Range.hs new file mode 100644 index 00000000..a26cc765 --- /dev/null +++ b/src/Rel8/Type/Builder/Range.hs @@ -0,0 +1,112 @@ +{-# language OverloadedStrings #-} + +module Rel8.Type.Builder.Range ( + range, + multirange, + int4range, + int8range, + numrange, + tsrange, + tstzrange, + daterange, + int4multirange, + int8multirange, + nummultirange, + tsmultirange, + tstzmultirange, + datemultirange, +) where + +-- base +import Data.Int (Int32, Int64) +import Prelude + +-- bytestring +import Data.ByteString.Builder (Builder, string7, char8, int32Dec, int64Dec) +import Data.ByteString.Builder.Prim (primBounded) + +-- rel8 +import qualified Rel8.Type.Builder.Fold as Fold +import qualified Rel8.Type.Builder.Time as Builder + +-- postgresql-binary +import qualified PostgreSQL.Binary.Range as Range + +-- scientific +import Data.ByteString.Builder.Scientific (scientificBuilder) +import Data.Scientific (Scientific) + +-- time +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime) +import Data.Time.LocalTime (LocalTime) + + +range :: (a -> Builder) -> Range.Range a -> Builder +range _ Range.Empty = string7 "empty" +range boundsBuilder (Range.Range lower upper) = + left <> char8 ',' <> right + where + left = + case lower of + Range.Inf -> char8 '(' + Range.Incl a -> char8 '[' <> boundsBuilder a <> char8 ']' + Range.Excl a -> char8 '(' <> boundsBuilder a <> char8 ')' + right = + case upper of + Range.Inf -> char8 ')' + Range.Incl a -> boundsBuilder a <> char8 ']' + Range.Excl a -> boundsBuilder a <> char8 ')' + + +multirange :: (a -> Builder) -> Range.Multirange a -> Builder +multirange boundsBuilder ranges = + char8 '{' <> Fold.interfoldMap (char8 ',') (range boundsBuilder) ranges <> char8 '}' + + +int4range :: Range.Range Int32 -> Builder +int4range = range int32Dec + + +int8range :: Range.Range Int64 -> Builder +int8range = range int64Dec + + +numrange :: Range.Range Scientific -> Builder +numrange = range scientificBuilder + + +tsrange :: Range.Range LocalTime -> Builder +tsrange = range (primBounded Builder.localTime) + + +tstzrange :: Range.Range UTCTime -> Builder +tstzrange = range (primBounded Builder.utcTime) + + +daterange :: Range.Range Day -> Builder +daterange = range (primBounded Builder.day) + + +int4multirange :: Range.Multirange Int32 -> Builder +int4multirange = multirange int32Dec + + +int8multirange :: Range.Multirange Int64 -> Builder +int8multirange = multirange int64Dec + + +nummultirange :: Range.Multirange Scientific -> Builder +nummultirange = multirange scientificBuilder + + +tsmultirange :: Range.Multirange LocalTime -> Builder +tsmultirange = multirange (primBounded Builder.localTime) + + +tstzmultirange :: Range.Multirange UTCTime -> Builder +tstzmultirange = multirange (primBounded Builder.utcTime) + + +datemultirange :: Range.Multirange Day -> Builder +datemultirange = multirange (primBounded Builder.day) diff --git a/src/Rel8/Type/Parser/Range.hs b/src/Rel8/Type/Parser/Range.hs new file mode 100644 index 00000000..7209d71a --- /dev/null +++ b/src/Rel8/Type/Parser/Range.hs @@ -0,0 +1,113 @@ +{-# language OverloadedStrings #-} + +module Rel8.Type.Parser.Range + ( range + , multirange + , int4range + , int8range + , numrange + , tsrange + , tstzrange + , daterange + , int4multirange + , int8multirange + , nummultirange + , tsmultirange + , tstzmultirange + , datemultirange + ) +where + +-- attoparsec +import qualified Data.Attoparsec.ByteString.Char8 as A + +-- base +import Control.Applicative ((<|>), optional) +import Data.Functor (void) +import Data.Int (Int32, Int64) +import Prelude + +-- postgresql-binary +import qualified PostgreSQL.Binary.Range as Range + +-- scientific +import Data.Scientific (Scientific) + +-- rel8 +import qualified Rel8.Type.Parser.Time as Parser + +-- time +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime) +import Data.Time.LocalTime (LocalTime) + + +range :: A.Parser a -> A.Parser (Range.Range a) +range boundsParser = empty <|> range' + where + range' = do + open <- openMarker + lower <- optional boundsParser + void $ A.char ',' + upper <- optional boundsParser + close <- closeMarker + pure $ Range.Range (maybe Range.Inf open lower) (maybe Range.Inf close upper) + empty = A.string "empty" *> pure Range.Empty + openMarker = (A.char '[' *> pure Range.Incl) <|> (A.char '(' *> pure Range.Excl) + closeMarker = (A.char ']' *> pure Range.Incl) <|> (A.char ')' *> pure Range.Excl) + + +multirange :: A.Parser a -> A.Parser (Range.Multirange a) +multirange boundsParser = + A.char '{' *> A.sepBy element (A.char delimiter) <* A.char '}' + where + delimiter = ',' + element = range boundsParser + + +int4range :: A.Parser (Range.Range Int32) +int4range = range $ A.signed A.decimal + + +int8range :: A.Parser (Range.Range Int64) +int8range = range $ A.signed A.decimal + + +numrange :: A.Parser (Range.Range Scientific) +numrange = range A.scientific + + +tsrange :: A.Parser (Range.Range LocalTime) +tsrange = range Parser.localTime + + +tstzrange :: A.Parser (Range.Range UTCTime) +tstzrange = range Parser.utcTime + + +daterange :: A.Parser (Range.Range Day) +daterange = range Parser.day + + +int4multirange :: A.Parser (Range.Multirange Int32) +int4multirange = multirange $ A.signed A.decimal + + +int8multirange :: A.Parser (Range.Multirange Int64) +int8multirange = multirange $ A.signed A.decimal + + +nummultirange :: A.Parser (Range.Multirange Scientific) +nummultirange = multirange A.scientific + + +tsmultirange :: A.Parser (Range.Multirange LocalTime) +tsmultirange = multirange Parser.localTime + + +tstzmultirange :: A.Parser (Range.Multirange UTCTime) +tstzmultirange = multirange Parser.utcTime + + +datemultirange :: A.Parser (Range.Multirange Day) +datemultirange = multirange Parser.day