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

Use Write as context for both Inserts and Updates (replaces Create and Insert context)

Browse Source
This commit is contained in:
Shane O'Brien 2021-06-16 23:13:43 +01:00
parent 0b071aeca7
commit 09a9c587da
No known key found for this signature in database
GPG Key ID: 35A00ED1B695C1A1
29 changed files with 522 additions and 431 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
rel8.cabal
View File

@ -121,7 +121,6 @@ library
Rel8.Schema.HTable.Product
Rel8.Schema.HTable.These
Rel8.Schema.HTable.Vectorize
Rel8.Schema.Insert
Rel8.Schema.Kind
Rel8.Schema.Name
Rel8.Schema.Null
@ -131,6 +130,7 @@ library
Rel8.Schema.Spec.ConstrainDBType
Rel8.Schema.Spec.ConstrainType
Rel8.Schema.Table
Rel8.Schema.Write
Rel8.Statement.Delete
Rel8.Statement.Insert
@ -147,7 +147,6 @@ library
Rel8.Table.Either
Rel8.Table.Eq
Rel8.Table.HKD
Rel8.Table.Insert
Rel8.Table.List
Rel8.Table.Maybe
Rel8.Table.Name
@ -162,6 +161,7 @@ library
Rel8.Table.These
Rel8.Table.Undefined
Rel8.Table.Unreify
Rel8.Table.Write
Rel8.Type
Rel8.Type.Array

37
src/Rel8.hs
View File

@ -59,7 +59,7 @@ module Rel8
, catMaybeTable
, bindMaybeTable
, traverseMaybeTable
, insertMaybeTable
, writeMaybeTable
, nameMaybeTable
-- ** @EitherTable@
@ -70,7 +70,7 @@ module Rel8
, keepRightTable
, bindEitherTable
, bitraverseEitherTable
, insertEitherTable
, writeEitherTable
, nameEitherTable
-- ** @TheseTable@
@ -87,13 +87,13 @@ module Rel8
, keepThoseTable, loseThoseTable
, bindTheseTable
, bitraverseTheseTable
, insertTheseTable
, writeTheseTable
, nameTheseTable
-- ** @ListTable@
, ListTable
, listTable
, insertListTable
, writeListTable
, nameListTable
, many
, manyExpr
@ -103,7 +103,7 @@ module Rel8
-- ** @NonEmptyTable@
, NonEmptyTable
, nonEmptyTable
, insertNonEmptyTable
, writeNonEmptyTable
, nameNonEmptyTable
, some
, someExpr
@ -115,7 +115,7 @@ module Rel8
, BuildADT, buildADT
, ConstructADT, constructADT
, DeconstructADT, deconstructADT
, InsertADT, insertADT
, WriteADT, writeADT
, NameADT, nameADT
, AggregateADT, aggregateADT
@ -124,7 +124,7 @@ module Rel8
, BuildHKD, buildHKD
, ConstructHKD, constructHKD
, DeconstructHKD, deconstructHKD
, InsertHKD, insertHKD
, WriteHKD, writeHKD
, NameHKD, nameHKD
, AggregateHKD, aggregateHKD
@ -252,11 +252,6 @@ module Rel8
, OnConflict(..)
, insert
, Create( Default, Value )
, unValue
, toInsert
, toInsertDefaults
-- ** @DELETE@
, Delete(..)
, delete
@ -271,10 +266,23 @@ module Rel8
-- ** @CREATE VIEW@
, createView
-- ** Write
, Writable( Default, Value )
, Write
, Writes
, defaultValue
, override
, write
, reset
, fromWrite
, unwrite
-- * TODO
-- TODO
-- These need organizing, but are reachable from Rel8's documentation so we
-- do need to export and document them.
, Recontextualize
, Nullable
, NotNull
, HTable
@ -330,11 +338,11 @@ import Rel8.Query.These
import Rel8.Query.Values
import Rel8.Schema.Context.Label
import Rel8.Schema.HTable
import Rel8.Schema.Insert
import Rel8.Schema.Name
import Rel8.Schema.Null hiding ( nullable )
import Rel8.Schema.Result ( Result )
import Rel8.Schema.Table
import Rel8.Schema.Write
import Rel8.Statement.Delete
import Rel8.Statement.Insert
import Rel8.Statement.Returning
@ -349,16 +357,17 @@ import Rel8.Table.Bool
import Rel8.Table.Either
import Rel8.Table.Eq
import Rel8.Table.HKD
import Rel8.Table.Insert
import Rel8.Table.List
import Rel8.Table.Maybe
import Rel8.Table.Name
import Rel8.Table.NonEmpty
import Rel8.Table.Ord
import Rel8.Table.Order
import Rel8.Table.Recontextualize
import Rel8.Table.Rel8able ()
import Rel8.Table.Serialize
import Rel8.Table.These
import Rel8.Table.Write
import Rel8.Type
import Rel8.Type.Composite
import Rel8.Type.Eq

4
src/Rel8/Column/ADT.hs
View File

@ -71,9 +71,9 @@ sfromColumnsADT :: ADTable t
sfromColumnsADT = \case
SAggregate -> AHADT . ADT . hunreify
SExpr -> AHADT . ADT . hunreify
SInsert -> AHADT . ADT . hunreify
SName -> AHADT . ADT . hunreify
SResult -> AHADT . fromADT . ADT . hunreify
SWrite -> AHADT . ADT . hunreify
SReify context -> AHADT . sfromColumnsADT context . hunreify
@ -84,7 +84,7 @@ stoColumnsADT :: ADTable t
stoColumnsADT = \case
SAggregate -> hreify . (\(AHADT (ADT a)) -> a)
SExpr -> hreify . (\(AHADT (ADT a)) -> a)
SInsert -> hreify . (\(AHADT (ADT a)) -> a)
SName -> hreify . (\(AHADT (ADT a)) -> a)
SResult -> hreify . (\(ADT a) -> a) . toADT . (\(AHADT a) -> a)
SWrite -> hreify . (\(AHADT (ADT a)) -> a)
SReify context -> hreify . stoColumnsADT context . (\(AHADT a) -> a)

32
src/Rel8/Column/Either.hs
View File

@ -23,11 +23,11 @@ import Rel8.Expr ( Expr )
import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
import Rel8.Schema.Context ( Col )
import Rel8.Schema.HTable.Either ( HEitherTable )
import Rel8.Schema.Insert ( Insert )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.Name ( Name(..) )
import Rel8.Schema.Reify ( Reify, hreify, hunreify )
import Rel8.Schema.Result ( Result )
import Rel8.Schema.Write ( Write )
import Rel8.Table
( Table, Columns, Context, fromColumns, toColumns
, Unreify, reify, unreify
@ -41,7 +41,7 @@ type family HEither context where
HEither (Reify context) = AHEither context
HEither Aggregate = EitherTable
HEither Expr = EitherTable
HEither Insert = EitherTable
HEither Write = EitherTable
HEither Name = EitherTable
HEither Result = Either
@ -92,9 +92,9 @@ sbimapEither :: ()
sbimapEither = \case
SAggregate -> \f g (AHEither a) -> AHEither (bimap f g a)
SExpr -> \f g (AHEither a) -> AHEither (bimap f g a)
SResult -> \f g (AHEither a) -> AHEither (bimap f g a)
SInsert -> \f g (AHEither a) -> AHEither (bimap f g a)
SName -> \f g (AHEither a) -> AHEither (bimap f g a)
SResult -> \f g (AHEither a) -> AHEither (bimap f g a)
SWrite -> \f g (AHEither a) -> AHEither (bimap f g a)
SReify context -> \f g (AHEither a) -> AHEither (sbimapEither context f g a)
@ -113,17 +113,17 @@ sfromColumnsEither = \case
bimap (fromColumns . hreify) (fromColumns . hreify) .
fromColumns .
hunreify
SName ->
AHEither .
bimap (fromColumns . hreify) (fromColumns . hreify) .
fromColumns .
hunreify
SResult ->
AHEither .
bimap (fromColumns . hreify) (fromColumns . hreify) .
fromColumns .
hunreify
SInsert ->
AHEither .
bimap (fromColumns . hreify) (fromColumns . hreify) .
fromColumns .
hunreify
SName ->
SWrite ->
AHEither .
bimap (fromColumns . hreify) (fromColumns . hreify) .
fromColumns .
@ -150,17 +150,17 @@ stoColumnsEither = \case
toColumns .
bimap (hunreify . toColumns) (hunreify . toColumns) .
(\(AHEither a) -> a)
SName ->
hreify .
toColumns .
bimap (hunreify . toColumns) (hunreify . toColumns) .
(\(AHEither a) -> a)
SResult ->
hreify .
toColumns .
bimap (hunreify . toColumns) (hunreify . toColumns) .
(\(AHEither a) -> a)
SInsert ->
hreify .
toColumns .
bimap (hunreify . toColumns) (hunreify . toColumns) .
(\(AHEither a) -> a)
SName ->
SWrite ->
hreify .
toColumns .
bimap (hunreify . toColumns) (hunreify . toColumns) .

8
src/Rel8/Column/Field.hs
View File

@ -20,13 +20,13 @@ import Rel8.Expr ( Expr, Col( E ) )
import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
import Rel8.Kind.Defaulting ( Defaulting, KnownDefaulting )
import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
import Rel8.Schema.Insert ( Col( I ), Create(..), Insert )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.Name ( Name(..), Col( N ) )
import Rel8.Schema.Null ( Sql )
import Rel8.Schema.Reify ( Reify, Col(..) )
import Rel8.Schema.Result ( Col( R ), Result )
import Rel8.Schema.Spec ( Spec( Spec ) )
import Rel8.Schema.Write ( Col( W ), Write, Writable(..) )
import Rel8.Table
( Table, Columns, Context, fromColumns, toColumns
, Unreify, reify, unreify
@ -40,7 +40,7 @@ type family Field context defaulting a where
Field (Reify context) defaulting a = AField context defaulting a
Field Aggregate _defaulting a = Aggregate a
Field Expr _defaulting a = Expr a
Field Insert defaulting a = Create defaulting a
Field Write defaulting a = Writable defaulting a
Field Name _defaulting a = Name a
Field Result _defaulting a = a
@ -80,9 +80,9 @@ sfromColumn :: ()
sfromColumn = \case
SAggregate -> \(A a) -> AField a
SExpr -> \(E a) -> AField a
SInsert -> \(I a) -> AField a
SName -> \(N a) -> AField a
SResult -> \(R a) -> AField a
SWrite -> \(W a) -> AField a
SReify context -> \(Reify a) -> AField (sfromColumn context a)
@ -93,7 +93,7 @@ stoColumn :: ()
stoColumn = \case
SAggregate -> \(AField a) -> A a
SExpr -> \(AField a) -> E a
SInsert -> \(AField a) -> I a
SName -> \(AField a) -> N a
SResult -> \(AField a) -> R a
SWrite -> \(AField a) -> W a
SReify context -> \(AField a) -> Reify (stoColumn context a)

4
src/Rel8/Column/Lift.hs
View File

@ -70,9 +70,9 @@ sfromColumnsLift :: HKDable a
sfromColumnsLift = \case
SAggregate -> ALift . fromColumns . hunreify
SExpr -> ALift . fromColumns . hunreify
SInsert -> ALift . fromColumns . hunreify
SName -> ALift . fromColumns . hunreify
SResult -> ALift . fromHKD . HKD . hunreify
SWrite -> ALift . fromColumns . hunreify
SReify context -> ALift . sfromColumnsLift context . hunreify
@ -83,7 +83,7 @@ stoColumnsLift :: HKDable a
stoColumnsLift = \case
SAggregate -> hreify . toColumns . unALift
SExpr -> hreify . toColumns . unALift
SInsert -> hreify . toColumns . unALift
SName -> hreify . toColumns . unALift
SResult -> hreify . (\(HKD a) -> a) . toHKD . unALift
SWrite -> hreify . toColumns . unALift
SReify context -> hreify . stoColumnsLift context . unALift

16
src/Rel8/Column/List.hs
View File

@ -22,11 +22,11 @@ import Rel8.Expr ( Expr )
import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
import Rel8.Schema.Context ( Col )
import Rel8.Schema.HTable.List ( HListTable )
import Rel8.Schema.Insert ( Insert )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.Name ( Name )
import Rel8.Schema.Reify ( Reify, hreify, hunreify )
import Rel8.Schema.Result ( Result )
import Rel8.Schema.Write ( Write )
import Rel8.Table
( Table, Columns, Congruent, Context, fromColumns, toColumns
, Unreify, reify, unreify
@ -41,7 +41,7 @@ type family HList context where
HList (Reify context) = AHList context
HList Aggregate = ListTable
HList Expr = ListTable
HList Insert = ListTable
HList Write = ListTable
HList Name = ListTable
HList Result = []
@ -85,9 +85,9 @@ smapList :: Congruent a b
smapList = \case
SAggregate -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
SExpr -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
SResult -> \f _ (AHList as) -> AHList (fmap f as)
SInsert -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
SName -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
SResult -> \f _ (AHList as) -> AHList (fmap f as)
SWrite -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a))
SReify context -> \f g (AHList as) -> AHList (smapList context f g as)
@ -98,9 +98,9 @@ sfromColumnsList :: Table (Reify context) a
sfromColumnsList = \case
SAggregate -> AHList . ListTable
SExpr -> AHList . ListTable
SResult -> AHList . fmap (fromColumns . hreify) . fromColumns . hunreify
SInsert -> AHList . ListTable
SName -> AHList . ListTable
SResult -> AHList . fmap (fromColumns . hreify) . fromColumns . hunreify
SWrite -> AHList . ListTable
SReify context ->
AHList .
smapList context (fromColumns . hreify) hreify .
@ -115,10 +115,10 @@ stoColumnsList :: Table (Reify context) a
stoColumnsList = \case
SAggregate -> \(AHList (ListTable a)) -> a
SExpr -> \(AHList (ListTable a)) -> a
SName -> \(AHList (ListTable a)) -> a
SResult ->
hreify . toColumns . fmap (hunreify . toColumns) . (\(AHList a) -> a)
SInsert -> \(AHList (ListTable a)) -> a
SName -> \(AHList (ListTable a)) -> a
SWrite -> \(AHList (ListTable a)) -> a
SReify context ->
hreify .
stoColumnsList context .

18
src/Rel8/Column/Maybe.hs
View File

@ -22,11 +22,11 @@ import Rel8.Expr ( Expr )
import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
import Rel8.Schema.Context ( Col )
import Rel8.Schema.HTable.Maybe ( HMaybeTable )
import Rel8.Schema.Insert ( Insert )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.Name ( Name )
import Rel8.Schema.Reify ( Reify, hreify, hunreify )
import Rel8.Schema.Result ( Result )
import Rel8.Schema.Write ( Write )
import Rel8.Table
( Table, Columns, Context, fromColumns, toColumns
, Unreify, reify, unreify
@ -40,9 +40,9 @@ type family HMaybe context where
HMaybe (Reify context) = AHMaybe context
HMaybe Aggregate = MaybeTable
HMaybe Expr = MaybeTable
HMaybe Insert = MaybeTable
HMaybe Name = MaybeTable
HMaybe Result = Maybe
HMaybe Write = MaybeTable
type AHMaybe :: K.Context -> Type -> Type
@ -85,9 +85,9 @@ smapMaybe :: ()
smapMaybe = \case
SAggregate -> \f (AHMaybe a) -> AHMaybe (fmap f a)
SExpr -> \f (AHMaybe a) -> AHMaybe (fmap f a)
SResult -> \f (AHMaybe a) -> AHMaybe (fmap f a)
SInsert -> \f (AHMaybe a) -> AHMaybe (fmap f a)
SName -> \f (AHMaybe a) -> AHMaybe (fmap f a)
SResult -> \f (AHMaybe a) -> AHMaybe (fmap f a)
SWrite -> \f (AHMaybe a) -> AHMaybe (fmap f a)
SReify context -> \f (AHMaybe a) -> AHMaybe (smapMaybe context f a)
@ -98,9 +98,9 @@ sfromColumnsMaybe :: Table (Reify context) a
sfromColumnsMaybe = \case
SAggregate -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
SExpr -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
SResult -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
SInsert -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
SName -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
SResult -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
SWrite -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify
SReify context ->
AHMaybe .
smapMaybe context (fromColumns . hreify) .
@ -117,11 +117,11 @@ stoColumnsMaybe = \case
hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
SExpr ->
hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
SName ->
hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
SResult ->
hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
SInsert ->
hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
SName ->
SWrite ->
hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a)
SReify context ->
hreify .

16
src/Rel8/Column/NonEmpty.hs
View File

@ -23,11 +23,11 @@ import Rel8.Expr ( Expr )
import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
import Rel8.Schema.Context ( Col )
import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
import Rel8.Schema.Insert ( Insert )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.Name ( Name )
import Rel8.Schema.Reify ( Reify, hreify, hunreify )
import Rel8.Schema.Result ( Result )
import Rel8.Schema.Write ( Write )
import Rel8.Table
( Table, Columns, Congruent, Context, fromColumns, toColumns
, Unreify, reify, unreify
@ -42,9 +42,9 @@ type family HNonEmpty context where
HNonEmpty (Reify context) = AHNonEmpty context
HNonEmpty Aggregate = NonEmptyTable
HNonEmpty Expr = NonEmptyTable
HNonEmpty Insert = NonEmptyTable
HNonEmpty Name = NonEmptyTable
HNonEmpty Result = NonEmpty
HNonEmpty Write = NonEmptyTable
type AHNonEmpty :: K.Context -> Type -> Type
@ -86,9 +86,9 @@ smapNonEmpty :: Congruent a b
smapNonEmpty = \case
SAggregate -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
SExpr -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
SResult -> \f _ (AHNonEmpty as) -> AHNonEmpty (fmap f as)
SInsert -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
SName -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
SResult -> \f _ (AHNonEmpty as) -> AHNonEmpty (fmap f as)
SWrite -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a))
SReify context -> \f g (AHNonEmpty as) -> AHNonEmpty (smapNonEmpty context f g as)
@ -99,10 +99,10 @@ sfromColumnsNonEmpty :: Table (Reify context) a
sfromColumnsNonEmpty = \case
SAggregate -> AHNonEmpty . NonEmptyTable
SExpr -> AHNonEmpty . NonEmptyTable
SName -> AHNonEmpty . NonEmptyTable
SResult ->
AHNonEmpty . fmap (fromColumns . hreify) . fromColumns . hunreify
SInsert -> AHNonEmpty . NonEmptyTable
SName -> AHNonEmpty . NonEmptyTable
SWrite -> AHNonEmpty . NonEmptyTable
SReify context ->
AHNonEmpty .
smapNonEmpty context (fromColumns . hreify) hreify .
@ -117,10 +117,10 @@ stoColumnsNonEmpty :: Table (Reify context) a
stoColumnsNonEmpty = \case
SAggregate -> \(AHNonEmpty (NonEmptyTable a)) -> a
SExpr -> \(AHNonEmpty (NonEmptyTable a)) -> a
SName -> \(AHNonEmpty (NonEmptyTable a)) -> a
SResult ->
hreify . toColumns . fmap (hunreify . toColumns) . (\(AHNonEmpty a) -> a)
SInsert -> \(AHNonEmpty (NonEmptyTable a)) -> a
SName -> \(AHNonEmpty (NonEmptyTable a)) -> a
SWrite -> \(AHNonEmpty (NonEmptyTable a)) -> a
SReify context ->
hreify .
stoColumnsNonEmpty context .

30
src/Rel8/Column/These.hs
View File

@ -24,11 +24,11 @@ import Rel8.Expr ( Expr )
import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
import Rel8.Schema.Context ( Col )
import Rel8.Schema.HTable.These ( HTheseTable )
import Rel8.Schema.Insert ( Insert )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.Name ( Name )
import Rel8.Schema.Reify ( Reify, hreify, hunreify )
import Rel8.Schema.Result ( Result )
import Rel8.Schema.Write ( Write )
import Rel8.Table
( Table, Columns, Context, fromColumns, toColumns
, Unreify, reify, unreify
@ -45,7 +45,7 @@ type family HThese context where
HThese (Reify context) = AHThese context
HThese Aggregate = TheseTable
HThese Expr = TheseTable
HThese Insert = TheseTable
HThese Write = TheseTable
HThese Name = TheseTable
HThese Result = These
@ -97,7 +97,7 @@ sbimapThese = \case
SAggregate -> \f g (AHThese a) -> AHThese (bimap f g a)
SExpr -> \f g (AHThese a) -> AHThese (bimap f g a)
SResult -> \f g (AHThese a) -> AHThese (bimap f g a)
SInsert -> \f g (AHThese a) -> AHThese (bimap f g a)
SWrite -> \f g (AHThese a) -> AHThese (bimap f g a)
SName -> \f g (AHThese a) -> AHThese (bimap f g a)
SReify context -> \f g (AHThese a) -> AHThese (sbimapThese context f g a)
@ -117,17 +117,17 @@ sfromColumnsThese = \case
bimap (fromColumns . hreify) (fromColumns . hreify) .
fromColumns .
hunreify
SName ->
AHThese .
bimap (fromColumns . hreify) (fromColumns . hreify) .
fromColumns .
hunreify
SResult ->
AHThese .
bimap (fromColumns . hreify) (fromColumns . hreify) .
fromColumns .
hunreify
SInsert ->
AHThese .
bimap (fromColumns . hreify) (fromColumns . hreify) .
fromColumns .
hunreify
SName ->
SWrite ->
AHThese .
bimap (fromColumns . hreify) (fromColumns . hreify) .
fromColumns .
@ -154,17 +154,17 @@ stoColumnsThese = \case
toColumns .
bimap (hunreify . toColumns) (hunreify . toColumns) .
(\(AHThese a) -> a)
SName ->
hreify .
toColumns .
bimap (hunreify . toColumns) (hunreify . toColumns) .
(\(AHThese a) -> a)
SResult ->
hreify .
toColumns .
bimap (hunreify . toColumns) (hunreify . toColumns) .
(\(AHThese a) -> a)
SInsert ->
hreify .
toColumns .
bimap (hunreify . toColumns) (hunreify . toColumns) .
(\(AHThese a) -> a)
SName ->
SWrite ->
hreify .
toColumns .
bimap (hunreify . toColumns) (hunreify . toColumns) .

2
src/Rel8/Expr.hs
View File

@ -106,7 +106,7 @@ instance Sql DBFractional a => Fractional (Expr a) where
instance Sql DBFloating a => Floating (Expr a) where
pi = nullaryFunction "PI"
pi = nullaryFunction "pi"
exp = function "exp"
log = function "ln"
sqrt = function "sqrt"

72
src/Rel8/Generic/Construction.hs
View File

@ -16,7 +16,7 @@
module Rel8.Generic.Construction
( GGBuildable
, GGBuild, ggbuild
, GGInsert, gginsert
, GGWrite, ggwrite
, GGConstructable
, GGConstruct, ggconstruct
, GGDeconstruct, ggdeconstruct
@ -63,13 +63,13 @@ import qualified Rel8.Kind.Algebra as K
import Rel8.Schema.Context.Nullify ( runTag )
import Rel8.Schema.HTable ( HTable )
import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
import Rel8.Schema.Insert ( Col( I ), Create(..), Insert )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.Name ( Col( N ), Name( Name ) )
import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
import Rel8.Schema.Spec ( SSpec( SSpec, nullity, info ) )
import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify )
import Rel8.Schema.Result ( Result )
import Rel8.Schema.Write ( Col( W ), Write, Writable(..) )
import Rel8.Table
( TTable, TColumns, TUnreify
, Table, fromColumns, toColumns, reify, unreify
@ -83,7 +83,7 @@ type GGBuildable algebra name rep =
( KnownAlgebra algebra
, Eval (GGColumns algebra TColumns (Eval (rep (Reify Aggregate)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
, Eval (GGColumns algebra TColumns (Eval (rep (Reify Expr)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
, Eval (GGColumns algebra TColumns (Eval (rep (Reify Insert)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
, Eval (GGColumns algebra TColumns (Eval (rep (Reify Write)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
, Eval (GGColumns algebra TColumns (Eval (rep (Reify Name)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
, HTable (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))))
, GGBuildable' algebra name rep
@ -94,17 +94,17 @@ type GGBuildable' :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) ->
type family GGBuildable' algebra name rep where
GGBuildable' 'K.Product name rep =
( name ~ GConstructor (Eval (rep (Reify Expr)))
, name ~ GConstructor (Eval (rep (Reify Insert)))
, name ~ GConstructor (Eval (rep (Reify Write)))
, Representable TUnreify (Eval (rep (Reify Expr)))
, Representable TUnreify (Eval (rep (Reify Insert)))
, Representable TUnreify (Eval (rep (Reify Write)))
, GConstructable (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr)))
, GConstructable (TTable (Reify Insert)) TColumns TUnreify (Col (Reify Insert)) (Eval (rep (Reify Insert)))
, GConstructable (TTable (Reify Write)) TColumns TUnreify (Col (Reify Write)) (Eval (rep (Reify Write)))
)
GGBuildable' 'K.Sum name rep =
( Representable TUnreify (GConstructorADT name (Eval (rep (Reify Expr))))
, Representable TUnreify (GConstructorADT name (Eval (rep (Reify Insert))))
, Representable TUnreify (GConstructorADT name (Eval (rep (Reify Write))))
, GMakeableADT (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) name (Eval (rep (Reify Expr)))
, GMakeableADT (TTable (Reify Insert)) TColumns TUnreify (Col (Reify Insert)) name (Eval (rep (Reify Insert)))
, GMakeableADT (TTable (Reify Write)) TColumns TUnreify (Col (Reify Write)) name (Eval (rep (Reify Write)))
)
@ -150,48 +150,48 @@ ggbuild gfromColumns = case algebraSing @algebra of
(HType . Reify . E . litExpr)
type GGInsert :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
type family GGInsert algebra name rep r where
GGInsert 'K.Product _name rep r =
GConstruct TUnreify (Eval (rep (Reify Insert))) r
GGInsert 'K.Sum name rep r =
GConstruct TUnreify (GConstructorADT name (Eval (rep (Reify Insert)))) r
type GGWrite :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
type family GGWrite algebra name rep r where
GGWrite 'K.Product _name rep r =
GConstruct TUnreify (Eval (rep (Reify Write))) r
GGWrite 'K.Sum name rep r =
GConstruct TUnreify (GConstructorADT name (Eval (rep (Reify Write)))) r
gginsert :: forall algebra name rep a. GGBuildable algebra name rep
=> (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Insert) -> a)
-> GGInsert algebra name rep a
gginsert gfromColumns = case algebraSing @algebra of
ggwrite :: forall algebra name rep a. GGBuildable algebra name rep
=> (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))) (Col Write) -> a)
-> GGWrite algebra name rep a
ggwrite gfromColumns = case algebraSing @algebra of
SProduct ->
gtabulate @TUnreify @(Eval (rep (Reify Insert))) @a $
gtabulate @TUnreify @(Eval (rep (Reify Write))) @a $
gfromColumns .
hunreify .
gconstruct
@(TTable (Reify Insert))
@(TTable (Reify Write))
@TColumns
@TUnreify
@(Col (Reify Insert))
@(Eval (rep (Reify Insert)))
@(Col (Reify Write))
@(Eval (rep (Reify Write)))
(\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
SSum ->
gtabulate @TUnreify @(GConstructorADT name (Eval (rep (Reify Insert)))) @a $
gtabulate @TUnreify @(GConstructorADT name (Eval (rep (Reify Write)))) @a $
gfromColumns .
hunreify .
gmakeADT
@(TTable (Reify Insert))
@(TTable (Reify Write))
@TColumns
@TUnreify
@(Col (Reify Insert))
@(Col (Reify Write))
@name
@(Eval (rep (Reify Insert)))
@(Eval (rep (Reify Write)))
(\(_ :: proxy x) -> toColumns . reify @_ @x Refl)
(\SSpec {info} -> Reify $ I (Value (snull info)))
(\SSpec {info} -> Reify $ W (Value (snull info)))
(\SSpec {nullity} -> case nullity of
Null -> id
NotNull -> \case
Reify (I Default) -> Reify (I Default)
Reify (I (Value a)) -> Reify (I (Value (nullify a))))
(HType . Reify . I . Value . litExpr)
Reify (W Default) -> Reify (W Default)
Reify (W (Value a)) -> Reify (W (Value (nullify a))))
(HType . Reify . W . Value . litExpr)
type GGConstructable :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint
@ -199,7 +199,7 @@ type GGConstructable algebra rep =
( KnownAlgebra algebra
, Eval (GGColumns algebra TColumns (Eval (rep (Reify Aggregate)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
, Eval (GGColumns algebra TColumns (Eval (rep (Reify Expr)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
, Eval (GGColumns algebra TColumns (Eval (rep (Reify Insert)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
, Eval (GGColumns algebra TColumns (Eval (rep (Reify Write)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
, Eval (GGColumns algebra TColumns (Eval (rep (Reify Name)))) ~ Eval (GGColumns algebra TColumns (Eval (rep (Reify Result))))
, HTable (Eval (GGColumns algebra TColumns (Eval (rep (Reify Result)))))
, GGConstructable' algebra rep
@ -211,24 +211,24 @@ type family GGConstructable' algebra rep where
GGConstructable' 'K.Product rep =
( Representable TUnreify (Eval (rep (Reify Aggregate)))
, Representable TUnreify (Eval (rep (Reify Expr)))
, Representable TUnreify (Eval (rep (Reify Insert)))
, Representable TUnreify (Eval (rep (Reify Write)))
, Representable TUnreify (Eval (rep (Reify Name)))
, GConstructable (TTable (Reify Aggregate)) TColumns TUnreify (Col (Reify Aggregate)) (Eval (rep (Reify Aggregate)))
, GConstructable (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr)))
, GConstructable (TTable (Reify Insert)) TColumns TUnreify (Col (Reify Insert)) (Eval (rep (Reify Insert)))
, GConstructable (TTable (Reify Write)) TColumns TUnreify (Col (Reify Write)) (Eval (rep (Reify Write)))
, GConstructable (TTable (Reify Name)) TColumns TUnreify (Col (Reify Name)) (Eval (rep (Reify Name)))
)
GGConstructable' 'K.Sum rep =
( RepresentableConstructors TUnreify (Eval (rep (Reify Expr)))
, RepresentableConstructors TUnreify (Eval (rep (Reify Insert)))
, RepresentableConstructors TUnreify (Eval (rep (Reify Write)))
, RepresentableFields TUnreify (Eval (rep (Reify Aggregate)))
, RepresentableFields TUnreify (Eval (rep (Reify Expr)))
, RepresentableFields TUnreify (Eval (rep (Reify Name)))
, Functor (GConstructors TUnreify (Eval (rep (Reify Expr))))
, Functor (GConstructors TUnreify (Eval (rep (Reify Insert))))
, Functor (GConstructors TUnreify (Eval (rep (Reify Write))))
, GConstructableADT (TTable (Reify Aggregate)) TColumns TUnreify (Col (Reify Aggregate)) (Eval (rep (Reify Aggregate)))
, GConstructableADT (TTable (Reify Expr)) TColumns TUnreify (Col (Reify Expr)) (Eval (rep (Reify Expr)))
, GConstructableADT (TTable (Reify Insert)) TColumns TUnreify (Col (Reify Insert)) (Eval (rep (Reify Insert)))
, GConstructableADT (TTable (Reify Write)) TColumns TUnreify (Col (Reify Write)) (Eval (rep (Reify Write)))
, GConstructableADT (TTable (Reify Name)) TColumns TUnreify (Col (Reify Name)) (Eval (rep (Reify Name)))
)

21
src/Rel8/Kind/Context.hs
View File

@ -1,4 +1,5 @@
{-# language DataKinds #-}
{-# language FlexibleInstances #-}
{-# language GADTs #-}
{-# language LambdaCase #-}
{-# language StandaloneKindSignatures #-}
@ -21,20 +22,20 @@ import Rel8.Expr ( Expr )
import Rel8.Schema.Dict ( Dict( Dict ) )
import Rel8.Schema.Context ( Interpretation )
import Rel8.Schema.Context.Label ( Labelable )
import Rel8.Schema.Insert ( Insert )
import Rel8.Schema.Kind ( Context )
import Rel8.Schema.Name ( Name )
import Rel8.Schema.Reify ( Reify )
import Rel8.Schema.Result ( Result )
import Rel8.Schema.Write ( Write )
type SContext :: Context -> Type
data SContext context where
SAggregate :: SContext Aggregate
SExpr :: SContext Expr
SInsert :: SContext Insert
SName :: SContext Name
SResult :: SContext Result
SWrite :: SContext Write
SReify :: SContext context -> SContext (Reify context)
@ -51,16 +52,16 @@ instance Reifiable Expr where
contextSing = SExpr
instance Reifiable Name where
contextSing = SName
instance Reifiable Result where
contextSing = SResult
instance Reifiable Insert where
contextSing = SInsert
instance Reifiable Name where
contextSing = SName
instance Reifiable Write where
contextSing = SWrite
instance Reifiable context => Reifiable (Reify context) where
@ -71,9 +72,9 @@ sReifiable :: SContext context -> Dict Reifiable context
sReifiable = \case
SAggregate -> Dict
SExpr -> Dict
SInsert -> Dict
SName -> Dict
SResult -> Dict
SWrite -> Dict
SReify context -> case sReifiable context of
Dict -> Dict
@ -82,8 +83,8 @@ sLabelable :: SContext context -> Dict Labelable context
sLabelable = \case
SAggregate -> Dict
SExpr -> Dict
SInsert -> Dict
SName -> Dict
SResult -> Dict
SWrite -> Dict
SReify context -> case sLabelable context of
Dict -> Dict

169
src/Rel8/Schema/Insert.hs
View File

@ -1,169 +0,0 @@
{-# language DataKinds #-}
{-# language DuplicateRecordFields #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language GADTs #-}
{-# language LambdaCase #-}
{-# language MultiParamTypeClasses #-}
{-# language NamedFieldPuns #-}
{-# language PolyKinds #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}
{-# language UndecidableSuperClasses #-}
module Rel8.Schema.Insert
( Insert(..)
, OnConflict(..)
, Col( I, unI )
, Inserts
, Create(..)
, unValue
)
where
-- base
import Data.Functor.Identity ( Identity )
import Data.Kind ( Constraint, Type )
import Prelude
-- rel8
import Rel8.Aggregate ( Aggregate )
import Rel8.Expr ( Expr )
import Rel8.Kind.Defaulting ( Defaulting(HasDefault, NoDefault), KnownDefaulting )
import Rel8.Schema.Context ( Interpretation(..) )
import Rel8.Schema.Context.Label ( Labelable(..) )
import Rel8.Schema.Context.Nullify
( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier
, runTag, unnull
)
import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
import Rel8.Schema.Name ( Name, Selects )
import Rel8.Schema.Null ( Sql )
import Rel8.Schema.Reify ( notReify )
import Rel8.Schema.Result ( Result )
import Rel8.Schema.Spec ( SSpec(SSpec, nullity), Spec(Spec) )
import Rel8.Schema.Table ( TableSchema )
import Rel8.Statement.Returning ( Returning )
import Rel8.Table
( Table, Context, Columns, fromColumns, toColumns
, reify, unreify
)
import Rel8.Table.Recontextualize ( Recontextualize )
import Rel8.Table.Tag ( Tag(..), fromExpr )
import Rel8.Type ( DBType )
-- | @OnConflict@ allows you to add an @ON CONFLICT@ clause to an @INSERT@
-- statement.
data OnConflict
= Abort -- ^ @ON CONFLICT ABORT@
| DoNothing -- ^ @ON CONFLICT DO NOTHING@
-- | The constituent parts of a SQL @INSERT@ statement.
type Insert :: k -> Type
data Insert a where
Insert :: (Selects names exprs, Inserts exprs inserts) =>
{ into :: TableSchema names
-- ^ Which table to insert into.
, rows :: [inserts]
-- ^ The rows to insert.
, onConflict :: OnConflict
-- ^ What to do if the inserted rows conflict with data already in the
-- table.
, returning :: Returning names a
-- ^ What information to return on completion.
}
-> Insert a
instance Interpretation Insert where
data Col Insert _spec where
I :: {unI :: !(Create defaulting a)} -> Col Insert ('Spec labels defaulting a)
type Create :: Defaulting -> Type -> Type
data Create defaulting a where
Default :: Create 'HasDefault a
Value :: Expr a -> Create defaulting a
unValue :: Create 'NoDefault a -> Expr a
unValue (Value a) = a
instance (KnownDefaulting defaulting, Sql DBType a) =>
Table Insert (Create defaulting a)
where
type Columns (Create defaulting a) = HIdentity ('Spec '[] defaulting a)
type Context (Create defaulting a) = Insert
toColumns = HIdentity . I
fromColumns (HIdentity (I a)) = a
reify = notReify
unreify = notReify
instance Sql DBType a =>
Recontextualize Aggregate Insert (Aggregate a) (Create 'NoDefault a)
instance Sql DBType a => Recontextualize Expr Insert (Expr a) (Create 'NoDefault a)
instance Sql DBType a =>
Recontextualize Result Insert (Identity a) (Create 'NoDefault a)
instance Sql DBType a =>
Recontextualize Insert Aggregate (Create 'NoDefault a) (Aggregate a)
instance Sql DBType a => Recontextualize Insert Expr (Create 'NoDefault a) (Expr a)
instance Sql DBType a =>
Recontextualize Insert Result (Create 'NoDefault a) (Identity a)
instance Sql DBType a => Recontextualize Insert Insert (Create 'NoDefault a) (Create 'NoDefault a)
instance Sql DBType a => Recontextualize Insert Name (Create 'NoDefault a) (Name a)
instance Sql DBType a => Recontextualize Name Insert (Name a) (Create 'NoDefault a)
instance Labelable Insert where
labeler (I a) = I a
unlabeler (I a) = I a
instance Nullifiable Insert where
encodeTag = I . Value . expr
decodeTag (I (Value a)) = fromExpr a
nullifier Tag {expr} test SSpec {nullity} = \case
I Default -> I Default
I (Value a) -> I $ Value $ runTag nullity condition a
where
condition = test expr
unnullifier SSpec {nullity} = \case
I Default -> I Default
I (Value a) -> I $ Value $ unnull nullity a
{-# INLINABLE encodeTag #-}
{-# INLINABLE decodeTag #-}
{-# INLINABLE nullifier #-}
{-# INLINABLE unnullifier #-}
-- | @Inserts a b@ means that the columns in @a@ are compatible for inserting
-- with the table @b@.
type Inserts :: Type -> Type -> Constraint
class Recontextualize Expr Insert exprs inserts => Inserts exprs inserts
instance Recontextualize Expr Insert exprs inserts => Inserts exprs inserts

2
src/Rel8/Schema/Spec.hs
View File

@ -16,12 +16,12 @@ import Data.Kind ( Constraint, Type )
import Prelude ()
-- rel8
import Rel8.Kind.Labels ( Labels, SLabels, KnownLabels, labelsSing )
import Rel8.Kind.Defaulting
( Defaulting
, SDefaulting
, KnownDefaulting, defaultingSing
)
import Rel8.Kind.Labels ( Labels, SLabels, KnownLabels, labelsSing )
import Rel8.Schema.Null ( Nullity, Sql, Unnullify, nullable )
import Rel8.Type ( DBType, typeInformation )
import Rel8.Type.Information ( TypeInformation )

214
src/Rel8/Schema/Write.hs Normal file
View File

@ -0,0 +1,214 @@
{-# language DataKinds #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language GADTs #-}
{-# language LambdaCase #-}
{-# language MultiParamTypeClasses #-}
{-# language NamedFieldPuns #-}
{-# language PolyKinds #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}
{-# language UndecidableSuperClasses #-}
module Rel8.Schema.Write
( Writable( Default, Value )
, Write, fromWrite, unwrite
, Writes
, Col( W, unW )
) where
-- base
import Data.Functor.Identity ( Identity )
import Data.Kind ( Constraint, Type )
import Data.String ( IsString, fromString )
import Prelude
-- rel8
import Rel8.Aggregate ( Aggregate )
import Rel8.Expr ( Expr )
import Rel8.Kind.Defaulting
( Defaulting( HasDefault, NoDefault )
, KnownDefaulting
)
import Rel8.Schema.Context ( Interpretation( Col ) )
import Rel8.Schema.Context.Label ( Labelable( labeler, unlabeler) )
import Rel8.Schema.Context.Nullify
( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier
, runTag, unnull
)
import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
import Rel8.Schema.Name ( Name )
import Rel8.Schema.Null ( Sql )
import Rel8.Schema.Reify ( notReify )
import Rel8.Schema.Result ( Result )
import Rel8.Schema.Spec ( Spec( Spec ), SSpec( SSpec, nullity ) )
import Rel8.Table
( Table, Columns, Context, fromColumns, toColumns
, reify, unreify
)
import Rel8.Table.Recontextualize ( Recontextualize )
import Rel8.Table.Tag ( Tag( Tag, expr ), fromExpr )
import Rel8.Type ( DBType )
import Rel8.Type.Monoid ( DBMonoid )
import Rel8.Type.Num ( DBFloating, DBFractional, DBNum )
import Rel8.Type.Semigroup ( DBSemigroup )
type Writable :: Defaulting -> k -> Type
data Writable defaulting a where
Default :: k ~ Type => Writable 'HasDefault (a :: k)
Value :: k ~ Type => Expr a -> Writable defaulting (a :: k)
fromWrite :: Writable defaulting a -> Maybe (Expr a)
fromWrite Default = Nothing
fromWrite (Value a) = Just a
unwrite :: Write a -> Expr a
unwrite (Value a) = a
instance Sql DBSemigroup a => Semigroup (Writable defaulting a) where
(<>) = zipWrites (<>)
instance Sql DBMonoid a => Monoid (Writable defaulting a) where
mempty = Value mempty
instance (Sql IsString a, Sql DBType a) => IsString (Writable defaulting a) where
fromString = Value . fromString
instance Sql DBNum a => Num (Writable defaulting a) where
(+) = zipWrites (+)
(*) = zipWrites (*)
(-) = zipWrites (-)
abs = mapWrite abs
negate = mapWrite negate
signum = mapWrite signum
fromInteger = Value . fromInteger
instance Sql DBFractional a => Fractional (Writable defaulting a) where
(/) = zipWrites (/)
fromRational = Value . fromRational
instance Sql DBFloating a => Floating (Writable defaulting a) where
pi = Value pi
exp = mapWrite exp
log = mapWrite log
sqrt = mapWrite sqrt
(**) = zipWrites (**)
logBase = zipWrites logBase
sin = mapWrite sin
cos = mapWrite cos
tan = mapWrite tan
asin = mapWrite asin
acos = mapWrite acos
atan = mapWrite atan
sinh = mapWrite sinh
cosh = mapWrite cosh
tanh = mapWrite tanh
asinh = mapWrite atanh
acosh = mapWrite acosh
atanh = mapWrite atanh
mapWrite :: ()
=> (Expr (a :: Type) -> Expr (b :: Type))
-> Writable defaulting a -> Writable defaulting b
mapWrite _ Default = Default
mapWrite f (Value a) = Value (f a)
zipWrites :: ()
=> (Expr (a :: Type) -> Expr (b :: Type) -> Expr (c :: Type))
-> Writable defaulting a -> Writable defaulting b -> Writable defaulting c
zipWrites _ Default _ = Default
zipWrites _ _ Default = Default
zipWrites f (Value a) (Value b) = Value (f a b)
type Write :: k -> Type
type Write = Writable 'NoDefault
instance (KnownDefaulting defaulting, Sql DBType a) =>
Table Write (Writable defaulting a)
where
type Columns (Writable defaulting a) = HIdentity ('Spec '[] defaulting a)
type Context (Writable defaulting a) = Write
toColumns = HIdentity . W
fromColumns (HIdentity (W a)) = a
reify = notReify
unreify = notReify
instance Interpretation Write where
data Col Write _spec where
W :: {unW :: !(Writable defaulting a)} -> Col Write ('Spec labels defaulting a)
instance Sql DBType a => Recontextualize Aggregate Write (Aggregate a) (Write a)
instance Sql DBType a => Recontextualize Expr Write (Expr a) (Write a)
instance Sql DBType a => Recontextualize Result Write (Identity a) (Write a)
instance Sql DBType a => Recontextualize Write Aggregate (Write a) (Aggregate a)
instance Sql DBType a => Recontextualize Write Expr (Write a) (Expr a)
instance Sql DBType a => Recontextualize Write Result (Write a) (Identity a)
instance Sql DBType a => Recontextualize Write Write (Write a) (Write a)
instance Sql DBType a => Recontextualize Write Name (Write a) (Name a)
instance Sql DBType a => Recontextualize Name Write (Name a) (Write a)
instance Labelable Write where
labeler (W a) = W a
unlabeler (W a) = W a
instance Nullifiable Write where
encodeTag = W . Value . expr
decodeTag (W (Value a)) = fromExpr a
nullifier Tag {expr} test SSpec {nullity} = \case
W Default -> W Default
W (Value a) -> W $ Value $ runTag nullity condition a
where
condition = test expr
unnullifier SSpec {nullity} = \case
W Default -> W Default
W (Value a) -> W $ Value $ unnull nullity a
{-# INLINABLE encodeTag #-}
{-# INLINABLE decodeTag #-}
{-# INLINABLE nullifier #-}
{-# INLINABLE unnullifier #-}
-- | @Writes a b@ means that the columns in @a@ are compatible for inserting
-- with the table @b@.
type Writes :: Type -> Type -> Constraint
class Recontextualize Expr Write exprs writes => Writes exprs writes
instance Recontextualize Expr Write exprs writes => Writes exprs writes

32
src/Rel8/Statement/Insert.hs
View File

@ -1,6 +1,8 @@
{-# language DuplicateRecordFields #-}
{-# language GADTs #-}
{-# language NamedFieldPuns #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
module Rel8.Statement.Insert
@ -13,6 +15,7 @@ where
-- base
import Control.Exception ( throwIO )
import Data.List.NonEmpty ( NonEmpty( (:|) ) )
import Data.Kind ( Type )
import Prelude
-- hasql
@ -27,7 +30,9 @@ import qualified Opaleye.Internal.Manipulation as Opaleye
import qualified Opaleye.Manipulation as Opaleye
-- rel8
import Rel8.Schema.Insert ( Insert(..), OnConflict(..) )
import Rel8.Schema.Name ( Selects )
import Rel8.Schema.Table ( TableSchema )
import Rel8.Schema.Write ( Writes )
import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )
import Rel8.Table ( fromColumns, toColumns )
import Rel8.Table.Opaleye ( castTable, table, unpackspec )
@ -38,6 +43,31 @@ import qualified Data.Text as Text ( pack )
import Data.Text.Encoding ( encodeUtf8 )
-- | @OnConflict@ allows you to add an @ON CONFLICT@ clause to an @INSERT@
-- statement.
type OnConflict :: Type
data OnConflict
= Abort -- ^ @ON CONFLICT ABORT@
| DoNothing -- ^ @ON CONFLICT DO NOTHING@
-- | The constituent parts of a SQL @INSERT@ statement.
type Insert :: Type -> Type
data Insert a where
Insert :: (Selects names exprs, Writes exprs writes) =>
{ into :: TableSchema names
-- ^ Which table to insert into.
, rows :: [writes]
-- ^ The rows to insert.
, onConflict :: OnConflict
-- ^ What to do if the inserted rows conflict with data already in the
-- table.
, returning :: Returning names a
-- ^ What information to return on completion.
}
-> Insert a
-- | Run an @INSERT@ statement
insert :: Connection -> Insert a -> IO a
insert c Insert {into, rows, onConflict, returning} =

13
src/Rel8/Statement/Update.hs
View File

@ -25,17 +25,14 @@ import qualified Hasql.Statement as Hasql
-- opaleye
import qualified Opaleye.Internal.Manipulation as Opaleye
-- profunctors
import Data.Profunctor ( lmap )
-- rel8
import Rel8.Expr ( Expr )
import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
import Rel8.Schema.Name ( Selects )
import Rel8.Schema.Table ( TableSchema )
import Rel8.Schema.Write ( Writes )
import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )
import Rel8.Table ( fromColumns, toColumns )
import Rel8.Table.Insert ( toInsert )
import Rel8.Table.Opaleye ( castTable, table, unpackspec )
import Rel8.Table.Serialize ( Serializable, parse )
@ -47,10 +44,10 @@ import Data.Text.Encoding ( encodeUtf8 )
-- | The constituent parts of an @UPDATE@ statement.
type Update :: Type -> Type
data Update a where
Update :: Selects names exprs =>
Update :: (Selects names exprs, Writes exprs writes) =>
{ target :: TableSchema names
-- ^ Which table to update.
, set :: exprs -> exprs
, set :: exprs -> writes
-- ^ How to update each selected row.
, updateWhere :: exprs -> Expr Bool
-- ^ Which rows to select for update.
@ -74,7 +71,7 @@ update c Update {target, set, updateWhere, returning} =
prepare = False
sql = Opaleye.arrangeUpdateSql target' set' where'
where
target' = lmap toInsert $ table $ toColumns <$> target
target' = table $ toColumns <$> target
set' = toColumns . set . fromColumns
where' = toColumn . toPrimExpr . updateWhere . fromColumns
@ -94,7 +91,7 @@ update c Update {target, set, updateWhere, returning} =
where'
project'
where
target' = lmap toInsert $ table $ toColumns <$> target
target' = table $ toColumns <$> target
set' = toColumns . set . fromColumns
where' = toColumn . toPrimExpr . updateWhere . fromColumns
project' = castTable . toColumns . project . fromColumns

16
src/Rel8/Table/ADT.hs
View File

@ -16,7 +16,7 @@ module Rel8.Table.ADT
, ADTable, fromADT, toADT
, BuildableADT
, BuildADT, buildADT
, InsertADT, insertADT
, WriteADT, writeADT
, ConstructableADT
, ConstructADT, constructADT
, DeconstructADT, deconstructADT
@ -41,7 +41,7 @@ import Rel8.FCF ( Eval, Exp )
import Rel8.Generic.Construction
( GGBuildable
, GGBuild, ggbuild
, GGInsert, gginsert
, GGWrite, ggwrite
, GGConstructable
, GGConstruct, ggconstruct
, GGDeconstruct, ggdeconstruct
@ -59,7 +59,7 @@ import qualified Rel8.Generic.Table.ADT as G
import qualified Rel8.Kind.Algebra as K
import Rel8.Schema.Context ( Col )
import Rel8.Schema.HTable ( HTable )
import Rel8.Schema.Insert ( Insert )
import Rel8.Schema.Write ( Write )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.Name ( Name )
import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify )
@ -156,13 +156,13 @@ buildADT =
ggbuild @'K.Sum @name @(ADTRep t) @(ADT t Expr) ADT
type InsertADT :: K.Rel8able -> Symbol -> Type
type InsertADT t name = GGInsert 'K.Sum name (ADTRep t) (ADT t Insert)
type WriteADT :: K.Rel8able -> Symbol -> Type
type WriteADT t name = GGWrite 'K.Sum name (ADTRep t) (ADT t Write)
insertADT :: forall t name. BuildableADT t name => InsertADT t name
insertADT =
gginsert @'K.Sum @name @(ADTRep t) @(ADT t Insert) ADT
writeADT :: forall t name. BuildableADT t name => WriteADT t name
writeADT =
ggwrite @'K.Sum @name @(ADTRep t) @(ADT t Write) ADT
type ConstructableADT :: K.Rel8able -> Constraint

20
src/Rel8/Table/Either.hs
View File

@ -18,7 +18,7 @@ module Rel8.Table.Either
( EitherTable(..)
, eitherTable, leftTable, rightTable
, isLeftTable, isRightTable
, insertEitherTable, nameEitherTable
, nameEitherTable, writeEitherTable
)
where
@ -47,7 +47,7 @@ import Rel8.Schema.HTable.Either ( HEitherTable(..) )
import Rel8.Schema.HTable.Identity ( HIdentity(..) )
import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
import Rel8.Schema.Insert ( Insert )
import Rel8.Schema.Write ( Write )
import Rel8.Schema.Name ( Name )
import Rel8.Table
( Table, Columns, Context, fromColumns, toColumns
@ -55,12 +55,12 @@ import Rel8.Table
)
import Rel8.Table.Bool ( bool )
import Rel8.Table.Eq ( EqTable, eqTable )
import Rel8.Table.Insert ( toInsert )
import Rel8.Table.Ord ( OrdTable, ordTable )
import Rel8.Table.Recontextualize ( Recontextualize )
import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
import Rel8.Table.Undefined ( undefined )
import Rel8.Table.Write ( write )
import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
-- semigroupoids
@ -177,17 +177,17 @@ rightTableWith :: a -> b -> EitherTable a b
rightTableWith = EitherTable (fromExpr (litExpr IsRight))
insertEitherTable :: (Table Insert a, Table Insert b)
=> Either a b -> EitherTable a b
insertEitherTable = \case
Left a -> EitherTable (fromExpr (litExpr IsLeft)) a (fromColumns (toInsert undefined))
Right b -> EitherTable (fromExpr (litExpr IsRight)) (fromColumns (toInsert undefined)) b
nameEitherTable :: Name EitherTag -> a -> b -> EitherTable a b
nameEitherTable = EitherTable . fromName
writeEitherTable :: (Table Write a, Table Write b)
=> Either a b -> EitherTable a b
writeEitherTable = \case
Left a -> EitherTable (fromExpr (litExpr IsLeft)) a (fromColumns (write undefined))
Right b -> EitherTable (fromExpr (litExpr IsRight)) (fromColumns (write undefined)) b
toColumns2 ::
( HTable t
, HTable u

16
src/Rel8/Table/HKD.hs
View File

@ -16,7 +16,7 @@ module Rel8.Table.HKD
, HKDable, fromHKD, toHKD, HKDT(..)
, BuildableHKD
, BuildHKD, buildHKD
, InsertHKD, insertHKD
, WriteHKD, writeHKD
, ConstructableHKD
, ConstructHKD, constructHKD
, DeconstructHKD, deconstructHKD
@ -44,7 +44,7 @@ import Rel8.Kind.Algebra ( KnownAlgebra )
import Rel8.Generic.Construction
( GGBuildable
, GGBuild, ggbuild
, GGInsert, gginsert
, GGWrite, ggwrite
, GGConstructable
, GGConstruct, ggconstruct
, GGDeconstruct, ggdeconstruct
@ -66,7 +66,7 @@ import Rel8.Generic.Table
import Rel8.Schema.Context ( Col )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.HTable ( HTable )
import Rel8.Schema.Insert ( Insert )
import Rel8.Schema.Write ( Write )
import Rel8.Schema.Name ( Name )
import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify, notReify )
import Rel8.Schema.Result ( Result )
@ -223,13 +223,13 @@ buildHKD =
ggbuild @(GAlgebra (Rep a)) @name @(HKDRep a) @(HKD a Expr) HKD
type InsertHKD :: Type -> Symbol -> Type
type InsertHKD a name = GGInsert (GAlgebra (Rep a)) name (HKDRep a) (HKD a Insert)
type WriteHKD :: Type -> Symbol -> Type
type WriteHKD a name = GGWrite (GAlgebra (Rep a)) name (HKDRep a) (HKD a Write)
insertHKD :: forall a name. BuildableHKD a name => InsertHKD a name
insertHKD =
gginsert @(GAlgebra (Rep a)) @name @(HKDRep a) @(HKD a Insert) HKD
writeHKD :: forall a name. BuildableHKD a name => WriteHKD a name
writeHKD =
ggwrite @(GAlgebra (Rep a)) @name @(HKDRep a) @(HKD a Write) HKD
type ConstructableHKD :: Type -> Constraint

49
src/Rel8/Table/Insert.hs
View File

@ -1,49 +0,0 @@
{-# language FlexibleContexts #-}
{-# language NamedFieldPuns #-}
{-# language TypeFamilies #-}
{-# language ViewPatterns #-}
module Rel8.Table.Insert
( toInsert
, toInsertDefaults
)
where
-- base
import Prelude
-- rel8
import Rel8.Expr ( Col( E ) )
import Rel8.Kind.Defaulting ( SDefaulting( SHasDefault, SNoDefault ) )
import Rel8.Schema.HTable ( hfield, htabulate, hspecs )
import Rel8.Schema.Insert ( Inserts, Col( I ), Create(..) )
import Rel8.Schema.Spec ( SSpec(..) )
import Rel8.Table ( fromColumns, toColumns )
-- | @toInsert@ converts a 'Table' of 'Expr's into a 'Table' that can be used
-- with 'Rel8.insert'. This will override any columns that have default values
-- to use exactly what is given. If you want to use default values, you can
-- either override the result of @toInsert@, or use 'toInsertDefaults'.
toInsert :: Inserts exprs inserts => exprs -> inserts
toInsert (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
case hfield hspecs field of
SSpec {} -> I $ case hfield exprs field of
E expr -> Value expr
-- | @toInsertDefaults@ converts a 'Table' of 'Expr's into a 'Table' that can
-- be used with 'Rel8.insert'. Any columns that have a default value will
-- override whatever is in the input expression.
--
-- One example where this is useful is for any table that has a special @id@
-- column, which has a default value to draw a new value from a sequence. If we
-- use 'toInsertDefaults', we can provide a dummy value that will be replaced
-- with a call to @DEFAULT@.
toInsertDefaults :: Inserts exprs inserts => exprs -> inserts
toInsertDefaults (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
case hfield hspecs field of
SSpec {defaulting} -> case hfield exprs field of
E expr -> I $ case defaulting of
SNoDefault -> Value expr
SHasDefault -> Default

14
src/Rel8/Table/List.hs
View File

@ -10,7 +10,7 @@
module Rel8.Table.List
( ListTable(..)
, listTable, insertListTable, nameListTable
, listTable, nameListTable, writeListTable
)
where
@ -26,12 +26,12 @@ import Rel8.Expr.Array ( sappend, sempty, slistOf )
import Rel8.Schema.Dict ( Dict( Dict ) )
import Rel8.Schema.HTable.List ( HListTable )
import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize )
import Rel8.Schema.Insert ( Inserts )
import Rel8.Schema.Name ( Col( N ), Name( Name ) )
import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
import Rel8.Schema.Spec ( SSpec(..) )
import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )
import Rel8.Schema.Reify ( hreify, hunreify )
import Rel8.Schema.Write ( Writes )
import Rel8.Table
( Table, Context, Columns, fromColumns, toColumns
, reify, unreify
@ -41,11 +41,11 @@ import Rel8.Table.Alternative
, AlternativeTable, emptyTable
)
import Rel8.Table.Eq ( EqTable, eqTable )
import Rel8.Table.Insert ( toInsert )
import Rel8.Table.Ord ( OrdTable, ordTable )
import Rel8.Table.Recontextualize ( Recontextualize )
import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
import Rel8.Table.Unreify ( Unreifies )
import Rel8.Table.Write ( write )
-- | A @ListTable@ value contains zero or more instances of @a@. You construct
@ -126,13 +126,13 @@ listTable =
fmap toColumns
insertListTable :: Inserts exprs inserts => [exprs] -> ListTable inserts
insertListTable = toInsert . listTable
nameListTable :: Table Name a => a -> ListTable a
nameListTable =
ListTable .
hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .
pure .
toColumns
writeListTable :: Writes exprs writes => [exprs] -> ListTable writes
writeListTable = write . listTable

19
src/Rel8/Table/Maybe.hs
View File

@ -17,7 +17,8 @@ module Rel8.Table.Maybe
, maybeTable, nothingTable, justTable
, isNothingTable, isJustTable
, ($?)
, insertMaybeTable, nameMaybeTable
, nameMaybeTable
, writeMaybeTable
)
where
@ -44,9 +45,9 @@ import Rel8.Schema.HTable.Identity ( HIdentity(..) )
import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
import Rel8.Schema.Insert ( Insert )
import Rel8.Schema.Name ( Name )
import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql, nullable )
import Rel8.Schema.Write ( Write )
import Rel8.Table
( Table, Columns, Context, fromColumns, toColumns
, reify, unreify
@ -57,7 +58,7 @@ import Rel8.Table.Alternative
)
import Rel8.Table.Bool ( bool )
import Rel8.Table.Eq ( EqTable, eqTable )
import Rel8.Table.Insert ( toInsert )
import Rel8.Table.Write ( write )
import Rel8.Table.Ord ( OrdTable, ordTable )
import Rel8.Table.Recontextualize ( Recontextualize )
import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
@ -209,16 +210,16 @@ f $? ma@(MaybeTable _ a) = case nullable @b of
infixl 4 $?
insertMaybeTable :: Table Insert a => Maybe a -> MaybeTable a
insertMaybeTable = \case
Nothing -> MaybeTable (fromExpr null) (fromColumns (toInsert undefined))
Just a -> justTable a
nameMaybeTable :: Name (Maybe MaybeTag) -> a -> MaybeTable a
nameMaybeTable = MaybeTable . fromName
writeMaybeTable :: Table Write a => Maybe a -> MaybeTable a
writeMaybeTable = \case
Nothing -> MaybeTable (fromExpr null) (fromColumns (write undefined))
Just a -> justTable a
toColumns1 ::
( HTable t
, HConstrainTag context MaybeTag

16
src/Rel8/Table/NonEmpty.hs
View File

@ -10,7 +10,7 @@
module Rel8.Table.NonEmpty
( NonEmptyTable(..)
, nonEmptyTable, insertNonEmptyTable, nameNonEmptyTable
, nonEmptyTable, nameNonEmptyTable, writeNonEmptyTable
)
where
@ -27,23 +27,23 @@ import Rel8.Expr.Array ( sappend1, snonEmptyOf )
import Rel8.Schema.Dict ( Dict( Dict ) )
import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
import Rel8.Schema.HTable.Vectorize ( happend, hvectorize )
import Rel8.Schema.Insert ( Inserts )
import Rel8.Schema.Name ( Col( N ), Name( Name ) )
import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
import Rel8.Schema.Reify ( hreify, hunreify )
import Rel8.Schema.Spec ( SSpec(..) )
import Rel8.Schema.Spec.ConstrainDBType ( dbTypeDict, dbTypeNullity )
import Rel8.Schema.Write ( Writes )
import Rel8.Table
( Table, Context, Columns, fromColumns, toColumns
, reify, unreify
)
import Rel8.Table.Alternative ( AltTable, (<|>:) )
import Rel8.Table.Eq ( EqTable, eqTable )
import Rel8.Table.Insert ( toInsert )
import Rel8.Table.Ord ( OrdTable, ordTable )
import Rel8.Table.Recontextualize ( Recontextualize )
import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
import Rel8.Table.Unreify ( Unreifies )
import Rel8.Table.Write ( write )
-- | A @NonEmptyTable@ value contains one or more instances of @a@. You
@ -118,14 +118,14 @@ nonEmptyTable =
fmap toColumns
insertNonEmptyTable :: Inserts exprs inserts
=> NonEmpty exprs -> NonEmptyTable inserts
insertNonEmptyTable = toInsert . nonEmptyTable
nameNonEmptyTable :: Table Name a => a -> NonEmptyTable a
nameNonEmptyTable =
NonEmptyTable .
hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .
pure .
toColumns
writeNonEmptyTable :: Writes exprs writes
=> NonEmpty exprs -> NonEmptyTable writes
writeNonEmptyTable = write . nonEmptyTable

22
src/Rel8/Table/Opaleye.hs
View File

@ -1,7 +1,7 @@
{-# language BlockArguments #-}
{-# language DataKinds #-}
{-# language DisambiguateRecordFields #-}
{-# language FlexibleContexts #-}
{-# language LambdaCase #-}
{-# language NamedFieldPuns #-}
{-# language TypeFamilies #-}
{-# language ViewPatterns #-}
@ -45,10 +45,10 @@ import Rel8.Expr.Opaleye
)
import Rel8.Kind.Defaulting ( SDefaulting( SNoDefault, SHasDefault ) )
import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate )
import Rel8.Schema.Insert ( Col( I ), Create(..), Insert, Inserts )
import Rel8.Schema.Name ( Col( N ), Name( Name ), Selects )
import Rel8.Schema.Spec ( SSpec(..) )
import Rel8.Schema.Table ( TableSchema(..) )
import Rel8.Schema.Write ( Col( W ), Write, Writes, Writable(..), fromWrite )
import Rel8.Table ( Table, fromColumns, toColumns )
import Rel8.Table.Undefined ( undefined )
@ -83,36 +83,32 @@ distinctspec =
toColumns
table ::(Selects names exprs, Inserts exprs inserts)
=> TableSchema names -> Opaleye.Table inserts exprs
table ::(Selects names exprs, Writes exprs writes)
=> TableSchema names -> Opaleye.Table writes exprs
table (TableSchema name schema columns) =
case schema of
Nothing -> Opaleye.Table name (tableFields columns)
Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns)
tableFields :: (Selects names exprs, Inserts exprs inserts)
=> names -> Opaleye.TableFields inserts exprs
tableFields :: (Selects names exprs, Writes exprs writes)
=> names -> Opaleye.TableFields writes exprs
tableFields (toColumns -> names) = dimap toColumns fromColumns $
unwrapApplicative $ htabulateA $ \field -> WrapApplicative $
case hfield hspecs field of
specs -> case hfield names field of
name -> lmap (`hfield` field) (go specs name)
where
go :: SSpec spec -> Col Name spec -> Opaleye.TableFields (Col Insert spec) (Col Expr spec)
go :: SSpec spec -> Col Name spec -> Opaleye.TableFields (Col Write spec) (Col Expr spec)
go SSpec {defaulting} (N (Name name)) = case defaulting of
SNoDefault ->
lmap (\(I (Value a)) -> toColumn $ toPrimExpr a) $
lmap (\(W (Value a)) -> toColumn $ toPrimExpr a) $
E . fromPrimExpr . fromColumn <$>
Opaleye.requiredTableField name
SHasDefault ->
lmap (\(I ma) -> toColumn . toPrimExpr <$> fromInsert ma) $
lmap (\(W ma) -> toColumn . toPrimExpr <$> fromWrite ma) $
E . fromPrimExpr . fromColumn <$>
Opaleye.optionalTableField name
where
fromInsert = \case
Default -> Nothing
Value a -> Just a
unpackspec :: Table Expr a => Opaleye.Unpackspec a a

18
src/Rel8/Table/These.hs
View File

@ -21,7 +21,7 @@ module Rel8.Table.These
, isThisTable, isThatTable, isThoseTable
, hasHereTable, hasThereTable
, justHereTable, justThereTable
, insertTheseTable, nameTheseTable
, nameTheseTable, writeTheseTable
)
where
@ -51,8 +51,8 @@ import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
import Rel8.Schema.HTable.Identity ( HIdentity(..) )
import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
import Rel8.Schema.HTable.These ( HTheseTable(..) )
import Rel8.Schema.Insert ( Insert )
import Rel8.Schema.Name ( Name )
import Rel8.Schema.Write ( Write )
import Rel8.Table
( Table, Columns, Context, fromColumns, toColumns
, reify, unreify
@ -62,7 +62,7 @@ import Rel8.Table.Maybe
( MaybeTable(..)
, maybeTable, justTable, nothingTable
, isJustTable
, insertMaybeTable, nameMaybeTable
, nameMaybeTable, writeMaybeTable
)
import Rel8.Table.Ord ( OrdTable, ordTable )
import Rel8.Table.Recontextualize ( Recontextualize )
@ -231,12 +231,6 @@ theseTable f g h TheseTable {here, there} =
there
insertTheseTable :: (Table Insert a, Table Insert b)
=> These a b -> TheseTable a b
insertTheseTable =
TheseTable <$> insertMaybeTable . justHere <*> insertMaybeTable . justThere
nameTheseTable :: ()
=> Name (Maybe MaybeTag)
-> Name (Maybe MaybeTag)
@ -250,6 +244,12 @@ nameTheseTable here there a b =
}
writeTheseTable :: (Table Write a, Table Write b)
=> These a b -> TheseTable a b
writeTheseTable =
TheseTable <$> writeMaybeTable . justHere <*> writeMaybeTable . justThere
toColumns2 ::
( HTable t
, HTable u

8
src/Rel8/Table/Unreify.hs
View File

@ -41,11 +41,11 @@ import Rel8.Aggregate ( Aggregate )
import Rel8.Expr ( Expr )
import Rel8.Kind.Context ( SContext(..), Reifiable, sReifiable )
import Rel8.Schema.Dict ( Dict( Dict ) )
import Rel8.Schema.Insert ( Insert )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.Name ( Name )
import Rel8.Schema.Reify ( Reify )
import Rel8.Schema.Result ( Result )
import Rel8.Schema.Write ( Write )
import Rel8.Table ( Table, Context, Congruent, Unreify )
@ -59,16 +59,16 @@ type Unreifiable :: Type -> Constraint
class
( Context a ~ Reify Aggregate => Unreifier Aggregate a
, Context a ~ Reify Expr => Unreifier Expr a
, Context a ~ Reify Insert => Unreifier Insert a
, Context a ~ Reify Name => Unreifier Name a
, Context a ~ Reify Write => Unreifier Write a
, (forall ctx. (Context a ~ Reify (Reify ctx), Reifiable ctx) => Unreifier (Reify ctx) a)
)
=> Unreifiable a
instance
( Context a ~ Reify Aggregate => Unreifier Aggregate a
, Context a ~ Reify Expr => Unreifier Expr a
, Context a ~ Reify Insert => Unreifier Insert a
, Context a ~ Reify Name => Unreifier Name a
, Context a ~ Reify Write => Unreifier Write a
, (forall ctx. (Context a ~ Reify (Reify ctx), Reifiable ctx) => Unreifier (Reify ctx) a)
)
=> Unreifiable a
@ -99,8 +99,8 @@ unreifiability :: (Context a ~ Reify context, Unreifiable a)
unreifiability = \case
SAggregate -> Unreifiability SAggregate
SExpr -> Unreifiability SExpr
SInsert -> Unreifiability SInsert
SName -> Unreifiability SName
SResult -> UResult
SWrite -> Unreifiability SWrite
SReify context -> case sReifiable context of
Dict -> Unreifiability (SReify context)

61
src/Rel8/Table/Write.hs Normal file
View File

@ -0,0 +1,61 @@
{-# language FlexibleContexts #-}
{-# language NamedFieldPuns #-}
{-# language TypeFamilies #-}
{-# language ViewPatterns #-}
module Rel8.Table.Write
( defaultValue
, override
, write
, reset
)
where
-- base
import Prelude
-- rel8
import Rel8.Column ( Default )
import Rel8.Expr ( Col( E ), Expr )
import Rel8.Kind.Defaulting ( SDefaulting( SHasDefault, SNoDefault ) )
import Rel8.Schema.HTable ( hfield, hspecs, htabulate )
import Rel8.Schema.Spec ( SSpec(..) )
import Rel8.Schema.Write ( Col( W ), Write, Writes, Writable(..) )
import Rel8.Table ( Table, fromColumns, toColumns )
defaultValue :: Default Write a
defaultValue = Default
override :: Expr a -> Default Write a
override = Value
-- | @write@ converts a 'Table' of 'Expr's into a 'Table' that can be used
-- with 'Rel8.insert'. This will override any columns that have default values
-- to use exactly what is given. If you want to use default values, you can
-- override the result of @write@ either manually, or using automatically using
-- 'reset'.
write :: Writes exprs inserts => exprs -> inserts
write (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
case hfield hspecs field of
SSpec {} -> W $ case hfield exprs field of
E expr -> Value expr
-- | @reset@ takes a 'Table' of 'Write's and, for each column which has a
-- default value, resets the value of that column to its default.
--
-- One example where this is useful is for any table that has a special @id@
-- column, which has a default value to draw a new value from a sequence. If
-- we want to make a copy of an existing row, but with a new @id@, we can run
-- the existing row through 'write', and then feed that to 'reset' to reset
-- the @id@ column.
reset :: Table Write a => a -> a
reset (toColumns -> as) = fromColumns $ htabulate $ \field ->
case hfield hspecs field of
SSpec {defaulting} -> case hfield as field of
W a -> W $ case defaulting of
SNoDefault -> a
SHasDefault -> Default