git.iko.soy/rel8
on 8575057 help sign in
rel8/src/Rel8/Query/Optimize.hs
200 lines 4.5 kB history raw
1{-# language ApplicativeDo #-}
2{-# language LambdaCase #-}
4{-# options -fno-warn-name-shadowing #-}
6module Rel8.Query.Optimize
7 ( optimize
8 )
9where
11-- base
12import Control.Applicative
13import Data.Functor.Identity
14import Prelude
16-- opaleye
17import Opaleye.Internal.HaskellDB.PrimQuery
18import Opaleye.Internal.PrimQuery
21optimize :: PrimQuery' a -> PrimQuery' a
22optimize =
23 transformOf primQuery optimisePredicates
26primQuery
27 :: Applicative f
28 => ( PrimQuery' a -> f ( PrimQuery' a ) ) -> PrimQuery' a -> f ( PrimQuery' a )
29primQuery f = \case
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 )
67 other ->
68 pure other
71optimisePredicates :: PrimQuery' a -> PrimQuery' a
72optimisePredicates = \case
73 Join joinType predicate bindingsA bindingsB primQueryA primQueryB ->
74 Join joinType ( nullIsFalse predicate ) bindingsA bindingsB primQueryA primQueryB
76 other ->
77 other
80nullIsFalse :: PrimExpr -> PrimExpr
81nullIsFalse =
82 rewriteOf primExprs simplifyCaseAnalysis
84 where
86 simplifyCaseAnalysis = \case
87 CaseExpr [ ( UnExpr OpIsNull _, ConstExpr ( BoolLit False ) ) ] notNullBranch ->
88 Just notNullBranch
90 CaseExpr [ ( UnExpr OpIsNull x, UnExpr OpIsNull y ) ] notNullBranch ->
91 Just
92 ( BinExpr
93 (:||)
94 ( BinExpr (:&&) ( UnExpr OpIsNull x ) ( UnExpr OpIsNull y ) )
95 notNullBranch
96 )
98 _ ->
99 Nothing
103-- | Traverse all immediate 'PrimExpr's
104primExprs :: Applicative f => ( PrimExpr -> f PrimExpr ) -> PrimExpr -> f PrimExpr
105primExprs f = \case
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
118 a <- f a
119 b <- f b
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 )
135 ConstExpr l ->
136 pure ( ConstExpr l )
138 CaseExpr cases def -> do
139 cases <- traverse ( both f ) cases
140 def <- f def
142 return ( CaseExpr cases def )
144 other ->
145 pure other
149aggrOpPrimExprs :: Applicative f => ( PrimExpr -> f PrimExpr ) -> AggrOp -> f AggrOp
150aggrOpPrimExprs f = \case
151 AggrStringAggr primExpr -> do
152 primExpr <- f primExpr
154 return ( AggrStringAggr primExpr )
156 other ->
157 pure other
160orderExprPrimExprs :: Applicative f => ( PrimExpr -> f PrimExpr ) -> OrderExpr -> f OrderExpr
161orderExprPrimExprs f ( OrderExpr orderOp primExpr ) = do
162 primExpr <- f primExpr
164 return ( OrderExpr orderOp primExpr )
167-- | Traverse both sides of a homogeneous tuple.
168both :: Applicative f => ( t -> f b ) -> ( t, t ) -> f ( b, b )
169both f ( a,b ) =
170 liftA2 (,) ( f a ) ( f b )
173rewriteOf
174 :: ( ( a -> Identity a ) -> a -> Identity a )
175 -> ( a -> Maybe a ) -> a -> a
176rewriteOf l f =
177 go where
179 go = transformOf l ( \x -> maybe x go ( f x ) )
182transformOf
183 :: ( ( a -> Identity a ) -> a -> Identity a )
184 -> ( a -> a )
185 -> a
186 -> a
187{-# inline transformOf #-}
188transformOf l f = go where
190 go =
191 f . over l go
194over
195 :: ( ( s -> Identity t ) -> a -> Identity b )
196 -> ( s -> t )
197 -> a
198 -> b
199over l f =
200 runIdentity . l (Identity . f)