Range.hs

{-|
Module: Squeal.PostgreSQL.Expression.Range
Description: range types and functions
Copyright: (c) Eitan Chatav, 2019
Maintainer: eitan@morphism.tech
Stability: experimental

range types and functions
-}

{-# LANGUAGE
    AllowAmbiguousTypes
  , DataKinds
  , DeriveAnyClass
  , DeriveGeneric
  , DeriveFoldable
  , DerivingStrategies
  , DeriveTraversable
  , FlexibleContexts
  , FlexibleInstances
  , LambdaCase
  , MultiParamTypeClasses
  , OverloadedLabels
  , OverloadedStrings
  , PatternSynonyms
  , RankNTypes
  , ScopedTypeVariables
  , TypeApplications
  , TypeFamilies
  , TypeOperators
  , UndecidableInstances
#-}

module Squeal.PostgreSQL.Expression.Range
  ( -- * Range
    Range (..)
  , (<=..<=), (<..<), (<=..<), (<..<=)
  , moreThan, atLeast, lessThan, atMost
  , singleton, whole
  , Bound (..)
    -- * Range Function
    -- ** Range Construction
  , range
    -- ** Range Operator
  , (.<@)
  , (@>.)
  , (<<@)
  , (@>>)
  , (&<)
  , (&>)
  , (-|-)
  , (@+)
  , (@*)
  , (@-)
    -- ** Range Function
  , lowerBound
  , upperBound
  , isEmpty
  , lowerInc
  , lowerInf
  , upperInc
  , upperInf
  , rangeMerge
  ) where

import qualified GHC.Generics as GHC
import qualified Generics.SOP as SOP

import Squeal.PostgreSQL.Expression
import Squeal.PostgreSQL.Expression.Type hiding (bool)
import Squeal.PostgreSQL.Type.PG
import Squeal.PostgreSQL.Render
import Squeal.PostgreSQL.Type.Schema

-- $setup
-- >>> import Squeal.PostgreSQL (tstzrange, numrange, int4range, now, printSQL)

-- | Construct a `range`
--
-- >>> printSQL $ range tstzrange (atLeast now)
-- tstzrange(now(), NULL, '[)')
-- >>> printSQL $ range numrange (0 <=..< 2*pi)
-- numrange((0.0 :: numeric), ((2.0 :: numeric) * pi()), '[)')
-- >>> printSQL $ range int4range Empty
-- ('empty' :: int4range)
range
  :: TypeExpression db (null ('PGrange ty))
  -- ^ range type
  -> Range (Expression grp lat with db params from ('NotNull ty))
  -- ^ range of values
  -> Expression grp lat with db params from (null ('PGrange ty))
range ty = \case
  Empty -> UnsafeExpression $ parenthesized
    (emp <+> "::" <+> renderSQL ty)
  NonEmpty l u -> UnsafeExpression $ renderSQL ty <> parenthesized
    (commaSeparated (args l u))
  where
    emp = singleQuote <> "empty" <> singleQuote
    args l u = [arg l, arg u, singleQuote <> bra l <> ket u <> singleQuote]
    singleQuote = "\'"
    arg = \case
      Infinite -> "NULL"; Closed x -> renderSQL x; Open x -> renderSQL x
    bra = \case Infinite -> "("; Closed _ -> "["; Open _ -> "("
    ket = \case Infinite -> ")"; Closed _ -> "]"; Open _ -> ")"

-- | The type of `Bound` for a `Range`.
data Bound x
  = Infinite -- ^ unbounded
  | Closed x -- ^ inclusive
  | Open x -- ^ exclusive
  deriving
    ( Eq, Ord, Show, Read, GHC.Generic
    , Functor, Foldable, Traversable )

-- | A `Range` datatype that comprises connected subsets of
-- the real line.
data Range x = Empty | NonEmpty (Bound x) (Bound x)
  deriving
    ( Eq, Ord, Show, Read, GHC.Generic
    , Functor, Foldable, Traversable )
  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
-- | `PGrange` @(@`PG` @hask)@
instance IsPG hask => IsPG (Range hask) where
  type PG (Range hask) = 'PGrange (PG hask)

-- | Finite `Range` constructor
(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x
infix 4 <=..<=, <..<, <=..<, <..<=
x <=..<= y = NonEmpty (Closed x) (Closed y)
x <..< y = NonEmpty (Open x) (Open y)
x <=..< y = NonEmpty (Closed x) (Open y)
x <..<= y = NonEmpty (Open x) (Closed y)

-- | Half-infinite `Range` constructor
moreThan, atLeast, lessThan, atMost :: x -> Range x
moreThan x = NonEmpty (Open x) Infinite
atLeast x = NonEmpty (Closed x) Infinite
lessThan x = NonEmpty Infinite (Open x)
atMost x = NonEmpty Infinite (Closed x)

-- | A point on the line
singleton :: x -> Range x
singleton x = x <=..<= x

-- | The `whole` line
whole :: Range x
whole = NonEmpty Infinite Infinite

-- | range is contained by
(.<@) :: Operator (null0 ty) (null1 ('PGrange ty)) ('Null 'PGbool)
(.<@) = unsafeBinaryOp "<@"

-- | contains range
(@>.) :: Operator (null0 ('PGrange ty)) (null1 ty) ('Null 'PGbool)
(@>.) = unsafeBinaryOp "@>"

-- | strictly left of,
-- return false when an empty range is involved
(<<@) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
(<<@) = unsafeBinaryOp "<<"

-- | strictly right of,
-- return false when an empty range is involved
(@>>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
(@>>) = unsafeBinaryOp ">>"

-- | does not extend to the right of,
-- return false when an empty range is involved
(&<) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
(&<) = unsafeBinaryOp "&<"

-- | does not extend to the left of,
-- return false when an empty range is involved
(&>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
(&>) = unsafeBinaryOp "&>"

-- | is adjacent to, return false when an empty range is involved
(-|-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
(-|-) = unsafeBinaryOp "-|-"

-- | union, will fail if the resulting range would
-- need to contain two disjoint sub-ranges
(@+) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
(@+) = unsafeBinaryOp "+"

-- | intersection
(@*) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
(@*) = unsafeBinaryOp "*"

-- | difference, will fail if the resulting range would
-- need to contain two disjoint sub-ranges
(@-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
(@-) = unsafeBinaryOp "-"

-- | lower bound of range
lowerBound :: null ('PGrange ty) --> 'Null ty
lowerBound = unsafeFunction "lower"

-- | upper bound of range
upperBound :: null ('PGrange ty) --> 'Null ty
upperBound = unsafeFunction "upper"

-- | is the range empty?
isEmpty :: null ('PGrange ty) --> 'Null 'PGbool
isEmpty = unsafeFunction "isempty"

-- | is the lower bound inclusive?
lowerInc :: null ('PGrange ty) --> 'Null 'PGbool
lowerInc = unsafeFunction "lower_inc"

-- | is the lower bound infinite?
lowerInf :: null ('PGrange ty) --> 'Null 'PGbool
lowerInf = unsafeFunction "lower_inf"

-- | is the upper bound inclusive?
upperInc :: null ('PGrange ty) --> 'Null 'PGbool
upperInc = unsafeFunction "upper_inc"

-- | is the upper bound infinite?
upperInf :: null ('PGrange ty) --> 'Null 'PGbool
upperInf = unsafeFunction "upper_inf"

-- | the smallest range which includes both of the given ranges
rangeMerge ::
  '[null ('PGrange ty), null ('PGrange ty)]
  ---> null ('PGrange ty)
rangeMerge = unsafeFunctionN "range_merge"