{-# LANGUAGE LambdaCase #-}

module Opaleye.Internal.Optimize where

import           Prelude hiding (product)

import qualified Opaleye.Internal.PrimQuery as PQ
import           Opaleye.Internal.Helpers   ((.:))

import qualified Data.List.NonEmpty as NEL
import           Data.Semigroup ((<>))

import           Control.Applicative ((<$>), (<*>), liftA2, pure)
import           Control.Arrow (first)

optimize :: PQ.PrimQuery' a -> PQ.PrimQuery' a
optimize :: forall a. PrimQuery' a -> PrimQuery' a
optimize = forall a p. PrimQueryFold' a p -> PrimQuery' a -> p
PQ.foldPrimQuery (forall a. PrimQueryFoldP a (PrimQuery' a) (PrimQuery' a)
noSingletonProduct
                             forall a q p.
PrimQueryFoldP a (PrimQuery' a) q
-> PrimQueryFoldP a p (PrimQuery' a) -> PrimQueryFoldP a p q
`PQ.composePrimQueryFold` forall a. PrimQueryFoldP a (PrimQuery' a) (PrimQuery' a)
mergeProduct
                             forall a q p.
PrimQueryFoldP a (PrimQuery' a) q
-> PrimQueryFoldP a p (PrimQuery' a) -> PrimQueryFoldP a p q
`PQ.composePrimQueryFold` forall a. PrimQueryFoldP a (PrimQuery' a) (PrimQuery' a)
removeUnit)

removeUnit :: PQ.PrimQueryFoldP a (PQ.PrimQuery' a) (PQ.PrimQuery' a)
removeUnit :: forall a. PrimQueryFoldP a (PrimQuery' a) (PrimQuery' a)
removeUnit = forall a. PrimQueryFoldP a (PrimQuery' a) (PrimQuery' a)
PQ.primQueryFoldDefault { product :: NonEmpty (Lateral, PrimQuery' a) -> [PrimExpr] -> PrimQuery' a
PQ.product   = forall {a}.
NonEmpty (Lateral, PrimQuery' a) -> [PrimExpr] -> PrimQuery' a
product }
  where product :: NonEmpty (Lateral, PrimQuery' a) -> [PrimExpr] -> PrimQuery' a
product NonEmpty (Lateral, PrimQuery' a)
pqs = forall {a}.
NonEmpty (Lateral, PrimQuery' a) -> [PrimExpr] -> PrimQuery' a
PQ.Product NonEmpty (Lateral, PrimQuery' a)
pqs'
          where pqs' :: NonEmpty (Lateral, PrimQuery' a)
pqs' = case forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty (forall a. (a -> Bool) -> NonEmpty a -> [a]
NEL.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PrimQuery' a -> Bool
PQ.isUnit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) NonEmpty (Lateral, PrimQuery' a)
pqs) of
                         Maybe (NonEmpty (Lateral, PrimQuery' a))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. PrimQuery' a
PQ.Unit)
                         Just NonEmpty (Lateral, PrimQuery' a)
xs -> NonEmpty (Lateral, PrimQuery' a)
xs

mergeProduct :: PQ.PrimQueryFoldP a (PQ.PrimQuery' a) (PQ.PrimQuery' a)
mergeProduct :: forall a. PrimQueryFoldP a (PrimQuery' a) (PrimQuery' a)
mergeProduct = forall a. PrimQueryFoldP a (PrimQuery' a) (PrimQuery' a)
PQ.primQueryFoldDefault { product :: NonEmpty (Lateral, PrimQuery' a) -> [PrimExpr] -> PrimQuery' a
PQ.product   = forall {a}.
NonEmpty (Lateral, PrimQuery' a) -> [PrimExpr] -> PrimQuery' a
product }
  where product :: NonEmpty (Lateral, PrimQuery' a) -> [PrimExpr] -> PrimQuery' a
product NonEmpty (Lateral, PrimQuery' a)
pqs [PrimExpr]
pes = forall {a}.
NonEmpty (Lateral, PrimQuery' a) -> [PrimExpr] -> PrimQuery' a
PQ.Product NonEmpty (Lateral, PrimQuery' a)
pqs' ([PrimExpr]
pes forall a. [a] -> [a] -> [a]
++ [PrimExpr]
pes')
          where pqs' :: NonEmpty (Lateral, PrimQuery' a)
pqs' = NonEmpty (Lateral, PrimQuery' a)
pqs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {a}.
(Lateral, PrimQuery' a) -> NonEmpty (Lateral, PrimQuery' a)
queries
                queries :: (Lateral, PrimQuery' a) -> NonEmpty (Lateral, PrimQuery' a)
queries (Lateral
lat, PQ.Product NonEmpty (Lateral, PrimQuery' a)
qs [PrimExpr]
_) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Lateral
lat forall a. Semigroup a => a -> a -> a
<>)) NonEmpty (Lateral, PrimQuery' a)
qs
                queries (Lateral, PrimQuery' a)
q = forall (m :: * -> *) a. Monad m => a -> m a
return (Lateral, PrimQuery' a)
q
                pes' :: [PrimExpr]
pes' = forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (Lateral, PrimQuery' a)
pqs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {a} {a}. (a, PrimQuery' a) -> [PrimExpr]
conds
                conds :: (a, PrimQuery' a) -> [PrimExpr]
conds (a
_lat, PQ.Product NonEmpty (Lateral, PrimQuery' a)
_ [PrimExpr]
cs) = [PrimExpr]
cs
                conds (a, PrimQuery' a)
_ = []

noSingletonProduct :: PQ.PrimQueryFoldP a (PQ.PrimQuery' a) (PQ.PrimQuery' a)
noSingletonProduct :: forall a. PrimQueryFoldP a (PrimQuery' a) (PrimQuery' a)
noSingletonProduct = forall a. PrimQueryFoldP a (PrimQuery' a) (PrimQuery' a)
PQ.primQueryFoldDefault { product :: NonEmpty (Lateral, PrimQuery' a) -> [PrimExpr] -> PrimQuery' a
PQ.product = forall {a}.
NonEmpty (Lateral, PrimQuery' a) -> [PrimExpr] -> PrimQuery' a
product }
  where product :: NonEmpty (Lateral, PrimQuery' a) -> [PrimExpr] -> PrimQuery' a
product NonEmpty (Lateral, PrimQuery' a)
pqs [PrimExpr]
conds = case (forall a. NonEmpty a -> (a, Maybe (NonEmpty a))
NEL.uncons NonEmpty (Lateral, PrimQuery' a)
pqs, [PrimExpr]
conds) of
          (((Lateral
PQ.NonLateral, PrimQuery' a
x), Maybe (NonEmpty (Lateral, PrimQuery' a))
Nothing), []) -> PrimQuery' a
x
          (((Lateral, PrimQuery' a),
  Maybe (NonEmpty (Lateral, PrimQuery' a))),
 [PrimExpr])
_ -> forall {a}.
NonEmpty (Lateral, PrimQuery' a) -> [PrimExpr] -> PrimQuery' a
PQ.Product NonEmpty (Lateral, PrimQuery' a)
pqs [PrimExpr]
conds

removeEmpty :: PQ.PrimQuery' a -> Maybe (PQ.PrimQuery' b)
removeEmpty :: forall a b. PrimQuery' a -> Maybe (PrimQuery' b)
removeEmpty = forall a p. PrimQueryFold' a p -> PrimQuery' a -> p
PQ.foldPrimQuery PQ.PrimQueryFold {
    unit :: Maybe (PrimQuery' b)
PQ.unit      = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. PrimQuery' a
PQ.Unit
  , empty :: a -> Maybe (PrimQuery' b)
PQ.empty     = forall a b. a -> b -> a
const forall a. Maybe a
Nothing
  , baseTable :: TableIdentifier -> Bindings PrimExpr -> Maybe (PrimQuery' b)
PQ.baseTable = forall (m :: * -> *) a. Monad m => a -> m a
return forall r z a b. (r -> z) -> (a -> b -> r) -> a -> b -> z
.: forall a. TableIdentifier -> Bindings PrimExpr -> PrimQuery' a
PQ.BaseTable
  , product :: NonEmpty (Lateral, Maybe (PrimQuery' b))
-> [PrimExpr] -> Maybe (PrimQuery' b)
PQ.product   = let sequenceOf :: ((a -> a) -> t) -> t
sequenceOf (a -> a) -> t
l = forall {a}. a -> a
traverseOf (a -> a) -> t
l forall {a}. a -> a
id
                       traverseOf :: a -> a
traverseOf = forall {a}. a -> a
id
                       _2 :: (a -> Maybe b) -> (Lateral, a) -> Maybe (Lateral, b)
_2 = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
                   in
                   \NonEmpty (Lateral, Maybe (PrimQuery' b))
x [PrimExpr]
y -> forall {a}.
NonEmpty (Lateral, PrimQuery' a) -> [PrimExpr] -> PrimQuery' a
PQ.Product forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {t}. ((a -> a) -> t) -> t
sequenceOf (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverseforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall {a} {b}.
(a -> Maybe b) -> (Lateral, a) -> Maybe (Lateral, b)
_2) NonEmpty (Lateral, Maybe (PrimQuery' b))
x
                                      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure [PrimExpr]
y
  , aggregate :: Bindings (Maybe (AggrOp, [OrderExpr], AggrDistinct), Symbol)
-> Maybe (PrimQuery' b) -> Maybe (PrimQuery' b)
PQ.aggregate = 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.
Bindings (Maybe (AggrOp, [OrderExpr], AggrDistinct), Symbol)
-> PrimQuery' a -> PrimQuery' a
PQ.Aggregate
  , distinctOnOrderBy :: Maybe (NonEmpty PrimExpr)
-> [OrderExpr] -> Maybe (PrimQuery' b) -> Maybe (PrimQuery' b)
PQ.distinctOnOrderBy = \Maybe (NonEmpty PrimExpr)
mDistinctOns -> 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.
Maybe (NonEmpty PrimExpr)
-> [OrderExpr] -> PrimQuery' a -> PrimQuery' a
PQ.DistinctOnOrderBy Maybe (NonEmpty PrimExpr)
mDistinctOns
  , limit :: LimitOp -> Maybe (PrimQuery' b) -> Maybe (PrimQuery' b)
PQ.limit     = 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. LimitOp -> PrimQuery' a -> PrimQuery' a
PQ.Limit
  , join :: JoinType
-> PrimExpr
-> (Lateral, Maybe (PrimQuery' b))
-> (Lateral, Maybe (PrimQuery' b))
-> Maybe (PrimQuery' b)
PQ.join      = \JoinType
jt PrimExpr
pe (Lateral, Maybe (PrimQuery' b))
pq1 (Lateral, Maybe (PrimQuery' b))
pq2 -> forall a.
JoinType
-> PrimExpr
-> (Lateral, PrimQuery' a)
-> (Lateral, PrimQuery' a)
-> PrimQuery' a
PQ.Join JoinType
jt PrimExpr
pe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Lateral, Maybe (PrimQuery' b))
pq1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Lateral, Maybe (PrimQuery' b))
pq2
  , semijoin :: SemijoinType
-> Maybe (PrimQuery' b)
-> Maybe (PrimQuery' b)
-> Maybe (PrimQuery' b)
PQ.semijoin  = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
SemijoinType -> PrimQuery' a -> PrimQuery' a -> PrimQuery' a
PQ.Semijoin
  , exists :: Symbol -> Maybe (PrimQuery' b) -> Maybe (PrimQuery' b)
PQ.exists    = 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. Symbol -> PrimQuery' a -> PrimQuery' a
PQ.Exists
  , values :: [Symbol] -> NonEmpty [PrimExpr] -> Maybe (PrimQuery' b)
PQ.values    = forall (m :: * -> *) a. Monad m => a -> m a
return forall r z a b. (r -> z) -> (a -> b -> r) -> a -> b -> z
.: forall a. [Symbol] -> NonEmpty [PrimExpr] -> PrimQuery' a
PQ.Values
  , binary :: BinOp
-> (Maybe (PrimQuery' b), Maybe (PrimQuery' b))
-> Maybe (PrimQuery' b)
PQ.binary    = \case
      -- Some unfortunate duplication here
      BinOp
PQ.Except       -> forall {a}.
(PrimQuery' a -> Maybe (PrimQuery' a))
-> (PrimQuery' a -> Maybe (PrimQuery' a))
-> BinOp
-> (Maybe (PrimQuery' a), Maybe (PrimQuery' a))
-> Maybe (PrimQuery' a)
binary forall a. a -> Maybe a
Just            (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) BinOp
PQ.Except
      BinOp
PQ.Union        -> forall {a}.
(PrimQuery' a -> Maybe (PrimQuery' a))
-> (PrimQuery' a -> Maybe (PrimQuery' a))
-> BinOp
-> (Maybe (PrimQuery' a), Maybe (PrimQuery' a))
-> Maybe (PrimQuery' a)
binary forall a. a -> Maybe a
Just            forall a. a -> Maybe a
Just            BinOp
PQ.Union
      BinOp
PQ.Intersect    -> forall {a}.
(PrimQuery' a -> Maybe (PrimQuery' a))
-> (PrimQuery' a -> Maybe (PrimQuery' a))
-> BinOp
-> (Maybe (PrimQuery' a), Maybe (PrimQuery' a))
-> Maybe (PrimQuery' a)
binary (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) BinOp
PQ.Intersect

      BinOp
PQ.ExceptAll    -> forall {a}.
(PrimQuery' a -> Maybe (PrimQuery' a))
-> (PrimQuery' a -> Maybe (PrimQuery' a))
-> BinOp
-> (Maybe (PrimQuery' a), Maybe (PrimQuery' a))
-> Maybe (PrimQuery' a)
binary forall a. a -> Maybe a
Just            (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) BinOp
PQ.ExceptAll
      BinOp
PQ.UnionAll     -> forall {a}.
(PrimQuery' a -> Maybe (PrimQuery' a))
-> (PrimQuery' a -> Maybe (PrimQuery' a))
-> BinOp
-> (Maybe (PrimQuery' a), Maybe (PrimQuery' a))
-> Maybe (PrimQuery' a)
binary forall a. a -> Maybe a
Just            forall a. a -> Maybe a
Just            BinOp
PQ.UnionAll
      BinOp
PQ.IntersectAll -> forall {a}.
(PrimQuery' a -> Maybe (PrimQuery' a))
-> (PrimQuery' a -> Maybe (PrimQuery' a))
-> BinOp
-> (Maybe (PrimQuery' a), Maybe (PrimQuery' a))
-> Maybe (PrimQuery' a)
binary (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) BinOp
PQ.IntersectAll
  , label :: String -> Maybe (PrimQuery' b) -> Maybe (PrimQuery' b)
PQ.label     = 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. String -> PrimQuery' a -> PrimQuery' a
PQ.Label
  , relExpr :: PrimExpr -> Bindings PrimExpr -> Maybe (PrimQuery' b)
PQ.relExpr   = forall (m :: * -> *) a. Monad m => a -> m a
return forall r z a b. (r -> z) -> (a -> b -> r) -> a -> b -> z
.: forall a. PrimExpr -> Bindings PrimExpr -> PrimQuery' a
PQ.RelExpr
  , rebind :: Bool
-> Bindings PrimExpr
-> Maybe (PrimQuery' b)
-> Maybe (PrimQuery' b)
PQ.rebind    = \Bool
b -> 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. Bool -> Bindings PrimExpr -> PrimQuery' a -> PrimQuery' a
PQ.Rebind Bool
b
  , forUpdate :: Maybe (PrimQuery' b) -> Maybe (PrimQuery' b)
PQ.forUpdate = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. PrimQuery' a -> PrimQuery' a
PQ.ForUpdate
  , with :: Recursive
-> Symbol
-> [Symbol]
-> Maybe (PrimQuery' b)
-> Maybe (PrimQuery' b)
-> Maybe (PrimQuery' b)
PQ.with      = \Recursive
recursive Symbol
name [Symbol]
cols -> forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (forall a.
Recursive
-> Symbol
-> [Symbol]
-> PrimQuery' a
-> PrimQuery' a
-> PrimQuery' a
PQ.With Recursive
recursive Symbol
name [Symbol]
cols)
  }
  where -- If only the first argument is Just, do n1 on it
        -- If only the second argument is Just, do n2 on it
        binary :: (PrimQuery' a -> Maybe (PrimQuery' a))
-> (PrimQuery' a -> Maybe (PrimQuery' a))
-> BinOp
-> (Maybe (PrimQuery' a), Maybe (PrimQuery' a))
-> Maybe (PrimQuery' a)
binary PrimQuery' a -> Maybe (PrimQuery' a)
n1 PrimQuery' a -> Maybe (PrimQuery' a)
n2 BinOp
jj = \case
          (Maybe (PrimQuery' a)
Nothing, Maybe (PrimQuery' a)
Nothing)   -> forall a. Maybe a
Nothing
          (Maybe (PrimQuery' a)
Nothing, Just PrimQuery' a
pq2)  -> PrimQuery' a -> Maybe (PrimQuery' a)
n2 PrimQuery' a
pq2
          (Just PrimQuery' a
pq1, Maybe (PrimQuery' a)
Nothing)  -> PrimQuery' a -> Maybe (PrimQuery' a)
n1 PrimQuery' a
pq1
          (Just PrimQuery' a
pq1, Just PrimQuery' a
pq2) -> forall a. a -> Maybe a
Just (forall a. BinOp -> (PrimQuery' a, PrimQuery' a) -> PrimQuery' a
PQ.Binary BinOp
jj (PrimQuery' a
pq1, PrimQuery' a
pq2))