{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}

module Opaleye.Internal.Sql where

import           Prelude hiding (product)

import qualified Opaleye.Internal.PrimQuery as PQ

import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
import           Opaleye.Internal.HaskellDB.PrimQuery (Symbol(Symbol))
import qualified Opaleye.Internal.HaskellDB.Sql as HSql
import qualified Opaleye.Internal.HaskellDB.Sql.Default as SD
import qualified Opaleye.Internal.HaskellDB.Sql.Print as SP
import qualified Opaleye.Internal.HaskellDB.Sql.Generate as SG
import qualified Opaleye.Internal.Tag as T

import qualified Data.List.NonEmpty as NEL
import qualified Data.Maybe as M
import qualified Data.Void as V

import qualified Control.Arrow as Arr

data Select = SelectFrom From
            | Table HSql.SqlTable
            | RelExpr HSql.SqlExpr
            -- ^ A relation-valued expression
            | SelectJoin Join
            | SelectSemijoin Semijoin
            | SelectValues Values
            | SelectBinary Binary
            | SelectLabel Label
            | SelectExists Exists
            | SelectWith With
            deriving Int -> Select -> ShowS
[Select] -> ShowS
Select -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Select] -> ShowS
$cshowList :: [Select] -> ShowS
show :: Select -> String
$cshow :: Select -> String
showsPrec :: Int -> Select -> ShowS
$cshowsPrec :: Int -> Select -> ShowS
Show

data SelectAttrs =
    Star
  | SelectAttrs (NEL.NonEmpty (HSql.SqlExpr, Maybe HSql.SqlColumn))
  | SelectAttrsStar (NEL.NonEmpty (HSql.SqlExpr, Maybe HSql.SqlColumn))
  deriving Int -> SelectAttrs -> ShowS
[SelectAttrs] -> ShowS
SelectAttrs -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SelectAttrs] -> ShowS
$cshowList :: [SelectAttrs] -> ShowS
show :: SelectAttrs -> String
$cshow :: SelectAttrs -> String
showsPrec :: Int -> SelectAttrs -> ShowS
$cshowsPrec :: Int -> SelectAttrs -> ShowS
Show

data From = From {
  From -> SelectAttrs
attrs      :: SelectAttrs,
  From -> [(Lateral, Select)]
tables     :: [(Lateral, Select)],
  From -> [SqlExpr]
criteria   :: [HSql.SqlExpr],
  From -> Maybe (NonEmpty SqlExpr)
groupBy    :: Maybe (NEL.NonEmpty HSql.SqlExpr),
  From -> [(SqlExpr, SqlOrder)]
orderBy    :: [(HSql.SqlExpr, HSql.SqlOrder)],
  From -> Maybe (NonEmpty SqlExpr)
distinctOn :: Maybe (NEL.NonEmpty HSql.SqlExpr),
  From -> Maybe Int
limit      :: Maybe Int,
  From -> Maybe Int
offset     :: Maybe Int,
  From -> Maybe LockStrength
for        :: Maybe LockStrength
  }
          deriving Int -> From -> ShowS
[From] -> ShowS
From -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [From] -> ShowS
$cshowList :: [From] -> ShowS
show :: From -> String
$cshow :: From -> String
showsPrec :: Int -> From -> ShowS
$cshowsPrec :: Int -> From -> ShowS
Show

data Join = Join {
  Join -> JoinType
jJoinType   :: JoinType,
  Join -> ((Lateral, Select), (Lateral, Select))
jTables     :: ((Lateral, Select), (Lateral, Select)),
  Join -> SqlExpr
jCond       :: HSql.SqlExpr
  }
                deriving Int -> Join -> ShowS
[Join] -> ShowS
Join -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Join] -> ShowS
$cshowList :: [Join] -> ShowS
show :: Join -> String
$cshow :: Join -> String
showsPrec :: Int -> Join -> ShowS
$cshowsPrec :: Int -> Join -> ShowS
Show

data Semijoin = Semijoin
  { Semijoin -> SemijoinType
sjType     :: SemijoinType
  , Semijoin -> Select
sjTable    :: Select
  , Semijoin -> Select
sjCriteria :: Select
  } deriving Int -> Semijoin -> ShowS
[Semijoin] -> ShowS
Semijoin -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Semijoin] -> ShowS
$cshowList :: [Semijoin] -> ShowS
show :: Semijoin -> String
$cshow :: Semijoin -> String
showsPrec :: Int -> Semijoin -> ShowS
$cshowsPrec :: Int -> Semijoin -> ShowS
Show

data Values = Values {
  Values -> SelectAttrs
vAttrs  :: SelectAttrs,
  Values -> [[SqlExpr]]
vValues :: [[HSql.SqlExpr]]
} deriving Int -> Values -> ShowS
[Values] -> ShowS
Values -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Values] -> ShowS
$cshowList :: [Values] -> ShowS
show :: Values -> String
$cshow :: Values -> String
showsPrec :: Int -> Values -> ShowS
$cshowsPrec :: Int -> Values -> ShowS
Show

data Binary = Binary {
  Binary -> BinOp
bOp :: BinOp,
  Binary -> Select
bSelect1 :: Select,
  Binary -> Select
bSelect2 :: Select
} deriving Int -> Binary -> ShowS
[Binary] -> ShowS
Binary -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Binary] -> ShowS
$cshowList :: [Binary] -> ShowS
show :: Binary -> String
$cshow :: Binary -> String
showsPrec :: Int -> Binary -> ShowS
$cshowsPrec :: Int -> Binary -> ShowS
Show

data JoinType = LeftJoin | RightJoin | FullJoin deriving Int -> JoinType -> ShowS
[JoinType] -> ShowS
JoinType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JoinType] -> ShowS
$cshowList :: [JoinType] -> ShowS
show :: JoinType -> String
$cshow :: JoinType -> String
showsPrec :: Int -> JoinType -> ShowS
$cshowsPrec :: Int -> JoinType -> ShowS
Show
data SemijoinType = Semi | Anti deriving Int -> SemijoinType -> ShowS
[SemijoinType] -> ShowS
SemijoinType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SemijoinType] -> ShowS
$cshowList :: [SemijoinType] -> ShowS
show :: SemijoinType -> String
$cshow :: SemijoinType -> String
showsPrec :: Int -> SemijoinType -> ShowS
$cshowsPrec :: Int -> SemijoinType -> ShowS
Show
data BinOp = Except | ExceptAll | Union | UnionAll | Intersect | IntersectAll deriving Int -> BinOp -> ShowS
[BinOp] -> ShowS
BinOp -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BinOp] -> ShowS
$cshowList :: [BinOp] -> ShowS
show :: BinOp -> String
$cshow :: BinOp -> String
showsPrec :: Int -> BinOp -> ShowS
$cshowsPrec :: Int -> BinOp -> ShowS
Show
data Lateral = Lateral | NonLateral deriving Int -> Lateral -> ShowS
[Lateral] -> ShowS
Lateral -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Lateral] -> ShowS
$cshowList :: [Lateral] -> ShowS
show :: Lateral -> String
$cshow :: Lateral -> String
showsPrec :: Int -> Lateral -> ShowS
$cshowsPrec :: Int -> Lateral -> ShowS
Show
data LockStrength = Update deriving Int -> LockStrength -> ShowS
[LockStrength] -> ShowS
LockStrength -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LockStrength] -> ShowS
$cshowList :: [LockStrength] -> ShowS
show :: LockStrength -> String
$cshow :: LockStrength -> String
showsPrec :: Int -> LockStrength -> ShowS
$cshowsPrec :: Int -> LockStrength -> ShowS
Show
data Recursive = NonRecursive | Recursive deriving Int -> Recursive -> ShowS
[Recursive] -> ShowS
Recursive -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Recursive] -> ShowS
$cshowList :: [Recursive] -> ShowS
show :: Recursive -> String
$cshow :: Recursive -> String
showsPrec :: Int -> Recursive -> ShowS
$cshowsPrec :: Int -> Recursive -> ShowS
Show
data With = With {
  With -> SqlTable
wTable     :: HSql.SqlTable, -- The name of the result, i.e. WITH <name> AS
  With -> [SqlColumn]
wCols      :: [HSql.SqlColumn],
  With -> Recursive
wRecursive :: Recursive,
  With -> Select
wWith      :: Select,
  With -> Select
wSelect    :: Select
} deriving Int -> With -> ShowS
[With] -> ShowS
With -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [With] -> ShowS
$cshowList :: [With] -> ShowS
show :: With -> String
$cshow :: With -> String
showsPrec :: Int -> With -> ShowS
$cshowsPrec :: Int -> With -> ShowS
Show


data Label = Label {
  Label -> String
lLabel  :: String,
  Label -> Select
lSelect :: Select
} deriving Int -> Label -> ShowS
[Label] -> ShowS
Label -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Label] -> ShowS
$cshowList :: [Label] -> ShowS
show :: Label -> String
$cshow :: Label -> String
showsPrec :: Int -> Label -> ShowS
$cshowsPrec :: Int -> Label -> ShowS
Show

data Returning a = Returning a (NEL.NonEmpty HSql.SqlExpr)

data Exists = Exists
  { Exists -> Symbol
existsBinding :: Symbol
  , Exists -> Select
existsTable :: Select
  } deriving Int -> Exists -> ShowS
[Exists] -> ShowS
Exists -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Exists] -> ShowS
$cshowList :: [Exists] -> ShowS
show :: Exists -> String
$cshow :: Exists -> String
showsPrec :: Int -> Exists -> ShowS
$cshowsPrec :: Int -> Exists -> ShowS
Show

sqlQueryGenerator :: PQ.PrimQueryFold' V.Void Select
sqlQueryGenerator :: PrimQueryFold' Void Select
sqlQueryGenerator = PQ.PrimQueryFold
  { unit :: Select
PQ.unit              = Select
unit
  , empty :: Void -> Select
PQ.empty             = forall select. Void -> select
empty
  , baseTable :: TableIdentifier -> Bindings PrimExpr -> Select
PQ.baseTable         = TableIdentifier -> Bindings PrimExpr -> Select
baseTable
  , product :: NonEmpty (Lateral, Select) -> [PrimExpr] -> Select
PQ.product           = NonEmpty (Lateral, Select) -> [PrimExpr] -> Select
product
  , aggregate :: Bindings (Maybe (AggrOp, [OrderExpr], AggrDistinct), Symbol)
-> Select -> Select
PQ.aggregate         = Bindings (Maybe (AggrOp, [OrderExpr], AggrDistinct), Symbol)
-> Select -> Select
aggregate
  , distinctOnOrderBy :: Maybe (NonEmpty PrimExpr) -> [OrderExpr] -> Select -> Select
PQ.distinctOnOrderBy = Maybe (NonEmpty PrimExpr) -> [OrderExpr] -> Select -> Select
distinctOnOrderBy
  , limit :: LimitOp -> Select -> Select
PQ.limit             = LimitOp -> Select -> Select
limit_
  , join :: JoinType
-> PrimExpr -> (Lateral, Select) -> (Lateral, Select) -> Select
PQ.join              = JoinType
-> PrimExpr -> (Lateral, Select) -> (Lateral, Select) -> Select
join
  , semijoin :: SemijoinType -> Select -> Select -> Select
PQ.semijoin          = SemijoinType -> Select -> Select -> Select
semijoin
  , values :: [Symbol] -> NonEmpty [PrimExpr] -> Select
PQ.values            = [Symbol] -> NonEmpty [PrimExpr] -> Select
values
  , binary :: BinOp -> (Select, Select) -> Select
PQ.binary            = BinOp -> (Select, Select) -> Select
binary
  , label :: String -> Select -> Select
PQ.label             = String -> Select -> Select
label
  , relExpr :: PrimExpr -> Bindings PrimExpr -> Select
PQ.relExpr           = PrimExpr -> Bindings PrimExpr -> Select
relExpr
  , exists :: Symbol -> Select -> Select
PQ.exists            = Symbol -> Select -> Select
exists
  , rebind :: Bool -> Bindings PrimExpr -> Select -> Select
PQ.rebind            = Bool -> Bindings PrimExpr -> Select -> Select
rebind
  , forUpdate :: Select -> Select
PQ.forUpdate         = Select -> Select
forUpdate
  , with :: Recursive -> Symbol -> [Symbol] -> Select -> Select -> Select
PQ.with              = Recursive -> Symbol -> [Symbol] -> Select -> Select -> Select
with
  }

exists :: Symbol -> Select -> Select
exists :: Symbol -> Select -> Select
exists Symbol
binding Select
table = Exists -> Select
SelectExists (Symbol -> Select -> Exists
Exists Symbol
binding Select
table)

sql :: ([HPQ.PrimExpr], PQ.PrimQuery' V.Void, T.Tag) -> Select
sql :: ([PrimExpr], PrimQuery' Void, Tag) -> Select
sql ([PrimExpr]
pes, PrimQuery' Void
pq, Tag
t) = From -> Select
SelectFrom forall a b. (a -> b) -> a -> b
$ From
newSelect { attrs :: SelectAttrs
attrs = NonEmpty (SqlExpr, Maybe SqlColumn) -> SelectAttrs
SelectAttrs (forall a. [(SqlExpr, Maybe a)] -> NonEmpty (SqlExpr, Maybe a)
ensureColumns ([PrimExpr] -> [(SqlExpr, Maybe SqlColumn)]
makeAttrs [PrimExpr]
pes))
                                          , tables :: [(Lateral, Select)]
tables = forall t. t -> [(Lateral, t)]
oneTable Select
pqSelect }
  where pqSelect :: Select
pqSelect = forall a p. PrimQueryFold' a p -> PrimQuery' a -> p
PQ.foldPrimQuery PrimQueryFold' Void Select
sqlQueryGenerator PrimQuery' Void
pq
        makeAttrs :: [PrimExpr] -> [(SqlExpr, Maybe SqlColumn)]
makeAttrs = forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith PrimExpr -> Int -> (SqlExpr, Maybe SqlColumn)
makeAttr) [Int
1..]
        makeAttr :: PrimExpr -> Int -> (SqlExpr, Maybe SqlColumn)
makeAttr PrimExpr
pe Int
i = (Symbol, PrimExpr) -> (SqlExpr, Maybe SqlColumn)
sqlBinding (String -> Tag -> Symbol
Symbol (String
"result" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int
i :: Int)) Tag
t, PrimExpr
pe)

unit :: Select
unit :: Select
unit = From -> Select
SelectFrom From
newSelect { attrs :: SelectAttrs
attrs  = NonEmpty (SqlExpr, Maybe SqlColumn) -> SelectAttrs
SelectAttrs (forall a. [(SqlExpr, Maybe a)] -> NonEmpty (SqlExpr, Maybe a)
ensureColumns []) }

empty :: V.Void -> select
empty :: forall select. Void -> select
empty = forall select. Void -> select
V.absurd

oneTable :: t -> [(Lateral, t)]
oneTable :: forall t. t -> [(Lateral, t)]
oneTable t
t = [(Lateral
NonLateral, t
t)]

baseTable :: PQ.TableIdentifier -> [(Symbol, HPQ.PrimExpr)] -> Select
baseTable :: TableIdentifier -> Bindings PrimExpr -> Select
baseTable TableIdentifier
ti Bindings PrimExpr
columns = From -> Select
SelectFrom forall a b. (a -> b) -> a -> b
$
    From
newSelect { attrs :: SelectAttrs
attrs = NonEmpty (SqlExpr, Maybe SqlColumn) -> SelectAttrs
SelectAttrs (forall a. [(SqlExpr, Maybe a)] -> NonEmpty (SqlExpr, Maybe a)
ensureColumns (forall a b. (a -> b) -> [a] -> [b]
map (Symbol, PrimExpr) -> (SqlExpr, Maybe SqlColumn)
sqlBinding Bindings PrimExpr
columns))
              , tables :: [(Lateral, Select)]
tables = forall t. t -> [(Lateral, t)]
oneTable (SqlTable -> Select
Table (Maybe String -> String -> SqlTable
HSql.SqlTable (TableIdentifier -> Maybe String
PQ.tiSchemaName TableIdentifier
ti) (TableIdentifier -> String
PQ.tiTableName TableIdentifier
ti))) }

product :: NEL.NonEmpty (PQ.Lateral, Select) -> [HPQ.PrimExpr] -> Select
product :: NonEmpty (Lateral, Select) -> [PrimExpr] -> Select
product NonEmpty (Lateral, Select)
ss [PrimExpr]
pes = From -> Select
SelectFrom forall a b. (a -> b) -> a -> b
$
    From
newSelect { tables :: [(Lateral, Select)]
tables = forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (Lateral, Select)
ss'
              , criteria :: [SqlExpr]
criteria = forall a b. (a -> b) -> [a] -> [b]
map PrimExpr -> SqlExpr
sqlExpr [PrimExpr]
pes }
  where ss' :: NonEmpty (Lateral, Select)
ss' = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty (Lateral, Select)
ss forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
Arr.first forall a b. (a -> b) -> a -> b
$ \case
          Lateral
PQ.Lateral    -> Lateral
Lateral
          Lateral
PQ.NonLateral -> Lateral
NonLateral

aggregate :: [(Symbol,
               (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct),
                HPQ.Symbol))]
          -> Select
          -> Select
aggregate :: Bindings (Maybe (AggrOp, [OrderExpr], AggrDistinct), Symbol)
-> Select -> Select
aggregate Bindings (Maybe (AggrOp, [OrderExpr], AggrDistinct), Symbol)
aggrs' Select
s =
  From -> Select
SelectFrom forall a b. (a -> b) -> a -> b
$ From
newSelect { attrs :: SelectAttrs
attrs = NonEmpty (SqlExpr, Maybe SqlColumn) -> SelectAttrs
SelectAttrs (forall a. [(SqlExpr, Maybe a)] -> NonEmpty (SqlExpr, Maybe a)
ensureColumns (forall a b. (a -> b) -> [a] -> [b]
map (Symbol, (Maybe (AggrOp, [OrderExpr], AggrDistinct), PrimExpr))
-> (SqlExpr, Maybe SqlColumn)
attr [(Symbol, (Maybe (AggrOp, [OrderExpr], AggrDistinct), PrimExpr))]
aggrs))
                         , tables :: [(Lateral, Select)]
tables = forall t. t -> [(Lateral, t)]
oneTable Select
s
                         , groupBy :: Maybe (NonEmpty SqlExpr)
groupBy = (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall symbol aggrOp.
[(symbol, (Maybe aggrOp, PrimExpr))] -> NonEmpty SqlExpr
groupBy') [(Symbol, (Maybe (AggrOp, [OrderExpr], AggrDistinct), PrimExpr))]
aggrs }
  where --- Although in the presence of an aggregation function,
        --- grouping by an empty list is equivalent to omitting group
        --- by, the equivalence does not hold in the absence of an
        --- aggregation function.  In the absence of an aggregation
        --- function, group by of an empty list will return a single
        --- row (if there are any and zero rows otherwise).  A query
        --- without group by will return all rows.  This is a weakness
        --- of SQL.  Really there ought to be a separate SELECT
        --- AGGREGATE operation.
        ---
        --- Syntactically one cannot group by an empty list in SQL.
        --- We take the conservative approach of explicitly grouping
        --- by a constant if we are provided with an empty list of
        --- group bys.  This yields a single group.  (Alternatively,
        --- we could check whether any aggregation functions have been
        --- applied and only group by a constant in the case where
        --- none have.  That would make the generated SQL less noisy.)
        ---
        --- "GROUP BY 0" means group by the zeroth column so we
        --- instead use an expression rather than a constant.
        handleEmpty :: [HSql.SqlExpr] -> NEL.NonEmpty HSql.SqlExpr
        handleEmpty :: [SqlExpr] -> NonEmpty SqlExpr
handleEmpty = forall a. (SqlExpr -> a) -> [a] -> NonEmpty a
ensureColumnsGen SqlExpr -> SqlExpr
SP.deliteral

        aggrs :: [(Symbol, (Maybe (AggrOp, [OrderExpr], AggrDistinct), PrimExpr))]
aggrs = (forall a b. (a -> b) -> [a] -> [b]
map forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
Arr.second forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
Arr.second) Symbol -> PrimExpr
HPQ.AttrExpr Bindings (Maybe (AggrOp, [OrderExpr], AggrDistinct), Symbol)
aggrs'

        groupBy' :: [(symbol, (Maybe aggrOp, HPQ.PrimExpr))]
                 -> NEL.NonEmpty HSql.SqlExpr
        groupBy' :: forall symbol aggrOp.
[(symbol, (Maybe aggrOp, PrimExpr))] -> NonEmpty SqlExpr
groupBy' = [SqlExpr] -> NonEmpty SqlExpr
handleEmpty
                   forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map PrimExpr -> SqlExpr
sqlExpr
                   forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a} {b}. (a, (a, b)) -> b
expr
                   forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
M.isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {a} {b}. (a, (a, b)) -> a
aggrOp)
        attr :: (Symbol, (Maybe (AggrOp, [OrderExpr], AggrDistinct), PrimExpr))
-> (SqlExpr, Maybe SqlColumn)
attr = (Symbol, PrimExpr) -> (SqlExpr, Maybe SqlColumn)
sqlBinding forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
Arr.second (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe (AggrOp, [OrderExpr], AggrDistinct) -> PrimExpr -> PrimExpr
aggrExpr)
        expr :: (a, (a, b)) -> b
expr (a
_, (a
_, b
e)) = b
e
        aggrOp :: (a, (a, b)) -> a
aggrOp (a
_, (a
x, b
_)) = a
x


aggrExpr :: Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct) -> HPQ.PrimExpr -> HPQ.PrimExpr
aggrExpr :: Maybe (AggrOp, [OrderExpr], AggrDistinct) -> PrimExpr -> PrimExpr
aggrExpr = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\(AggrOp
op, [OrderExpr]
ord, AggrDistinct
distinct) PrimExpr
e -> AggrDistinct -> AggrOp -> PrimExpr -> [OrderExpr] -> PrimExpr
HPQ.AggrExpr AggrDistinct
distinct AggrOp
op PrimExpr
e [OrderExpr]
ord)

distinctOnOrderBy :: Maybe (NEL.NonEmpty HPQ.PrimExpr) -> [HPQ.OrderExpr] -> Select -> Select
distinctOnOrderBy :: Maybe (NonEmpty PrimExpr) -> [OrderExpr] -> Select -> Select
distinctOnOrderBy Maybe (NonEmpty PrimExpr)
distinctExprs [OrderExpr]
orderExprs Select
s = From -> Select
SelectFrom forall a b. (a -> b) -> a -> b
$ From
newSelect
    { tables :: [(Lateral, Select)]
tables     = forall t. t -> [(Lateral, t)]
oneTable Select
s
    , distinctOn :: Maybe (NonEmpty SqlExpr)
distinctOn = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SqlGenerator -> PrimExpr -> SqlExpr
SG.sqlExpr SqlGenerator
SD.defaultSqlGenerator) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (NonEmpty PrimExpr)
distinctExprs
    , orderBy :: [(SqlExpr, SqlOrder)]
orderBy    = forall a b. (a -> b) -> [a] -> [b]
map (SqlGenerator -> OrderExpr -> (SqlExpr, SqlOrder)
SD.toSqlOrder SqlGenerator
SD.defaultSqlGenerator) forall a b. (a -> b) -> a -> b
$
        -- Postgres requires all 'DISTINCT ON' expressions to appear before any other
        -- 'ORDER BY' expressions if there are any.
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a b. (a -> b) -> [a] -> [b]
map (OrderOp -> PrimExpr -> OrderExpr
HPQ.OrderExpr OrderOp
ascOp) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NEL.toList) Maybe (NonEmpty PrimExpr)
distinctExprs forall a. [a] -> [a] -> [a]
++ [OrderExpr]
orderExprs
    }
    where
        ascOp :: OrderOp
ascOp = HPQ.OrderOp
            { orderDirection :: OrderDirection
HPQ.orderDirection = OrderDirection
HPQ.OpAsc
            , orderNulls :: OrderNulls
HPQ.orderNulls     = OrderNulls
HPQ.NullsLast }

limit_ :: PQ.LimitOp -> Select -> Select
limit_ :: LimitOp -> Select -> Select
limit_ LimitOp
lo Select
s = From -> Select
SelectFrom forall a b. (a -> b) -> a -> b
$ From
newSelect { tables :: [(Lateral, Select)]
tables = forall t. t -> [(Lateral, t)]
oneTable Select
s
                                     , limit :: Maybe Int
limit = Maybe Int
limit'
                                     , offset :: Maybe Int
offset = Maybe Int
offset' }
  where (Maybe Int
limit', Maybe Int
offset') = case LimitOp
lo of
          PQ.LimitOp Int
n         -> (forall a. a -> Maybe a
Just Int
n, forall a. Maybe a
Nothing)
          PQ.OffsetOp Int
n        -> (forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just Int
n)
          PQ.LimitOffsetOp Int
l Int
o -> (forall a. a -> Maybe a
Just Int
l, forall a. a -> Maybe a
Just Int
o)

join :: PQ.JoinType
     -> HPQ.PrimExpr
     -> (PQ.Lateral, Select)
     -> (PQ.Lateral, Select)
     -> Select
join :: JoinType
-> PrimExpr -> (Lateral, Select) -> (Lateral, Select) -> Select
join JoinType
j PrimExpr
cond (Lateral, Select)
s1 (Lateral, Select)
s2 =
  Join -> Select
SelectJoin Join { jJoinType :: JoinType
jJoinType = JoinType -> JoinType
joinType JoinType
j
                  , jTables :: ((Lateral, Select), (Lateral, Select))
jTables   = (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
Arr.first Lateral -> Lateral
lat (Lateral, Select)
s1, forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
Arr.first Lateral -> Lateral
lat (Lateral, Select)
s2)
                  , jCond :: SqlExpr
jCond     = PrimExpr -> SqlExpr
sqlExpr PrimExpr
cond }
  where lat :: Lateral -> Lateral
lat = \case
          Lateral
PQ.Lateral -> Lateral
Lateral
          Lateral
PQ.NonLateral -> Lateral
NonLateral

semijoin :: PQ.SemijoinType -> Select -> Select -> Select
semijoin :: SemijoinType -> Select -> Select -> Select
semijoin SemijoinType
t Select
q1 Select
q2 = Semijoin -> Select
SelectSemijoin (SemijoinType -> Select -> Select -> Semijoin
Semijoin (SemijoinType -> SemijoinType
semijoinType SemijoinType
t) Select
q1 Select
q2)


-- Postgres seems to name columns of VALUES clauses "column1",
-- "column2", ... . I'm not sure to what extent it is customisable or
-- how robust it is to rely on this
values :: [Symbol] -> NEL.NonEmpty [HPQ.PrimExpr] -> Select
values :: [Symbol] -> NonEmpty [PrimExpr] -> Select
values [Symbol]
columns NonEmpty [PrimExpr]
pes = Values -> Select
SelectValues Values { vAttrs :: SelectAttrs
vAttrs  = NonEmpty (SqlExpr, Maybe SqlColumn) -> SelectAttrs
SelectAttrs ([Symbol] -> NonEmpty (SqlExpr, Maybe SqlColumn)
mkColumns [Symbol]
columns)
                                         , vValues :: [[SqlExpr]]
vValues = forall a. NonEmpty a -> [a]
NEL.toList ((forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map) PrimExpr -> SqlExpr
sqlExpr NonEmpty [PrimExpr]
pes) }
  where mkColumns :: [Symbol] -> NonEmpty (SqlExpr, Maybe SqlColumn)
mkColumns = forall a. [(SqlExpr, Maybe a)] -> NonEmpty (SqlExpr, Maybe a)
ensureColumns forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b c. ((a, b) -> c) -> a -> b -> c
curry ((Symbol, PrimExpr) -> (SqlExpr, Maybe SqlColumn)
sqlBinding forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
Arr.second Int -> PrimExpr
mkColumn))) [Int
1..]
        mkColumn :: Int -> PrimExpr
mkColumn Int
i = (String -> PrimExpr
HPQ.BaseTableAttrExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"column" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) (Int
i::Int)

binary :: PQ.BinOp -> (Select, Select) -> Select
binary :: BinOp -> (Select, Select) -> Select
binary BinOp
op (Select
select1, Select
select2) = Binary -> Select
SelectBinary Binary {
  bOp :: BinOp
bOp = BinOp -> BinOp
binOp BinOp
op,
  bSelect1 :: Select
bSelect1 = Select
select1,
  bSelect2 :: Select
bSelect2 = Select
select2
  }

with :: PQ.Recursive -> Symbol -> [Symbol]-> Select -> Select -> Select
with :: Recursive -> Symbol -> [Symbol] -> Select -> Select -> Select
with Recursive
recursive Symbol
name [Symbol]
cols Select
wWith Select
wSelect = With -> Select
SelectWith forall a b. (a -> b) -> a -> b
$ With {[SqlColumn]
SqlTable
Recursive
Select
wCols :: [SqlColumn]
wRecursive :: Recursive
wTable :: SqlTable
wSelect :: Select
wWith :: Select
wSelect :: Select
wWith :: Select
wRecursive :: Recursive
wCols :: [SqlColumn]
wTable :: SqlTable
..}
  where
   wTable :: SqlTable
wTable = Maybe String -> String -> SqlTable
HSql.SqlTable forall a. Maybe a
Nothing (Symbol -> String
sqlSymbol Symbol
name)
   wRecursive :: Recursive
wRecursive = case Recursive
recursive of
     Recursive
PQ.NonRecursive -> Recursive
NonRecursive
     Recursive
PQ.Recursive -> Recursive
Recursive
   wCols :: [SqlColumn]
wCols = forall a b. (a -> b) -> [a] -> [b]
map (String -> SqlColumn
HSql.SqlColumn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> String
sqlSymbol) [Symbol]
cols

joinType :: PQ.JoinType -> JoinType
joinType :: JoinType -> JoinType
joinType JoinType
PQ.LeftJoin = JoinType
LeftJoin
joinType JoinType
PQ.RightJoin = JoinType
RightJoin
joinType JoinType
PQ.FullJoin = JoinType
FullJoin

semijoinType :: PQ.SemijoinType -> SemijoinType
semijoinType :: SemijoinType -> SemijoinType
semijoinType SemijoinType
PQ.Semi = SemijoinType
Semi
semijoinType SemijoinType
PQ.Anti = SemijoinType
Anti

binOp :: PQ.BinOp -> BinOp
binOp :: BinOp -> BinOp
binOp BinOp
o = case BinOp
o of
  BinOp
PQ.Except       -> BinOp
Except
  BinOp
PQ.ExceptAll    -> BinOp
ExceptAll
  BinOp
PQ.Union        -> BinOp
Union
  BinOp
PQ.UnionAll     -> BinOp
UnionAll
  BinOp
PQ.Intersect    -> BinOp
Intersect
  BinOp
PQ.IntersectAll -> BinOp
IntersectAll

newSelect :: From
newSelect :: From
newSelect = From {
  attrs :: SelectAttrs
attrs      = SelectAttrs
Star,
  tables :: [(Lateral, Select)]
tables     = [],
  criteria :: [SqlExpr]
criteria   = [],
  groupBy :: Maybe (NonEmpty SqlExpr)
groupBy    = forall a. Maybe a
Nothing,
  orderBy :: [(SqlExpr, SqlOrder)]
orderBy    = [],
  distinctOn :: Maybe (NonEmpty SqlExpr)
distinctOn = forall a. Maybe a
Nothing,
  limit :: Maybe Int
limit      = forall a. Maybe a
Nothing,
  offset :: Maybe Int
offset     = forall a. Maybe a
Nothing,
  for :: Maybe LockStrength
for        = forall a. Maybe a
Nothing
  }

sqlExpr :: HPQ.PrimExpr -> HSql.SqlExpr
sqlExpr :: PrimExpr -> SqlExpr
sqlExpr = SqlGenerator -> PrimExpr -> SqlExpr
SG.sqlExpr SqlGenerator
SD.defaultSqlGenerator

sqlSymbol :: Symbol -> String
sqlSymbol :: Symbol -> String
sqlSymbol (Symbol String
sym Tag
t) = Tag -> ShowS
T.tagWith Tag
t String
sym

sqlBinding :: (Symbol, HPQ.PrimExpr) -> (HSql.SqlExpr, Maybe HSql.SqlColumn)
sqlBinding :: (Symbol, PrimExpr) -> (SqlExpr, Maybe SqlColumn)
sqlBinding (Symbol
s, PrimExpr
pe) = (PrimExpr -> SqlExpr
sqlExpr PrimExpr
pe, forall a. a -> Maybe a
Just (String -> SqlColumn
HSql.SqlColumn (Symbol -> String
sqlSymbol Symbol
s)))

ensureColumns :: [(HSql.SqlExpr, Maybe a)]
             -> NEL.NonEmpty (HSql.SqlExpr, Maybe a)
ensureColumns :: forall a. [(SqlExpr, Maybe a)] -> NonEmpty (SqlExpr, Maybe a)
ensureColumns = forall a. (SqlExpr -> a) -> [a] -> NonEmpty a
ensureColumnsGen (\SqlExpr
x -> (SqlExpr
x,forall a. Maybe a
Nothing))

-- | For ensuring that we have at least one column in a SELECT or RETURNING
ensureColumnsGen :: (HSql.SqlExpr -> a)
              -> [a]
              -> NEL.NonEmpty a
ensureColumnsGen :: forall a. (SqlExpr -> a) -> [a] -> NonEmpty a
ensureColumnsGen SqlExpr -> a
f = forall a. a -> Maybe a -> a
M.fromMaybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlExpr -> a
f forall a b. (a -> b) -> a -> b
$ String -> SqlExpr
HSql.ConstSqlExpr String
"0")
                   forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty

label :: String -> Select -> Select
label :: String -> Select -> Select
label String
l Select
s = Label -> Select
SelectLabel (String -> Select -> Label
Label String
l Select
s)

-- Very similar to 'baseTable'
relExpr :: HPQ.PrimExpr -> [(Symbol, HPQ.PrimExpr)] -> Select
relExpr :: PrimExpr -> Bindings PrimExpr -> Select
relExpr PrimExpr
pe Bindings PrimExpr
columns = From -> Select
SelectFrom forall a b. (a -> b) -> a -> b
$
    From
newSelect { attrs :: SelectAttrs
attrs = NonEmpty (SqlExpr, Maybe SqlColumn) -> SelectAttrs
SelectAttrs (forall a. [(SqlExpr, Maybe a)] -> NonEmpty (SqlExpr, Maybe a)
ensureColumns (forall a b. (a -> b) -> [a] -> [b]
map (Symbol, PrimExpr) -> (SqlExpr, Maybe SqlColumn)
sqlBinding Bindings PrimExpr
columns))
              , tables :: [(Lateral, Select)]
tables = forall t. t -> [(Lateral, t)]
oneTable (SqlExpr -> Select
RelExpr (PrimExpr -> SqlExpr
sqlExpr PrimExpr
pe))
              }

rebind :: Bool -> [(Symbol, HPQ.PrimExpr)] -> Select -> Select
rebind :: Bool -> Bindings PrimExpr -> Select -> Select
rebind Bool
star Bindings PrimExpr
pes Select
select = From -> Select
SelectFrom From
newSelect
  { attrs :: SelectAttrs
attrs = NonEmpty (SqlExpr, Maybe SqlColumn) -> SelectAttrs
selectAttrs (forall a. [(SqlExpr, Maybe a)] -> NonEmpty (SqlExpr, Maybe a)
ensureColumns (forall a b. (a -> b) -> [a] -> [b]
map (Symbol, PrimExpr) -> (SqlExpr, Maybe SqlColumn)
sqlBinding Bindings PrimExpr
pes))
  , tables :: [(Lateral, Select)]
tables = forall t. t -> [(Lateral, t)]
oneTable Select
select
  }
  where selectAttrs :: NonEmpty (SqlExpr, Maybe SqlColumn) -> SelectAttrs
selectAttrs = case Bool
star of
          Bool
True  -> NonEmpty (SqlExpr, Maybe SqlColumn) -> SelectAttrs
SelectAttrsStar
          Bool
False -> NonEmpty (SqlExpr, Maybe SqlColumn) -> SelectAttrs
SelectAttrs

forUpdate :: Select -> Select
forUpdate :: Select -> Select
forUpdate Select
s = From -> Select
SelectFrom From
newSelect {
    tables :: [(Lateral, Select)]
tables = [(Lateral
NonLateral, Select
s)]
  , for :: Maybe LockStrength
for = forall a. a -> Maybe a
Just LockStrength
Update
  }