circuithub/rel8
1
1
Fork 0
mirror of https://github.com/circuithub/rel8.git synced 2024-10-27 10:23:19 +03:00
Code Issues Projects Releases Wiki Activity

Smaller core

Browse Source
This commit is contained in:
Ollie Charles 2017-03-14 12:24:00 +00:00
parent 554e0c12e6
commit ffa98e9196
9 changed files with 383 additions and 400 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
Rel8.hs
View File

@ -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
View File

@ -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))
--------------------------------------------------------------------------------

1
Rel8/Internal.hs
View File

@ -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

101
Rel8/Internal/Generic.hs
View File

@ -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)

514
Rel8/Internal/Table.hs
View File

@ -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))

54
Rel8/Internal/Types.hs
View File

@ -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'

3
default.nix
View File

@ -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;
}

28
doc/Example.hs
View File

@ -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)

5
rel8.cabal
View File

@ -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