diff --git a/rel8.cabal b/rel8.cabal index 7ed594a..23e3ba7 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -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 diff --git a/src/Rel8.hs b/src/Rel8.hs index e33ed59..0991525 100644 --- a/src/Rel8.hs +++ b/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 diff --git a/src/Rel8/Column/ADT.hs b/src/Rel8/Column/ADT.hs index d225a13..6b720b8 100644 --- a/src/Rel8/Column/ADT.hs +++ b/src/Rel8/Column/ADT.hs @@ -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) diff --git a/src/Rel8/Column/Either.hs b/src/Rel8/Column/Either.hs index 961b969..73a7937 100644 --- a/src/Rel8/Column/Either.hs +++ b/src/Rel8/Column/Either.hs @@ -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) . diff --git a/src/Rel8/Column/Field.hs b/src/Rel8/Column/Field.hs index f6fdfa8..be7633c 100644 --- a/src/Rel8/Column/Field.hs +++ b/src/Rel8/Column/Field.hs @@ -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) diff --git a/src/Rel8/Column/Lift.hs b/src/Rel8/Column/Lift.hs index de931a8..3b2fdc0 100644 --- a/src/Rel8/Column/Lift.hs +++ b/src/Rel8/Column/Lift.hs @@ -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 diff --git a/src/Rel8/Column/List.hs b/src/Rel8/Column/List.hs index f5736af..1fa2225 100644 --- a/src/Rel8/Column/List.hs +++ b/src/Rel8/Column/List.hs @@ -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 . diff --git a/src/Rel8/Column/Maybe.hs b/src/Rel8/Column/Maybe.hs index 08ff9fe..d5ca716 100644 --- a/src/Rel8/Column/Maybe.hs +++ b/src/Rel8/Column/Maybe.hs @@ -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 . diff --git a/src/Rel8/Column/NonEmpty.hs b/src/Rel8/Column/NonEmpty.hs index 799827b..f573323 100644 --- a/src/Rel8/Column/NonEmpty.hs +++ b/src/Rel8/Column/NonEmpty.hs @@ -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 . diff --git a/src/Rel8/Column/These.hs b/src/Rel8/Column/These.hs index 522f53b..af73088 100644 --- a/src/Rel8/Column/These.hs +++ b/src/Rel8/Column/These.hs @@ -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) . diff --git a/src/Rel8/Expr.hs b/src/Rel8/Expr.hs index 0392ec8..732f861 100644 --- a/src/Rel8/Expr.hs +++ b/src/Rel8/Expr.hs @@ -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" diff --git a/src/Rel8/Generic/Construction.hs b/src/Rel8/Generic/Construction.hs index ed085a3..38f8491 100644 --- a/src/Rel8/Generic/Construction.hs +++ b/src/Rel8/Generic/Construction.hs @@ -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))) ) diff --git a/src/Rel8/Kind/Context.hs b/src/Rel8/Kind/Context.hs index c3b3323..6d473a3 100644 --- a/src/Rel8/Kind/Context.hs +++ b/src/Rel8/Kind/Context.hs @@ -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 diff --git a/src/Rel8/Schema/Insert.hs b/src/Rel8/Schema/Insert.hs deleted file mode 100644 index 8e727a9..0000000 --- a/src/Rel8/Schema/Insert.hs +++ /dev/null @@ -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 diff --git a/src/Rel8/Schema/Spec.hs b/src/Rel8/Schema/Spec.hs index ffd1418..df84d2c 100644 --- a/src/Rel8/Schema/Spec.hs +++ b/src/Rel8/Schema/Spec.hs @@ -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 ) diff --git a/src/Rel8/Schema/Write.hs b/src/Rel8/Schema/Write.hs new file mode 100644 index 0000000..ff914d2 --- /dev/null +++ b/src/Rel8/Schema/Write.hs @@ -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 diff --git a/src/Rel8/Statement/Insert.hs b/src/Rel8/Statement/Insert.hs index 0ec38df..5b2b458 100644 --- a/src/Rel8/Statement/Insert.hs +++ b/src/Rel8/Statement/Insert.hs @@ -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} = diff --git a/src/Rel8/Statement/Update.hs b/src/Rel8/Statement/Update.hs index 4729915..edb412a 100644 --- a/src/Rel8/Statement/Update.hs +++ b/src/Rel8/Statement/Update.hs @@ -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 diff --git a/src/Rel8/Table/ADT.hs b/src/Rel8/Table/ADT.hs index 12926fc..8d15df6 100644 --- a/src/Rel8/Table/ADT.hs +++ b/src/Rel8/Table/ADT.hs @@ -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 diff --git a/src/Rel8/Table/Either.hs b/src/Rel8/Table/Either.hs index 691da93..af6c43b 100644 --- a/src/Rel8/Table/Either.hs +++ b/src/Rel8/Table/Either.hs @@ -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 diff --git a/src/Rel8/Table/HKD.hs b/src/Rel8/Table/HKD.hs index cc4f80c..94be5ac 100644 --- a/src/Rel8/Table/HKD.hs +++ b/src/Rel8/Table/HKD.hs @@ -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 diff --git a/src/Rel8/Table/Insert.hs b/src/Rel8/Table/Insert.hs deleted file mode 100644 index c68c7f4..0000000 --- a/src/Rel8/Table/Insert.hs +++ /dev/null @@ -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 diff --git a/src/Rel8/Table/List.hs b/src/Rel8/Table/List.hs index 664633a..75622c7 100644 --- a/src/Rel8/Table/List.hs +++ b/src/Rel8/Table/List.hs @@ -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 diff --git a/src/Rel8/Table/Maybe.hs b/src/Rel8/Table/Maybe.hs index 68120d4..bab54fc 100644 --- a/src/Rel8/Table/Maybe.hs +++ b/src/Rel8/Table/Maybe.hs @@ -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 diff --git a/src/Rel8/Table/NonEmpty.hs b/src/Rel8/Table/NonEmpty.hs index f2ab407..b342862 100644 --- a/src/Rel8/Table/NonEmpty.hs +++ b/src/Rel8/Table/NonEmpty.hs @@ -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 diff --git a/src/Rel8/Table/Opaleye.hs b/src/Rel8/Table/Opaleye.hs index 443add2..ebc9695 100644 --- a/src/Rel8/Table/Opaleye.hs +++ b/src/Rel8/Table/Opaleye.hs @@ -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 diff --git a/src/Rel8/Table/These.hs b/src/Rel8/Table/These.hs index 7170e79..768d9a5 100644 --- a/src/Rel8/Table/These.hs +++ b/src/Rel8/Table/These.hs @@ -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 diff --git a/src/Rel8/Table/Unreify.hs b/src/Rel8/Table/Unreify.hs index 8348836..b6ee99c 100644 --- a/src/Rel8/Table/Unreify.hs +++ b/src/Rel8/Table/Unreify.hs @@ -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) diff --git a/src/Rel8/Table/Write.hs b/src/Rel8/Table/Write.hs new file mode 100644 index 0000000..e908025 --- /dev/null +++ b/src/Rel8/Table/Write.hs @@ -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