{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeSynonymInstances #-}

module Opaleye.Internal.QueryArr where

import           Prelude hiding (id)

import qualified Opaleye.Internal.Unpackspec as U
import qualified Opaleye.Internal.Tag as Tag
import           Opaleye.Internal.Tag (Tag)
import qualified Opaleye.Internal.PrimQuery as PQ

import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ

import qualified Control.Arrow as Arr
import           Control.Arrow ((&&&), (***), arr, returnA)
import qualified Control.Category as C
import           Control.Category ((<<<), id)
import           Control.Applicative (Applicative, pure, (<*>))
import           Data.List.NonEmpty ( NonEmpty((:|)) )
import qualified Data.Profunctor as P
import qualified Data.Profunctor.Product as PP

-- Ideally this should be wrapped in a monad which automatically
-- increments the Tag, but I couldn't be bothered to do that.
--
-- The function 'Lateral -> PrimQuery -> PrimQuery' represents a
-- select arrow in the following way:
--
--    Lateral
-- -- ^ Whether to join me laterally
-- -> PrimQuery
-- -- ^ The query that I will be joined after.  If I refer to columns
-- -- in here in a way that is only valid when I am joined laterally,
-- -- then Lateral must be passed in as the argument above.
-- -> PrimQuery
-- -- ^ The result after joining me
--
-- It is *always* valid to pass Lateral as the first argument.  So why
-- wouldn't we do that?  Because we don't want to generate lateral
-- subqueries if they are not needed; it might have performance
-- implications.  Even though there is good evidence that it *doesn't*
-- have performance implications
-- (https://github.com/tomjaguarpaw/haskell-opaleye/pull/480) we still
-- want to be cautious.

-- | A parametrised 'Select'.  A @SelectArr a b@ accepts an argument
-- of type @a@.
--
-- @SelectArr a b@ is analogous to a Haskell function @a -> [b]@.
newtype SelectArr a b = QueryArr ((a, Tag) -> (b, PQ.Lateral -> PQ.PrimQuery -> PQ.PrimQuery, Tag))

type QueryArr = SelectArr
type Query = SelectArr ()

productQueryArr :: ((a, Tag) -> (b, PQ.PrimQuery, Tag)) -> QueryArr a b
productQueryArr :: ((a, Tag) -> (b, PrimQuery, Tag)) -> QueryArr a b
productQueryArr (a, Tag) -> (b, PrimQuery, Tag)
f = ((a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag))
-> QueryArr a b
forall a b.
((a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag))
-> SelectArr a b
QueryArr (a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag)
g
  where g :: (a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag)
g (a
a0, Tag
t0) = (b
a1, \Lateral
lat PrimQuery
primQuery -> Lateral -> PrimQuery -> PrimQuery -> PrimQuery
PQ.times Lateral
lat PrimQuery
primQuery PrimQuery
primQuery', Tag
t1)
          where (b
a1, PrimQuery
primQuery', Tag
t1) = (a, Tag) -> (b, PrimQuery, Tag)
f (a
a0, Tag
t0)

{-# DEPRECATED simpleQueryArr "Use 'productQueryArr' instead. Its name indicates better what it actually does" #-}
simpleQueryArr :: ((a, Tag) -> (b, PQ.PrimQuery, Tag)) -> QueryArr a b
simpleQueryArr :: ((a, Tag) -> (b, PrimQuery, Tag)) -> QueryArr a b
simpleQueryArr = ((a, Tag) -> (b, PrimQuery, Tag)) -> QueryArr a b
forall a b. ((a, Tag) -> (b, PrimQuery, Tag)) -> QueryArr a b
productQueryArr

mapPrimQuery :: (PQ.PrimQuery -> PQ.PrimQuery) -> SelectArr a b -> SelectArr a b
mapPrimQuery :: (PrimQuery -> PrimQuery) -> SelectArr a b -> SelectArr a b
mapPrimQuery PrimQuery -> PrimQuery
f SelectArr a b
sa =
  ((a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag))
-> SelectArr a b
forall a b.
((a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag))
-> SelectArr a b
QueryArr ((\(b
b, Lateral -> PrimQuery -> PrimQuery
pqf, Tag
t) -> (b
b, \Lateral
lat -> PrimQuery -> PrimQuery
f (PrimQuery -> PrimQuery)
-> (PrimQuery -> PrimQuery) -> PrimQuery -> PrimQuery
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lateral -> PrimQuery -> PrimQuery
pqf Lateral
lat, Tag
t)) ((b, Lateral -> PrimQuery -> PrimQuery, Tag)
 -> (b, Lateral -> PrimQuery -> PrimQuery, Tag))
-> ((a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag))
-> (a, Tag)
-> (b, Lateral -> PrimQuery -> PrimQuery, Tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SelectArr a b
-> (a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag)
forall a b.
QueryArr a b
-> (a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag)
runQueryArr SelectArr a b
sa)

runQueryArr :: QueryArr a b -> (a, Tag) -> (b, PQ.Lateral -> PQ.PrimQuery -> PQ.PrimQuery, Tag)
runQueryArr :: QueryArr a b
-> (a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag)
runQueryArr (QueryArr (a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag)
f) = (a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag)
f

-- Unit defines no columns so joining it non-LATERAL is OK.
runSimpleQueryArr :: QueryArr a b -> (a, Tag) -> (b, PQ.PrimQuery, Tag)
runSimpleQueryArr :: QueryArr a b -> (a, Tag) -> (b, PrimQuery, Tag)
runSimpleQueryArr QueryArr a b
f = (\(b
b, Lateral -> PrimQuery -> PrimQuery
pqf, Tag
t) -> (b
b, Lateral -> PrimQuery -> PrimQuery
pqf Lateral
PQ.NonLateral PrimQuery
forall a. PrimQuery' a
PQ.Unit, Tag
t)) ((b, Lateral -> PrimQuery -> PrimQuery, Tag)
 -> (b, PrimQuery, Tag))
-> ((a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag))
-> (a, Tag)
-> (b, PrimQuery, Tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryArr a b
-> (a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag)
forall a b.
QueryArr a b
-> (a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag)
runQueryArr QueryArr a b
f

runSimpleQueryArrStart :: QueryArr a b -> a -> (b, PQ.PrimQuery, Tag)
runSimpleQueryArrStart :: QueryArr a b -> a -> (b, PrimQuery, Tag)
runSimpleQueryArrStart QueryArr a b
q a
a = QueryArr a b -> (a, Tag) -> (b, PrimQuery, Tag)
forall a b. QueryArr a b -> (a, Tag) -> (b, PrimQuery, Tag)
runSimpleQueryArr QueryArr a b
q (a
a, Tag
Tag.start)

runQueryArrUnpack :: U.Unpackspec a b
                  -> Query a -> ([HPQ.PrimExpr], PQ.PrimQuery, Tag)
runQueryArrUnpack :: Unpackspec a b -> Query a -> ([PrimExpr], PrimQuery, Tag)
runQueryArrUnpack Unpackspec a b
unpackspec Query a
q = ([PrimExpr]
primExprs, PrimQuery
primQ, Tag
endTag)
  where (a
columns, PrimQuery
primQ, Tag
endTag) = Query a -> () -> (a, PrimQuery, Tag)
forall a b. QueryArr a b -> a -> (b, PrimQuery, Tag)
runSimpleQueryArrStart Query a
q ()
        primExprs :: [PrimExpr]
primExprs = Unpackspec a b -> a -> [PrimExpr]
forall s t. Unpackspec s t -> s -> [PrimExpr]
U.collectPEs Unpackspec a b
unpackspec a
columns

first3 :: (a1 -> b) -> (a1, a2, a3) -> (b, a2, a3)
first3 :: (a1 -> b) -> (a1, a2, a3) -> (b, a2, a3)
first3 a1 -> b
f (a1
a1, a2
a2, a3
a3) = (a1 -> b
f a1
a1, a2
a2, a3
a3)

-- | A @SELECT@, i.e. an SQL query which produces a collection of
-- rows.
--
-- @Select a@ is analogous to a Haskell value @[a]@.
type Select = SelectArr ()

-- | Implements @LATERAL@ subqueries.
--
-- You might find it easier to use 'Opaleye.Lateral.laterally' (if you
-- want to apply 'Opaleye.Aggregate.aggregate',
-- 'Opaleye.Order.orderBy' or 'Opaleye.Order.limit' to a 'SelectArr')
-- or 'Opaleye.Lateral.bilaterally' (if you want to apply
-- 'Opaleye.Binary.union', 'Opaleye.Binary.intersect' and
-- 'Opaleye.Binary.except' to two 'SelectArr's).
lateral :: (i -> Select a) -> SelectArr i a
lateral :: (i -> Select a) -> SelectArr i a
lateral i -> Select a
f = ((i, Tag) -> (a, Lateral -> PrimQuery -> PrimQuery, Tag))
-> SelectArr i a
forall a b.
((a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag))
-> SelectArr a b
QueryArr (i, Tag) -> (a, Lateral -> PrimQuery -> PrimQuery, Tag)
forall p. (i, Tag) -> (a, p -> PrimQuery -> PrimQuery, Tag)
qa
  where
    qa :: (i, Tag) -> (a, p -> PrimQuery -> PrimQuery, Tag)
qa (i
i, Tag
tag) = (a
a, p -> PrimQuery -> PrimQuery
forall p. p -> PrimQuery -> PrimQuery
primQueryJoin, Tag
tag')
      where
        (a
a, Lateral -> PrimQuery -> PrimQuery
primQueryR, Tag
tag') = Select a
-> ((), Tag) -> (a, Lateral -> PrimQuery -> PrimQuery, Tag)
forall a b.
QueryArr a b
-> (a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag)
runQueryArr (i -> Select a
f i
i) ((), Tag
tag)
        primQueryJoin :: p -> PrimQuery -> PrimQuery
primQueryJoin p
_ = Lateral -> PrimQuery -> PrimQuery
primQueryR Lateral
PQ.Lateral

-- | Convert an arrow argument into a function argument so that it can
-- be applied inside @do@-notation rather than arrow notation.
viaLateral :: SelectArr i a -> i -> Select a
viaLateral :: SelectArr i a -> i -> Select a
viaLateral SelectArr i a
s i
i = SelectArr i a
s SelectArr i a -> SelectArr () i -> Select a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< i -> SelectArr () i
forall (f :: * -> *) a. Applicative f => a -> f a
pure i
i

bind :: SelectArr i a -> (a -> SelectArr i b) -> SelectArr i b
bind :: SelectArr i a -> (a -> SelectArr i b) -> SelectArr i b
bind SelectArr i a
s a -> SelectArr i b
f = proc i
i -> do
  a
a <- SelectArr i a
s -< i
i
  b
b <- ((a, i) -> Select b) -> SelectArr (a, i) b
forall i a. (i -> Select a) -> SelectArr i a
lateral (\(a
a, i
i) -> SelectArr i b -> i -> Select b
forall i a. SelectArr i a -> i -> Select a
viaLateral (a -> SelectArr i b
f a
a) i
i) -< (a
a, i
i)
  SelectArr b b
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< b
b

arrowApply :: SelectArr (SelectArr i a, i) a
arrowApply :: SelectArr (SelectArr i a, i) a
arrowApply = ((SelectArr i a, i) -> Select a) -> SelectArr (SelectArr i a, i) a
forall i a. (i -> Select a) -> SelectArr i a
lateral (\(SelectArr i a
f, i
i) -> SelectArr i a -> i -> Select a
forall i a. SelectArr i a -> i -> Select a
viaLateral SelectArr i a
f i
i)

instance C.Category QueryArr where
  id :: QueryArr a a
id = (a -> a) -> QueryArr a a
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
  QueryArr (b, Tag) -> (c, Lateral -> PrimQuery -> PrimQuery, Tag)
f . :: QueryArr b c -> QueryArr a b -> QueryArr a c
. QueryArr (a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag)
g = ((a, Tag) -> (c, Lateral -> PrimQuery -> PrimQuery, Tag))
-> QueryArr a c
forall a b.
((a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag))
-> SelectArr a b
QueryArr (\(a
a, Tag
t) ->
                                        let (b
b, Lateral -> PrimQuery -> PrimQuery
pqf, Tag
t') = (a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag)
g (a
a, Tag
t)
                                            (c
c, Lateral -> PrimQuery -> PrimQuery
pqf', Tag
t'') = (b, Tag) -> (c, Lateral -> PrimQuery -> PrimQuery, Tag)
f (b
b, Tag
t')
                                        in (c
c, \Lateral
lat -> Lateral -> PrimQuery -> PrimQuery
pqf' Lateral
lat (PrimQuery -> PrimQuery)
-> (PrimQuery -> PrimQuery) -> PrimQuery -> PrimQuery
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lateral -> PrimQuery -> PrimQuery
pqf Lateral
lat, Tag
t''))

instance Arr.Arrow QueryArr where
  arr :: (b -> c) -> QueryArr b c
arr b -> c
f   = ((b, Tag) -> (c, Lateral -> PrimQuery -> PrimQuery, Tag))
-> QueryArr b c
forall a b.
((a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag))
-> SelectArr a b
QueryArr (\(b
a, Tag
t) -> (b -> c
f b
a, (PrimQuery -> PrimQuery) -> Lateral -> PrimQuery -> PrimQuery
forall a b. a -> b -> a
const PrimQuery -> PrimQuery
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id, Tag
t))
  first :: QueryArr b c -> QueryArr (b, d) (c, d)
first (QueryArr (b, Tag) -> (c, Lateral -> PrimQuery -> PrimQuery, Tag)
f) = (((b, d), Tag) -> ((c, d), Lateral -> PrimQuery -> PrimQuery, Tag))
-> QueryArr (b, d) (c, d)
forall a b.
((a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag))
-> SelectArr a b
QueryArr ((b, d), Tag) -> ((c, d), Lateral -> PrimQuery -> PrimQuery, Tag)
forall b.
((b, b), Tag) -> ((c, b), Lateral -> PrimQuery -> PrimQuery, Tag)
g
    where g :: ((b, b), Tag) -> ((c, b), Lateral -> PrimQuery -> PrimQuery, Tag)
g ((b
b, b
d), Tag
t0) = (c -> (c, b))
-> (c, Lateral -> PrimQuery -> PrimQuery, Tag)
-> ((c, b), Lateral -> PrimQuery -> PrimQuery, Tag)
forall a1 b a2 a3. (a1 -> b) -> (a1, a2, a3) -> (b, a2, a3)
first3 (\c
c -> (c
c, b
d)) ((b, Tag) -> (c, Lateral -> PrimQuery -> PrimQuery, Tag)
f (b
b, Tag
t0))

instance Arr.ArrowChoice QueryArr where
  left :: QueryArr b c -> QueryArr (Either b d) (Either c d)
left (QueryArr (b, Tag) -> (c, Lateral -> PrimQuery -> PrimQuery, Tag)
f) = ((Either b d, Tag)
 -> (Either c d, Lateral -> PrimQuery -> PrimQuery, Tag))
-> QueryArr (Either b d) (Either c d)
forall a b.
((a, Tag) -> (b, Lateral -> PrimQuery -> PrimQuery, Tag))
-> SelectArr a b
QueryArr (Either b d, Tag)
-> (Either c d, Lateral -> PrimQuery -> PrimQuery, Tag)
forall b.
(Either b b, Tag)
-> (Either c b, Lateral -> PrimQuery -> PrimQuery, Tag)
g
    where g :: (Either b b, Tag)
-> (Either c b, Lateral -> PrimQuery -> PrimQuery, Tag)
g (Either b b
e, Tag
t0) = case Either b b
e of
            Left b
a -> (c -> Either c b)
-> (c, Lateral -> PrimQuery -> PrimQuery, Tag)
-> (Either c b, Lateral -> PrimQuery -> PrimQuery, Tag)
forall a1 b a2 a3. (a1 -> b) -> (a1, a2, a3) -> (b, a2, a3)
first3 c -> Either c b
forall a b. a -> Either a b
Left ((b, Tag) -> (c, Lateral -> PrimQuery -> PrimQuery, Tag)
f (b
a, Tag
t0))
            Right b
b -> (b -> Either c b
forall a b. b -> Either a b
Right b
b, (PrimQuery -> PrimQuery) -> Lateral -> PrimQuery -> PrimQuery
forall a b. a -> b -> a
const PrimQuery -> PrimQuery
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id, Tag
t0)

instance Arr.ArrowApply QueryArr where
  app :: QueryArr (QueryArr b c, b) c
app = QueryArr (QueryArr b c, b) c
forall b c. QueryArr (QueryArr b c, b) c
arrowApply

instance Functor (QueryArr a) where
  fmap :: (a -> b) -> QueryArr a a -> QueryArr a b
fmap a -> b
f = ((a -> b) -> SelectArr a b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> b
f SelectArr a b -> QueryArr a a -> QueryArr a b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<<)

instance Applicative (QueryArr a) where
  pure :: a -> QueryArr a a
pure = (a -> a) -> QueryArr a a
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((a -> a) -> QueryArr a a) -> (a -> a -> a) -> a -> QueryArr a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> a
forall a b. a -> b -> a
const
  QueryArr a (a -> b)
f <*> :: QueryArr a (a -> b) -> QueryArr a a -> QueryArr a b
<*> QueryArr a a
g = ((a -> b, a) -> b) -> SelectArr (a -> b, a) b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (((a -> b) -> a -> b) -> (a -> b, a) -> b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($)) SelectArr (a -> b, a) b -> SelectArr a (a -> b, a) -> QueryArr a b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< (QueryArr a (a -> b)
f QueryArr a (a -> b) -> QueryArr a a -> SelectArr a (a -> b, a)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& QueryArr a a
g)

instance Monad (QueryArr a) where
  return :: a -> QueryArr a a
return = a -> QueryArr a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  >>= :: QueryArr a a -> (a -> QueryArr a b) -> QueryArr a b
(>>=) = QueryArr a a -> (a -> QueryArr a b) -> QueryArr a b
forall a a b. QueryArr a a -> (a -> QueryArr a b) -> QueryArr a b
bind

instance P.Profunctor QueryArr where
  dimap :: (a -> b) -> (c -> d) -> QueryArr b c -> QueryArr a d
dimap a -> b
f c -> d
g QueryArr b c
a = (c -> d) -> SelectArr c d
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr c -> d
g SelectArr c d -> SelectArr a c -> QueryArr a d
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< QueryArr b c
a QueryArr b c -> SelectArr a b -> SelectArr a c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< (a -> b) -> SelectArr a b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> b
f

instance PP.ProductProfunctor QueryArr where
  empty :: QueryArr () ()
empty = QueryArr () ()
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
  ***! :: QueryArr a b -> QueryArr a' b' -> QueryArr (a, a') (b, b')
(***!) = QueryArr a b -> QueryArr a' b' -> QueryArr (a, a') (b, b')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
(***)