git.iko.soy/rel8
on b97cd4e help sign in
rel8/src/Rel8/Table/Opaleye.hs
126 lines 4.2 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 ( fromPrimExpr, toPrimExpr
39 , traversePrimExpr
40 , fromColumn, toColumn
41 )
42import Rel8.Kind.Necessity ( SNecessity( SRequired, SOptional ) )
43import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs )
44import Rel8.Schema.Insert ( Insert, Inserts, Col(..) )
45import Rel8.Schema.Name ( Name, Selects, Col(..) )
46import Rel8.Schema.Spec ( SSpec(..) )
47import Rel8.Schema.Table ( TableSchema(..) )
48import Rel8.Table ( Table, fromColumns, toColumns )
49import Rel8.Table.Undefined ( undefined )
51-- semigroupoids
52import Data.Functor.Apply ( WrappedApplicative(..) )
55aggregator :: Opaleye.Aggregator (Aggregate exprs) exprs
56aggregator = Opaleye.Aggregator $ Opaleye.PackMap $
57 \f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) -> inner f ()
60binaryspec :: Table Expr a => Opaleye.Binaryspec a a
61binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->
62 fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
63 WrapApplicative $
64 case (hfield (toColumns as) field, hfield (toColumns bs) field) of
65 (DB a, DB b) -> DB . fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)
68distinctspec :: Table Expr a => Opaleye.Distinctspec a a
69distinctspec =
70 Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->
71 fmap fromColumns .
72 unwrapApplicative .
73 htraverse
74 (\(DB a) ->
75 WrapApplicative $ DB . fromPrimExpr <$> f (Nothing, toPrimExpr a)) .
76 toColumns
79table ::(Selects names exprs, Inserts exprs inserts)
80 => TableSchema names -> Opaleye.Table inserts exprs
81table (TableSchema name schema columns) =
82 case schema of
83 Nothing -> Opaleye.Table name (tableFields columns)
84 Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns)
87tableFields :: (Selects names exprs, Inserts exprs inserts)
88 => names -> Opaleye.TableFields inserts exprs
89tableFields (toColumns -> names) = dimap toColumns fromColumns $
90 unwrapApplicative $ htabulateA $ \field -> WrapApplicative $
91 case hfield hspecs field of
92 specs -> case hfield names field of
93 name -> lmap (`hfield` field) (go specs name)
94 where
95 go :: SSpec spec -> Col Name spec -> Opaleye.TableFields (Col Insert spec) (Col Expr spec)
96 go SSpec {necessity} (NameCol name) = case necessity of
97 SRequired ->
98 lmap (\(RequiredInsert a) -> toColumn $ toPrimExpr a) $
99 DB . fromPrimExpr . fromColumn <$>
100 Opaleye.requiredTableField name
101 SOptional ->
102 lmap (\(OptionalInsert ma) -> toColumn . toPrimExpr <$> ma) $
103 DB . fromPrimExpr . fromColumn <$>
104 Opaleye.optionalTableField name
107unpackspec :: Table Expr a => Opaleye.Unpackspec a a
108unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->
109 fmap fromColumns .
110 unwrapApplicative .
111 htraverse (\(DB a) -> WrapApplicative $ DB <$> traversePrimExpr f a) .
112 toColumns
113{-# INLINABLE unpackspec #-}
116valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a
117valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec
120toPackMap :: Table Expr a
121 => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a
122toPackMap as = Opaleye.PackMap $ \f () ->
123 fmap fromColumns $
124 unwrapApplicative .
125 htraverse (\(DB a) -> WrapApplicative $ DB <$> traversePrimExpr f a) $
126 toColumns as