git.iko.soy/rel8
on 00a36f5 help sign in
rel8/src/Rel8/Table/Opaleye.hs
130 lines 4.4 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 )
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.Context ( Col, Col'(..), Insertion, Name(..) )
45import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs )
46import Rel8.Schema.Spec ( SSpec(..) )
47import Rel8.Schema.Table ( TableSchema(..) )
48import Rel8.Table ( Table, fromColumns, toColumns )
49import Rel8.Table.Recontextualize ( Selects, Inserts )
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 Insertion spec) (Col Expr spec)
99 go SSpec {necessity, info, nullability} (Col (Name name)) =
100 case necessity of
101 SRequired ->
102 lmap (\(RequiredInsert a) -> toColumn $ toPrimExpr a) $
103 DB . scastExpr nullability info . fromPrimExpr . fromColumn <$>
104 Opaleye.requiredTableField name
105 SOptional ->
106 lmap (\(OptionalInsert ma) -> toColumn . toPrimExpr <$> ma) $
107 DB . scastExpr nullability info . fromPrimExpr . fromColumn <$>
108 Opaleye.optionalTableField name
111unpackspec :: Table Expr a => Opaleye.Unpackspec a a
112unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->
113 fmap fromColumns .
114 unwrapApplicative .
115 htraverse (\(DB a) -> WrapApplicative $ DB <$> traversePrimExpr f a) .
116 toColumns
117{-# INLINABLE unpackspec #-}
120valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a
121valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec
124toPackMap :: Table Expr a
125 => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a
126toPackMap as = Opaleye.PackMap $ \f () ->
127 fmap fromColumns $
128 unwrapApplicative .
129 htraverse (\(DB a) -> WrapApplicative $ DB <$> traversePrimExpr f a) $
130 toColumns as