@@ -1,200 +0,0 @@
1−{-# language ApplicativeDo #-}
2−{-# language LambdaCase #-}
4−{-# options -fno-warn-name-shadowing #-}
6−module Rel8.Query.Optimize
12−import Control.Applicative
13−import Data.Functor.Identity
17−import Opaleye.Internal.HaskellDB.PrimQuery
18−import Opaleye.Internal.PrimQuery
21−optimize :: PrimQuery' a -> PrimQuery' a
23− transformOf primQuery optimisePredicates
28− => ( PrimQuery' a -> f ( PrimQuery' a ) ) -> PrimQuery' a -> f ( PrimQuery' a )
30− Aggregate bindingsAndPrimExpr primQuery -> do
31− primQuery <- f primQuery
33− return ( Aggregate bindingsAndPrimExpr primQuery )
35− DistinctOnOrderBy maybePrimExprs orderExprs primQuery -> do
36− primQuery <- f primQuery
38− return ( DistinctOnOrderBy maybePrimExprs orderExprs primQuery )
40− Limit limitOp primQuery -> do
41− primQuery <- f primQuery
43− return ( Limit limitOp primQuery )
45− Join joinType primExpr bindingsA bindingsB primQueryA primQueryB -> do
46− primQueryA <- f primQueryA
47− primQueryB <- f primQueryB
49− return ( Join joinType primExpr bindingsA bindingsB primQueryA primQueryB )
51− Exists bool primQueryA primQueryB -> do
52− primQueryA <- f primQueryA
53− primQueryB <- f primQueryB
55− return ( Exists bool primQueryA primQueryB )
57− Binary binOp primQueries -> do
58− primQueries <- both f primQueries
60− return ( Binary binOp primQueries )
62− Label label primQuery -> do
63− primQuery <- f primQuery
65− return ( Label label primQuery )
71−optimisePredicates :: PrimQuery' a -> PrimQuery' a
72−optimisePredicates = \case
73− Join joinType predicate bindingsA bindingsB primQueryA primQueryB ->
74− Join joinType ( nullIsFalse predicate ) bindingsA bindingsB primQueryA primQueryB
80−nullIsFalse :: PrimExpr -> PrimExpr
82− rewriteOf primExprs simplifyCaseAnalysis
86− simplifyCaseAnalysis = \case
87− CaseExpr [ ( UnExpr OpIsNull _, ConstExpr ( BoolLit False ) ) ] notNullBranch ->
90− CaseExpr [ ( UnExpr OpIsNull x, UnExpr OpIsNull y ) ] notNullBranch ->
94− ( BinExpr (:&&) ( UnExpr OpIsNull x ) ( UnExpr OpIsNull y ) )
103−-- | Traverse all immediate 'PrimExpr's
104−primExprs :: Applicative f => ( PrimExpr -> f PrimExpr ) -> PrimExpr -> f PrimExpr
106− AttrExpr ( Symbol string tag ) ->
107− pure ( AttrExpr ( Symbol string tag ) )
109− BaseTableAttrExpr attribute ->
110− pure ( BaseTableAttrExpr attribute )
112− CompositeExpr primExpr attribute -> do
113− primExpr <- f primExpr
115− return ( CompositeExpr primExpr attribute )
117− BinExpr binOp a b -> do
121− return ( BinExpr binOp a b )
123− UnExpr unOp primExpr -> do
124− primExpr <- f primExpr
126− return ( UnExpr unOp primExpr )
128− AggrExpr aggrDistinct aggrOp primExpr orderExprs -> do
129− aggrOp <- aggrOpPrimExprs f aggrOp
130− primExpr <- f primExpr
131− orderExprs <- traverse ( orderExprPrimExprs f ) orderExprs
133− return ( AggrExpr aggrDistinct aggrOp primExpr orderExprs )
136− pure ( ConstExpr l )
138− CaseExpr cases def -> do
139− cases <- traverse ( both f ) cases
142− return ( CaseExpr cases def )
149−aggrOpPrimExprs :: Applicative f => ( PrimExpr -> f PrimExpr ) -> AggrOp -> f AggrOp
150−aggrOpPrimExprs f = \case
151− AggrStringAggr primExpr -> do
152− primExpr <- f primExpr
154− return ( AggrStringAggr primExpr )
160−orderExprPrimExprs :: Applicative f => ( PrimExpr -> f PrimExpr ) -> OrderExpr -> f OrderExpr
161−orderExprPrimExprs f ( OrderExpr orderOp primExpr ) = do
162− primExpr <- f primExpr
164− return ( OrderExpr orderOp primExpr )
167−-- | Traverse both sides of a homogeneous tuple.
168−both :: Applicative f => ( t -> f b ) -> ( t, t ) -> f ( b, b )
170− liftA2 (,) ( f a ) ( f b )
174− :: ( ( a -> Identity a ) -> a -> Identity a )
175− -> ( a -> Maybe a ) -> a -> a
179− go = transformOf l ( \x -> maybe x go ( f x ) )
183− :: ( ( a -> Identity a ) -> a -> Identity a )
187−{-# inline transformOf #-}
188−transformOf l f = go where
195− :: ( ( s -> Identity t ) -> a -> Identity b )
200− runIdentity . l (Identity . f)