git.iko.soy/rel8
on 11bcbbb help sign in
rel8/src/Rel8/Table/Opaleye.hs
129 lines 4.3 kB history raw
1{-# language DisambiguateRecordFields #-}
2{-# language FlexibleContexts #-}
3{-# language NamedFieldPuns #-}
4{-# language TypeFamilies #-}
5{-# language ViewPatterns #-}
7module Rel8.Table.Opaleye
8 ( aggregator
9 , binaryspec
10 , distinctspec
11 , table
12 , tableFields
13 , unpackspec
14 , valuesspec
15 )
16where
18-- base
19import Prelude hiding ( undefined )
21-- opaleye
22import qualified Opaleye.Internal.Aggregate as Opaleye
23import qualified Opaleye.Internal.Binary as Opaleye
24import qualified Opaleye.Internal.Distinct as Opaleye
25import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
26import qualified Opaleye.Internal.PackMap as Opaleye
27import qualified Opaleye.Internal.Unpackspec as Opaleye
28import qualified Opaleye.Internal.Values as Opaleye
29import qualified Opaleye.Internal.Table as Opaleye
31-- profunctors
32import Data.Profunctor ( dimap, lmap )
34-- rel8
35import Rel8.Aggregate ( Aggregate( Aggregate ) )
36import Rel8.Expr ( Expr, Col(..) )
37import Rel8.Expr.Opaleye
38 ( scastExpr
39 , fromPrimExpr, toPrimExpr
40 , traversePrimExpr
41 , fromColumn, toColumn
42 )
43import Rel8.Kind.Necessity ( SNecessity( SRequired, SOptional ) )
44import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs )
45import Rel8.Schema.Insert ( Insert, Inserts, Col(..) )
46import Rel8.Schema.Name ( Name, Selects, Col(..) )
47import Rel8.Schema.Spec ( SSpec(..) )
48import Rel8.Schema.Table ( TableSchema(..) )
49import Rel8.Table ( Table, fromColumns, toColumns )
50import Rel8.Table.Undefined ( undefined )
52-- semigroupoids
53import Data.Functor.Apply ( WrappedApplicative(..) )
56aggregator :: Opaleye.Aggregator (Aggregate exprs) exprs
57aggregator = Opaleye.Aggregator $ Opaleye.PackMap $
58 \f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) -> inner f ()
61binaryspec :: Table Expr a => Opaleye.Binaryspec a a
62binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->
63 fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
64 WrapApplicative $
65 case (hfield (toColumns as) field, hfield (toColumns bs) field) of
66 (DB a, DB b) -> DB . fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)
69distinctspec :: Table Expr a => Opaleye.Distinctspec a a
70distinctspec =
71 Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->
72 fmap fromColumns .
73 unwrapApplicative .
74 htraverse
75 (\(DB a) ->
76 WrapApplicative $ DB . fromPrimExpr <$> f (Nothing, toPrimExpr a)) .
77 toColumns
80table ::(Selects names exprs, Inserts exprs inserts)
81 => TableSchema names -> Opaleye.Table inserts exprs
82table (TableSchema name schema columns) =
83 Opaleye.Table qualified (tableFields columns)
84 where
85 qualified = case schema of
86 Nothing -> name
87 Just qualifier -> qualifier <> "." <> name
90tableFields :: (Selects names exprs, Inserts exprs inserts)
91 => names -> Opaleye.TableFields inserts exprs
92tableFields (toColumns -> names) = dimap toColumns fromColumns $
93 unwrapApplicative $ htabulateA $ \field -> WrapApplicative $
94 case hfield hspecs field of
95 specs -> case hfield names field of
96 name -> lmap (`hfield` field) (go specs name)
97 where
98 go :: SSpec spec -> Col Name spec -> Opaleye.TableFields (Col Insert spec) (Col Expr spec)
99 go SSpec {necessity, info} (NameCol name) = case necessity of
100 SRequired ->
101 lmap (\(RequiredInsert a) -> toColumn $ toPrimExpr a) $
102 DB . scastExpr info . fromPrimExpr . fromColumn <$>
103 Opaleye.requiredTableField name
104 SOptional ->
105 lmap (\(OptionalInsert ma) -> toColumn . toPrimExpr <$> ma) $
106 DB . scastExpr info . fromPrimExpr . fromColumn <$>
107 Opaleye.optionalTableField name
110unpackspec :: Table Expr a => Opaleye.Unpackspec a a
111unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->
112 fmap fromColumns .
113 unwrapApplicative .
114 htraverse (\(DB a) -> WrapApplicative $ DB <$> traversePrimExpr f a) .
115 toColumns
116{-# INLINABLE unpackspec #-}
119valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a
120valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec
123toPackMap :: Table Expr a
124 => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a
125toPackMap as = Opaleye.PackMap $ \f () ->
126 fmap fromColumns $
127 unwrapApplicative .
128 htraverse (\(DB a) -> WrapApplicative $ DB <$> traversePrimExpr f a) $
129 toColumns as