{-# language ApplicativeDo #-}
{-# language LambdaCase #-}

{-# options -fno-warn-name-shadowing #-}

module Rel8.Query.Optimize
  ( optimize
  )
where

-- base
import Control.Applicative
import Data.Functor.Identity
import Prelude

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


optimize :: PrimQuery' a -> PrimQuery' a
optimize :: PrimQuery' a -> PrimQuery' a
optimize =
  ((PrimQuery' a -> Identity (PrimQuery' a))
 -> PrimQuery' a -> Identity (PrimQuery' a))
-> (PrimQuery' a -> PrimQuery' a) -> PrimQuery' a -> PrimQuery' a
forall a.
((a -> Identity a) -> a -> Identity a) -> (a -> a) -> a -> a
transformOf (PrimQuery' a -> Identity (PrimQuery' a))
-> PrimQuery' a -> Identity (PrimQuery' a)
forall (f :: * -> *) a.
Applicative f =>
(PrimQuery' a -> f (PrimQuery' a))
-> PrimQuery' a -> f (PrimQuery' a)
primQuery PrimQuery' a -> PrimQuery' a
forall a. PrimQuery' a -> PrimQuery' a
optimisePredicates


primQuery
  :: Applicative f
  => ( PrimQuery' a -> f ( PrimQuery' a ) ) -> PrimQuery' a -> f ( PrimQuery' a )
primQuery :: (PrimQuery' a -> f (PrimQuery' a))
-> PrimQuery' a -> f (PrimQuery' a)
primQuery PrimQuery' a -> f (PrimQuery' a)
f = \case
  Aggregate Bindings (Maybe (AggrOp, [OrderExpr], AggrDistinct), Symbol)
bindingsAndPrimExpr PrimQuery' a
primQuery -> do
    PrimQuery' a
primQuery <- PrimQuery' a -> f (PrimQuery' a)
f PrimQuery' a
primQuery

    return ( Bindings (Maybe (AggrOp, [OrderExpr], AggrDistinct), Symbol)
-> PrimQuery' a -> PrimQuery' a
forall a.
Bindings (Maybe (AggrOp, [OrderExpr], AggrDistinct), Symbol)
-> PrimQuery' a -> PrimQuery' a
Aggregate Bindings (Maybe (AggrOp, [OrderExpr], AggrDistinct), Symbol)
bindingsAndPrimExpr PrimQuery' a
primQuery )

  DistinctOnOrderBy Maybe (NonEmpty PrimExpr)
maybePrimExprs [OrderExpr]
orderExprs PrimQuery' a
primQuery -> do
    PrimQuery' a
primQuery <- PrimQuery' a -> f (PrimQuery' a)
f PrimQuery' a
primQuery

    return ( Maybe (NonEmpty PrimExpr)
-> [OrderExpr] -> PrimQuery' a -> PrimQuery' a
forall a.
Maybe (NonEmpty PrimExpr)
-> [OrderExpr] -> PrimQuery' a -> PrimQuery' a
DistinctOnOrderBy Maybe (NonEmpty PrimExpr)
maybePrimExprs [OrderExpr]
orderExprs PrimQuery' a
primQuery )

  Limit LimitOp
limitOp PrimQuery' a
primQuery -> do
    PrimQuery' a
primQuery <- PrimQuery' a -> f (PrimQuery' a)
f PrimQuery' a
primQuery

    return ( LimitOp -> PrimQuery' a -> PrimQuery' a
forall a. LimitOp -> PrimQuery' a -> PrimQuery' a
Limit LimitOp
limitOp PrimQuery' a
primQuery )

  Join JoinType
joinType PrimExpr
primExpr Bindings PrimExpr
bindingsA Bindings PrimExpr
bindingsB PrimQuery' a
primQueryA PrimQuery' a
primQueryB -> do
    PrimQuery' a
primQueryA <- PrimQuery' a -> f (PrimQuery' a)
f PrimQuery' a
primQueryA
    PrimQuery' a
primQueryB <- PrimQuery' a -> f (PrimQuery' a)
f PrimQuery' a
primQueryB

    return ( JoinType
-> PrimExpr
-> Bindings PrimExpr
-> Bindings PrimExpr
-> PrimQuery' a
-> PrimQuery' a
-> PrimQuery' a
forall a.
JoinType
-> PrimExpr
-> Bindings PrimExpr
-> Bindings PrimExpr
-> PrimQuery' a
-> PrimQuery' a
-> PrimQuery' a
Join JoinType
joinType PrimExpr
primExpr Bindings PrimExpr
bindingsA Bindings PrimExpr
bindingsB PrimQuery' a
primQueryA PrimQuery' a
primQueryB )

  Exists Bool
bool PrimQuery' a
primQueryA PrimQuery' a
primQueryB -> do
    PrimQuery' a
primQueryA <- PrimQuery' a -> f (PrimQuery' a)
f PrimQuery' a
primQueryA
    PrimQuery' a
primQueryB <- PrimQuery' a -> f (PrimQuery' a)
f PrimQuery' a
primQueryB

    return ( Bool -> PrimQuery' a -> PrimQuery' a -> PrimQuery' a
forall a. Bool -> PrimQuery' a -> PrimQuery' a -> PrimQuery' a
Exists Bool
bool PrimQuery' a
primQueryA PrimQuery' a
primQueryB )

  Binary BinOp
binOp (PrimQuery' a, PrimQuery' a)
primQueries -> do
    (PrimQuery' a, PrimQuery' a)
primQueries <- (PrimQuery' a -> f (PrimQuery' a))
-> (PrimQuery' a, PrimQuery' a) -> f (PrimQuery' a, PrimQuery' a)
forall (f :: * -> *) t b.
Applicative f =>
(t -> f b) -> (t, t) -> f (b, b)
both PrimQuery' a -> f (PrimQuery' a)
f (PrimQuery' a, PrimQuery' a)
primQueries

    return ( BinOp -> (PrimQuery' a, PrimQuery' a) -> PrimQuery' a
forall a. BinOp -> (PrimQuery' a, PrimQuery' a) -> PrimQuery' a
Binary BinOp
binOp (PrimQuery' a, PrimQuery' a)
primQueries  )

  Label String
label PrimQuery' a
primQuery -> do
    PrimQuery' a
primQuery <- PrimQuery' a -> f (PrimQuery' a)
f PrimQuery' a
primQuery

    return ( String -> PrimQuery' a -> PrimQuery' a
forall a. String -> PrimQuery' a -> PrimQuery' a
Label String
label PrimQuery' a
primQuery )

  PrimQuery' a
other ->
    PrimQuery' a -> f (PrimQuery' a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrimQuery' a
other


optimisePredicates :: PrimQuery' a -> PrimQuery' a
optimisePredicates :: PrimQuery' a -> PrimQuery' a
optimisePredicates = \case
  Join JoinType
joinType PrimExpr
predicate Bindings PrimExpr
bindingsA Bindings PrimExpr
bindingsB PrimQuery' a
primQueryA PrimQuery' a
primQueryB ->
    JoinType
-> PrimExpr
-> Bindings PrimExpr
-> Bindings PrimExpr
-> PrimQuery' a
-> PrimQuery' a
-> PrimQuery' a
forall a.
JoinType
-> PrimExpr
-> Bindings PrimExpr
-> Bindings PrimExpr
-> PrimQuery' a
-> PrimQuery' a
-> PrimQuery' a
Join JoinType
joinType ( PrimExpr -> PrimExpr
nullIsFalse PrimExpr
predicate ) Bindings PrimExpr
bindingsA Bindings PrimExpr
bindingsB PrimQuery' a
primQueryA PrimQuery' a
primQueryB

  PrimQuery' a
other ->
    PrimQuery' a
other


nullIsFalse :: PrimExpr -> PrimExpr
nullIsFalse :: PrimExpr -> PrimExpr
nullIsFalse =
  ((PrimExpr -> Identity PrimExpr) -> PrimExpr -> Identity PrimExpr)
-> (PrimExpr -> Maybe PrimExpr) -> PrimExpr -> PrimExpr
forall a.
((a -> Identity a) -> a -> Identity a) -> (a -> Maybe a) -> a -> a
rewriteOf (PrimExpr -> Identity PrimExpr) -> PrimExpr -> Identity PrimExpr
forall (f :: * -> *).
Applicative f =>
(PrimExpr -> f PrimExpr) -> PrimExpr -> f PrimExpr
primExprs PrimExpr -> Maybe PrimExpr
simplifyCaseAnalysis

  where

    simplifyCaseAnalysis :: PrimExpr -> Maybe PrimExpr
simplifyCaseAnalysis = \case
      CaseExpr [ ( UnExpr UnOp
OpIsNull PrimExpr
_, ConstExpr ( BoolLit Bool
False ) ) ] PrimExpr
notNullBranch ->
        PrimExpr -> Maybe PrimExpr
forall a. a -> Maybe a
Just PrimExpr
notNullBranch

      CaseExpr [ ( UnExpr UnOp
OpIsNull PrimExpr
x, UnExpr UnOp
OpIsNull PrimExpr
y ) ] PrimExpr
notNullBranch ->
        PrimExpr -> Maybe PrimExpr
forall a. a -> Maybe a
Just
          ( BinOp -> PrimExpr -> PrimExpr -> PrimExpr
BinExpr
              BinOp
(:||)
              ( BinOp -> PrimExpr -> PrimExpr -> PrimExpr
BinExpr BinOp
(:&&) ( UnOp -> PrimExpr -> PrimExpr
UnExpr UnOp
OpIsNull PrimExpr
x ) ( UnOp -> PrimExpr -> PrimExpr
UnExpr UnOp
OpIsNull PrimExpr
y ) )
              PrimExpr
notNullBranch
          )

      PrimExpr
_ ->
        Maybe PrimExpr
forall a. Maybe a
Nothing



-- | Traverse all immediate 'PrimExpr's
primExprs :: Applicative f => ( PrimExpr -> f PrimExpr ) -> PrimExpr -> f PrimExpr
primExprs :: (PrimExpr -> f PrimExpr) -> PrimExpr -> f PrimExpr
primExprs PrimExpr -> f PrimExpr
f = \case
  AttrExpr ( Symbol String
string Tag
tag ) ->
    PrimExpr -> f PrimExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Symbol -> PrimExpr
AttrExpr ( String -> Tag -> Symbol
Symbol String
string Tag
tag ) )

  BaseTableAttrExpr String
attribute ->
    PrimExpr -> f PrimExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( String -> PrimExpr
BaseTableAttrExpr String
attribute )

  CompositeExpr PrimExpr
primExpr String
attribute -> do
    PrimExpr
primExpr <- PrimExpr -> f PrimExpr
f PrimExpr
primExpr

    return ( PrimExpr -> String -> PrimExpr
CompositeExpr PrimExpr
primExpr String
attribute )

  BinExpr BinOp
binOp PrimExpr
a PrimExpr
b -> do
    PrimExpr
a <- PrimExpr -> f PrimExpr
f PrimExpr
a
    PrimExpr
b <- PrimExpr -> f PrimExpr
f PrimExpr
b

    return ( BinOp -> PrimExpr -> PrimExpr -> PrimExpr
BinExpr BinOp
binOp PrimExpr
a PrimExpr
b )

  UnExpr UnOp
unOp PrimExpr
primExpr -> do
    PrimExpr
primExpr <- PrimExpr -> f PrimExpr
f PrimExpr
primExpr

    return ( UnOp -> PrimExpr -> PrimExpr
UnExpr UnOp
unOp PrimExpr
primExpr )

  AggrExpr AggrDistinct
aggrDistinct AggrOp
aggrOp PrimExpr
primExpr [OrderExpr]
orderExprs -> do
    AggrOp
aggrOp <- (PrimExpr -> f PrimExpr) -> AggrOp -> f AggrOp
forall (f :: * -> *).
Applicative f =>
(PrimExpr -> f PrimExpr) -> AggrOp -> f AggrOp
aggrOpPrimExprs PrimExpr -> f PrimExpr
f AggrOp
aggrOp
    PrimExpr
primExpr <- PrimExpr -> f PrimExpr
f PrimExpr
primExpr
    [OrderExpr]
orderExprs <- (OrderExpr -> f OrderExpr) -> [OrderExpr] -> f [OrderExpr]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ( (PrimExpr -> f PrimExpr) -> OrderExpr -> f OrderExpr
forall (f :: * -> *).
Applicative f =>
(PrimExpr -> f PrimExpr) -> OrderExpr -> f OrderExpr
orderExprPrimExprs PrimExpr -> f PrimExpr
f ) [OrderExpr]
orderExprs

    return ( AggrDistinct -> AggrOp -> PrimExpr -> [OrderExpr] -> PrimExpr
AggrExpr AggrDistinct
aggrDistinct AggrOp
aggrOp PrimExpr
primExpr [OrderExpr]
orderExprs )

  ConstExpr Literal
l ->
    PrimExpr -> f PrimExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Literal -> PrimExpr
ConstExpr Literal
l )

  CaseExpr [(PrimExpr, PrimExpr)]
cases PrimExpr
def -> do
    [(PrimExpr, PrimExpr)]
cases <- ((PrimExpr, PrimExpr) -> f (PrimExpr, PrimExpr))
-> [(PrimExpr, PrimExpr)] -> f [(PrimExpr, PrimExpr)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ( (PrimExpr -> f PrimExpr)
-> (PrimExpr, PrimExpr) -> f (PrimExpr, PrimExpr)
forall (f :: * -> *) t b.
Applicative f =>
(t -> f b) -> (t, t) -> f (b, b)
both PrimExpr -> f PrimExpr
f ) [(PrimExpr, PrimExpr)]
cases
    PrimExpr
def <- PrimExpr -> f PrimExpr
f PrimExpr
def

    return ( [(PrimExpr, PrimExpr)] -> PrimExpr -> PrimExpr
CaseExpr [(PrimExpr, PrimExpr)]
cases PrimExpr
def )

  PrimExpr
other ->
    PrimExpr -> f PrimExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrimExpr
other



aggrOpPrimExprs :: Applicative f => ( PrimExpr -> f PrimExpr ) -> AggrOp -> f AggrOp
aggrOpPrimExprs :: (PrimExpr -> f PrimExpr) -> AggrOp -> f AggrOp
aggrOpPrimExprs PrimExpr -> f PrimExpr
f = \case
  AggrStringAggr PrimExpr
primExpr -> do
    PrimExpr
primExpr <- PrimExpr -> f PrimExpr
f PrimExpr
primExpr

    return ( PrimExpr -> AggrOp
AggrStringAggr PrimExpr
primExpr )

  AggrOp
other ->
    AggrOp -> f AggrOp
forall (f :: * -> *) a. Applicative f => a -> f a
pure AggrOp
other


orderExprPrimExprs :: Applicative f => ( PrimExpr -> f PrimExpr ) -> OrderExpr -> f OrderExpr
orderExprPrimExprs :: (PrimExpr -> f PrimExpr) -> OrderExpr -> f OrderExpr
orderExprPrimExprs PrimExpr -> f PrimExpr
f ( OrderExpr OrderOp
orderOp PrimExpr
primExpr ) = do
  PrimExpr
primExpr <- PrimExpr -> f PrimExpr
f PrimExpr
primExpr

  return ( OrderOp -> PrimExpr -> OrderExpr
OrderExpr OrderOp
orderOp PrimExpr
primExpr )


-- | Traverse both sides of a homogeneous tuple.
both :: Applicative f => ( t -> f b ) -> ( t, t ) -> f ( b, b )
both :: (t -> f b) -> (t, t) -> f (b, b)
both t -> f b
f ( t
a,t
b ) =
  (b -> b -> (b, b)) -> f b -> f b -> f (b, b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) ( t -> f b
f t
a ) ( t -> f b
f t
b )


rewriteOf
  :: ( ( a -> Identity a ) -> a -> Identity a )
  -> ( a -> Maybe a ) -> a -> a
rewriteOf :: ((a -> Identity a) -> a -> Identity a) -> (a -> Maybe a) -> a -> a
rewriteOf (a -> Identity a) -> a -> Identity a
l a -> Maybe a
f =
  a -> a
go where

  go :: a -> a
go = ((a -> Identity a) -> a -> Identity a) -> (a -> a) -> a -> a
forall a.
((a -> Identity a) -> a -> Identity a) -> (a -> a) -> a -> a
transformOf (a -> Identity a) -> a -> Identity a
l ( \a
x -> a -> (a -> a) -> Maybe a -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
x a -> a
go ( a -> Maybe a
f a
x ) )


transformOf
  :: ( ( a -> Identity a ) -> a -> Identity a )
  -> ( a -> a )
  -> a
  -> a
{-# inline transformOf #-}
transformOf :: ((a -> Identity a) -> a -> Identity a) -> (a -> a) -> a -> a
transformOf (a -> Identity a) -> a -> Identity a
l a -> a
f = a -> a
go where

  go :: a -> a
go =
    a -> a
f (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> Identity a) -> a -> Identity a) -> (a -> a) -> a -> a
forall s t a b.
((s -> Identity t) -> a -> Identity b) -> (s -> t) -> a -> b
over (a -> Identity a) -> a -> Identity a
l a -> a
go


over
  :: ( ( s -> Identity t ) -> a -> Identity b )
  -> ( s -> t )
  -> a
  -> b
over :: ((s -> Identity t) -> a -> Identity b) -> (s -> t) -> a -> b
over (s -> Identity t) -> a -> Identity b
l s -> t
f =
  Identity b -> b
forall a. Identity a -> a
runIdentity (Identity b -> b) -> (a -> Identity b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> Identity t) -> a -> Identity b
l (t -> Identity t
forall a. a -> Identity a
Identity (t -> Identity t) -> (s -> t) -> s -> Identity t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> t
f)