mirror of
https://github.com/circuithub/rel8.git
synced 2024-08-17 20:00:23 +03:00
Use Write as context for both Inserts and Updates (replaces Create and Insert context)
This commit is contained in:
parent
0b071aeca7
commit
09a9c587da
@ -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
37
src/Rel8.hs
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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) .
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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 .
|
||||
|
@ -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 .
|
||||
|
@ -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 .
|
||||
|
@ -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) .
|
||||
|
@ -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"
|
||||
|
@ -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)))
|
||||
)
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
@ -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
214
src/Rel8/Schema/Write.hs
Normal 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
|
@ -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} =
|
||||
|
@ -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,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
|
||||
|
@ -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,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
|
||||
|
@ -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
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
61
src/Rel8/Table/Write.hs
Normal 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
|
Loading…
Reference in New Issue
Block a user