mirror of
https://github.com/circuithub/rel8.git
synced 2024-10-27 10:23:19 +03:00
Smaller core
This commit is contained in:
parent
554e0c12e6
commit
ffa98e9196
62
Rel8.hs
62
Rel8.hs
@ -19,8 +19,10 @@ module Rel8
|
||||
|
||||
-- * Defining Tables
|
||||
C
|
||||
, Anon
|
||||
, HasDefault(..)
|
||||
, BaseTable(tableName)
|
||||
, Table
|
||||
|
||||
-- * Querying Tables
|
||||
, O.Query, O.QueryArr
|
||||
@ -43,6 +45,7 @@ module Rel8
|
||||
, asc, desc, orderNulls, O.orderBy, OrderNulls(..)
|
||||
|
||||
-- * Aggregation
|
||||
-- $aggregation
|
||||
, aggregate
|
||||
, AggregateTable
|
||||
, count, groupBy, DBSum(..), countStar, DBMin(..), DBMax(..), DBAvg(..)
|
||||
@ -50,7 +53,6 @@ module Rel8
|
||||
, countRows, Aggregate
|
||||
|
||||
-- * Tables
|
||||
, Table
|
||||
, MaybeTable, isTableNull
|
||||
, Col(..)
|
||||
|
||||
@ -92,7 +94,7 @@ module Rel8
|
||||
, delete
|
||||
|
||||
-- * Interpretations
|
||||
, QueryResult, Schema, Anon
|
||||
, QueryResult, SchemaInfo, Anon
|
||||
|
||||
-- * Re-exported symbols
|
||||
, Connection, Stream, Of, Generic
|
||||
@ -105,10 +107,11 @@ module Rel8
|
||||
, dbBinOp
|
||||
) where
|
||||
|
||||
import Data.Functor.Rep (mzipWithRep)
|
||||
import Control.Applicative (liftA2)
|
||||
import Control.Category ((.), id)
|
||||
import Control.Lens (view, from)
|
||||
import Control.Monad.Rel8
|
||||
import Control.Monad.Zip
|
||||
import Data.List (foldl')
|
||||
import Data.Profunctor (lmap)
|
||||
import Data.Text (Text)
|
||||
@ -132,10 +135,8 @@ import qualified Opaleye.Operators as O
|
||||
import qualified Opaleye.Order as O
|
||||
import Prelude hiding (not, (.), id)
|
||||
import Rel8.Internal
|
||||
import Rel8.Internal.DBType
|
||||
import Streaming (Of, Stream)
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Take the @LEFT JOIN@ of two queries.
|
||||
leftJoin
|
||||
@ -160,7 +161,7 @@ leftJoin condition l r =
|
||||
-- given query. The input to the 'QueryArr' is a predicate function against
|
||||
-- rows in the to-be-joined query.
|
||||
--
|
||||
-- === __Example__
|
||||
-- === Example
|
||||
-- @
|
||||
-- -- Return all users and comments, including users who haven't made a comment.
|
||||
-- usersAndComments :: Query (User Expr, MaybeTable (Comment Expr))
|
||||
@ -242,11 +243,10 @@ unionAll =
|
||||
(O.PackMap
|
||||
(\f (l, r) ->
|
||||
fmap
|
||||
(viewFrom expressions)
|
||||
(view (from expressions))
|
||||
(sequenceA
|
||||
((mzipWith
|
||||
(\(Some (Expr prim1)) (Some (Expr prim2)) ->
|
||||
Some . Expr <$> f (prim1, prim2))
|
||||
((mzipWithRep
|
||||
(\prim1 prim2 -> f (prim1, prim2))
|
||||
(view expressions l)
|
||||
(view expressions r)))))))
|
||||
|
||||
@ -314,6 +314,7 @@ unionAll =
|
||||
} deriving (Generic)
|
||||
|
||||
instance 'BaseTable' Part where 'tableName' = \"part\"
|
||||
instance 'Table' (Part 'Expr') (Part 'QueryResult')
|
||||
@
|
||||
|
||||
The @Part@ table has 5 columns, each defined with the @C f ..@
|
||||
@ -325,9 +326,11 @@ unionAll =
|
||||
managed by the database.
|
||||
3. The type of the column.
|
||||
|
||||
After defining the table, we finally need to make an instance of 'BaseTable'
|
||||
so @rel8@ can query this table. By using @deriving (Generic)@, we simply need
|
||||
to write @instance BaseTable Part where tableName = "part"@.
|
||||
After defining the table, we finally need to make instances of 'BaseTable' and
|
||||
'Table' so @rel8@ can query this table. By using @deriving (Generic)@, we
|
||||
simply need to write @instance BaseTable Part where tableName = "part"@. The
|
||||
'Table' instance demonstrates that a @Part Expr@ value can be selected from
|
||||
the database as @Part QueryResult@.
|
||||
|
||||
=== Querying tables
|
||||
|
||||
@ -399,6 +402,7 @@ unionAll =
|
||||
} deriving (Generic)
|
||||
|
||||
instance 'BaseTable' Supplier where 'tableName' = "supplier"
|
||||
instance 'Table' (Supplier 'Expr') (Supplier 'QueryResult')
|
||||
@
|
||||
|
||||
We can take the product of all parts paired against all suppliers:
|
||||
@ -493,3 +497,35 @@ unionAll =
|
||||
though in @rel8@ we're a little bit more general.
|
||||
|
||||
-}
|
||||
|
||||
|
||||
{- $aggregation
|
||||
|
||||
To aggregate a series of rows, use the 'aggregate' query transform.
|
||||
@aggregate@ takes a 'Query' that returns any 'AggregateTable' as a result.
|
||||
@AggregateTable@s are like @Tables@, except that all expressions describe
|
||||
a way to aggregate data. While tuples are instances of @AggregateTable@,
|
||||
it's recommended to introduce new data types to represent aggregations for
|
||||
clarity:
|
||||
|
||||
=== Example
|
||||
|
||||
@
|
||||
data UserInfo f = UserInfo
|
||||
{ userCount :: Anon f Int64
|
||||
, latestLogin :: Anon f UTCTime
|
||||
, uType :: Anon f Type
|
||||
} deriving (Generic)
|
||||
|
||||
instance AggregateTable (UserInfo Aggregate) (UserInfo Expr)
|
||||
|
||||
userInfo :: Query (UserInfo Expr)
|
||||
userInfo = aggregate $ proc _ -> do
|
||||
user <- queryTable -< ()
|
||||
returnA -< UserInfo { userCount = count (userId user)
|
||||
, latestLogin = max (userLastLoggedIn user)
|
||||
, uType = groupBy (userType user)
|
||||
}
|
||||
@
|
||||
|
||||
-}
|
||||
|
15
Rel8/IO.hs
15
Rel8/IO.hs
@ -22,6 +22,7 @@ module Rel8.IO
|
||||
, streamCursor
|
||||
) where
|
||||
|
||||
import Control.Lens (nullOf)
|
||||
import Control.Monad (void)
|
||||
import Control.Monad.Catch (MonadMask)
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
@ -31,9 +32,9 @@ import qualified Data.List.NonEmpty as NEL
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.String (fromString)
|
||||
import Database.PostgreSQL.Simple (Connection)
|
||||
import Database.PostgreSQL.Simple (defaultFoldOptions)
|
||||
import qualified Database.PostgreSQL.Simple as Pg
|
||||
import qualified Database.PostgreSQL.Simple.FromRow as Pg
|
||||
import Database.PostgreSQL.Simple (defaultFoldOptions)
|
||||
import Database.PostgreSQL.Simple.Streaming
|
||||
(queryWith_, streamWithOptionsAndParser_)
|
||||
import qualified Opaleye as O
|
||||
@ -41,8 +42,8 @@ import qualified Opaleye.Internal.RunQuery as O
|
||||
import qualified Opaleye.Internal.Table as O
|
||||
import Rel8.Internal.Expr
|
||||
import Rel8.Internal.Operators
|
||||
import Rel8.Internal.Table
|
||||
import Rel8.Internal.Types (Insert, QueryResult)
|
||||
import Rel8.Internal.Table hiding (columns)
|
||||
import Rel8.Internal.Types
|
||||
import Streaming (Stream, Of)
|
||||
import qualified Streaming.Prelude as S
|
||||
|
||||
@ -61,7 +62,7 @@ type QueryRunner m = forall a. Pg.RowParser a -> Pg.Query -> Stream (Of a) m ()
|
||||
-- @
|
||||
-- 'stream' = 'queryWith_'
|
||||
-- @
|
||||
stream :: (MonadResource m, MonadMask m) => Connection -> QueryRunner m
|
||||
stream :: (MonadResource m) => Connection -> QueryRunner m
|
||||
stream conn parser query = queryWith_ parser conn query
|
||||
|
||||
-- | Stream the results of a query and fetch the results using a PostgreSQL
|
||||
@ -139,7 +140,7 @@ update conn f up =
|
||||
-- | Update rows in a 'BaseTable' and return the results. Corresponds to
|
||||
-- @UPDATE ... RETURNING@.
|
||||
updateReturning
|
||||
:: (BaseTable table, DBBool bool, MonadIO m)
|
||||
:: (BaseTable table, DBBool bool)
|
||||
=> QueryRunner m
|
||||
-> (table Expr -> Expr bool)
|
||||
-> (table Expr -> table Expr)
|
||||
@ -163,8 +164,8 @@ delete conn f =
|
||||
queryRunner :: Table a b => O.QueryRunner a b
|
||||
queryRunner =
|
||||
O.QueryRunner (void unpackColumns)
|
||||
rowParser
|
||||
(Prelude.not . null . view expressions)
|
||||
(const rowParser)
|
||||
(Prelude.not . nullOf (expressions . traverse))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
@ -5,7 +5,6 @@ module Rel8.Internal (module X) where
|
||||
import Rel8.Internal.Aggregate as X
|
||||
import Rel8.Internal.DBType as X
|
||||
import Rel8.Internal.Expr as X
|
||||
import Rel8.Internal.Generic as X
|
||||
import Rel8.Internal.Operators as X
|
||||
import Rel8.Internal.Order as X
|
||||
import Rel8.Internal.Table as X
|
||||
|
@ -1,101 +0,0 @@
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Rel8.Internal.Generic where
|
||||
|
||||
import Control.Applicative (liftA2)
|
||||
import Data.Profunctor (dimap, lmap)
|
||||
import Data.Profunctor.Product ((***!))
|
||||
import Data.Proxy (Proxy(..))
|
||||
import GHC.Generics (K1(..), M1(..), (:*:)(..))
|
||||
import GHC.TypeLits (symbolVal, KnownSymbol)
|
||||
import qualified Opaleye.Internal.Column as O
|
||||
import qualified Opaleye.Internal.HaskellDB.PrimQuery as O
|
||||
import qualified Opaleye.Internal.Table as O
|
||||
import Prelude hiding (not, id)
|
||||
import Rel8.Internal.Expr
|
||||
import Rel8.Internal.Types
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | The class of values that can be traversed for 'O.PrimExpr's.
|
||||
|
||||
class MapPrimExpr s where
|
||||
mapPrimExpr :: Applicative f => (O.PrimExpr -> f O.PrimExpr) -> s -> f s
|
||||
|
||||
instance MapPrimExpr (Expr column) where
|
||||
mapPrimExpr f (Expr a) = fmap Expr (f a)
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Witness the schema definition for table columns.
|
||||
class WitnessSchema a where
|
||||
schema :: a
|
||||
|
||||
instance KnownSymbol name =>
|
||||
WitnessSchema (SchemaInfo name def t) where
|
||||
schema = SchemaInfo (symbolVal (Proxy @name))
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
class GTraverseSchema schema expr | schema -> expr where
|
||||
gtraverseSchema
|
||||
:: Applicative f
|
||||
=> (forall a. String -> f (Expr a)) -> schema x -> f (expr y)
|
||||
|
||||
instance (GTraverseSchema schema expr) =>
|
||||
GTraverseSchema (M1 i c schema) (M1 i c expr) where
|
||||
gtraverseSchema f (M1 a) = M1 <$> gtraverseSchema f a
|
||||
|
||||
instance (GTraverseSchema fSchema fExpr, GTraverseSchema gSchema gExpr) =>
|
||||
GTraverseSchema (fSchema :*: gSchema) (fExpr :*: gExpr) where
|
||||
gtraverseSchema f (l :*: r) =
|
||||
liftA2 (:*:) (gtraverseSchema f l) (gtraverseSchema f r)
|
||||
|
||||
instance GTraverseSchema (K1 i (SchemaInfo name def a)) (K1 i (Expr a)) where
|
||||
gtraverseSchema f (K1 (SchemaInfo a)) = K1 <$> f a
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Form 'O.Writer's from a schema specification
|
||||
class Writer (f :: * -> *) schema expr | f schema -> expr where
|
||||
columnWriter :: proxy f -> schema a -> O.Writer (expr a) ()
|
||||
|
||||
instance (Writer f schema expr) =>
|
||||
Writer f (M1 i c schema) (M1 i c expr) where
|
||||
columnWriter p (M1 s) = lmap (\(M1 a) -> a) (columnWriter p s)
|
||||
|
||||
instance (Writer f fSchema fExpr, Writer f gSchema gExpr) =>
|
||||
Writer f (fSchema :*: gSchema) (fExpr :*: gExpr) where
|
||||
columnWriter p (l :*: r) =
|
||||
dimap (\(l' :*: r') -> (l', r')) fst (columnWriter p l ***! columnWriter p r)
|
||||
|
||||
instance Writer Expr (K1 i (SchemaInfo name d a)) (K1 i (Expr a)) where
|
||||
columnWriter _ (K1 (SchemaInfo name)) =
|
||||
dimap
|
||||
(\(K1 expr) -> exprToColumn expr)
|
||||
(const ())
|
||||
(O.required name)
|
||||
|
||||
instance Writer Insert (K1 i (SchemaInfo name 'NoDefault a)) (K1 i (Expr a)) where
|
||||
columnWriter _ (K1 (SchemaInfo name)) =
|
||||
dimap
|
||||
(\(K1 expr) -> exprToColumn expr)
|
||||
(const ())
|
||||
(O.required name)
|
||||
|
||||
instance Writer Insert (K1 i (SchemaInfo name 'HasDefault a)) (K1 i (Default (Expr a))) where
|
||||
columnWriter _ (K1 (SchemaInfo name)) =
|
||||
dimap
|
||||
(\(K1 def) ->
|
||||
case def of
|
||||
InsertDefault -> O.Column O.DefaultInsertExpr
|
||||
OverrideDefault expr -> exprToColumn expr)
|
||||
(const ())
|
||||
(O.required name)
|
@ -1,39 +1,39 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE DefaultSignatures #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
-- | This module defines the 'Table' type class.
|
||||
module Rel8.Internal.Table where
|
||||
|
||||
import Data.Functor.Product
|
||||
import Data.Profunctor
|
||||
import Control.Applicative (liftA2)
|
||||
import Data.Proxy
|
||||
import GHC.TypeLits
|
||||
import Control.Applicative
|
||||
import Control.Lens (Iso', from, iso, view)
|
||||
import Control.Monad (replicateM_)
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import Data.Functor.Compose (Compose(..))
|
||||
import Data.Foldable (traverse_)
|
||||
import Data.Functor.Identity
|
||||
import Data.Functor.Product
|
||||
import Data.Functor.Rep (Representable, index, tabulate, pureRep)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Profunctor (dimap, lmap)
|
||||
import Data.Profunctor.Product ((***!))
|
||||
import Data.Proxy (Proxy(..))
|
||||
import Data.Profunctor (dimap)
|
||||
import Data.Tagged (Tagged(..), untag)
|
||||
import Database.PostgreSQL.Simple.FromField (FromField)
|
||||
import Database.PostgreSQL.Simple.FromRow (RowParser, field)
|
||||
import GHC.Generics
|
||||
((:*:)(..), Generic, K1(..), M1(..), Rep, from, to)
|
||||
import Generics.OneLiner
|
||||
(ADTRecord, Constraints, For(..), createA, nullaryOp)
|
||||
((:*:)(..), Generic, K1(..), M1(..), Rep, to)
|
||||
import GHC.Generics.Lens (generic, _M1, _K1)
|
||||
import Generics.OneLiner (nullaryOp, ADTRecord, Constraints, For(..))
|
||||
import qualified Opaleye.Aggregate as O
|
||||
import qualified Opaleye.Column as O
|
||||
import qualified Opaleye.Internal.Aggregate as O
|
||||
@ -48,20 +48,7 @@ import Prelude hiding (not)
|
||||
import Prelude hiding (not, id)
|
||||
import Rel8.Internal.DBType
|
||||
import Rel8.Internal.Expr
|
||||
import Rel8.Internal.Generic
|
||||
import Rel8.Internal.Types
|
||||
import Control.Monad.Zip
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Some f where
|
||||
Some :: f a -> Some f
|
||||
|
||||
view :: ((a -> Identity b) -> (s -> Identity t)) -> s -> a
|
||||
view = undefined
|
||||
|
||||
viewFrom :: ((a -> Identity b) -> (s -> Identity t)) -> a -> s
|
||||
viewFrom = undefined
|
||||
|
||||
type family MkRowF a :: * -> * where
|
||||
MkRowF (M1 i c f) = MkRowF f
|
||||
@ -79,94 +66,90 @@ type family MkRowF a :: * -> * where
|
||||
-- 'Table' - but cannot be inserted as it doesn't belong to any base table.
|
||||
--
|
||||
-- You should not need to define your own instances of 'Table' in idiomatic
|
||||
-- @rel8@ usage - all 'BaseTable's are 'Table's, and the tupling of two (or
|
||||
-- more) 'Table's is also a 'Table'.
|
||||
class (MonadZip (RowF expr), Traversable (RowF expr)) => Table expr haskell | expr -> haskell, haskell -> expr where
|
||||
-- @rel8@ usage - beyond simplying deriving an instance and using generics.
|
||||
class (Representable (RowF expr), Traversable (RowF expr)) =>
|
||||
Table expr haskell | expr -> haskell, haskell -> expr where
|
||||
|
||||
-- | Every 'Table' is isomorphic to a 'Functor' with finite cardinality
|
||||
-- (a 'Representable' functor). This type witnesses what that functor
|
||||
-- is. By default, this functor can be derived from the generic representation
|
||||
-- of @expr@.
|
||||
type RowF expr :: * -> *
|
||||
type RowF expr = MkRowF (Rep expr)
|
||||
|
||||
rowParser :: expr -> RowParser haskell
|
||||
-- | Witness the isomorphism between the expression's functor of primitive
|
||||
-- expressions, and the user friendly expression type. A default
|
||||
-- implementation is provided, assuming every field in @expr@ contains
|
||||
-- exactly one 'Expr'.
|
||||
expressions :: Iso' expr (RowF expr O.PrimExpr)
|
||||
|
||||
expressions
|
||||
:: (Profunctor p, Functor f)
|
||||
=> p (RowF expr (Some Expr)) (f (RowF expr (Some Expr))) -> p expr (f expr)
|
||||
|
||||
---------------------------------------------------------------------------------------
|
||||
-- Every expression can be parsed into Haskell, once results have been
|
||||
-- retrieved from the database. A generic implementation is provided which
|
||||
-- assumes that every field in @haskell@ represents exactly one column
|
||||
-- in the result.
|
||||
rowParser :: RowParser haskell
|
||||
|
||||
default
|
||||
rowParser
|
||||
:: (Generic haskell, Generic expr, GTable (Rep expr) (Rep haskell))
|
||||
=> expr -> RowParser haskell
|
||||
rowParser = fmap to . growParser . from
|
||||
:: (Generic haskell, GTable (Rep expr) (Rep haskell))
|
||||
=> RowParser haskell
|
||||
rowParser = fmap to growParser
|
||||
|
||||
default
|
||||
expressions
|
||||
:: ( Generic expr
|
||||
, GTable (Rep expr) (Rep haskell)
|
||||
, Functor f
|
||||
, Profunctor p
|
||||
, RowF expr ~ MkRowF (Rep expr)
|
||||
)
|
||||
=> p (RowF expr (Some Expr)) (f (RowF expr (Some Expr))) -> p expr (f expr)
|
||||
expressions = dimap from (fmap to) . gexpressions
|
||||
=> Iso' expr (RowF expr O.PrimExpr)
|
||||
expressions = generic . gexpressions
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
class GTable expr haskell | expr -> haskell, haskell -> expr where
|
||||
growParser :: expr a -> RowParser (haskell a)
|
||||
gexpressions
|
||||
:: (Profunctor p, Functor f)
|
||||
=> p (MkRowF expr (Some Expr)) (f (MkRowF expr (Some Expr)))
|
||||
-> p (expr ()) (f (expr ()))
|
||||
growParser :: RowParser (haskell a)
|
||||
gexpressions :: Iso' (expr a) (MkRowF expr O.PrimExpr)
|
||||
|
||||
instance GTable expr haskell => GTable (M1 i c expr) (M1 i c haskell) where
|
||||
growParser (M1 a) = M1 <$> growParser a
|
||||
gexpressions = dimap (\(M1 a) -> view gexpressions a) (fmap (M1 . viewFrom gexpressions))
|
||||
growParser = M1 <$> growParser
|
||||
gexpressions = _M1 . gexpressions
|
||||
|
||||
instance (GTable le lh, GTable re rh) =>
|
||||
GTable (le :*: re) (lh :*: rh) where
|
||||
growParser (a :*: b) = liftA2 (:*:) (growParser a) (growParser b)
|
||||
growParser = liftA2 (:*:) growParser growParser
|
||||
gexpressions =
|
||||
dimap
|
||||
(\(a :*: b) -> Pair (view gexpressions a) (view gexpressions b))
|
||||
(fmap (\(Pair a b) -> viewFrom gexpressions a :*: viewFrom gexpressions b))
|
||||
iso
|
||||
(\(l :*: r) -> Pair (view gexpressions l) (view gexpressions r))
|
||||
(\(Pair l r) ->
|
||||
view (from gexpressions) l :*: view (from gexpressions) r)
|
||||
|
||||
instance {-# OVERLAPPABLE #-} Table expr haskell => GTable (K1 i expr) (K1 i haskell) where
|
||||
growParser (K1 expr) = K1 <$> rowParser expr
|
||||
gexpressions = dimap (\(K1 a) -> view expressions a) (fmap (K1 . viewFrom expressions))
|
||||
instance {-# OVERLAPPABLE #-}
|
||||
Table expr haskell => GTable (K1 i expr) (K1 i haskell) where
|
||||
growParser = K1 <$> rowParser
|
||||
gexpressions = _K1 . expressions
|
||||
|
||||
instance DBType a =>
|
||||
GTable (K1 i (Expr a)) (K1 i a) where
|
||||
growParser _ = K1 <$> field
|
||||
growParser = K1 <$> field
|
||||
gexpressions =
|
||||
dimap
|
||||
(\(K1 a) -> Identity (Some a))
|
||||
(fmap (\(Identity (Some (Expr prim))) -> K1 (Expr prim)))
|
||||
iso
|
||||
(\(K1 (Expr prim)) -> Identity prim)
|
||||
(\(Identity prim) -> K1 (Expr prim))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Stock instances of 'Table'
|
||||
|
||||
-- | Any 'BaseTable' is a 'Table'.
|
||||
instance {-# OVERLAPPABLE #-}
|
||||
( BaseTable table
|
||||
, f ~ Expr
|
||||
, g ~ QueryResult
|
||||
, BaseTableF table ~ RowF (table Expr)
|
||||
) =>
|
||||
Table (table f) (table g) where
|
||||
rowParser _ = parseBaseTable
|
||||
expressions = baseTableExprs
|
||||
|
||||
instance (Table a a', Table b b') =>
|
||||
Table (a, b) (a', b') where
|
||||
instance (Table a a', Table b b') => Table (a, b) (a', b') where
|
||||
type RowF (a, b) = Product (RowF a) (RowF b)
|
||||
|
||||
expressions =
|
||||
dimap
|
||||
(\(l, r) -> Pair (view expressions l) (view expressions r))
|
||||
(fmap (\(Pair l r) -> (viewFrom expressions l, viewFrom expressions r)))
|
||||
(fmap
|
||||
(\(Pair l r) ->
|
||||
(view (from expressions) l, view (from expressions) r)))
|
||||
|
||||
rowParser (l, r) = (,) <$> rowParser l <*> rowParser r
|
||||
rowParser = (,) <$> rowParser <*> rowParser
|
||||
|
||||
instance (Table a a', Table b b', Table c c') =>
|
||||
Table (a, b, c) (a', b', c') where
|
||||
@ -180,11 +163,11 @@ instance (Table a a', Table b b', Table c c') =>
|
||||
(view expressions c))
|
||||
(fmap
|
||||
(\(Pair (Pair a b) c) ->
|
||||
( viewFrom expressions a
|
||||
, viewFrom expressions b
|
||||
, viewFrom expressions c)))
|
||||
( view (from expressions) a
|
||||
, view (from expressions) b
|
||||
, view (from expressions) c)))
|
||||
|
||||
rowParser (a, b, c) = (,,) <$> rowParser a <*> rowParser b <*> rowParser c
|
||||
rowParser = (,,) <$> rowParser <*> rowParser <*> rowParser
|
||||
|
||||
instance (Table a a', Table b b', Table c c', Table d d') =>
|
||||
Table (a, b, c, d) (a', b', c', d') where
|
||||
@ -200,16 +183,16 @@ instance (Table a a', Table b b', Table c c', Table d d') =>
|
||||
(view expressions d))
|
||||
(fmap
|
||||
(\(Pair (Pair (Pair a b) c) d) ->
|
||||
( viewFrom expressions a
|
||||
, viewFrom expressions b
|
||||
, viewFrom expressions c
|
||||
, viewFrom expressions d)))
|
||||
( view (from expressions) a
|
||||
, view (from expressions) b
|
||||
, view (from expressions) c
|
||||
, view (from expressions) d)))
|
||||
|
||||
rowParser (a, b, c, d) =
|
||||
(,,,) <$> rowParser a
|
||||
<*> rowParser b
|
||||
<*> rowParser c
|
||||
<*> rowParser d
|
||||
rowParser =
|
||||
(,,,) <$> rowParser
|
||||
<*> rowParser
|
||||
<*> rowParser
|
||||
<*> rowParser
|
||||
|
||||
instance (Table a a', Table b b', Table c c', Table d d', Table e e') =>
|
||||
Table (a, b, c, d, e) (a', b', c', d', e') where
|
||||
@ -227,18 +210,18 @@ instance (Table a a', Table b b', Table c c', Table d d', Table e e') =>
|
||||
(view expressions e))
|
||||
(fmap
|
||||
(\(Pair (Pair (Pair (Pair a b) c) d) e) ->
|
||||
( viewFrom expressions a
|
||||
, viewFrom expressions b
|
||||
, viewFrom expressions c
|
||||
, viewFrom expressions d
|
||||
, viewFrom expressions e)))
|
||||
( view (from expressions) a
|
||||
, view (from expressions) b
|
||||
, view (from expressions) c
|
||||
, view (from expressions) d
|
||||
, view (from expressions) e)))
|
||||
|
||||
rowParser (a, b, c, d, e) =
|
||||
(,,,,) <$> rowParser a
|
||||
<*> rowParser b
|
||||
<*> rowParser c
|
||||
<*> rowParser d
|
||||
<*> rowParser e
|
||||
rowParser =
|
||||
(,,,,) <$> rowParser
|
||||
<*> rowParser
|
||||
<*> rowParser
|
||||
<*> rowParser
|
||||
<*> rowParser
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
@ -249,25 +232,27 @@ data MaybeTable row = MaybeTable (Expr (Maybe Bool)) row
|
||||
|
||||
-- | The result of a left/right join is a table, but the table may be entirely
|
||||
-- @null@ sometimes.
|
||||
instance (Table expr haskell) =>
|
||||
Table (MaybeTable expr) (Maybe haskell) where
|
||||
instance (Table expr haskell) => Table (MaybeTable expr) (Maybe haskell) where
|
||||
type RowF (MaybeTable expr) = Product Identity (RowF expr)
|
||||
|
||||
expressions =
|
||||
dimap
|
||||
(\(MaybeTable tag row) -> Pair (view expressions tag) (view expressions row))
|
||||
(\(MaybeTable tag row) ->
|
||||
Pair (view expressions tag) (view expressions row))
|
||||
(fmap
|
||||
(\(Pair tag row) ->
|
||||
MaybeTable (viewFrom expressions tag) (viewFrom expressions row)))
|
||||
MaybeTable
|
||||
(view (from expressions) tag)
|
||||
(view (from expressions) row)))
|
||||
|
||||
rowParser (MaybeTable _ row) = do
|
||||
rowParser = do
|
||||
isNull' <- field
|
||||
if fromMaybe True isNull'
|
||||
then Nothing <$ replicateM_ (length (view expressions row)) (field :: RowParser (Maybe ()))
|
||||
else fmap Just (rowParser row)
|
||||
|
||||
-- traverseBinary f (MaybeTable tagL l, MaybeTable tagR r) =
|
||||
-- MaybeTable <$> traverseBinary f (tagL, tagR) <*> traverseBinary f (l, r)
|
||||
then Nothing <$
|
||||
replicateM_
|
||||
(length (pureRep () :: RowF expr ()))
|
||||
(field :: RowParser (Maybe ()))
|
||||
else fmap Just rowParser
|
||||
|
||||
-- | Project an expression out of a 'MaybeTable', preserving the fact that this
|
||||
-- column might be @null@. Like field selection.
|
||||
@ -328,19 +313,18 @@ newtype Col a = Col { unCol :: a }
|
||||
deriving (Show, ToJSON, FromJSON, Read, Eq, Ord)
|
||||
|
||||
-- | Single 'Expr'essions are tables, but the result will be wrapped in 'Col'.
|
||||
instance (DBType a) =>
|
||||
Table (Expr a) (Col a) where
|
||||
instance DBType a => Table (Expr a) (Col a) where
|
||||
type RowF (Expr a) = Identity
|
||||
expressions = dimap (Identity . Some) (fmap (\(Identity (Some (Expr prim))) -> Expr prim))
|
||||
rowParser _ = fmap Col field
|
||||
expressions = dimap (\(Expr a) -> return a) (fmap (Expr . runIdentity))
|
||||
rowParser = fmap Col field
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
traversePrimExprs
|
||||
:: (Applicative f, Table expr haskell)
|
||||
=> (O.PrimExpr -> f O.PrimExpr) -> expr -> f expr
|
||||
traversePrimExprs f =
|
||||
fmap (viewFrom expressions) .
|
||||
traverse (\(Some (Expr prim)) -> Some . Expr <$> f prim) . view expressions
|
||||
traversePrimExprs f expr =
|
||||
expressions (traverse f) expr
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
unpackColumns :: Table expr haskell => O.Unpackspec expr expr
|
||||
@ -349,130 +333,103 @@ unpackColumns = O.Unpackspec (O.PackMap traversePrimExprs)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | A 'BaseTable' is a table that is specified directly in a relational
|
||||
-- database schema with @CREATE TABLE@. You introduce 'BaseTables' by defining
|
||||
-- Haskell records parameterised over some functor @f@, and then use 'C' to
|
||||
-- define individual columns. Finally, derive 'Generic' and provide a minimal
|
||||
-- 'BaseTable' instance.
|
||||
--
|
||||
-- === Example
|
||||
--
|
||||
-- @
|
||||
-- data Part f =
|
||||
-- Part { partId :: 'C' f \"PID\" ''HasDefault' Int
|
||||
-- , partName :: 'C' f \"PName\" ''NoDefault' Text
|
||||
-- , partColor :: 'C' f \"Color\" ''NoDefault' Int
|
||||
-- } deriving (Generic)
|
||||
--
|
||||
-- instance 'BaseTable' Part where tableName = "part"
|
||||
-- @
|
||||
class (Table (table Expr) (table QueryResult)) => BaseTable table where
|
||||
type BaseTableF table :: * -> *
|
||||
type BaseTableF table = MkRowF (Rep (table Expr))
|
||||
-- database schema with @CREATE TABLE@. This allows you to both @SELECT FROM@
|
||||
-- rows from this table, @UPDATE@ and @DELETE@ existing rows and @INSERT@ new
|
||||
-- rows.
|
||||
|
||||
class Table (table Expr) (table QueryResult) => BaseTable table where
|
||||
-- | The name of this table in the database. You can use the 'FromString'
|
||||
-- instance for 'Tagged' to simply write
|
||||
-- @tableName = "employees"@, for example.
|
||||
tableName :: Tagged table String
|
||||
|
||||
-- | Witness the schema of a table at the value level.
|
||||
tableSchema :: table Schema
|
||||
columns :: table SchemaInfo
|
||||
|
||||
-- | Parse query results for this table.
|
||||
parseBaseTable :: RowParser (table QueryResult)
|
||||
|
||||
-- | Traverse over all column names in a schema, converting to 'Expr's that
|
||||
-- would select those columns.
|
||||
traverseSchema
|
||||
:: Applicative f
|
||||
=> (forall a. String -> f (Expr a)) -> table Schema -> f (table Expr)
|
||||
|
||||
-- | Traverse over all primitive expressions in a table of expressions.
|
||||
baseTableExprs
|
||||
:: (Profunctor p, Functor f)
|
||||
=> p (BaseTableF table (Some Expr)) (f (BaseTableF table (Some Expr)))
|
||||
-> p (table Expr) (f (table Expr))
|
||||
|
||||
-- | Traverse over all aggregates in a table of aggregations, converting them
|
||||
-- to the expressions that refer to aggregation results.
|
||||
traverseBaseTableAggregates :: O.Aggregator (table Aggregate) (table Expr)
|
||||
|
||||
insertWriter :: O.Writer (table Insert) a
|
||||
|
||||
updateWriter :: O.Writer (table Expr) a
|
||||
-- | Any 'BaseTable' is isomorphic to a set of interpretations. These
|
||||
-- interpretations can be viewed as colimits if we throw away the type
|
||||
-- information.
|
||||
tabular
|
||||
:: Interpretation f
|
||||
-> Iso' (table f) (RowF (table Expr) (Colimit f))
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
default
|
||||
parseBaseTable :: ( ADTRecord (table QueryResult)
|
||||
, Constraints (table QueryResult) FromField
|
||||
)
|
||||
=> RowParser (table QueryResult)
|
||||
parseBaseTable =
|
||||
head (getCompose (createA (For :: For FromField) (Compose [field])))
|
||||
|
||||
default
|
||||
tableSchema
|
||||
:: (ADTRecord (table Schema), Constraints (table Schema) WitnessSchema)
|
||||
=> table Schema
|
||||
tableSchema = nullaryOp (For :: For WitnessSchema) schema
|
||||
|
||||
default
|
||||
traverseSchema
|
||||
:: ( GTraverseSchema (Rep (table Schema)) (Rep (table Expr))
|
||||
, Generic (table Schema)
|
||||
, Generic (table Expr)
|
||||
, Applicative f
|
||||
columns
|
||||
:: ( ADTRecord (table SchemaInfo)
|
||||
, Constraints (table SchemaInfo) WitnessSchema
|
||||
)
|
||||
=> (forall a. String -> f (Expr a)) -> table Schema -> f (table Expr)
|
||||
traverseSchema f = fmap to . gtraverseSchema f . from
|
||||
=> table SchemaInfo
|
||||
columns = nullaryOp (For :: For WitnessSchema) schema
|
||||
|
||||
default
|
||||
baseTableExprs
|
||||
:: ( Generic (table Expr)
|
||||
, GTable (Rep (table Expr)) (Rep (table QueryResult))
|
||||
, Functor f
|
||||
, Profunctor p
|
||||
, RowF (table Expr) ~ MkRowF (Rep (table Expr))
|
||||
tabular
|
||||
:: ( Generic (table f)
|
||||
, GTabular Expr (Rep (table Expr)) (RowF (table Expr))
|
||||
, GTabular SchemaInfo (Rep (table SchemaInfo)) (RowF (table Expr))
|
||||
, GTabular Insert (Rep (table Insert)) (RowF (table Expr))
|
||||
)
|
||||
=> p (RowF (table Expr) (Some Expr)) (f (RowF (table Expr) (Some Expr)))
|
||||
-> p (table Expr) (f (table Expr))
|
||||
baseTableExprs = dimap from (fmap to) . gexpressions
|
||||
|
||||
default
|
||||
traverseBaseTableAggregates
|
||||
:: ( GTraverseAggregator (Rep (table Aggregate)) (Rep (table Expr))
|
||||
, Generic (table Expr)
|
||||
, Generic (table Aggregate)
|
||||
)
|
||||
=> O.Aggregator (table Aggregate) (table Expr)
|
||||
traverseBaseTableAggregates = dimap from to gaggregator
|
||||
|
||||
default
|
||||
updateWriter
|
||||
:: ( ADTRecord (table Expr)
|
||||
, ADTRecord (table Schema)
|
||||
, Writer Expr (Rep (table Schema)) (Rep (table Expr))
|
||||
)
|
||||
=> O.Writer (table Expr) a
|
||||
updateWriter =
|
||||
case lmap from (columnWriter (Proxy @Expr) (from (tableSchema @table))) of
|
||||
O.Writer f -> O.Writer f
|
||||
|
||||
default
|
||||
insertWriter :: ( ADTRecord (table Schema)
|
||||
, Writer Insert (Rep (table Schema)) (Rep (table Insert))
|
||||
, Generic (table Insert)
|
||||
)
|
||||
=> O.Writer (table Insert) a
|
||||
insertWriter =
|
||||
case lmap from (columnWriter (Proxy @Insert) (from (tableSchema @table))) of
|
||||
O.Writer f -> O.Writer f
|
||||
=> Interpretation f -> Iso' (table f) (RowF (table Expr) (Colimit f))
|
||||
tabular AsExpr = generic . gtabular AsExpr
|
||||
tabular AsSchemaInfo = generic . gtabular AsSchemaInfo
|
||||
tabular AsInsert = generic . gtabular AsInsert
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
viewTable :: BaseTable table => table Expr
|
||||
class GTabular i repIn repOut where
|
||||
gtabular :: Interpretation i -> Iso' (repIn a) (repOut (Colimit i))
|
||||
|
||||
instance GTabular i repIn repOut => GTabular i (M1 meta c repIn) repOut where
|
||||
gtabular i = _M1 . gtabular i
|
||||
|
||||
instance (GTabular i inl outl, GTabular i inr outr) =>
|
||||
GTabular i (inl :*: inr) (Product outl outr) where
|
||||
gtabular i =
|
||||
iso
|
||||
(\(a :*: b) -> Pair (view (gtabular i) a) (view (gtabular i) b))
|
||||
(\(Pair a b) -> view (from (gtabular i)) a :*: view (from (gtabular i)) b)
|
||||
|
||||
instance GTabular Expr (K1 i (Expr a)) Identity where
|
||||
gtabular _ =
|
||||
_K1 . iso (Identity . Colimit) (\(Identity (Colimit (Expr a))) -> Expr a)
|
||||
|
||||
instance GTabular SchemaInfo (K1 i (SchemaInfo (a :: k))) Identity where
|
||||
gtabular _ =
|
||||
_K1 .
|
||||
iso
|
||||
(\(SchemaInfo a) -> Identity (Colimit (SchemaInfo a)))
|
||||
(\(Identity (Colimit (SchemaInfo a))) -> SchemaInfo a)
|
||||
|
||||
-- This is only proper if OverrideDefault DefaultInsertExpr can't occur.
|
||||
instance GTabular Insert (K1 i (Default (Expr a))) Identity where
|
||||
gtabular _ = _K1 . iso forward backward
|
||||
where
|
||||
forward (OverrideDefault a) = Identity (Colimit (InsertExpr a))
|
||||
forward InsertDefault =
|
||||
Identity (Colimit (InsertExpr (Expr O.DefaultInsertExpr)))
|
||||
backward (Identity (Colimit (InsertExpr (Expr O.DefaultInsertExpr)))) =
|
||||
InsertDefault
|
||||
backward (Identity (Colimit (InsertExpr (Expr prim)))) =
|
||||
OverrideDefault (Expr prim)
|
||||
|
||||
instance GTabular Insert (K1 i (Expr a)) Identity where
|
||||
gtabular _ = _K1 . iso forward backward
|
||||
where
|
||||
forward = Identity . Colimit . InsertExpr
|
||||
backward (Identity (Colimit (InsertExpr (Expr a)))) = Expr a
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
viewTable
|
||||
:: forall table.
|
||||
BaseTable table
|
||||
=> table Expr
|
||||
viewTable =
|
||||
runIdentity
|
||||
(traverseSchema (Identity . Expr . O.BaseTableAttrExpr) tableSchema)
|
||||
view
|
||||
(from expressions)
|
||||
(fmap
|
||||
(\(Colimit (SchemaInfo str)) -> O.BaseTableAttrExpr str)
|
||||
(view (tabular AsSchemaInfo) (columns @table)))
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
@ -491,7 +448,23 @@ tableDefinition
|
||||
tableDefinition =
|
||||
O.Table
|
||||
(untag @table tableName)
|
||||
(O.TableProperties insertWriter (O.View viewTable))
|
||||
(O.TableProperties
|
||||
(O.Writer
|
||||
(O.PackMap
|
||||
(\f a ->
|
||||
let columnName =
|
||||
index
|
||||
(fmap
|
||||
(\(Colimit (SchemaInfo str)) -> str)
|
||||
(view (tabular AsSchemaInfo) (columns @table)))
|
||||
exprs =
|
||||
fmap
|
||||
(fmap (\(Colimit (InsertExpr (Expr x))) -> x) .
|
||||
view (tabular AsInsert))
|
||||
a
|
||||
foo rep = f (fmap (`index` rep) exprs, columnName rep)
|
||||
in traverse_ id (tabulate @(RowF (table Expr)) foo))))
|
||||
(O.View viewTable))
|
||||
|
||||
tableDefinitionUpdate
|
||||
:: forall table.
|
||||
@ -500,76 +473,91 @@ tableDefinitionUpdate
|
||||
tableDefinitionUpdate =
|
||||
O.Table
|
||||
(untag @table tableName)
|
||||
(O.TableProperties updateWriter (O.View viewTable))
|
||||
(O.TableProperties
|
||||
(O.Writer
|
||||
(O.PackMap
|
||||
(\f a ->
|
||||
let columnName =
|
||||
index
|
||||
(fmap
|
||||
(\(Colimit (SchemaInfo str)) -> str)
|
||||
(view (tabular AsSchemaInfo) (columns @table)))
|
||||
exprs = fmap (view expressions) a
|
||||
foo rep = f (fmap (`index` rep) exprs, columnName rep)
|
||||
in traverse_ id (tabulate @(RowF (table Expr)) foo))))
|
||||
(O.View viewTable))
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | 'AggregateTable' is used to demonstrate that a table only contains
|
||||
-- aggregation or @GROUP BY@ expressions. If you wish to use your own records
|
||||
-- for aggregation results, parameterise the record over @f@, use 'Anon' to
|
||||
-- specify the columns, and then generically derive 'AggregateTable':
|
||||
--
|
||||
-- __Example__
|
||||
--
|
||||
-- @
|
||||
-- data UserInfo f = UserInfo
|
||||
-- { userCount :: Anon f Int64
|
||||
-- , latestLogin :: Anon f UTCTime
|
||||
-- } deriving (Generic)
|
||||
-- instance AggregateTable (UserInfo Aggregate) (UserInfo Expr)
|
||||
-- @
|
||||
|
||||
-- specify the columns, and then generically derive 'AggregateTable'
|
||||
class AggregateTable columns result | columns -> result, result -> columns where
|
||||
traverseAggregates :: O.Aggregator columns result
|
||||
aggregations :: Iso' columns (RowF result (Limit Aggregate))
|
||||
|
||||
default
|
||||
traverseAggregates
|
||||
:: ( GTraverseAggregator (Rep columns) (Rep result)
|
||||
, Generic columns
|
||||
, Generic result
|
||||
)
|
||||
=> O.Aggregator columns result
|
||||
traverseAggregates = dimap from to gaggregator
|
||||
aggregations
|
||||
:: (GTraverseAggregator (Rep columns) (Rep result), Generic columns)
|
||||
=> Iso' columns (MkRowF (Rep result) (Limit Aggregate))
|
||||
aggregations = generic . gaggregations
|
||||
|
||||
-- | A single column aggregates to a single expression.
|
||||
instance AggregateTable (Aggregate a) (Expr a) where
|
||||
traverseAggregates =
|
||||
O.Aggregator (O.PackMap (\f (Aggregate a b) -> fmap Expr (f (a, b))))
|
||||
aggregations =
|
||||
iso
|
||||
(\(Aggregate a e) -> Identity (Limit (Aggregate a e)))
|
||||
(runLimit . runIdentity)
|
||||
|
||||
instance (AggregateTable a1 b1, AggregateTable a2 b2) =>
|
||||
AggregateTable (a1, a2) (b1, b2) where
|
||||
traverseAggregates = traverseAggregates ***! traverseAggregates
|
||||
|
||||
-- | Any base table can be aggregated, provided you specify how to aggregate
|
||||
-- each column.
|
||||
instance {-# OVERLAPPABLE #-}
|
||||
(BaseTable table, f ~ Aggregate, g ~ Expr) => AggregateTable (table f) (table g) where
|
||||
traverseAggregates = traverseBaseTableAggregates
|
||||
aggregations =
|
||||
iso
|
||||
(\(a, b) -> Pair (view aggregations a) (view aggregations b))
|
||||
(\(Pair l r) ->
|
||||
(view (from aggregations) l, view (from aggregations) r))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
class GTraverseAggregator aggregator expr | aggregator -> expr where
|
||||
gaggregator
|
||||
:: O.Aggregator (aggregator x) (expr y)
|
||||
gaggregations
|
||||
:: Iso' (aggregator x) (MkRowF expr (Limit Aggregate))
|
||||
|
||||
instance (GTraverseAggregator aggregator expr) =>
|
||||
GTraverseAggregator (M1 i c aggregator) (M1 i c expr) where
|
||||
gaggregator = dimap (\(M1 a) -> a) M1 gaggregator
|
||||
instance (GTraverseAggregator aggregator f) =>
|
||||
GTraverseAggregator (M1 i c aggregator) (M1 i c f) where
|
||||
gaggregations = _M1 . gaggregations
|
||||
|
||||
instance ( GTraverseAggregator fAggregator fExpr
|
||||
, GTraverseAggregator gAggregator gExpr
|
||||
) =>
|
||||
GTraverseAggregator (fAggregator :*: gAggregator) (fExpr :*: gExpr) where
|
||||
gaggregator =
|
||||
dimap (\(a :*: b) -> (a, b)) (uncurry (:*:)) (gaggregator ***! gaggregator)
|
||||
gaggregations =
|
||||
iso
|
||||
(\(a :*: b) -> Pair (view gaggregations a) (view gaggregations b))
|
||||
(\(Pair a b) ->
|
||||
view (from gaggregations) a :*: view (from gaggregations) b)
|
||||
|
||||
instance AggregateTable a b => GTraverseAggregator (K1 i a) (K1 i b) where
|
||||
gaggregator = dimap (\(K1 a) -> a) K1 traverseAggregates
|
||||
gaggregations = _K1 . aggregations
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Evaluate aggregation over a query. The 'AggregateTable' constraint
|
||||
-- requires that all columns in each row must be grouped or aggregated.
|
||||
aggregate
|
||||
:: AggregateTable table result
|
||||
:: (AggregateTable table result, Table result haskell)
|
||||
=> O.Query table -> O.Query result
|
||||
aggregate = O.aggregate traverseAggregates
|
||||
aggregate =
|
||||
O.aggregate $
|
||||
O.Aggregator $
|
||||
O.PackMap $ \f ->
|
||||
fmap (view (from expressions)) .
|
||||
traverse (\(Limit (Aggregate a e)) -> f (a, e)) . view aggregations
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Witness the schema definition for table columns.
|
||||
class WitnessSchema a where
|
||||
schema :: a
|
||||
|
||||
instance KnownSymbol name =>
|
||||
WitnessSchema (SchemaInfo '(name, (def :: k), (t :: j))) where
|
||||
schema = SchemaInfo (symbolVal (Proxy @name))
|
||||
|
@ -1,12 +1,14 @@
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE RoleAnnotations #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Rel8.Internal.Types where
|
||||
|
||||
import GHC.TypeLits (Symbol)
|
||||
import Rel8.Internal.Expr (Expr)
|
||||
import Rel8.Internal.Expr
|
||||
import qualified Opaleye.Internal.HaskellDB.PrimQuery as O
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
@ -18,16 +20,14 @@ data QueryResult column
|
||||
-- Used to indicate that we will be inserting values. If columns are marked as
|
||||
-- having a default value, it will be possible to use 'Default' to let the
|
||||
-- database generate a value.
|
||||
data Insert a
|
||||
data Insert a = InsertExpr (Expr a)
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Used internal to reflect the schema of a table from types into values.
|
||||
data Schema a
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
data SchemaInfo (name :: Symbol) (hasDefault :: HasDefault) t =
|
||||
data SchemaInfo a =
|
||||
SchemaInfo String
|
||||
deriving (Show)
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
@ -42,14 +42,13 @@ data Default a
|
||||
= OverrideDefault a
|
||||
| InsertDefault
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
{-| All metadata about a column in a table.
|
||||
|
||||
'C' is used to specify information about individual columns in base
|
||||
tables.
|
||||
|
||||
=== __Example__
|
||||
=== Example
|
||||
|
||||
@
|
||||
data Employee f =
|
||||
@ -59,17 +58,50 @@ data Default a
|
||||
type family C f columnName hasDefault columnType :: * where
|
||||
C Expr _name _def t = Expr t
|
||||
C QueryResult _name _def t = t
|
||||
C Schema name hasDefault t = SchemaInfo name hasDefault t
|
||||
C SchemaInfo name hasDefault t = SchemaInfo '(name, hasDefault, t)
|
||||
C Insert name 'HasDefault t = Default (Expr t)
|
||||
C Insert name 'NoDefault t = Expr t
|
||||
C Aggregate name _ t = Aggregate t
|
||||
|
||||
|
||||
-- | @Anon@ can be used to define columns like 'C', but does not contain the
|
||||
-- extra metadata needed to define a 'BaseTable' instance. The main use of
|
||||
-- 'Anon' is to define "anonymous" tables that represent the intermediate
|
||||
-- parts of a query.
|
||||
--
|
||||
-- === Example
|
||||
--
|
||||
-- @
|
||||
-- data EmployeeAndManager f = EmployeeAndManager
|
||||
-- { employee :: Anon f Text
|
||||
-- , manager :: Anon f Text
|
||||
-- }
|
||||
--
|
||||
-- employeeAndManager :: Query (EmployeeAndManager Expr)
|
||||
-- employeeAndManager = proc _ -> do
|
||||
-- employee <- queryTable -< ()
|
||||
-- manager <- queryTable -< ()
|
||||
-- where_ -< employeeManager employee ==. managerId manager
|
||||
-- id -< EmployeeAndManager { employee = employeeName employee
|
||||
-- , manager = managerName manager
|
||||
-- }
|
||||
-- @
|
||||
type family Anon f columnType :: * where
|
||||
Anon Expr t = Expr t
|
||||
Anon QueryResult t = t
|
||||
Anon Aggregate t = Aggregate t
|
||||
|
||||
newtype Limit f = Limit
|
||||
{ runLimit :: forall a. f a
|
||||
}
|
||||
|
||||
data Colimit f where
|
||||
Colimit :: f a -> Colimit f
|
||||
|
||||
data Interpretation f where
|
||||
AsExpr :: Interpretation Expr
|
||||
AsSchemaInfo :: Interpretation SchemaInfo
|
||||
AsInsert :: Interpretation Insert
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Indicate whether or not a column has a default value. Used in conjunction
|
||||
-- with 'C'
|
||||
|
@ -1,6 +1,7 @@
|
||||
{ mkDerivation, base, one-liner, opaleye, postgresql-simple
|
||||
, product-profunctors, profunctors, scientific, stdenv, streaming
|
||||
, tagged, text, exceptions, free, streaming-postgresql-simple
|
||||
, lens
|
||||
}:
|
||||
mkDerivation {
|
||||
pname = "rel8";
|
||||
@ -9,7 +10,7 @@ mkDerivation {
|
||||
libraryHaskellDepends = [
|
||||
base one-liner opaleye postgresql-simple product-profunctors
|
||||
profunctors scientific streaming tagged text exceptions free
|
||||
streaming-postgresql-simple
|
||||
streaming-postgresql-simple lens
|
||||
];
|
||||
license = stdenv.lib.licenses.bsd3;
|
||||
}
|
||||
|
@ -1,10 +1,12 @@
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
-- This is the example from the documentation. We don't run any tests,
|
||||
-- just compiling is deemed satisfactory. If this fails to compile,
|
||||
-- make sure to update the documentation with the necessary changes!
|
||||
|
||||
{-# LANGUAGE Arrows, DataKinds, DeriveGeneric, FlexibleInstances,
|
||||
OverloadedStrings #-}
|
||||
OverloadedStrings, MultiParamTypeClasses #-}
|
||||
|
||||
module Main where
|
||||
|
||||
@ -13,6 +15,27 @@ import Control.Arrow
|
||||
import Rel8
|
||||
import Data.Int
|
||||
|
||||
data Small f =
|
||||
Small { smallId :: C f "PID" 'HasDefault Int32
|
||||
, smallName :: C f "PName" 'NoDefault String
|
||||
-- , partColor :: C f "Color" 'NoDefault Int32
|
||||
-- , partWeight :: C f "Weight" 'NoDefault Double
|
||||
-- , partCity :: C f "City" 'NoDefault String
|
||||
} deriving (Generic)
|
||||
|
||||
instance Table (Small Expr) (Small QueryResult)
|
||||
instance BaseTable Small where
|
||||
tableName = "small"
|
||||
-- tabular DomExpr =
|
||||
-- iso
|
||||
-- (\s@(Small a b) -> Pair (Identity (Colimit a)) (Identity (Colimit b)))
|
||||
-- (\(Pair (Identity (Colimit (Expr a))) (Identity (Colimit (Expr b)))) -> Small (Expr a) (Expr b))
|
||||
-- tabular DomSchemaInfo =
|
||||
-- iso
|
||||
-- (\s@(Small a b) -> Pair (Identity (Colimit a)) (Identity (Colimit b)))
|
||||
-- (\(Pair (Identity (Colimit (Expr a))) (Identity (Colimit (Expr b)))) -> Small (Expr a) (Expr b))
|
||||
|
||||
|
||||
data Part f =
|
||||
Part { partId :: C f "PID" 'HasDefault Int32
|
||||
, partName :: C f "PName" 'NoDefault String
|
||||
@ -21,8 +44,10 @@ data Part f =
|
||||
, partCity :: C f "City" 'NoDefault String
|
||||
} deriving (Generic)
|
||||
|
||||
instance Table (Part Expr) (Part QueryResult)
|
||||
instance BaseTable Part where tableName = "part"
|
||||
deriving instance Show (Part QueryResult)
|
||||
deriving instance Show (Part SchemaInfo)
|
||||
|
||||
allParts :: Query (Part Expr)
|
||||
allParts = queryTable
|
||||
@ -54,6 +79,7 @@ data Supplier f = Supplier
|
||||
, supplierCity :: C f "City" 'NoDefault String
|
||||
} deriving (Generic)
|
||||
|
||||
instance Table (Supplier Expr) (Supplier QueryResult)
|
||||
instance BaseTable Supplier where tableName = "supplier"
|
||||
deriving instance Show (Supplier QueryResult)
|
||||
|
||||
|
@ -24,7 +24,6 @@ library
|
||||
other-modules: Rel8.Internal.Aggregate
|
||||
Rel8.Internal.DBType
|
||||
Rel8.Internal.Expr
|
||||
Rel8.Internal.Generic
|
||||
Rel8.Internal.Operators
|
||||
Rel8.Internal.Order
|
||||
Rel8.Internal.Table
|
||||
@ -53,9 +52,11 @@ library
|
||||
, transformers
|
||||
, uuid
|
||||
, vector
|
||||
, lens
|
||||
, adjunctions
|
||||
-- hs-source-dirs:
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
ghc-options: -Wall -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns
|
||||
|
||||
|
||||
test-suite example
|
||||
|
Loading…
Reference in New Issue
Block a user