mirror of
https://github.com/circuithub/rel8.git
synced 2024-10-27 02:08:37 +03:00
Genesis
This commit is contained in:
commit
6367bf81a3
5
ChangeLog.md
Normal file
5
ChangeLog.md
Normal file
@ -0,0 +1,5 @@
|
||||
# Revision history for rel8
|
||||
|
||||
## 0.1.0.0 -- YYYY-mm-dd
|
||||
|
||||
* First version. Released on an unsuspecting world.
|
30
LICENSE
Normal file
30
LICENSE
Normal file
@ -0,0 +1,30 @@
|
||||
Copyright (c) 2017, Ollie Charles
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Ollie Charles nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
114
OpaleyeStub.hs
Normal file
114
OpaleyeStub.hs
Normal file
@ -0,0 +1,114 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
module OpaleyeStub where
|
||||
|
||||
import Control.Arrow
|
||||
import Control.Category
|
||||
import Data.Profunctor
|
||||
import Data.Profunctor.Product
|
||||
|
||||
-- import qualified Opaleye.Internal.Column as O
|
||||
-- import qualified Opaleye.Internal.HaskellDB.PrimQuery as O
|
||||
-- import qualified Opaleye.Internal.Join as O
|
||||
-- import qualified Opaleye.Internal.PGTypes as O
|
||||
-- import qualified Opaleye.Internal.PackMap as O
|
||||
-- import qualified Opaleye.Internal.QueryArr as O
|
||||
-- import qualified Opaleye.Internal.RunQuery as O
|
||||
-- import qualified Opaleye.Internal.Table as O
|
||||
-- import qualified Opaleye.Internal.TableMaker as O
|
||||
-- import qualified Opaleye.Internal.Unpackspec as O
|
||||
-- import qualified Opaleye.Join as O
|
||||
-- import qualified Opaleye.RunQuery as O
|
||||
-- import qualified Opaleye.Table as O
|
||||
|
||||
data PackMap a b s t =
|
||||
PackMap (forall f. Applicative f =>
|
||||
(a -> f b) -> s -> f t)
|
||||
|
||||
newtype Unpackspec columns columns' =
|
||||
Unpackspec (PackMap PrimExpr PrimExpr columns columns')
|
||||
|
||||
instance Functor (Unpackspec columns)
|
||||
instance Profunctor Unpackspec
|
||||
instance ProductProfunctor Unpackspec
|
||||
|
||||
data Literal
|
||||
= BoolLit Bool
|
||||
| IntegerLit Integer
|
||||
| NullLit
|
||||
|
||||
data PrimExpr
|
||||
= ConstExpr Literal
|
||||
| BaseTableAttrExpr String
|
||||
|
||||
newtype Column pgType = Column PrimExpr
|
||||
|
||||
newtype NullMaker a b = NullMaker (a -> b)
|
||||
|
||||
data QueryArr a b
|
||||
|
||||
instance Functor (QueryArr a)
|
||||
instance Applicative (QueryArr a)
|
||||
instance Arrow QueryArr
|
||||
instance Category QueryArr
|
||||
|
||||
type Query = QueryArr ()
|
||||
|
||||
data QueryRunner columns haskells =
|
||||
QueryRunner (Unpackspec columns ())
|
||||
(columns -> RowParser haskells)
|
||||
(columns -> Bool)
|
||||
|
||||
data RowParser a
|
||||
|
||||
instance Functor RowParser
|
||||
instance Applicative RowParser
|
||||
instance Monad RowParser
|
||||
|
||||
data TableProperties writerColumns viewColumns = TableProperties
|
||||
{ tablePropertiesWriter :: Writer writerColumns viewColumns
|
||||
, tablePropertiesView :: View viewColumns }
|
||||
|
||||
data View columns = View columns
|
||||
|
||||
newtype Writer columns dummy =
|
||||
Writer (forall f. Functor f =>
|
||||
PackMap (f PrimExpr, String) () (f columns) ())
|
||||
|
||||
data Table writerColumns viewColumns
|
||||
= Table String (TableProperties writerColumns viewColumns)
|
||||
| TableWithSchema String String (TableProperties writerColumns viewColumns)
|
||||
|
||||
|
||||
queryTableExplicit :: ColumnMaker tablecolumns columns
|
||||
-> Table a tablecolumns
|
||||
-> Query columns
|
||||
queryTableExplicit = undefined
|
||||
|
||||
newtype ColumnMaker columns columns' =
|
||||
ColumnMaker (PackMap PrimExpr PrimExpr columns columns')
|
||||
|
||||
runQueryExplicit :: QueryRunner columns haskells
|
||||
-> Connection
|
||||
-> Query columns
|
||||
-> IO [haskells]
|
||||
runQueryExplicit = undefined
|
||||
|
||||
data Connection
|
||||
|
||||
leftJoinExplicit :: Unpackspec columnsL columnsL
|
||||
-> Unpackspec columnsR columnsR
|
||||
-> NullMaker columnsR nullableColumnsR
|
||||
-> Query columnsL -> Query columnsR
|
||||
-> ((columnsL, columnsR) -> Column PGBool)
|
||||
-> Query (columnsL, nullableColumnsR)
|
||||
leftJoinExplicit = undefined
|
||||
|
||||
data PGBool
|
||||
|
||||
class FromField a
|
||||
instance FromField Bool
|
||||
instance FromField Int
|
||||
instance FromField a => FromField (Maybe a)
|
||||
|
||||
field :: FromField a => RowParser a
|
||||
field = undefined
|
408
Rel8.hs
Normal file
408
Rel8.hs
Normal file
@ -0,0 +1,408 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DefaultSignatures #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Rel8
|
||||
( -- $intro
|
||||
|
||||
-- * Defining Tables
|
||||
Column(..)
|
||||
, HasDefault(..)
|
||||
, Nullable(..)
|
||||
, PGType(..)
|
||||
, C
|
||||
, BaseTable(..)
|
||||
|
||||
-- * Tables
|
||||
, Table(..)
|
||||
, leftJoin
|
||||
, MaybeRow(..)
|
||||
, Col
|
||||
|
||||
-- * Expressions
|
||||
, Expr
|
||||
|
||||
-- * Literals
|
||||
, Lit(..)
|
||||
|
||||
-- ** Operators
|
||||
, (^/=^)
|
||||
|
||||
-- ** Null
|
||||
, toNullable
|
||||
, (?)
|
||||
|
||||
-- * Querying Tables
|
||||
, select
|
||||
, QueryResult
|
||||
|
||||
-- * Re-exported symbols
|
||||
, Connection, Stream, Of, Generic
|
||||
|
||||
-- * Lower level details
|
||||
, AsHaskell
|
||||
) where
|
||||
|
||||
import Data.Tagged (Tagged(..))
|
||||
import Control.Applicative ((<$), liftA2)
|
||||
import Control.Monad (void)
|
||||
import Control.Monad.IO.Class (MonadIO(liftIO))
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Profunctor (dimap)
|
||||
import Data.Profunctor.Product ((***!))
|
||||
import Data.Proxy (Proxy(..))
|
||||
-- import Database.PostgreSQL.Simple (Connection)
|
||||
-- import Database.PostgreSQL.Simple.FromField (FromField)
|
||||
-- import Database.PostgreSQL.Simple.FromRow (RowParser, field)
|
||||
import GHC.Generics
|
||||
(Generic, Rep, K1(..), M1(..), (:*:)(..), from, to)
|
||||
import GHC.TypeLits (Symbol, symbolVal, KnownSymbol)
|
||||
import Generics.OneLiner
|
||||
(ADTRecord, Constraints, For(..), createA, gtraverse, op0)
|
||||
import Streaming (Of, Stream)
|
||||
import Streaming.Prelude (each)
|
||||
|
||||
|
||||
import qualified OpaleyeStub as O
|
||||
import OpaleyeStub (Connection, RowParser, field, FromField)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Indicate whether or not a column has a default value.
|
||||
data HasDefault
|
||||
= HasDefault
|
||||
| NoDefault
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Indicate whether or not a column can take default values.
|
||||
data Nullable
|
||||
= Nullable
|
||||
| NotNullable
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
{-| All metadata about a column in a table.
|
||||
|
||||
'Column' is used to specify information about individual columns in base
|
||||
tables. While it is defined as a record, you construct 'Column's at the
|
||||
type level where record syntax is unfortunately not available.
|
||||
|
||||
=== __Example__
|
||||
|
||||
@
|
||||
data Employee f =
|
||||
Employee { employeeName :: C f ('Column "employee_name" 'NoDefault 'NotNullable 'PGText) }
|
||||
@
|
||||
-}
|
||||
data Column schema = Column
|
||||
{ _columnName :: Symbol
|
||||
, _columnHasDefault :: HasDefault
|
||||
, _columnNullable :: Nullable
|
||||
, _columnType :: schema
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Database-side PostgreSQL expressions of a given type.
|
||||
newtype Expr schema = Expr O.PrimExpr
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Map a schema definition into a set of expressions that would select those
|
||||
-- columns.
|
||||
class InferBaseTableAttrExpr schema expr where
|
||||
baseTableAttrExpr :: schema a -> expr a
|
||||
|
||||
instance (InferBaseTableAttrExpr schema expr) =>
|
||||
InferBaseTableAttrExpr (M1 i c schema) (M1 i c expr) where
|
||||
baseTableAttrExpr (M1 s) = M1 (baseTableAttrExpr s)
|
||||
|
||||
instance ( InferBaseTableAttrExpr fSchema fExpr
|
||||
, InferBaseTableAttrExpr gSchema gExpr
|
||||
) =>
|
||||
InferBaseTableAttrExpr (fSchema :*: gSchema) (fExpr :*: gExpr) where
|
||||
baseTableAttrExpr (l :*: r) = baseTableAttrExpr l :*: baseTableAttrExpr r
|
||||
|
||||
instance InferBaseTableAttrExpr (K1 i (Tagged name String)) (K1 i (Expr a)) where
|
||||
baseTableAttrExpr (K1 (Tagged name)) = K1 (Expr (O.BaseTableAttrExpr name))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Witness the schema definition for table columns.
|
||||
class WitnessSchema a where
|
||||
schema :: a
|
||||
|
||||
instance KnownSymbol name =>
|
||||
WitnessSchema (Tagged name String) where
|
||||
schema = Tagged (symbolVal (Proxy :: Proxy name))
|
||||
|
||||
data Schema a
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
class ToPrimExpr a where
|
||||
toPrimExpr :: a -> O.PrimExpr
|
||||
|
||||
instance ToPrimExpr (Expr column) where
|
||||
toPrimExpr (Expr a) = a
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- TODO Unsure if we want to assume this type of table
|
||||
|
||||
class BaseTable (table :: (Column a -> *) -> *) where
|
||||
tableName :: proxy table -> String
|
||||
queryTable :: O.Query (table Expr)
|
||||
default queryTable :: ( ADTRecord (table Expr)
|
||||
, ADTRecord (table Schema)
|
||||
, Constraints (table Expr) ToPrimExpr
|
||||
, Constraints (table Schema) WitnessSchema
|
||||
, InferBaseTableAttrExpr (Rep (table Schema)) (Rep (table Expr))) =>
|
||||
O.Query (table Expr)
|
||||
queryTable =
|
||||
O.queryTableExplicit
|
||||
(O.ColumnMaker
|
||||
(O.PackMap
|
||||
(\f ->
|
||||
gtraverse (For :: For ToPrimExpr) (\s -> s <$ f (toPrimExpr s)))))
|
||||
(O.Table
|
||||
(tableName (Proxy :: Proxy table))
|
||||
(O.TableProperties
|
||||
(O.Writer (O.PackMap (\_ _ -> pure ())))
|
||||
(O.View
|
||||
(to
|
||||
(baseTableAttrExpr
|
||||
(from
|
||||
(
|
||||
(op0 (For :: For WitnessSchema) schema :: table Schema))))))))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
class Table expr haskell | expr -> haskell, haskell -> expr where
|
||||
rowParser :: expr -> RowParser haskell
|
||||
default rowParser :: ( ADTRecord haskell
|
||||
, Constraints haskell FromField
|
||||
, Generic haskell) =>
|
||||
expr -> RowParser haskell
|
||||
rowParser _ = head (createA (For :: For FromField) [field])
|
||||
|
||||
unpackColumns :: O.Unpackspec expr expr
|
||||
default unpackColumns :: ( Generic expr
|
||||
, Constraints expr ToPrimExpr
|
||||
, ADTRecord expr) =>
|
||||
O.Unpackspec expr expr
|
||||
unpackColumns =
|
||||
O.Unpackspec
|
||||
(O.PackMap
|
||||
(\f ->
|
||||
gtraverse (For :: For ToPrimExpr) (\s -> s <$ f (toPrimExpr s))))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
type family C (f :: Column a -> *) (c :: Column a) :: * where
|
||||
C Expr ('Column _name _def 'Nullable t) = Expr ('Null t)
|
||||
C Expr ('Column _name _def 'NotNullable t) = Expr t
|
||||
|
||||
C QueryResult ('Column _name _def 'Nullable t) = AsHaskell ('Null t)
|
||||
C QueryResult ('Column _name _def 'NotNullable t) = AsHaskell t
|
||||
|
||||
C Schema ('Column name _def _null _t) = Tagged name String
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- TODO We really want this to be open, but that breaks the instance of
|
||||
-- res ~ AsHaskell a => Table (Expr a) (Col res)
|
||||
|
||||
-- This is because knowing `Col res` *must* let you know `Expr a`, but if
|
||||
-- `AsHaskell` were open (and hence not necessarily injective), we can't work out
|
||||
-- what `a` would be. Bummer.
|
||||
type family AsHaskell (t :: k) :: *
|
||||
type instance AsHaskell 'PGInteger = Int
|
||||
type instance AsHaskell 'PGBoolean = Bool
|
||||
type instance AsHaskell ('Null a) = Maybe (AsHaskell a)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
data PGType
|
||||
= PGInteger
|
||||
| PGBoolean
|
||||
| PGText
|
||||
| PGReal
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
data QueryResult column
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
select
|
||||
:: (MonadIO m, Table rows results)
|
||||
=> Connection -> O.Query rows -> Stream (Of results) m ()
|
||||
select connection query = do
|
||||
results <-
|
||||
liftIO $
|
||||
O.runQueryExplicit
|
||||
(O.QueryRunner
|
||||
(void unpackColumns)
|
||||
rowParser
|
||||
(\_columns -> True) -- TODO Will we support 0-column queries?
|
||||
)
|
||||
connection
|
||||
query
|
||||
each results
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
instance (Table lExpr lHaskell, Table rExpr rHaskell) =>
|
||||
Table (lExpr, rExpr) (lHaskell, rHaskell) where
|
||||
unpackColumns =
|
||||
(unpackColumns :: O.Unpackspec lExpr lExpr) ***!
|
||||
(unpackColumns :: O.Unpackspec rExpr rExpr)
|
||||
|
||||
rowParser (l, r) = liftA2 (,) (rowParser l) (rowParser r)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
data MaybeRow row = MaybeRow (Expr 'PGBoolean) row
|
||||
|
||||
instance (Table expr haskell) =>
|
||||
Table (MaybeRow expr) (Maybe haskell) where
|
||||
unpackColumns =
|
||||
dimap
|
||||
(\(MaybeRow tag row) -> (tag, row))
|
||||
(\(prim, expr) -> MaybeRow (Expr prim) expr)
|
||||
(O.Unpackspec (O.PackMap (\f (Expr tag) -> f tag)) ***! unpackColumns)
|
||||
|
||||
rowParser (MaybeRow _ r) = do
|
||||
isNull <- field
|
||||
if fromMaybe True isNull
|
||||
then return Nothing
|
||||
else fmap Just (rowParser r)
|
||||
|
||||
data Null a = Null a
|
||||
|
||||
(?) :: MaybeRow a -> (a -> Expr b) -> Expr ('Null b)
|
||||
MaybeRow _ row ? f = case f row of Expr a -> Expr a
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
leftJoin
|
||||
:: (Table lExpr lHaskell, Table rExpr rHaskell)
|
||||
=> (lExpr -> rExpr -> Expr 'PGBoolean)
|
||||
-> O.Query lExpr
|
||||
-> O.Query rExpr
|
||||
-> O.Query (lExpr,MaybeRow rExpr)
|
||||
leftJoin condition l r =
|
||||
O.leftJoinExplicit
|
||||
unpackColumns
|
||||
(unpackColumns ***! unpackColumns)
|
||||
(O.NullMaker (\(tag, t) -> MaybeRow tag t))
|
||||
l
|
||||
(liftA2 (,) (pure (lit False)) r)
|
||||
(\(a, (_, b)) ->
|
||||
case condition a b of
|
||||
Expr e -> O.Column e)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
class haskell ~ AsHaskell expr =>
|
||||
Lit haskell expr | haskell -> expr, expr -> haskell where
|
||||
lit :: haskell -> Expr expr
|
||||
|
||||
instance Lit Bool 'PGBoolean where
|
||||
lit = Expr . O.ConstExpr . O.BoolLit
|
||||
|
||||
instance Lit Int 'PGInteger where
|
||||
lit = Expr . O.ConstExpr . O.IntegerLit . fromIntegral
|
||||
|
||||
instance (AsHaskell a ~ b, Lit b a) =>
|
||||
Lit (Maybe b) ('Null a) where
|
||||
lit Nothing = Expr (O.ConstExpr O.NullLit)
|
||||
lit (Just a) =
|
||||
case lit a of
|
||||
Expr e -> Expr e
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
newtype Col a = Col a
|
||||
|
||||
instance (FromField haskell, Lit haskell a) =>
|
||||
Table (Expr a) (Col haskell) where
|
||||
unpackColumns =
|
||||
O.Unpackspec (O.PackMap (\f (Expr prim) -> fmap Expr (f prim)))
|
||||
rowParser _ = fmap Col field
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
(^/=^) :: Expr a -> Expr a -> Expr 'PGBoolean
|
||||
a ^/=^ b = undefined
|
||||
|
||||
toNullable :: Expr a -> Expr ('Null a)
|
||||
toNullable (Expr a) = Expr a
|
||||
|
||||
{- $intro
|
||||
|
||||
Welcome to @rel8@!
|
||||
|
||||
@rel8@ is a library that builds open the fantastic @opaleye@ to query
|
||||
databases. The main objectives of @rel8@ are:
|
||||
|
||||
* /Conciseness/: Users using @rel8@ should not need to write boiler-plate
|
||||
code. By using expressive types, we can provide sufficient information
|
||||
for the compiler to infer code whenever possible.
|
||||
|
||||
* /Inferrable/: Despite using a lot of type level magic, it should never
|
||||
be a requirement that the user must provide a type signature to allow a
|
||||
program to compile.
|
||||
|
||||
With that said, let's dive in and see an example of a program using @rel8@.
|
||||
|
||||
=== Required language extensions and imports
|
||||
|
||||
@
|
||||
{ -# LANGUAGE
|
||||
Arrows, DataKinds, DeriveGeneric, FlexibleInstances,
|
||||
MultiParamTypeClasses #- }
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Arrow
|
||||
import Rel8
|
||||
@
|
||||
|
||||
To use @rel8@, you will need a few language extensions:
|
||||
|
||||
* @Arrows@ is necessary to use @proc@ notation. As with @opaleye@, @rel8@
|
||||
uses arrows to guarantee queries are valid.
|
||||
|
||||
* @DataKinds@ is used to promote values to the type level when defining
|
||||
table/column metadata.
|
||||
|
||||
* @DeriveGeneric@ is used to automatically derive functions from schema
|
||||
information.
|
||||
|
||||
The others are used to provide the type system extensions needed by @rel8@.
|
||||
|
||||
=== Defining base tables
|
||||
|
||||
In order to query a database of existing tables, we need to let @rel8@ know
|
||||
about these tables, and the schema for each table. This is done by defining
|
||||
a Haskell /record/ for each table in the database. These records should be
|
||||
parameterised by a type variable @f@, and each column is a field in this
|
||||
record, of type @C f ('Column ...)@. Let's see how that looks with some
|
||||
example tables:
|
||||
|
||||
@
|
||||
data Part f =
|
||||
Part { partId :: 'C' f (''Column' \"PID\" ''HasDefault' ''NotNullable' ''PGInteger')
|
||||
, partName :: 'C' f (''Column' \"PName\" ''NoDefault' ''NotNullable' ''PGText')
|
||||
, partColor :: 'C' f (''Column' \"Color\" ''NoDefault' ''NotNullable' ''PGInteger')
|
||||
, partWeight :: 'C' f (''Column' \"Weight\" ''NoDefault' ''NotNullable' ''PGReal')
|
||||
, partCity :: 'C' f (''Column' \"City\" ''NoDefault' ''NotNullable' ''PGText')
|
||||
} deriving (Generic)
|
||||
|
||||
instance 'BaseTable' Part where tableName = "Part"
|
||||
@
|
||||
|
||||
The @Part@ table has 5 columns, each defined with the @C f ('Column ...)@
|
||||
pattern. For each column, we are specifying:
|
||||
|
||||
1. The column name
|
||||
2. Whether or not this column has a default value when inserting new rows.
|
||||
In this case @partId@ does, as this is an auto-incremented primary key
|
||||
managed by the database.
|
||||
3. Whether or not the column can take @null@ values.
|
||||
4. The type of the column.
|
||||
|
||||
=== Querying tables
|
||||
|
||||
With tables defined, we are now ready to write some queries. All base
|
||||
|
||||
-}
|
42
oneliner-test.hs
Normal file
42
oneliner-test.hs
Normal file
@ -0,0 +1,42 @@
|
||||
{-# LANGUAGE
|
||||
Arrows, DataKinds, DeriveGeneric, FlexibleInstances,
|
||||
MultiParamTypeClasses #-}
|
||||
|
||||
import Control.Arrow
|
||||
import Control.Applicative
|
||||
import Rel8
|
||||
import OpaleyeStub (Connection)
|
||||
|
||||
data TestTable f = TestTable
|
||||
{ testColumnA :: C f ('Column "a" 'NoDefault 'NotNullable 'PGInteger)
|
||||
, testColumnB :: C f ('Column "b" 'HasDefault 'Nullable 'PGInteger)
|
||||
} deriving (Generic)
|
||||
|
||||
instance BaseTable TestTable where
|
||||
tableName _ = "test_table"
|
||||
|
||||
instance Table (TestTable Expr) (TestTable QueryResult)
|
||||
|
||||
testQuery :: Stream (Of (TestTable QueryResult, TestTable QueryResult)) IO ()
|
||||
testQuery = select testConn $
|
||||
proc _ -> do
|
||||
(l,r) <- liftA2 (,) queryTable queryTable -< ()
|
||||
returnA -< (l,r)
|
||||
|
||||
test1Col :: Stream (Of (Col Int)) IO ()
|
||||
test1Col = select testConn $
|
||||
proc _ -> do
|
||||
t <- queryTable -< ()
|
||||
returnA -< testColumnA t
|
||||
|
||||
testLeftJoin :: Stream (Of (TestTable QueryResult, Col (Maybe Int))) IO ()
|
||||
testLeftJoin =
|
||||
select testConn $
|
||||
fmap (\(l,r) -> (l, r ? testColumnA)) $
|
||||
leftJoin
|
||||
(\l r -> toNullable (testColumnA l) ^/=^ testColumnB r)
|
||||
queryTable
|
||||
queryTable
|
||||
|
||||
testConn :: Connection
|
||||
testConn = undefined
|
25
rel8.cabal
Normal file
25
rel8.cabal
Normal file
@ -0,0 +1,25 @@
|
||||
-- Initial rel8.cabal generated by cabal init. For further documentation,
|
||||
-- see http://haskell.org/cabal/users-guide/
|
||||
|
||||
name: rel8
|
||||
version: 0.1.0.0
|
||||
-- synopsis:
|
||||
-- description:
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Ollie Charles
|
||||
maintainer: ollie@ocharles.org.uk
|
||||
-- copyright:
|
||||
category: Database
|
||||
build-type: Simple
|
||||
extra-source-files: ChangeLog.md
|
||||
cabal-version: >=1.10
|
||||
|
||||
library
|
||||
exposed-modules: Rel8, OpaleyeStub
|
||||
-- other-modules:
|
||||
other-extensions: Arrows, ConstraintKinds, DataKinds, DefaultSignatures, DeriveGeneric, FlexibleContexts, FlexibleInstances, FunctionalDependencies, KindSignatures, PolyKinds, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances, RankNTypes
|
||||
build-depends: base >=4.10 && <4.11, tagged >=0.8 && <0.9, profunctors >=5.2 && <5.3, product-profunctors >=0.7 && <0.8, one-liner >=0.6 && <0.7, streaming >=0.1 && <0.2
|
||||
-- hs-source-dirs:
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
Loading…
Reference in New Issue
Block a user