{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Rel8.Internal.Data.Range (
  Bound (Incl, Excl, Inf),
  Range (Empty, Range),
  quoteRange,
  mapRange,
  Multirange (Multirange),
  primMultirange,
) where

-- attoparsec
import qualified Data.Attoparsec.ByteString.Char8 as A

-- base
import Control.Applicative (many, optional, (<|>))
import Control.Monad ((>=>))
import Data.Foldable (fold)
import Data.Functor (void)
import Data.Functor.Contravariant ((>$<))
import Prelude

-- bytestring
import Data.ByteString (ByteString)
import Data.ByteString.Builder (Builder, toLazyByteString)
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as L

-- hasql
import qualified Hasql.Decoders as Decoder
import qualified Hasql.Encoders as Encoder

-- opaleye
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

-- postgresql-binary
import PostgreSQL.Binary.Range (Bound (Incl, Excl, Inf), Range (Empty, Range))
import qualified PostgreSQL.Binary.Range as PostgreSQL

-- rel8
import Rel8.Internal.Schema.QualifiedName (QualifiedName, showQualifiedName)
import Rel8.Internal.Type (DBType, typeInformation)
import Rel8.Internal.Type.Builder.Fold (interfoldMap)
import Rel8.Internal.Type.Decoder (Decoder (Decoder))
import qualified Rel8.Internal.Type.Decoder
import Rel8.Internal.Type.Encoder (Encoder (Encoder))
import qualified Rel8.Internal.Type.Encoder
import Rel8.Internal.Type.Eq (DBEq)
import Rel8.Internal.Type.Information (TypeInformation (TypeInformation))
import qualified Rel8.Internal.Type.Information
import Rel8.Internal.Type.Name (TypeName (TypeName))
import qualified Rel8.Internal.Type.Name
import Rel8.Internal.Type.Ord (DBOrd)
import Rel8.Internal.Type.Range (
  DBRange,
  rangeTypeName, rangeEncoder, rangeDecoder,
  multirangeTypeName, multirangeEncoder, multirangeDecoder,
 )
import Rel8.Internal.Type.Parser (parse)


newtype Multirange a = Multirange (PostgreSQL.Multirange a)
  deriving (Multirange a -> Multirange a -> Bool
(Multirange a -> Multirange a -> Bool)
-> (Multirange a -> Multirange a -> Bool) -> Eq (Multirange a)
forall a. Eq a => Multirange a -> Multirange a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Multirange a -> Multirange a -> Bool
== :: Multirange a -> Multirange a -> Bool
$c/= :: forall a. Eq a => Multirange a -> Multirange a -> Bool
/= :: Multirange a -> Multirange a -> Bool
Eq, Eq (Multirange a)
Eq (Multirange a) =>
(Multirange a -> Multirange a -> Ordering)
-> (Multirange a -> Multirange a -> Bool)
-> (Multirange a -> Multirange a -> Bool)
-> (Multirange a -> Multirange a -> Bool)
-> (Multirange a -> Multirange a -> Bool)
-> (Multirange a -> Multirange a -> Multirange a)
-> (Multirange a -> Multirange a -> Multirange a)
-> Ord (Multirange a)
Multirange a -> Multirange a -> Bool
Multirange a -> Multirange a -> Ordering
Multirange a -> Multirange a -> Multirange a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Multirange a)
forall a. Ord a => Multirange a -> Multirange a -> Bool
forall a. Ord a => Multirange a -> Multirange a -> Ordering
forall a. Ord a => Multirange a -> Multirange a -> Multirange a
$ccompare :: forall a. Ord a => Multirange a -> Multirange a -> Ordering
compare :: Multirange a -> Multirange a -> Ordering
$c< :: forall a. Ord a => Multirange a -> Multirange a -> Bool
< :: Multirange a -> Multirange a -> Bool
$c<= :: forall a. Ord a => Multirange a -> Multirange a -> Bool
<= :: Multirange a -> Multirange a -> Bool
$c> :: forall a. Ord a => Multirange a -> Multirange a -> Bool
> :: Multirange a -> Multirange a -> Bool
$c>= :: forall a. Ord a => Multirange a -> Multirange a -> Bool
>= :: Multirange a -> Multirange a -> Bool
$cmax :: forall a. Ord a => Multirange a -> Multirange a -> Multirange a
max :: Multirange a -> Multirange a -> Multirange a
$cmin :: forall a. Ord a => Multirange a -> Multirange a -> Multirange a
min :: Multirange a -> Multirange a -> Multirange a
Ord, Int -> Multirange a -> ShowS
[Multirange a] -> ShowS
Multirange a -> String
(Int -> Multirange a -> ShowS)
-> (Multirange a -> String)
-> ([Multirange a] -> ShowS)
-> Show (Multirange a)
forall a. Show a => Int -> Multirange a -> ShowS
forall a. Show a => [Multirange a] -> ShowS
forall a. Show a => Multirange a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Multirange a -> ShowS
showsPrec :: Int -> Multirange a -> ShowS
$cshow :: forall a. Show a => Multirange a -> String
show :: Multirange a -> String
$cshowList :: forall a. Show a => [Multirange a] -> ShowS
showList :: [Multirange a] -> ShowS
Show)


instance DBRange a => DBType (Range a) where
  typeInformation :: TypeInformation (Range a)
typeInformation =
    QualifiedName
-> Value (Range a)
-> Value (Range a)
-> TypeInformation a
-> TypeInformation (Range a)
forall a.
QualifiedName
-> Value (Range a)
-> Value (Range a)
-> TypeInformation a
-> TypeInformation (Range a)
rangeTypeInformation QualifiedName
name Value (Range a)
forall a. DBRange a => Value (Range a)
rangeEncoder Value (Range a)
forall a. DBRange a => Value (Range a)
rangeDecoder TypeInformation a
element
    where
      name :: QualifiedName
name = forall a. DBRange a => QualifiedName
rangeTypeName @a
      element :: TypeInformation a
element = forall a. DBType a => TypeInformation a
typeInformation @a


instance DBRange a => DBEq (Range a)


instance DBRange a => DBOrd (Range a)


instance DBRange a => DBType (Multirange a) where
  typeInformation :: TypeInformation (Multirange a)
typeInformation =
    QualifiedName
-> QualifiedName
-> Value (Multirange a)
-> Value (Multirange a)
-> TypeInformation a
-> TypeInformation (Multirange a)
forall a.
QualifiedName
-> QualifiedName
-> Value (Multirange a)
-> Value (Multirange a)
-> TypeInformation a
-> TypeInformation (Multirange a)
multirangeTypeInformation
      QualifiedName
multiname
      QualifiedName
name
      Value (Multirange a)
forall a. DBRange a => Value (Multirange a)
multirangeEncoder
      Value (Multirange a)
forall a. DBRange a => Value (Multirange a)
multirangeDecoder
      TypeInformation a
element
    where
      multiname :: QualifiedName
multiname = forall a. DBRange a => QualifiedName
multirangeTypeName @a
      name :: QualifiedName
name = forall a. DBRange a => QualifiedName
rangeTypeName @a
      element :: TypeInformation a
element = forall a. DBType a => TypeInformation a
typeInformation @a


instance DBRange a => DBEq (Multirange a)


instance DBRange a => DBOrd (Multirange a)


rangeTypeInformation ::
  QualifiedName ->
  Encoder.Value (Range a) ->
  Decoder.Value (Range a) ->
  TypeInformation a ->
  TypeInformation (Range a)
rangeTypeInformation :: forall a.
QualifiedName
-> Value (Range a)
-> Value (Range a)
-> TypeInformation a
-> TypeInformation (Range a)
rangeTypeInformation QualifiedName
name Value (Range a)
encoder Value (Range a)
decoder TypeInformation a
element =
  TypeInformation
    { encode :: Encoder (Range a)
encode =
        Encoder
          { binary :: Value (Range a)
binary = Value (Range a)
encoder
          , text :: Range a -> Builder
text = Range ByteString -> Builder
buildRange (Range ByteString -> Builder)
-> (Range a -> Range ByteString) -> Range a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> ByteString) -> Range a -> Range ByteString
forall a b. (a -> b) -> Range a -> Range b
mapRange (Builder -> ByteString
render (Builder -> ByteString) -> (a -> Builder) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInformation a
element.encode.text)
          , quote :: Range a -> PrimExpr
quote = QualifiedName -> Range PrimExpr -> PrimExpr
quoteRange QualifiedName
name (Range PrimExpr -> PrimExpr)
-> (Range a -> Range PrimExpr) -> Range a -> PrimExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> PrimExpr) -> Range a -> Range PrimExpr
forall a b. (a -> b) -> Range a -> Range b
mapRange TypeInformation a
element.encode.quote
          }
    , decode :: Decoder (Range a)
decode =
        Decoder
          { binary :: Value (Range a)
binary = Value (Range a)
decoder
          , text :: Parser (Range a)
text = ByteString -> Either String (Range ByteString)
parseRange (ByteString -> Either String (Range ByteString))
-> (Range ByteString -> Either String (Range a))
-> Parser (Range a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (ByteString -> Either String a)
-> Range ByteString -> Either String (Range a)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Range a -> f (Range b)
traverseRange TypeInformation a
element.decode.text
          }
    , delimiter :: Char
delimiter = Char
','
    , typeName :: TypeName
typeName =
        TypeName
          { QualifiedName
name :: QualifiedName
name :: QualifiedName
name
          , modifiers :: [String]
modifiers = []
          , arrayDepth :: Word
arrayDepth = Word
0
          }
    }
  where
    render :: Builder -> ByteString
render = LazyByteString -> ByteString
L.toStrict (LazyByteString -> ByteString)
-> (Builder -> LazyByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
toLazyByteString


multirangeTypeInformation ::
  QualifiedName ->
  QualifiedName ->
  Encoder.Value (PostgreSQL.Multirange a) ->
  Decoder.Value (PostgreSQL.Multirange a) ->
  TypeInformation a ->
  TypeInformation (Multirange a)
multirangeTypeInformation :: forall a.
QualifiedName
-> QualifiedName
-> Value (Multirange a)
-> Value (Multirange a)
-> TypeInformation a
-> TypeInformation (Multirange a)
multirangeTypeInformation QualifiedName
multiname QualifiedName
name Value (Multirange a)
encoder Value (Multirange a)
decoder TypeInformation a
element =
  TypeInformation
    { encode :: Encoder (Multirange a)
encode =
        Encoder
          { binary :: Value (Multirange a)
binary = (\(Multirange Multirange a
ranges) -> Multirange a
ranges) (Multirange a -> Multirange a)
-> Value (Multirange a) -> Value (Multirange a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Value (Multirange a)
encoder
          , text :: Multirange a -> Builder
text =
              Multirange ByteString -> Builder
buildMultirange (Multirange ByteString -> Builder)
-> (Multirange a -> Multirange ByteString)
-> Multirange a
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> ByteString) -> Multirange a -> Multirange ByteString
forall a b. (a -> b) -> Multirange a -> Multirange b
mapMultirange (Builder -> ByteString
render (Builder -> ByteString) -> (a -> Builder) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeInformation a
element.encode.text)
          , quote :: Multirange a -> PrimExpr
quote =
              QualifiedName -> QualifiedName -> Multirange PrimExpr -> PrimExpr
quoteMultirange QualifiedName
multiname QualifiedName
name
                (Multirange PrimExpr -> PrimExpr)
-> (Multirange a -> Multirange PrimExpr)
-> Multirange a
-> PrimExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> PrimExpr) -> Multirange a -> Multirange PrimExpr
forall a b. (a -> b) -> Multirange a -> Multirange b
mapMultirange TypeInformation a
element.encode.quote
          }
    , decode :: Decoder (Multirange a)
decode =
        Decoder
          { binary :: Value (Multirange a)
binary = Multirange a -> Multirange a
forall a. Multirange a -> Multirange a
Multirange (Multirange a -> Multirange a)
-> Value (Multirange a) -> Value (Multirange a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value (Multirange a)
decoder
          , text :: Parser (Multirange a)
text = ByteString -> Either String (Multirange ByteString)
parseMultirange (ByteString -> Either String (Multirange ByteString))
-> (Multirange ByteString -> Either String (Multirange a))
-> Parser (Multirange a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (ByteString -> Either String a)
-> Multirange ByteString -> Either String (Multirange a)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Multirange a -> f (Multirange b)
traverseMultirange TypeInformation a
element.decode.text
          }
    , delimiter :: Char
delimiter = Char
','
    , typeName :: TypeName
typeName =
        TypeName
          { name :: QualifiedName
name = QualifiedName
multiname
          , modifiers :: [String]
modifiers = []
          , arrayDepth :: Word
arrayDepth = Word
0
          }
    }
  where
    render :: Builder -> ByteString
render = LazyByteString -> ByteString
L.toStrict (LazyByteString -> ByteString)
-> (Builder -> LazyByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
toLazyByteString


buildRange :: Range ByteString -> Builder
buildRange :: Range ByteString -> Builder
buildRange = \case
  Range ByteString
Empty -> String -> Builder
B.string7 String
"empty"
  Range Bound ByteString
lo Bound ByteString
hi -> Builder
lower Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.char8 Char
',' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
upper
    where
      lower :: Builder
lower = case Bound ByteString
lo of
        Incl ByteString
a -> Char -> Builder
B.char8 Char
'[' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
element ByteString
a
        Excl ByteString
a -> Char -> Builder
B.char8 Char
'(' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
element ByteString
a
        Bound ByteString
Inf -> Char -> Builder
B.char8 Char
'('
      upper :: Builder
upper = case Bound ByteString
hi of
        Incl ByteString
a -> ByteString -> Builder
element ByteString
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.char8 Char
']'
        Excl ByteString
a -> ByteString -> Builder
element ByteString
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.char8 Char
')'
        Bound ByteString
Inf -> Char -> Builder
B.char8 Char
')'
  where
    element :: ByteString -> Builder
element ByteString
bytes
      | ByteString -> Bool
BS.null ByteString
bytes = String -> Builder
B.string7 String
"\"\""
      | (Char -> Bool) -> ByteString -> Bool
BS.any (String -> Char -> Bool
A.inClass String
escapeClass) ByteString
bytes = ByteString -> Builder
escape ByteString
bytes
      | Bool
otherwise = ByteString -> Builder
B.byteString ByteString
bytes
    escapeClass :: String
escapeClass = String
",()[]\\\" \t\n\r\v\f"
    escape :: ByteString -> Builder
escape ByteString
bytes =
      Char -> Builder
B.char8 Char
'"' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Char -> Builder -> Builder) -> Builder -> ByteString -> Builder
forall a. (Char -> a -> a) -> a -> ByteString -> a
BS.foldr (Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
(<>) (Builder -> Builder -> Builder)
-> (Char -> Builder) -> Char -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Builder
go) Builder
forall a. Monoid a => a
mempty ByteString
bytes Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.char8 Char
'"'
      where
        go :: Char -> Builder
go = \case
          Char
'"' -> String -> Builder
B.string7 String
"\\\""
          Char
'\\' -> String -> Builder
B.string7 String
"\\\\"
          Char
c -> Char -> Builder
B.char8 Char
c


quoteRange :: QualifiedName -> Range Opaleye.PrimExpr -> Opaleye.PrimExpr
quoteRange :: QualifiedName -> Range PrimExpr -> PrimExpr
quoteRange QualifiedName
name = \case
  Range PrimExpr
Empty ->
    Literal -> PrimExpr
Opaleye.ConstExpr (String -> Literal
Opaleye.StringLit String
"empty")
  Range Bound PrimExpr
lo Bound PrimExpr
hi ->
    String -> [PrimExpr] -> PrimExpr
Opaleye.FunExpr String
constructor [PrimExpr
lower, PrimExpr
upper, PrimExpr
bounds]
    where
      lower :: PrimExpr
lower = case Bound PrimExpr
lo of
        Incl PrimExpr
a -> PrimExpr
a
        Excl PrimExpr
a -> PrimExpr
a
        Bound PrimExpr
Inf -> Literal -> PrimExpr
Opaleye.ConstExpr Literal
Opaleye.NullLit
      upper :: PrimExpr
upper = case Bound PrimExpr
hi of
        Incl PrimExpr
a -> PrimExpr
a
        Excl PrimExpr
a -> PrimExpr
a
        Bound PrimExpr
Inf -> Literal -> PrimExpr
Opaleye.ConstExpr Literal
Opaleye.NullLit
      bounds :: PrimExpr
bounds = Literal -> PrimExpr
Opaleye.ConstExpr (String -> Literal
Opaleye.StringLit (Char
l Char -> ShowS
forall a. a -> [a] -> [a]
: Char
h Char -> ShowS
forall a. a -> [a] -> [a]
: []))
        where
          l :: Char
l = case Bound PrimExpr
lo of
            Incl PrimExpr
_ -> Char
'['
            Bound PrimExpr
_ -> Char
'('
          h :: Char
h = case Bound PrimExpr
hi of
            Incl PrimExpr
_ -> Char
']'
            Bound PrimExpr
_ -> Char
')'
  where
    constructor :: String
constructor = QualifiedName -> String
showQualifiedName QualifiedName
name


parseRange :: ByteString -> Either String (Range ByteString)
parseRange :: ByteString -> Either String (Range ByteString)
parseRange = Parser (Range ByteString)
-> ByteString -> Either String (Range ByteString)
forall a. Parser a -> ByteString -> Either String a
parse (Parser (Range ByteString)
 -> ByteString -> Either String (Range ByteString))
-> Parser (Range ByteString)
-> ByteString
-> Either String (Range ByteString)
forall a b. (a -> b) -> a -> b
$ Parser (Range ByteString)
forall {a}. Parser ByteString (Range a)
empty Parser (Range ByteString)
-> Parser (Range ByteString) -> Parser (Range ByteString)
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Range ByteString)
nonEmpty
  where
    empty :: Parser ByteString (Range a)
empty = Range a
forall a. Range a
Empty Range a
-> Parser ByteString ByteString -> Parser ByteString (Range a)
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
A.string ByteString
"empty"
    nonEmpty :: Parser (Range ByteString)
nonEmpty = Parser (Range ByteString)
rangeParser


rangeParser :: A.Parser (Range ByteString)
rangeParser :: Parser (Range ByteString)
rangeParser = do
  lo <- ByteString -> Bound ByteString
forall a. a -> Bound a
Incl (ByteString -> Bound ByteString)
-> Parser ByteString Char
-> Parser ByteString (ByteString -> Bound ByteString)
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser ByteString Char
A.char Char
'[' Parser ByteString (ByteString -> Bound ByteString)
-> Parser ByteString (ByteString -> Bound ByteString)
-> Parser ByteString (ByteString -> Bound ByteString)
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Bound ByteString
forall a. a -> Bound a
Excl (ByteString -> Bound ByteString)
-> Parser ByteString Char
-> Parser ByteString (ByteString -> Bound ByteString)
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser ByteString Char
A.char Char
'('
  mlower <- optional element
  void $ A.char ','
  mupper <- optional element
  hi <- Incl <$ A.char ']' <|> Excl <$ A.char ')'
  let
    lower = Bound ByteString
-> (ByteString -> Bound ByteString)
-> Maybe ByteString
-> Bound ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bound ByteString
forall a. Bound a
Inf ByteString -> Bound ByteString
lo Maybe ByteString
mlower
    upper = Bound ByteString
-> (ByteString -> Bound ByteString)
-> Maybe ByteString
-> Bound ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bound ByteString
forall a. Bound a
Inf ByteString -> Bound ByteString
hi Maybe ByteString
mupper
  pure $ Range lower upper
  where
    element :: Parser ByteString ByteString
element = Parser ByteString ByteString
quoted Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
unquoted
      where
        unquoted :: Parser ByteString ByteString
unquoted = (Char -> Bool) -> Parser ByteString ByteString
A.takeWhile1 (String -> Char -> Bool
A.notInClass String
",)]")
        quoted :: Parser ByteString ByteString
quoted = Char -> Parser ByteString Char
A.char Char
'"' Parser ByteString Char
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ByteString
contents Parser ByteString ByteString
-> Parser ByteString Char -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
A.char Char
'"'
          where
            contents :: Parser ByteString ByteString
contents = [ByteString] -> ByteString
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([ByteString] -> ByteString)
-> Parser ByteString [ByteString] -> Parser ByteString ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString -> Parser ByteString [ByteString]
forall a. Parser ByteString a -> Parser ByteString [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser ByteString ByteString
unquote Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
unescape)
              where
                unquote :: Parser ByteString ByteString
unquote = (Char -> Bool) -> Parser ByteString ByteString
A.takeWhile1 (String -> Char -> Bool
A.notInClass String
"\"\\")
                unescape :: Parser ByteString ByteString
unescape = Char -> Parser ByteString Char
A.char Char
'\\' Parser ByteString Char
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> do
                  Char -> ByteString
BS.singleton (Char -> ByteString)
-> Parser ByteString Char -> Parser ByteString ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
                    Char -> Parser ByteString Char
A.char Char
'\\' Parser ByteString Char
-> Parser ByteString Char -> Parser ByteString Char
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser ByteString Char
A.char Char
'"'


buildMultirange :: Multirange ByteString -> Builder
buildMultirange :: Multirange ByteString -> Builder
buildMultirange (Multirange Multirange ByteString
ranges) =
  Char -> Builder
B.char8 Char
'{' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
-> (Range ByteString -> Builder)
-> Multirange ByteString
-> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
m -> (a -> m) -> t a -> m
interfoldMap (Char -> Builder
B.char8 Char
',') Range ByteString -> Builder
buildRange Multirange ByteString
ranges Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.char8 Char
'}'


quoteMultirange ::
  QualifiedName ->
  QualifiedName ->
  Multirange Opaleye.PrimExpr ->
  Opaleye.PrimExpr
quoteMultirange :: QualifiedName -> QualifiedName -> Multirange PrimExpr -> PrimExpr
quoteMultirange QualifiedName
multiname QualifiedName
name (Multirange Multirange PrimExpr
ranges) =
  QualifiedName -> [PrimExpr] -> PrimExpr
primMultirange QualifiedName
multiname ((Range PrimExpr -> PrimExpr) -> Multirange PrimExpr -> [PrimExpr]
forall a b. (a -> b) -> [a] -> [b]
map (PrimExpr -> PrimExpr
cast (PrimExpr -> PrimExpr)
-> (Range PrimExpr -> PrimExpr) -> Range PrimExpr -> PrimExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedName -> Range PrimExpr -> PrimExpr
quoteRange QualifiedName
name) Multirange PrimExpr
ranges)
  where
    cast :: PrimExpr -> PrimExpr
cast = String -> PrimExpr -> PrimExpr
Opaleye.CastExpr (QualifiedName -> String
showQualifiedName QualifiedName
name)


primMultirange :: QualifiedName -> [Opaleye.PrimExpr] -> Opaleye.PrimExpr
primMultirange :: QualifiedName -> [PrimExpr] -> PrimExpr
primMultirange = String -> [PrimExpr] -> PrimExpr
Opaleye.FunExpr (String -> [PrimExpr] -> PrimExpr)
-> (QualifiedName -> String)
-> QualifiedName
-> [PrimExpr]
-> PrimExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedName -> String
showQualifiedName


parseMultirange ::
  ByteString ->
  Either String (Multirange ByteString)
parseMultirange :: ByteString -> Either String (Multirange ByteString)
parseMultirange =
  Parser (Multirange ByteString)
-> ByteString -> Either String (Multirange ByteString)
forall a. Parser a -> ByteString -> Either String a
parse (Parser (Multirange ByteString)
 -> ByteString -> Either String (Multirange ByteString))
-> Parser (Multirange ByteString)
-> ByteString
-> Either String (Multirange ByteString)
forall a b. (a -> b) -> a -> b
$
    Multirange ByteString -> Multirange ByteString
forall a. Multirange a -> Multirange a
Multirange (Multirange ByteString -> Multirange ByteString)
-> Parser ByteString (Multirange ByteString)
-> Parser (Multirange ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      Char -> Parser ByteString Char
A.char Char
'{' Parser ByteString Char
-> Parser ByteString (Multirange ByteString)
-> Parser ByteString (Multirange ByteString)
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser (Range ByteString)
-> Parser ByteString Char
-> Parser ByteString (Multirange ByteString)
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
A.sepBy Parser (Range ByteString)
rangeParser (Char -> Parser ByteString Char
A.char Char
',') Parser ByteString (Multirange ByteString)
-> Parser ByteString Char
-> Parser ByteString (Multirange ByteString)
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
A.char Char
'}'


mapBound :: (a -> b) -> Bound a -> Bound b
mapBound :: forall a b. (a -> b) -> Bound a -> Bound b
mapBound a -> b
f = \case
  Incl a
a -> b -> Bound b
forall a. a -> Bound a
Incl (a -> b
f a
a)
  Excl a
a -> b -> Bound b
forall a. a -> Bound a
Excl (a -> b
f a
a)
  Bound a
Inf -> Bound b
forall a. Bound a
Inf


traverseBound ::
  Applicative f =>
  (a -> f b) ->
  Bound a ->
  f (Bound b)
traverseBound :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Bound a -> f (Bound b)
traverseBound a -> f b
f = \case
  Incl a
a -> b -> Bound b
forall a. a -> Bound a
Incl (b -> Bound b) -> f b -> f (Bound b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a
  Excl a
a -> b -> Bound b
forall a. a -> Bound a
Excl (b -> Bound b) -> f b -> f (Bound b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a
  Bound a
Inf -> Bound b -> f (Bound b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bound b
forall a. Bound a
Inf


mapRange :: (a -> b) -> Range a -> Range b
mapRange :: forall a b. (a -> b) -> Range a -> Range b
mapRange a -> b
f = \case
  Range a
Empty -> Range b
forall a. Range a
Empty
  Range Bound a
a Bound a
b -> Bound b -> Bound b -> Range b
forall a. Bound a -> Bound a -> Range a
Range ((a -> b) -> Bound a -> Bound b
forall a b. (a -> b) -> Bound a -> Bound b
mapBound a -> b
f Bound a
a) ((a -> b) -> Bound a -> Bound b
forall a b. (a -> b) -> Bound a -> Bound b
mapBound a -> b
f Bound a
b)


traverseRange ::
  Applicative f =>
  (a -> f b) ->
  Range a ->
  f (Range b)
traverseRange :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Range a -> f (Range b)
traverseRange a -> f b
f = \case
  Range a
Empty -> Range b -> f (Range b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Range b
forall a. Range a
Empty
  Range Bound a
a Bound a
b ->
    Bound b -> Bound b -> Range b
forall a. Bound a -> Bound a -> Range a
Range (Bound b -> Bound b -> Range b)
-> f (Bound b) -> f (Bound b -> Range b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> Bound a -> f (Bound b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Bound a -> f (Bound b)
traverseBound a -> f b
f Bound a
a f (Bound b -> Range b) -> f (Bound b) -> f (Range b)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (a -> f b) -> Bound a -> f (Bound b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Bound a -> f (Bound b)
traverseBound a -> f b
f Bound a
b


mapMultirange ::
  (a -> b) ->
  Multirange a ->
  Multirange b
mapMultirange :: forall a b. (a -> b) -> Multirange a -> Multirange b
mapMultirange a -> b
f (Multirange Multirange a
ranges) = Multirange b -> Multirange b
forall a. Multirange a -> Multirange a
Multirange ((Range a -> Range b) -> Multirange a -> Multirange b
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> Range a -> Range b
forall a b. (a -> b) -> Range a -> Range b
mapRange a -> b
f) Multirange a
ranges)


traverseMultirange ::
  Applicative f =>
  (a -> f b) ->
  Multirange a ->
  f (Multirange b)
traverseMultirange :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Multirange a -> f (Multirange b)
traverseMultirange a -> f b
f (Multirange Multirange a
ranges) =
  Multirange b -> Multirange b
forall a. Multirange a -> Multirange a
Multirange (Multirange b -> Multirange b)
-> f (Multirange b) -> f (Multirange b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Range a -> f (Range b)) -> Multirange a -> f (Multirange b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((a -> f b) -> Range a -> f (Range b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Range a -> f (Range b)
traverseRange a -> f b
f) Multirange a
ranges