diff --git a/rel8.cabal b/rel8.cabal index 9e44a06..448d59e 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -87,7 +87,6 @@ library Rel8.Schema.Column Rel8.Schema.Context - Rel8.Schema.Context.Identity Rel8.Schema.Context.Label Rel8.Schema.Context.Nullify Rel8.Schema.Dict @@ -117,6 +116,7 @@ library Rel8.Schema.Spec Rel8.Schema.Spec.ConstrainDBType Rel8.Schema.Spec.ConstrainType + Rel8.Schema.Structure Rel8.Schema.Table Rel8.Statement.Delete @@ -133,7 +133,6 @@ library Rel8.Table.Either Rel8.Table.Eq Rel8.Table.Insert - Rel8.Table.Lifted Rel8.Table.List Rel8.Table.Maybe Rel8.Table.Name @@ -163,8 +162,6 @@ library Rel8.Type.Sum Rel8.Type.Tag - Rel8.Schema.Structure - test-suite tests type: exitcode-stdio-1.0 build-depends: diff --git a/src/Rel8.hs b/src/Rel8.hs index ea71e49..e29a3ae 100644 --- a/src/Rel8.hs +++ b/src/Rel8.hs @@ -28,7 +28,7 @@ module Rel8 -- * Tables and higher-kinded tables , Rel8able , Column, Field, Necessity( Required, Optional ) - , Default, Label + , Default , HMaybe , HList , HNonEmpty @@ -268,7 +268,7 @@ import Rel8.Query.These import Rel8.Query.Values import Rel8.Schema.Column import Rel8.Schema.Context.Label -import Rel8.Schema.Field (Field) +import Rel8.Schema.Field import Rel8.Schema.Generic import Rel8.Schema.HTable import Rel8.Schema.Name @@ -307,5 +307,3 @@ import Rel8.Type.ReadShow import Rel8.Type.Semigroup import Rel8.Type.String import Rel8.Type.Sum - - diff --git a/src/Rel8/Expr/Eq.hs b/src/Rel8/Expr/Eq.hs index 4878e45..2e47f93 100644 --- a/src/Rel8/Expr/Eq.hs +++ b/src/Rel8/Expr/Eq.hs @@ -22,7 +22,7 @@ import Prelude import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 -import Rel8.Expr ( Expr ) +import {-# SOURCE #-} Rel8.Expr ( Expr ) import Rel8.Expr.Bool ( (&&.), (||.), false, or_, coalesce ) import Rel8.Expr.Null ( isNull, unsafeLiftOpNull ) import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr, zipPrimExprsWith ) diff --git a/src/Rel8/Schema/Column.hs b/src/Rel8/Schema/Column.hs index f10c9a3..ee2ee07 100644 --- a/src/Rel8/Schema/Column.hs +++ b/src/Rel8/Schema/Column.hs @@ -3,67 +3,24 @@ {-# language StandaloneKindSignatures #-} module Rel8.Schema.Column - ( Column, Default, Label - , HEither - , HList - , HMaybe - , HNonEmpty - , HThese + ( Column, Default ) where -- base -import Data.Functor.Identity ( Identity ) import Data.Kind ( Type ) -import Data.List.NonEmpty ( NonEmpty ) -import GHC.TypeLits ( Symbol ) -import Prelude +import Prelude () -- rel8 -import Rel8.Aggregate ( Aggregate ) -import Rel8.Expr ( Expr ) -import Rel8.Kind.Labels ( Labels ) import Rel8.Kind.Necessity ( Necessity( Required, Optional ) ) import Rel8.Schema.Field ( Field ) -import Rel8.Schema.Insert ( Insert ) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Name ( Name ) -import Rel8.Schema.Structure - ( Structure - , Shape( Either, List, Maybe, NonEmpty, These ) - , Shape1 - , Shape2 - ) -import Rel8.Table.Either ( EitherTable ) -import Rel8.Table.List ( ListTable ) -import Rel8.Table.Maybe ( MaybeTable ) -import Rel8.Table.NonEmpty ( NonEmptyTable ) -import Rel8.Table.These ( TheseTable ) - --- these -import Data.These ( These ) - - -type Label :: Symbol -> Type -> Type -data Label label a type Default :: Type -> Type data Default a -type GetLabel :: Type -> Labels -type family GetLabel a where - GetLabel (Label label _) = '[label] - GetLabel _ = '[] - - -type UnwrapLabel :: Type -> Type -type family UnwrapLabel a where - UnwrapLabel (Label _ a) = a - UnwrapLabel a = a - - type GetNecessity :: Type -> Necessity type family GetNecessity a where GetNecessity (Default _) = 'Optional @@ -82,61 +39,4 @@ type family UnwrapDefault a where -- both query data and rows decoded to Haskell. type Column :: K.Context -> Type -> Type type Column context a = - Field context (GetLabel a) - (GetNecessity (UnwrapLabel a)) - (UnwrapDefault (UnwrapLabel a)) - - -type HEither :: K.Context -> Type -> Type -> Type -type family HEither context where - HEither Structure = Shape2 'Either - HEither Aggregate = EitherTable - HEither Expr = EitherTable - HEither Identity = Either - HEither Insert = EitherTable - HEither Name = EitherTable - HEither _ = Either - - -type HList :: K.Context -> Type -> Type -type family HList context where - HList Structure = Shape1 'List - HList Aggregate = ListTable - HList Expr = ListTable - HList Identity = [] - HList Insert = ListTable - HList Name = ListTable - HList _ = [] - - -type HMaybe :: K.Context -> Type -> Type -type family HMaybe context where - HMaybe Structure = Shape1 'Maybe - HMaybe Aggregate = MaybeTable - HMaybe Expr = MaybeTable - HMaybe Identity = Maybe - HMaybe Insert = MaybeTable - HMaybe Name = MaybeTable - HMaybe _ = Maybe - - -type HNonEmpty :: K.Context -> Type -> Type -type family HNonEmpty context where - HNonEmpty Structure = Shape1 'NonEmpty - HNonEmpty Aggregate = NonEmptyTable - HNonEmpty Expr = NonEmptyTable - HNonEmpty Identity = NonEmpty - HNonEmpty Insert = NonEmptyTable - HNonEmpty Name = NonEmptyTable - HNonEmpty _ = NonEmpty - - -type HThese :: K.Context -> Type -> Type -> Type -type family HThese context where - HThese Structure = Shape2 'These - HThese Aggregate = TheseTable - HThese Expr = TheseTable - HThese Identity = These - HThese Insert = TheseTable - HThese Name = TheseTable - HThese _ = These + Field context (GetNecessity a) (UnwrapDefault a) diff --git a/src/Rel8/Schema/Context/Identity.hs b/src/Rel8/Schema/Context/Identity.hs deleted file mode 100644 index a8c7a1c..0000000 --- a/src/Rel8/Schema/Context/Identity.hs +++ /dev/null @@ -1,196 +0,0 @@ -{-# language DataKinds #-} -{-# language DisambiguateRecordFields #-} -{-# language NamedFieldPuns #-} -{-# language TypeFamilies #-} - -module Rel8.Schema.Context.Identity - ( fromHEitherTable, toHEitherTable - , fromHListTable, toHListTable - , fromHMaybeTable, toHMaybeTable - , fromHNonEmptyTable, toHNonEmptyTable - , fromHTheseTable, toHTheseTable - ) -where - --- base -import Data.Functor ( ($>) ) -import Data.Functor.Identity ( Identity ) -import Data.List.NonEmpty ( NonEmpty ) -import Prelude hiding ( null ) - --- rel8 -import Rel8.Schema.Context ( Col( Result ) ) -import Rel8.Schema.HTable ( HTable ) -import Rel8.Schema.HTable.Either ( HEitherTable(..) ) -import Rel8.Schema.HTable.Identity ( HIdentity(..) ) -import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) ) -import Rel8.Schema.HTable.List ( HListTable ) -import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable ) -import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify ) -import Rel8.Schema.HTable.These ( HTheseTable(..) ) -import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize ) -import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) ) -import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) ) -import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) ) - --- these -import Data.These ( These( This, That, These ) ) -import Data.These.Combinators ( justHere, justThere ) - - -toHEitherTable :: (HTable t, HTable u) - => Either (t (Col Identity)) (u (Col Identity)) - -> HEitherTable t u (Col Identity) -toHEitherTable = either hleft hright - where - hleft table = HEitherTable - { htag = HIdentity (Result IsLeft) - , hleft = hnullify nullifier table - , hright = hnulls null - } - hright table = HEitherTable - { htag = HIdentity (Result IsRight) - , hleft = hnulls null - , hright = hnullify nullifier table - } -{-# INLINABLE toHEitherTable #-} - - -fromHEitherTable :: (HTable t, HTable u) - => HEitherTable t u (Col Identity) - -> Either (t (Col Identity)) (u (Col Identity)) -fromHEitherTable HEitherTable {htag, hleft, hright} = case htag of - HIdentity (Result tag) -> case tag of - IsLeft -> maybe err Left $ hunnullify unnullifier hleft - IsRight -> maybe err Right $ hunnullify unnullifier hright - where - err = error "fromHEitherTable: mismatch between tag and data" -{-# INLINABLE fromHEitherTable #-} - - -toHListTable :: HTable t => [t (Col Identity)] -> HListTable t (Col Identity) -toHListTable = hvectorize vectorizer -{-# INLINABLE toHListTable #-} - - -fromHListTable :: HTable t => HListTable t (Col Identity) -> [t (Col Identity)] -fromHListTable = hunvectorize unvectorizer -{-# INLINABLE fromHListTable #-} - - -toHMaybeTable :: HTable t => Maybe (t (Col Identity)) -> HMaybeTable t (Col Identity) -toHMaybeTable = maybe hnothing hjust - where - hnothing = HMaybeTable - { htag = HIdentity (Result Nothing) - , hjust = hnulls null - } - hjust table = HMaybeTable - { htag = HIdentity (Result (Just IsJust)) - , hjust = hnullify nullifier table - } -{-# INLINABLE toHMaybeTable #-} - - -fromHMaybeTable :: HTable t => HMaybeTable t (Col Identity) -> Maybe (t (Col Identity)) -fromHMaybeTable HMaybeTable {htag, hjust} = case htag of - HIdentity (Result tag) -> tag $> - case hunnullify unnullifier hjust of - Nothing -> error "fromHMaybeTable: mismatch between tag and data" - Just just -> just -{-# INLINABLE fromHMaybeTable #-} - - -toHNonEmptyTable :: HTable t => NonEmpty (t (Col Identity)) -> HNonEmptyTable t (Col Identity) -toHNonEmptyTable = hvectorize vectorizer -{-# INLINABLE toHNonEmptyTable #-} - - -fromHNonEmptyTable :: HTable t => HNonEmptyTable t (Col Identity) -> NonEmpty (t (Col Identity)) -fromHNonEmptyTable = hunvectorize unvectorizer -{-# INLINABLE fromHNonEmptyTable #-} - - -toHTheseTable :: (HTable t, HTable u) - => These (t (Col Identity)) (u (Col Identity)) - -> HTheseTable t u (Col Identity) -toHTheseTable tables = HTheseTable - { hhereTag = relabel hhereTag - , hhere - , hthereTag = relabel hthereTag - , hthere - } - where - HMaybeTable - { htag = hhereTag - , hjust = hhere - } = toHMaybeTable (justHere tables) - HMaybeTable - { htag = hthereTag - , hjust = hthere - } = toHMaybeTable (justThere tables) -{-# INLINABLE toHTheseTable #-} - - -fromHTheseTable :: (HTable t, HTable u) - => HTheseTable t u (Col Identity) - -> These (t (Col Identity)) (u (Col Identity)) -fromHTheseTable HTheseTable {hhereTag, hhere, hthereTag, hthere} = - case (fromHMaybeTable mhere, fromHMaybeTable mthere) of - (Just a, Nothing) -> This a - (Nothing, Just b) -> That b - (Just a, Just b) -> These a b - _ -> error "fromHTheseTable: mismatch between tags and data" - where - mhere = HMaybeTable - { htag = relabel hhereTag - , hjust = hhere - } - mthere = HMaybeTable - { htag = relabel hthereTag - , hjust = hthere - } -{-# INLINABLE fromHTheseTable #-} - - -null :: Col Identity ('Spec labels necessity (Maybe a)) -null = Result Nothing - - -nullifier :: () - => SSpec ('Spec labels necessity a) - -> Col Identity ('Spec labels necessity a) - -> Col Identity ('Spec labels necessity (Nullify a)) -nullifier SSpec {nullity} (Result a) = Result $ case nullity of - Null -> a - NotNull -> Just a - - -unnullifier :: () - => SSpec ('Spec labels necessity a) - -> Col Identity ('Spec labels necessity (Nullify a)) - -> Maybe (Col Identity ('Spec labels necessity a)) -unnullifier SSpec {nullity} (Result a) = - case nullity of - Null -> pure $ Result a - NotNull -> Result <$> a - - -vectorizer :: Functor f - => SSpec ('Spec labels necessity a) - -> f (Col Identity ('Spec labels necessity a)) - -> Col Identity ('Spec labels necessity (f a)) -vectorizer _ = Result . fmap (\(Result a) -> a) - - -unvectorizer :: Functor f - => SSpec ('Spec labels necessity a) - -> Col Identity ('Spec labels necessity (f a)) - -> f (Col Identity ('Spec labels necessity a)) -unvectorizer _ (Result results) = Result <$> results - - -relabel :: () - => HIdentity ('Spec labels necessity a) (Col Identity) - -> HIdentity ('Spec relabels necessity a) (Col Identity) -relabel (HIdentity (Result a)) = HIdentity (Result a) diff --git a/src/Rel8/Schema/Field.hs b/src/Rel8/Schema/Field.hs index 1de1669..d01c28c 100644 --- a/src/Rel8/Schema/Field.hs +++ b/src/Rel8/Schema/Field.hs @@ -1,34 +1,725 @@ {-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language GADTs #-} +{-# language LambdaCase #-} +{-# language MultiParamTypeClasses #-} {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-} +{-# language UndecidableInstances #-} module Rel8.Schema.Field ( Field + , HEither, HList, HMaybe, HNonEmpty, HThese + , Reify, hreify, hunreify + , Reifiable + , AField(..) + , AHEither(..), AHList(..), AHMaybe(..), AHNonEmpty(..), AHThese(..) ) where -- base +import Data.Bifunctor ( Bifunctor, bimap ) import Data.Functor.Identity ( Identity ) -import Data.Kind ( Type ) +import Data.Kind ( Constraint, Type ) +import Data.List.NonEmpty ( NonEmpty ) import Prelude -- rel8 -import Rel8.Aggregate ( Aggregate ) -import Rel8.Expr ( Expr ) -import Rel8.Kind.Labels ( Labels ) -import Rel8.Kind.Necessity ( Necessity( Required, Optional ) ) -import Rel8.Schema.Insert ( Insert ) +import Rel8.Aggregate ( Aggregate, Col(..) ) +import Rel8.Expr ( Expr, Col(..) ) +import Rel8.Kind.Necessity + ( Necessity( Required, Optional ) + , SNecessity( SRequired, SOptional ) + , KnownNecessity, necessitySing + ) +import Rel8.Schema.Context ( Interpretation, Col(..) ) +import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler ) +import Rel8.Schema.HTable ( HTable, hfield, htabulate ) +import Rel8.Schema.HTable.Either ( HEitherTable ) +import Rel8.Schema.HTable.List ( HListTable ) +import Rel8.Schema.HTable.Maybe ( HMaybeTable ) +import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable ) +import Rel8.Schema.HTable.These ( HTheseTable ) +import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) ) +import Rel8.Schema.Insert ( Insert, Col(..) ) import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Name ( Name(..), Col(..) ) +import Rel8.Schema.Null ( Sql ) import Rel8.Schema.Spec ( Spec( Spec ) ) -import Rel8.Schema.Structure ( Structure, Shape( Column ), Shape1 ) +import Rel8.Table + ( Table, Columns, Context, fromColumns, toColumns + , Congruent + ) +import Rel8.Table.Either ( EitherTable ) +import Rel8.Table.List ( ListTable( ListTable ) ) +import Rel8.Table.Maybe ( MaybeTable ) +import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) ) +import Rel8.Table.Recontextualize ( Recontextualize ) +import Rel8.Table.These ( TheseTable ) +import Rel8.Type ( DBType ) + +-- these +import Data.These ( These ) -type Field :: K.Context -> Labels -> Necessity -> Type -> Type -type family Field labels context necessity a where - Field Identity _labels _necessity a = a - Field Expr _labels _necessity a = Expr a - Field Insert _labels 'Required a = Expr a - Field Insert _labels 'Optional a = Maybe (Expr a) - Field Aggregate _labels _necessity a = Aggregate (Expr a) - Field Structure labels necessity a = Shape1 'Column ('Spec labels necessity a) - Field context _labels _necessity a = context a +type Field :: K.Context -> Necessity -> Type -> Type +type family Field context necessity a where + Field (Reify context) necessity a = AField context necessity a + Field Identity _necessity a = a + Field Expr _necessity a = Expr a + Field Insert 'Required a = Expr a + Field Insert 'Optional a = Maybe (Expr a) + Field Aggregate _necessity a = Aggregate (Expr a) + Field context _necessity a = context a + + +type HEither :: K.Context -> Type -> Type -> Type +type family HEither context where + HEither (Reify context) = AHEither context + HEither Aggregate = EitherTable + HEither Expr = EitherTable + HEither Identity = Either + HEither Insert = EitherTable + HEither Name = EitherTable + HEither _ = Either + + +type HList :: K.Context -> Type -> Type +type family HList context where + HList (Reify context) = AHList context + HList Aggregate = ListTable + HList Expr = ListTable + HList Identity = [] + HList Insert = ListTable + HList Name = ListTable + HList _ = [] + + +type HMaybe :: K.Context -> Type -> Type +type family HMaybe context where + HMaybe (Reify context) = AHMaybe context + HMaybe Aggregate = MaybeTable + HMaybe Expr = MaybeTable + HMaybe Identity = Maybe + HMaybe Insert = MaybeTable + HMaybe Name = MaybeTable + HMaybe _ = Maybe + + +type HNonEmpty :: K.Context -> Type -> Type +type family HNonEmpty context where + HNonEmpty (Reify context) = AHNonEmpty context + HNonEmpty Aggregate = NonEmptyTable + HNonEmpty Expr = NonEmptyTable + HNonEmpty Identity = NonEmpty + HNonEmpty Insert = NonEmptyTable + HNonEmpty Name = NonEmptyTable + HNonEmpty _ = NonEmpty + + +type HThese :: K.Context -> Type -> Type -> Type +type family HThese context where + HThese (Reify context) = AHThese context + HThese Aggregate = TheseTable + HThese Expr = TheseTable + HThese Identity = These + HThese Insert = TheseTable + HThese Name = TheseTable + HThese _ = These + + +type AField :: K.Context -> Necessity -> Type -> Type +newtype AField context necessity a = AField (Field context necessity a) + + +instance (Reifiable context, KnownNecessity necessity, Sql DBType a) => + Table (Reify context) (AField context necessity a) + where + type Context (AField context necessity a) = Reify context + type Columns (AField context necessity a) = HIdentity ('Spec '[""] necessity a) + + fromColumns (HIdentity (Reify a)) = sfromColumn contextSing a + toColumns = HIdentity . Reify . stoColumn contextSing necessitySing + + +instance + ( Reifiable context, Reifiable context' + , KnownNecessity necessity, Sql DBType a + ) => + Recontextualize + (Reify context) + (Reify context') + (AField context necessity a) + (AField context' necessity a) + + +type AHEither :: K.Context -> Type -> Type -> Type +newtype AHEither context a b = AHEither (HEither context a b) + + +instance Reifiable context => Bifunctor (AHEither context) where + bimap = sbimapEither contextSing + + +instance Reifiable context => Functor (AHEither context a) where + fmap = bimap id + + +instance (Reifiable context, Table (Reify context) a, Table (Reify context) b) + => Table (Reify context) (AHEither context a b) + where + type Context (AHEither context a b) = Reify context + type Columns (AHEither context a b) = HEitherTable (Columns a) (Columns b) + + fromColumns = sfromColumnsEither contextSing + toColumns = stoColumnsEither contextSing + + +instance + ( Reifiable context, Reifiable context' + , Recontextualize (Reify context) (Reify context') a a' + , Recontextualize (Reify context) (Reify context') b b' + ) => + Recontextualize + (Reify context) + (Reify context') + (AHEither context a b) + (AHEither context' a' b') + + +type AHList :: K.Context -> Type -> Type +newtype AHList context a = AHList (HList context a) + + +instance (Reifiable context, Table (Reify context) a) => + Table (Reify context) (AHList context a) + where + type Context (AHList context a) = Reify context + type Columns (AHList context a) = HListTable (Columns a) + + fromColumns = sfromColumnsList contextSing + toColumns = stoColumnsList contextSing + + +instance + ( Reifiable context, Reifiable context' + , Recontextualize (Reify context) (Reify context') a a' + ) => + Recontextualize + (Reify context) + (Reify context') + (AHList context a) + (AHList context' a') + + +type AHMaybe :: K.Context -> Type -> Type +newtype AHMaybe context a = AHMaybe (HMaybe context a) + + +instance Reifiable context => Functor (AHMaybe context) where + fmap = smapMaybe contextSing + + +instance (Reifiable context, Table (Reify context) a) => + Table (Reify context) (AHMaybe context a) + where + type Context (AHMaybe context a) = Reify context + type Columns (AHMaybe context a) = HMaybeTable (Columns a) + + fromColumns = sfromColumnsMaybe contextSing + toColumns = stoColumnsMaybe contextSing + + +instance + ( Reifiable context, Reifiable context' + , Recontextualize (Reify context) (Reify context') a a' + ) => + Recontextualize + (Reify context) + (Reify context') + (AHMaybe context a) + (AHMaybe context' a') + + +type AHNonEmpty :: K.Context -> Type -> Type +newtype AHNonEmpty context a = AHNonEmpty (HNonEmpty context a) + + +instance (Reifiable context, Table (Reify context) a) => + Table (Reify context) (AHNonEmpty context a) + where + type Context (AHNonEmpty context a) = Reify context + type Columns (AHNonEmpty context a) = HNonEmptyTable (Columns a) + + fromColumns = sfromColumnsNonEmpty contextSing + toColumns = stoColumnsNonEmpty contextSing + + +instance + ( Reifiable context, Reifiable context' + , Recontextualize (Reify context) (Reify context') a a' + ) => + Recontextualize + (Reify context) + (Reify context') + (AHNonEmpty context a) + (AHNonEmpty context' a') + + +type AHThese :: K.Context -> Type -> Type -> Type +newtype AHThese context a b = AHThese (HThese context a b) + + +instance Reifiable context => Bifunctor (AHThese context) where + bimap = sbimapThese contextSing + + +instance Reifiable context => Functor (AHThese context a) where + fmap = bimap id + + +instance (Reifiable context, Table (Reify context) a, Table (Reify context) b) + => Table (Reify context) (AHThese context a b) + where + type Context (AHThese context a b) = Reify context + type Columns (AHThese context a b) = HTheseTable (Columns a) (Columns b) + + fromColumns = sfromColumnsThese contextSing + toColumns = stoColumnsThese contextSing + + +instance + ( Reifiable context, Reifiable context' + , Recontextualize (Reify context) (Reify context') a a' + , Recontextualize (Reify context) (Reify context') b b' + ) => + Recontextualize + (Reify context) + (Reify context') + (AHThese context a b) + (AHThese context' a' b') + + +type SContext :: K.Context -> Type +data SContext context where + SAggregate :: SContext Aggregate + SExpr :: SContext Expr + SIdentity :: SContext Identity + SInsert :: SContext Insert + SName :: SContext Name + SReify :: SContext context -> SContext (Reify context) + + +type Reifiable :: K.Context -> Constraint +class Interpretation context => Reifiable context where + contextSing :: SContext context + + +instance Reifiable Aggregate where + contextSing = SAggregate + + +instance Reifiable Expr where + contextSing = SExpr + + +instance Reifiable Identity where + contextSing = SIdentity + + +instance Reifiable Insert where + contextSing = SInsert + + +instance Reifiable Name where + contextSing = SName + + +type Reify :: K.Context -> K.Context +data Reify context a + + +instance Interpretation (Reify context) where + newtype Col (Reify context) spec = Reify (Col context spec) + + +instance Labelable context => Labelable (Reify context) where + labeler (Reify a) = Reify (labeler a) + unlabeler (Reify a) = Reify (unlabeler a) + + +instance Reifiable context => Reifiable (Reify context) where + contextSing = SReify contextSing + + +sfromColumn :: () + => SContext context + -> Col context ('Spec labels necessity a) + -> AField context necessity a +sfromColumn = \case + SAggregate -> \(Aggregation a) -> AField a + SExpr -> \(DB a) -> AField a + SIdentity -> \(Result a) -> AField a + SInsert -> \case + RequiredInsert a -> AField a + OptionalInsert a -> AField a + SName -> \(NameCol a) -> AField (Name a) + SReify context -> \(Reify a) -> AField (sfromColumn context a) + + +stoColumn :: () + => SContext context + -> SNecessity necessity + -> AField context necessity a + -> Col context ('Spec labels necessity a) +stoColumn = \case + SAggregate -> \_ (AField a) -> Aggregation a + SExpr -> \_ (AField a) -> DB a + SIdentity -> \_ (AField a) -> Result a + SInsert -> \case + SRequired -> \(AField a) -> RequiredInsert a + SOptional -> \(AField a) -> OptionalInsert a + SName -> \_ (AField (Name a)) -> NameCol a + SReify context -> + \necessity (AField a) -> Reify (stoColumn context necessity a) + + +sbimapEither :: () + => SContext context + -> (a -> c) + -> (b -> d) + -> AHEither context a b + -> AHEither context c d +sbimapEither = \case + SAggregate -> \f g (AHEither a) -> AHEither (bimap f g a) + SExpr -> \f g (AHEither a) -> AHEither (bimap f g a) + SIdentity -> \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) + SReify context -> \f g (AHEither a) -> AHEither (sbimapEither context f g a) + + +sfromColumnsEither :: (Table (Reify context) a, Table (Reify context) b) + => SContext context + -> HEitherTable (Columns a) (Columns b) (Col (Reify context)) + -> AHEither context a b +sfromColumnsEither = \case + SAggregate -> + AHEither . + bimap (fromColumns . hreify) (fromColumns . hreify) . + fromColumns . + hunreify + SExpr -> + AHEither . + bimap (fromColumns . hreify) (fromColumns . hreify) . + fromColumns . + hunreify + SIdentity -> + AHEither . + bimap (fromColumns . hreify) (fromColumns . hreify) . + fromColumns . + hunreify + SInsert -> + AHEither . + bimap (fromColumns . hreify) (fromColumns . hreify) . + fromColumns . + hunreify + SName -> + AHEither . + bimap (fromColumns . hreify) (fromColumns . hreify) . + fromColumns . + hunreify + SReify context -> + AHEither . + sbimapEither context (fromColumns . hreify) (fromColumns . hreify) . + sfromColumnsEither context . + hunreify + + +stoColumnsEither :: (Table (Reify context) a, Table (Reify context) b) + => SContext context + -> AHEither context a b + -> HEitherTable (Columns a) (Columns b) (Col (Reify context)) +stoColumnsEither = \case + SAggregate -> + hreify . + toColumns . + bimap (hunreify . toColumns) (hunreify . toColumns) . + (\(AHEither a) -> a) + SExpr -> + hreify . + toColumns . + bimap (hunreify . toColumns) (hunreify . toColumns) . + (\(AHEither a) -> a) + SIdentity -> + hreify . + toColumns . + bimap (hunreify . toColumns) (hunreify . toColumns) . + (\(AHEither a) -> a) + SInsert -> + hreify . + toColumns . + bimap (hunreify . toColumns) (hunreify . toColumns) . + (\(AHEither a) -> a) + SName -> + hreify . + toColumns . + bimap (hunreify . toColumns) (hunreify . toColumns) . + (\(AHEither a) -> a) + SReify context -> + hreify . + stoColumnsEither context . + sbimapEither context (hunreify . toColumns) (hunreify . toColumns) . + (\(AHEither a) -> a) + + +smapList :: Congruent a b + => SContext context + -> (a -> b) + -> (HListTable (Columns a) (Col (Context a)) -> HListTable (Columns b) (Col (Context b))) + -> AHList context a + -> AHList context b +smapList = \case + SAggregate -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a)) + SExpr -> \_ f (AHList (ListTable a)) -> AHList (ListTable (f a)) + SIdentity -> \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)) + SReify context -> \f g (AHList as) -> AHList (smapList context f g as) + + +sfromColumnsList :: Table (Reify context) a + => SContext context + -> HListTable (Columns a) (Col (Reify context)) + -> AHList context a +sfromColumnsList = \case + SAggregate -> AHList . ListTable + SExpr -> AHList . ListTable + SIdentity -> AHList . fmap (fromColumns . hreify) . fromColumns . hunreify + SInsert -> AHList . ListTable + SName -> AHList . ListTable + SReify context -> + AHList . + smapList context (fromColumns . hreify) hreify . + sfromColumnsList context . + hunreify + + +stoColumnsList :: Table (Reify context) a + => SContext context + -> AHList context a + -> HListTable (Columns a) (Col (Reify context)) +stoColumnsList = \case + SAggregate -> \(AHList (ListTable a)) -> a + SExpr -> \(AHList (ListTable a)) -> a + SIdentity -> + hreify . toColumns . fmap (hunreify . toColumns) . (\(AHList a) -> a) + SInsert -> \(AHList (ListTable a)) -> a + SName -> \(AHList (ListTable a)) -> a + SReify context -> + hreify . + stoColumnsList context . + smapList context (hunreify . toColumns) hunreify . + (\(AHList a) -> a) + + +smapMaybe :: () + => SContext context + -> (a -> b) + -> AHMaybe context a + -> AHMaybe context b +smapMaybe = \case + SAggregate -> \f (AHMaybe a) -> AHMaybe (fmap f a) + SExpr -> \f (AHMaybe a) -> AHMaybe (fmap f a) + SIdentity -> \f (AHMaybe a) -> AHMaybe (fmap f a) + SInsert -> \f (AHMaybe a) -> AHMaybe (fmap f a) + SName -> \f (AHMaybe a) -> AHMaybe (fmap f a) + SReify context -> \f (AHMaybe a) -> AHMaybe (smapMaybe context f a) + + +sfromColumnsMaybe :: Table (Reify context) a + => SContext context + -> HMaybeTable (Columns a) (Col (Reify context)) + -> AHMaybe context a +sfromColumnsMaybe = \case + SAggregate -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify + SExpr -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify + SIdentity -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify + SInsert -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify + SName -> AHMaybe . fmap (fromColumns . hreify) . fromColumns . hunreify + SReify context -> + AHMaybe . + smapMaybe context (fromColumns . hreify) . + sfromColumnsMaybe context . + hunreify + + +stoColumnsMaybe :: Table (Reify context) a + => SContext context + -> AHMaybe context a + -> HMaybeTable (Columns a) (Col (Reify context)) +stoColumnsMaybe = \case + SAggregate -> + hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a) + SExpr -> + hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a) + SIdentity -> + hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a) + SInsert -> + hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a) + SName -> + hreify . toColumns . fmap (hunreify . toColumns) . (\(AHMaybe a) -> a) + SReify context -> + hreify . + stoColumnsMaybe context . + smapMaybe context (hunreify . toColumns) . + (\(AHMaybe a) -> a) + + +smapNonEmpty :: Congruent a b + => SContext context + -> (a -> b) + -> (HNonEmptyTable (Columns a) (Col (Context a)) -> HNonEmptyTable (Columns b) (Col (Context b))) + -> AHNonEmpty context a + -> AHNonEmpty context b +smapNonEmpty = \case + SAggregate -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a)) + SExpr -> \_ f (AHNonEmpty (NonEmptyTable a)) -> AHNonEmpty (NonEmptyTable (f a)) + SIdentity -> \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)) + SReify context -> \f g (AHNonEmpty as) -> AHNonEmpty (smapNonEmpty context f g as) + + +sfromColumnsNonEmpty :: Table (Reify context) a + => SContext context + -> HNonEmptyTable (Columns a) (Col (Reify context)) + -> AHNonEmpty context a +sfromColumnsNonEmpty = \case + SAggregate -> AHNonEmpty . NonEmptyTable + SExpr -> AHNonEmpty . NonEmptyTable + SIdentity -> + AHNonEmpty . fmap (fromColumns . hreify) . fromColumns . hunreify + SInsert -> AHNonEmpty . NonEmptyTable + SName -> AHNonEmpty . NonEmptyTable + SReify context -> + AHNonEmpty . + smapNonEmpty context (fromColumns . hreify) hreify . + sfromColumnsNonEmpty context . + hunreify + + +stoColumnsNonEmpty :: Table (Reify context) a + => SContext context + -> AHNonEmpty context a + -> HNonEmptyTable (Columns a) (Col (Reify context)) +stoColumnsNonEmpty = \case + SAggregate -> \(AHNonEmpty (NonEmptyTable a)) -> a + SExpr -> \(AHNonEmpty (NonEmptyTable a)) -> a + SIdentity -> + hreify . toColumns . fmap (hunreify . toColumns) . (\(AHNonEmpty a) -> a) + SInsert -> \(AHNonEmpty (NonEmptyTable a)) -> a + SName -> \(AHNonEmpty (NonEmptyTable a)) -> a + SReify context -> + hreify . + stoColumnsNonEmpty context . + smapNonEmpty context (hunreify . toColumns) hunreify . + (\(AHNonEmpty a) -> a) + + +sbimapThese :: () + => SContext context + -> (a -> c) + -> (b -> d) + -> AHThese context a b + -> AHThese context c d +sbimapThese = \case + SAggregate -> \f g (AHThese a) -> AHThese (bimap f g a) + SExpr -> \f g (AHThese a) -> AHThese (bimap f g a) + SIdentity -> \f g (AHThese a) -> AHThese (bimap f g a) + SInsert -> \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) + + +sfromColumnsThese :: (Table (Reify context) a, Table (Reify context) b) + => SContext context + -> HTheseTable (Columns a) (Columns b) (Col (Reify context)) + -> AHThese context a b +sfromColumnsThese = \case + SAggregate -> + AHThese . + bimap (fromColumns . hreify) (fromColumns . hreify) . + fromColumns . + hunreify + SExpr -> + AHThese . + bimap (fromColumns . hreify) (fromColumns . hreify) . + fromColumns . + hunreify + SIdentity -> + AHThese . + bimap (fromColumns . hreify) (fromColumns . hreify) . + fromColumns . + hunreify + SInsert -> + AHThese . + bimap (fromColumns . hreify) (fromColumns . hreify) . + fromColumns . + hunreify + SName -> + AHThese . + bimap (fromColumns . hreify) (fromColumns . hreify) . + fromColumns . + hunreify + SReify context -> + AHThese . + sbimapThese context (fromColumns . hreify) (fromColumns . hreify) . + sfromColumnsThese context . + hunreify + + +stoColumnsThese :: (Table (Reify context) a, Table (Reify context) b) + => SContext context + -> AHThese context a b + -> HTheseTable (Columns a) (Columns b) (Col (Reify context)) +stoColumnsThese = \case + SAggregate -> + hreify . + toColumns . + bimap (hunreify . toColumns) (hunreify . toColumns) . + (\(AHThese a) -> a) + SExpr -> + hreify . + toColumns . + bimap (hunreify . toColumns) (hunreify . toColumns) . + (\(AHThese a) -> a) + SIdentity -> + hreify . + toColumns . + bimap (hunreify . toColumns) (hunreify . toColumns) . + (\(AHThese a) -> a) + SInsert -> + hreify . + toColumns . + bimap (hunreify . toColumns) (hunreify . toColumns) . + (\(AHThese a) -> a) + SName -> + hreify . + toColumns . + bimap (hunreify . toColumns) (hunreify . toColumns) . + (\(AHThese a) -> a) + SReify context -> + hreify . + stoColumnsThese context . + sbimapThese context (hunreify . toColumns) (hunreify . toColumns) . + (\(AHThese a) -> a) + + +hreify :: HTable t => t (Col context) -> t (Col (Reify context)) +hreify a = htabulate $ \field -> Reify (hfield a field) + + +hunreify :: HTable t => t (Col (Reify context)) -> t (Col context) +hunreify a = htabulate $ \field -> case hfield a field of + Reify x -> x diff --git a/src/Rel8/Schema/Generic.hs b/src/Rel8/Schema/Generic.hs index a33654e..208c924 100644 --- a/src/Rel8/Schema/Generic.hs +++ b/src/Rel8/Schema/Generic.hs @@ -6,13 +6,13 @@ {-# language FlexibleInstances #-} {-# language GADTs #-} {-# language MultiParamTypeClasses #-} +{-# language QuantifiedConstraints #-} {-# language ScopedTypeVariables #-} {-# language StandaloneKindSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} -{-# language ViewPatterns #-} {-# options_ghc -fno-warn-orphans #-} @@ -22,113 +22,44 @@ module Rel8.Schema.Generic where -- base -import Data.Bifunctor ( bimap ) -import Data.Functor.Identity ( Identity ) import Data.Kind ( Constraint, Type ) -import Data.List.NonEmpty ( NonEmpty ) import GHC.Generics ( Generic, Rep, from, to , (:*:)( (:*:) ), K1( K1 ), M1( M1 ) - , D, C, S + , D, S , Meta( MetaSel ) ) -import GHC.TypeLits ( Symbol, KnownSymbol ) +import qualified GHC.Generics as G ( C ) +import GHC.TypeLits ( KnownSymbol ) import Prelude +import Unsafe.Coerce ( unsafeCoerce ) -- rel8 -import Rel8.Aggregate ( Aggregate, Col(..) ) -import Rel8.Expr ( Expr, Col(..) ) -import Rel8.Kind.Necessity - ( SNecessity( SRequired, SOptional ) - , KnownNecessity, necessitySing - ) -import Rel8.Schema.Context ( Col(..) ) -import Rel8.Schema.Context.Identity - ( fromHEitherTable, toHEitherTable - , fromHListTable, toHListTable - , fromHMaybeTable, toHMaybeTable - , fromHNonEmptyTable, toHNonEmptyTable - , fromHTheseTable, toHTheseTable - ) -import Rel8.Schema.Context.Label - ( Labelable, labeler, unlabeler - , hlabeler, hunlabeler - ) -import Rel8.Schema.Field ( Field ) +import Rel8.Schema.Context ( Col ) +import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler ) +import Rel8.Schema.Field ( Reify, Reifiable, hreify, hunreify ) import Rel8.Schema.HTable ( HTable ) -import Rel8.Schema.HTable.Either ( HEitherTable ) -import Rel8.Schema.HTable.Identity ( HIdentity(..) ) import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel ) -import Rel8.Schema.HTable.List ( HListTable ) -import Rel8.Schema.HTable.Maybe ( HMaybeTable ) -import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable ) import Rel8.Schema.HTable.Pair ( HPair(..) ) -import Rel8.Schema.HTable.Quartet ( HQuartet(..) ) -import Rel8.Schema.HTable.Quintet ( HQuintet(..) ) -import Rel8.Schema.HTable.These ( HTheseTable ) -import Rel8.Schema.HTable.Trio ( HTrio(..) ) -import Rel8.Schema.HTable.Vectorize ( hrelabel ) -import Rel8.Schema.Insert ( Insert, Col(..) ) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Name ( Name( Name ), Col(..) ) -import Rel8.Schema.Spec ( Spec( Spec ), KTable ) -import Rel8.Schema.Structure - ( IsStructure, Shape(..), Shape1, Shape2 - , Structure - ) +import Rel8.Schema.Spec ( KTable ) import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns ) -import Rel8.Table.Either ( EitherTable ) -import Rel8.Table.Lifted - ( fromColumns1, toColumns1 - , fromColumns2, toColumns2 - ) -import Rel8.Table.List ( ListTable ) -import Rel8.Table.Maybe ( MaybeTable(..) ) -import Rel8.Table.NonEmpty ( NonEmptyTable ) -import Rel8.Table.These ( TheseTable ) - --- these -import Data.These ( These ) -instance (Rel8able t, TableHelper context) => Table context (t context) where - type Columns (t context) = GRep t +instance + ( Rel8able t + , Labelable context + , Reifiable context + , HTable (GRep context t) + ) => Table context (t context) + where + type Columns (t context) = GRep context t type Context (t context) = context - fromColumns = gfromColumns - toColumns = gtoColumns - -type TableHelper :: K.Context -> Constraint -class TableHelper context where - gfromColumns :: Rel8able t => GRep t (Col context) -> t context - gtoColumns :: Rel8able t => t context -> GRep t (Col context) - - -instance TableHelper Aggregate where - gfromColumns = fromAggregateColumns - gtoColumns = toAggregateColumns - - -instance TableHelper Expr where - gfromColumns = fromExprColumns - gtoColumns = toExprColumns - - -instance TableHelper Insert where - gfromColumns = fromInsertColumns - gtoColumns = toInsertColumns - - -instance TableHelper Identity where - gfromColumns = fromIdentityColumns - gtoColumns = toIdentityColumns - - -instance TableHelper Name where - gfromColumns = fromNameColumns - gtoColumns = toNameColumns + fromColumns = unreify . gfromColumns . hreify + toColumns = hunreify . gtoColumns . reify -- | This type class allows you to define custom 'Table's using higher-kinded @@ -174,876 +105,88 @@ instance TableHelper Name where -- deriving ( GHC.Generics.Generic, Rel8able ) -- @ type Rel8able :: KTable -> Constraint -class HTable (GRep t) => Rel8able t where - type GRep t :: K.HTable +class Rel8able t where + gfromColumns :: (Labelable context, Reifiable context) + => GRep context t (Col (Reify context)) -> t (Reify context) - fromAggregateColumns :: GRep t (Col Aggregate) -> t Aggregate - toAggregateColumns :: t Aggregate -> GRep t (Col Aggregate) + gtoColumns :: (Labelable context, Reifiable context) + => t (Reify context) -> GRep context t (Col (Reify context)) - fromExprColumns :: GRep t (Col Expr) -> t Expr - toExprColumns :: t Expr -> GRep t (Col Expr) + default gfromColumns :: forall context. + ( Generic (t (Reify context)) + , GRel8able context (Rep (t (Reify context))) + ) => GRep context t (Col (Reify context)) -> t (Reify context) + gfromColumns = to . fromGColumns @_ @(Rep (t (Reify context))) - fromInsertColumns :: GRep t (Col Insert) -> t Insert - toInsertColumns :: t Insert -> GRep t (Col Insert) + default gtoColumns :: forall context. + ( Generic (t (Reify context)) + , GRel8able context (Rep (t (Reify context))) + ) => t (Reify context) -> GRep context t (Col (Reify context)) + gtoColumns = toGColumns @_ @(Rep (t (Reify context))) . from - fromIdentityColumns :: GRep t (Col Identity) -> t Identity - toIdentityColumns :: t Identity -> GRep t (Col Identity) - fromNameColumns :: GRep t (Col Name) -> t Name - toNameColumns :: t Name -> GRep t (Col Name) - - type GRep t = GColumns (Rep (t Structure)) - - default fromAggregateColumns :: - ( Generic (t Aggregate) - , GColumns (Rep (t Structure)) ~ GRep t - , GRel8able Aggregate (Rep (t Structure)) (Rep (t Aggregate)) - ) => GRep t (Col Aggregate) -> t Aggregate - fromAggregateColumns = to . fromGColumns @_ @(Rep (t Structure)) - - default toAggregateColumns :: - ( Generic (t Aggregate) - , GColumns (Rep (t Structure)) ~ GRep t - , GRel8able Aggregate (Rep (t Structure)) (Rep (t Aggregate)) - ) => t Aggregate -> GRep t (Col Aggregate) - toAggregateColumns = toGColumns @_ @(Rep (t Structure)) . from - - default fromExprColumns :: - ( Generic (t Expr) - , GColumns (Rep (t Structure)) ~ GRep t - , GRel8able Expr (Rep (t Structure)) (Rep (t Expr)) - ) => GRep t (Col Expr) -> t Expr - fromExprColumns = to . fromGColumns @_ @(Rep (t Structure)) - - default toExprColumns :: - ( Generic (t Expr) - , GColumns (Rep (t Structure)) ~ GRep t - , GRel8able Expr (Rep (t Structure)) (Rep (t Expr)) - ) => t Expr -> GRep t (Col Expr) - toExprColumns = toGColumns @_ @(Rep (t Structure)) . from - - default fromInsertColumns :: - ( Generic (t Insert) - , GColumns (Rep (t Structure)) ~ GRep t - , GRel8able Insert (Rep (t Structure)) (Rep (t Insert)) - ) => GRep t (Col Insert) -> t Insert - fromInsertColumns = to . fromGColumns @_ @(Rep (t Structure)) - - default toInsertColumns :: - ( Generic (t Insert) - , GColumns (Rep (t Structure)) ~ GRep t - , GRel8able Insert (Rep (t Structure)) (Rep (t Insert)) - ) => t Insert -> GRep t (Col Insert) - toInsertColumns = toGColumns @_ @(Rep (t Structure)) . from - - default fromIdentityColumns :: - ( Generic (t Identity) - , GColumns (Rep (t Structure)) ~ GRep t - , GRel8able Identity (Rep (t Structure)) (Rep (t Identity)) - ) => GRep t (Col Identity) -> t Identity - fromIdentityColumns = to . fromGColumns @_ @(Rep (t Structure)) - - default toIdentityColumns :: - ( Generic (t Identity) - , GColumns (Rep (t Structure)) ~ GRep t - , GRel8able Identity (Rep (t Structure)) (Rep (t Identity)) - ) => t Identity -> GRep t (Col Identity) - toIdentityColumns = toGColumns @_ @(Rep (t Structure)) . from - - default fromNameColumns :: - ( Generic (t Name) - , GColumns (Rep (t Structure)) ~ GRep t - , GRel8able Name (Rep (t Structure)) (Rep (t Name)) - ) => GRep t (Col Name) -> t Name - fromNameColumns = to . fromGColumns @_ @(Rep (t Structure)) - - default toNameColumns :: - ( Generic (t Name) - , GColumns (Rep (t Structure)) ~ GRep t - , GRel8able Name (Rep (t Structure)) (Rep (t Name)) - ) => t Name -> GRep t (Col Name) - toNameColumns = toGColumns @_ @(Rep (t Structure)) . from +type GRep :: K.Context -> K.Table -> K.HTable +type GRep context t = GColumns (Rep (t (Reify context))) type GColumns :: (Type -> Type) -> K.HTable -type family GColumns structure where - GColumns (M1 D _ structure) = GColumns structure - GColumns (M1 C _ structure) = GColumns structure - GColumns (a :*: b) = HPair (GColumns a) (GColumns b) - GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ structure)) = - K1Columns label structure +type family GColumns rep where + GColumns (M1 D _ rep) = GColumns rep + GColumns (M1 G.C _ rep) = GColumns rep + GColumns (rep1 :*: rep2) = HPair (GColumns rep1) (GColumns rep2) + GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ a)) = + HLabel label (Columns a) -type GRel8able :: K.Context -> (Type -> Type) -> (Type -> Type) -> Constraint -class GRel8able context structure rep where - fromGColumns :: GColumns structure (Col context) -> rep x - toGColumns :: rep x -> GColumns structure (Col context) +type GRel8able :: K.Context -> (Type -> Type) -> Constraint +class GRel8able context rep where + fromGColumns :: GColumns rep (Col (Reify context)) -> rep x + toGColumns :: rep x -> GColumns rep (Col (Reify context)) -instance GRel8able context structure rep => GRel8able context (M1 D c structure) (M1 D c rep) where - fromGColumns = M1 . fromGColumns @context @structure @rep - toGColumns (M1 a) = toGColumns @context @structure @rep a +instance GRel8able context rep => GRel8able context (M1 D c rep) where + fromGColumns = M1 . fromGColumns @context @rep + toGColumns (M1 a) = toGColumns @context @rep a -instance GRel8able context structure rep => GRel8able context (M1 C c structure) (M1 C c rep) where - fromGColumns = M1 . fromGColumns @context @structure @rep - toGColumns (M1 a) = toGColumns @context @structure @rep a +instance GRel8able context rep => GRel8able context (M1 G.C c rep) where + fromGColumns = M1 . fromGColumns @context @rep + toGColumns (M1 a) = toGColumns @context @rep a -instance (GRel8able context structure1 rep1, GRel8able context structure2 rep2) => - GRel8able context (structure1 :*: structure2) (rep1 :*: rep2) +instance (GRel8able context rep1, GRel8able context rep2) => + GRel8able context (rep1 :*: rep2) where fromGColumns (HPair a b) = - fromGColumns @context @structure1 @rep1 a :*: - fromGColumns @context @structure2 @rep2 b + fromGColumns @context @rep1 a :*: fromGColumns @context @rep2 b toGColumns (a :*: b) = - HPair - (toGColumns @context @structure1 @rep1 a) - (toGColumns @context @structure2 @rep2 b) + HPair (toGColumns @context @rep1 a) (toGColumns @context @rep2 b) instance - ( K1Table label context isStructure structure a + ( Table (Reify context) a + , Labelable context + , KnownSymbol label + , GColumns (M1 S meta k1) ~ HLabel label (Columns a) , meta ~ 'MetaSel ('Just label) _su _ss _ds - , structureK1 ~ K1 i structure , k1 ~ K1 i a - ) => GRel8able context (M1 S meta structureK1) (M1 S meta k1) + ) => GRel8able context (M1 S meta k1) where - fromGColumns = M1 . K1 . fromK1Columns @label @_ @_ @structure - toGColumns (M1 (K1 a)) = toK1Columns @label @_ @_ @structure a + fromGColumns = M1 . K1 . fromColumns . hunlabel unlabeler + toGColumns (M1 (K1 a)) = hlabel labeler (toColumns a) -type K1Columns :: Symbol -> Type -> K.HTable -type family K1Columns label structure where - K1Columns label (Shape1 'Column ('Spec '[] necessity a)) = - HIdentity ('Spec '[label] necessity a) - K1Columns _label (Shape1 'Column ('Spec (label ': labels) necessity a)) = - HIdentity ('Spec (label ': labels) necessity a) - K1Columns label (Shape2 'Either a b) = - HLabel label (HEitherTable (K1Columns "Left" a) (K1Columns "Right" b)) - K1Columns label (Shape1 'List a) = HListTable (K1Columns label a) - K1Columns label (Shape1 'Maybe a) = HLabel label (HMaybeTable (K1Columns "Just" a)) - K1Columns label (Shape1 'NonEmpty a) = HNonEmptyTable (K1Columns label a) - K1Columns label (Shape2 'These a b) = - HLabel label (HTheseTable (K1Columns "Here" a) (K1Columns "There" b)) - K1Columns label (a, b) = - HLabel label - (HPair - (K1Columns "fst" a) - (K1Columns "snd" b)) - K1Columns label (a, b, c) = - HLabel label - (HTrio - (K1Columns "fst" a) - (K1Columns "snd" b) - (K1Columns "trd" c)) - K1Columns label (a, b, c, d) = - HLabel label - (HQuartet - (K1Columns "fst" a) - (K1Columns "snd" b) - (K1Columns "trd" c) - (K1Columns "frt" d)) - K1Columns label (a, b, c, d, e) = - HLabel label - (HQuintet - (K1Columns "fst" a) - (K1Columns "snd" b) - (K1Columns "trd" c) - (K1Columns "frt" d) - (K1Columns "fft" e)) - K1Columns label a = HLabel label (Columns a) +reify :: + (-- Rel8able t + --, forall necessity a. Coercible (Field context necessity a) (AField context necessity a) => Coercible (t context) (t (Reify context)) + ) + => t context -> t (Reify context) +reify = unsafeCoerce -type K1Table :: Symbol -> K.Context -> Bool -> Type -> Type -> Constraint -class isStructure ~ IsStructure structure => - K1Table label context isStructure structure a - where - fromK1Columns :: K1Columns label structure (Col context) -> a - toK1Columns :: a -> K1Columns label structure (Col context) - - -instance - ( x ~ Field Aggregate '[] necessity a - ) => K1Table label Aggregate 'True (Shape1 'Column ('Spec '[] necessity a)) x - where - fromK1Columns (HIdentity (Aggregation a)) = a - toK1Columns = HIdentity . Aggregation - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( x ~ Field Aggregate (label ': labels) necessity a - ) => K1Table _label Aggregate 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x - where - fromK1Columns (HIdentity (Aggregation a)) = a - toK1Columns = HIdentity . Aggregation - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( x ~ Field Expr '[] necessity a - ) => K1Table label Expr 'True (Shape1 'Column ('Spec '[] necessity a)) x - where - fromK1Columns (HIdentity (DB a)) = a - toK1Columns = HIdentity . DB - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( x ~ Field Expr (label ': labels) necessity a - ) => K1Table _label Expr 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x - where - fromK1Columns (HIdentity (DB a)) = a - toK1Columns = HIdentity . DB - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( x ~ Field Insert '[] necessity a - , KnownNecessity necessity - ) => K1Table label Insert 'True (Shape1 'Column ('Spec '[] necessity a)) x - where - fromK1Columns (HIdentity insert) = case insert of - RequiredInsert a -> a - OptionalInsert ma -> ma - toK1Columns a = HIdentity $ case necessitySing @necessity of - SRequired -> RequiredInsert a - SOptional -> OptionalInsert a - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( x ~ Field Insert (label ': labels) necessity a - , KnownNecessity necessity - ) => K1Table _label Insert 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x - where - fromK1Columns (HIdentity insert) = case insert of - RequiredInsert a -> a - OptionalInsert ma -> ma - toK1Columns a = HIdentity $ case necessitySing @necessity of - SRequired -> RequiredInsert a - SOptional -> OptionalInsert a - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( x ~ Field Identity '[] necessity a - ) => K1Table label Identity 'True (Shape1 'Column ('Spec '[] necessity a)) x - where - fromK1Columns (HIdentity (Result a)) = a - toK1Columns = HIdentity . Result - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( x ~ Field Identity (label ': labels) necessity a - ) => K1Table _label Identity 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x - where - fromK1Columns (HIdentity (Result a)) = a - toK1Columns = HIdentity . Result - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( x ~ Field Name '[] necessity a - ) => K1Table _label Name 'True (Shape1 'Column ('Spec (label ': labels) necessity a)) x - where - fromK1Columns (HIdentity (NameCol a)) = Name a - toK1Columns (Name a) = HIdentity (NameCol a) - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( x ~ Field Name (label ': labels) necessity a - ) => K1Table label Name 'True (Shape1 'Column ('Spec '[] necessity a)) x - where - fromK1Columns = Name . (\(NameCol a) -> a) . unlabeler . unHIdentity - toK1Columns = HIdentity . labeler . NameCol . (\(Name a) -> a) - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( HTable (K1Columns "Left" structure1) - , HTable (K1Columns "Right" structure2) - , K1Table "Left" Aggregate (IsStructure structure1) structure1 a - , K1Table "Right" Aggregate (IsStructure structure2) structure2 b - , e ~ EitherTable a b - , KnownSymbol label - ) => K1Table label Aggregate 'True (Shape2 'Either structure1 structure2) e - where - fromK1Columns = - fromColumns2 - (fromK1Columns @"Left" @_ @_ @structure1) - (fromK1Columns @"Right" @_ @_ @structure2) . - hunlabel unlabeler - toK1Columns = - hlabel labeler . - toColumns2 - (toK1Columns @"Left" @_ @_ @structure1) - (toK1Columns @"Right" @_ @_ @structure2) - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( HTable (K1Columns "Left" structure1) - , HTable (K1Columns "Right" structure2) - , K1Table "Left" Expr (IsStructure structure1) structure1 a - , K1Table "Right" Expr (IsStructure structure2) structure2 b - , e ~ EitherTable a b - , KnownSymbol label - ) => K1Table label Expr 'True (Shape2 'Either structure1 structure2) e - where - fromK1Columns = - fromColumns2 - (fromK1Columns @"Left" @_ @_ @structure1) - (fromK1Columns @"Right" @_ @_ @structure2) . - hunlabel unlabeler - toK1Columns = - hlabel labeler . - toColumns2 - (toK1Columns @"Left" @_ @_ @structure1) - (toK1Columns @"Right" @_ @_ @structure2) - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( HTable (K1Columns "Left" structure1) - , HTable (K1Columns "Right" structure2) - , K1Table "Left" Insert (IsStructure structure1) structure1 a - , K1Table "Right" Insert (IsStructure structure2) structure2 b - , e ~ EitherTable a b - , KnownSymbol label - ) => K1Table label Insert 'True (Shape2 'Either structure1 structure2) e - where - fromK1Columns = - fromColumns2 - (fromK1Columns @"Left" @_ @_ @structure1) - (fromK1Columns @"Right" @_ @_ @structure2) . - hunlabel unlabeler - toK1Columns = - hlabel labeler . - toColumns2 - (toK1Columns @"Left" @_ @_ @structure1) - (toK1Columns @"Right" @_ @_ @structure2) - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( HTable (K1Columns "Left" structure1) - , HTable (K1Columns "Right" structure2) - , K1Table "Left" Identity (IsStructure structure1) structure1 a - , K1Table "Right" Identity (IsStructure structure2) structure2 b - , e ~ Either a b - , KnownSymbol label - ) => K1Table label Identity 'True (Shape2 'Either structure1 structure2) e - where - fromK1Columns - = bimap - (fromK1Columns @"Left" @_ @_ @structure1) - (fromK1Columns @"Right" @_ @_ @structure2) - . fromHEitherTable - . hunlabel unlabeler - toK1Columns - = hlabel labeler - . toHEitherTable - . bimap - (toK1Columns @"Left" @_ @_ @structure1) - (toK1Columns @"Right" @_ @_ @structure2) - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( HTable (K1Columns "Left" structure1) - , HTable (K1Columns "Right" structure2) - , K1Table "Left" Name (IsStructure structure1) structure1 a - , K1Table "Right" Name (IsStructure structure2) structure2 b - , e ~ EitherTable a b - , KnownSymbol label - ) => K1Table label Name 'True (Shape2 'Either structure1 structure2) e - where - fromK1Columns = - fromColumns2 - (fromK1Columns @"Left" @_ @_ @structure1) - (fromK1Columns @"Right" @_ @_ @structure2) . - hunlabel unlabeler - toK1Columns = - hlabel labeler . - toColumns2 - (toK1Columns @"Left" @_ @_ @structure1) - (toK1Columns @"Right" @_ @_ @structure2) - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( Table Aggregate a - , K1Columns label structure ~ HLabel label (Columns a) - , as ~ ListTable a - , KnownSymbol label - ) => K1Table label Aggregate 'True (Shape1 'List structure) as - where - fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler) - toK1Columns = hrelabel (hlabel hlabeler) . toColumns - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( Table Expr a - , K1Columns label structure ~ HLabel label (Columns a) - , as ~ ListTable a - , KnownSymbol label - ) => K1Table label Expr 'True (Shape1 'List structure) as - where - fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler) - toK1Columns = hrelabel (hlabel hlabeler) . toColumns - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( Table Insert a - , K1Columns label structure ~ HLabel label (Columns a) - , as ~ ListTable a - , KnownSymbol label - ) => K1Table label Insert 'True (Shape1 'List structure) as - where - fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler) - toK1Columns = hrelabel (hlabel hlabeler) . toColumns - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( K1Table label Identity (IsStructure structure) structure a - , HTable (K1Columns label structure) - , as ~ [a] - ) => K1Table label Identity 'True (Shape1 'List structure) as - where - fromK1Columns = fmap (fromK1Columns @label @_ @_ @structure) . fromHListTable - toK1Columns = toHListTable . fmap (toK1Columns @label @_ @_ @structure) - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( Table Name a - , K1Columns label structure ~ HLabel label (Columns a) - , as ~ ListTable a - , KnownSymbol label - ) => K1Table label Name 'True (Shape1 'List structure) as - where - fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler) - toK1Columns = hrelabel (hlabel hlabeler) . toColumns - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( HTable (K1Columns "Just" structure) - , K1Table "Just" Aggregate (IsStructure structure) structure a - , ma ~ MaybeTable a - , KnownSymbol label - ) => K1Table label Aggregate 'True (Shape1 'Maybe structure) ma - where - fromK1Columns = - fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) . - hunlabel unlabeler - toK1Columns = - hlabel labeler . - toColumns1 (toK1Columns @"Just" @_ @_ @structure) - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( HTable (K1Columns "Just" structure) - , K1Table "Just" Expr (IsStructure structure) structure a - , ma ~ MaybeTable a - , KnownSymbol label - ) => K1Table label Expr 'True (Shape1 'Maybe structure) ma - where - fromK1Columns = - fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) . - hunlabel unlabeler - toK1Columns = - hlabel labeler . - toColumns1 (toK1Columns @"Just" @_ @_ @structure) - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( HTable (K1Columns "Just" structure) - , K1Table "Just" Insert (IsStructure structure) structure a - , ma ~ MaybeTable a - , KnownSymbol label - ) => K1Table label Insert 'True (Shape1 'Maybe structure) ma - where - fromK1Columns = - fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) . - hunlabel unlabeler - toK1Columns = - hlabel labeler . - toColumns1 (toK1Columns @"Just" @_ @_ @structure) - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( HTable (K1Columns "Just" structure) - , K1Table "Just" Identity (IsStructure structure) structure a - , ma ~ Maybe a - , KnownSymbol label - ) => K1Table label Identity 'True (Shape1 'Maybe structure) ma - where - fromK1Columns - = fmap (fromK1Columns @"Just" @_ @_ @structure) - . fromHMaybeTable - . hunlabel unlabeler - toK1Columns - = hlabel labeler - . toHMaybeTable - . fmap (toK1Columns @"Just" @_ @_ @structure) - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( HTable (K1Columns "Just" structure) - , K1Table "Just" Name (IsStructure structure) structure a - , ma ~ MaybeTable a - , KnownSymbol label - ) => K1Table label Name 'True (Shape1 'Maybe structure) ma - where - fromK1Columns = - fromColumns1 (fromK1Columns @"Just" @_ @_ @structure) . - hunlabel unlabeler - toK1Columns = - hlabel labeler . - toColumns1 (toK1Columns @"Just" @_ @_ @structure) - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( Table Aggregate a - , K1Columns label structure ~ HLabel label (Columns a) - , as ~ NonEmptyTable a - , KnownSymbol label - ) => K1Table label Aggregate 'True (Shape1 'NonEmpty structure) as - where - fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler) - toK1Columns = hrelabel (hlabel hlabeler) . toColumns - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( Table Expr a - , K1Columns label structure ~ HLabel label (Columns a) - , as ~ NonEmptyTable a - , KnownSymbol label - ) => K1Table label Expr 'True (Shape1 'NonEmpty structure) as - where - fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler) - toK1Columns = hrelabel (hlabel hlabeler) . toColumns - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( Table Insert a - , K1Columns label structure ~ HLabel label (Columns a) - , as ~ NonEmptyTable a - , KnownSymbol label - ) => K1Table label Insert 'True (Shape1 'NonEmpty structure) as - where - fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler) - toK1Columns = hrelabel (hlabel hlabeler) . toColumns - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( K1Table label Identity (IsStructure structure) structure a - , HTable (K1Columns label structure) - , as ~ NonEmpty a - ) => K1Table label Identity 'True (Shape1 'NonEmpty structure) as - where - fromK1Columns = fmap (fromK1Columns @label @_ @_ @structure) . fromHNonEmptyTable - toK1Columns = toHNonEmptyTable . fmap (toK1Columns @label @_ @_ @structure) - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( Table Name a - , K1Columns label structure ~ HLabel label (Columns a) - , as ~ NonEmptyTable a - , KnownSymbol label - ) => K1Table label Name 'True (Shape1 'NonEmpty structure) as - where - fromK1Columns = fromColumns . hrelabel (hunlabel hunlabeler) - toK1Columns = hrelabel (hlabel hlabeler) . toColumns - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( HTable (K1Columns "Here" structure1) - , HTable (K1Columns "There" structure2) - , K1Table "Here" Aggregate (IsStructure structure1) structure1 a - , K1Table "There" Aggregate (IsStructure structure2) structure2 b - , e ~ TheseTable a b - , KnownSymbol label - ) => K1Table label Aggregate 'True (Shape2 'These structure1 structure2) e - where - fromK1Columns = - fromColumns2 - (fromK1Columns @"Here" @_ @_ @structure1) - (fromK1Columns @"There" @_ @_ @structure2) . - hunlabel unlabeler - toK1Columns = - hlabel labeler . - toColumns2 - (toK1Columns @"Here" @_ @_ @structure1) - (toK1Columns @"There" @_ @_ @structure2) - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( HTable (K1Columns "Here" structure1) - , HTable (K1Columns "There" structure2) - , K1Table "Here" Expr (IsStructure structure1) structure1 a - , K1Table "There" Expr (IsStructure structure2) structure2 b - , e ~ TheseTable a b - , KnownSymbol label - ) => K1Table label Expr 'True (Shape2 'These structure1 structure2) e - where - fromK1Columns = - fromColumns2 - (fromK1Columns @"Here" @_ @_ @structure1) - (fromK1Columns @"There" @_ @_ @structure2) . - hunlabel unlabeler - toK1Columns = - hlabel labeler . - toColumns2 - (toK1Columns @"Here" @_ @_ @structure1) - (toK1Columns @"There" @_ @_ @structure2) - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( HTable (K1Columns "Here" structure1) - , HTable (K1Columns "There" structure2) - , K1Table "Here" Insert (IsStructure structure1) structure1 a - , K1Table "There" Insert (IsStructure structure2) structure2 b - , e ~ TheseTable a b - , KnownSymbol label - ) => K1Table label Insert 'True (Shape2 'These structure1 structure2) e - where - fromK1Columns = - fromColumns2 - (fromK1Columns @"Here" @_ @_ @structure1) - (fromK1Columns @"There" @_ @_ @structure2) . - hunlabel unlabeler - toK1Columns = - hlabel labeler . - toColumns2 - (toK1Columns @"Here" @_ @_ @structure1) - (toK1Columns @"There" @_ @_ @structure2) - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( HTable (K1Columns "Here" structure1) - , HTable (K1Columns "There" structure2) - , K1Table "Here" Identity (IsStructure structure1) structure1 a - , K1Table "There" Identity (IsStructure structure2) structure2 b - , e ~ These a b - , KnownSymbol label - ) => K1Table label Identity 'True (Shape2 'These structure1 structure2) e - where - fromK1Columns - = bimap - (fromK1Columns @"Here" @_ @_ @structure1) - (fromK1Columns @"There" @_ @_ @structure2) - . fromHTheseTable - . hunlabel unlabeler - toK1Columns - = hlabel labeler - . toHTheseTable - . bimap - (toK1Columns @"Here" @_ @_ @structure1) - (toK1Columns @"There" @_ @_ @structure2) - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( HTable (K1Columns "Here" structure1) - , HTable (K1Columns "There" structure2) - , K1Table "Here" Name (IsStructure structure1) structure1 a - , K1Table "There" Name (IsStructure structure2) structure2 b - , e ~ TheseTable a b - , KnownSymbol label - ) => K1Table label Name 'True (Shape2 'These structure1 structure2) e - where - fromK1Columns = - fromColumns2 - (fromK1Columns @"Here" @_ @_ @structure1) - (fromK1Columns @"There" @_ @_ @structure2) . - hunlabel unlabeler - toK1Columns = - hlabel labeler . - toColumns2 - (toK1Columns @"Here" @_ @_ @structure1) - (toK1Columns @"There" @_ @_ @structure2) - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( K1Table "fst" context (IsStructure structure1) structure1 a1 - , K1Table "snd" context (IsStructure structure2) structure2 a2 - , HTable (K1Columns "fst" structure1) - , HTable (K1Columns "snd" structure2) - , Labelable context - , a ~ (a1, a2) - , KnownSymbol label - ) => K1Table label context 'True (structure1, structure2) a - where - fromK1Columns (hunlabel unlabeler -> (HPair a b)) = - ( fromK1Columns @"fst" @_ @_ @structure1 a - , fromK1Columns @"snd" @_ @_ @structure2 b - ) - toK1Columns (a, b) = hlabel labeler $ HPair - { hfst = toK1Columns @"fst" @_ @_ @structure1 a - , hsnd = toK1Columns @"snd" @_ @_ @structure2 b - } - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( K1Table "fst" context (IsStructure structure1) structure1 a1 - , K1Table "snd" context (IsStructure structure2) structure2 a2 - , K1Table "trd" context (IsStructure structure3) structure3 a3 - , HTable (K1Columns "fst" structure1) - , HTable (K1Columns "snd" structure2) - , HTable (K1Columns "trd" structure3) - , Labelable context - , a ~ (a1, a2, a3) - , KnownSymbol label - ) => K1Table label context 'True (structure1, structure2, structure3) a - where - fromK1Columns (hunlabel unlabeler -> (HTrio a b c)) = - ( fromK1Columns @"fst" @_ @_ @structure1 a - , fromK1Columns @"snd" @_ @_ @structure2 b - , fromK1Columns @"trd" @_ @_ @structure3 c - ) - toK1Columns (a, b, c) = hlabel labeler $ HTrio - { hfst = toK1Columns @"fst" @_ @_ @structure1 a - , hsnd = toK1Columns @"snd" @_ @_ @structure2 b - , htrd = toK1Columns @"trd" @_ @_ @structure3 c - } - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( K1Table "fst" context (IsStructure structure1) structure1 a1 - , K1Table "snd" context (IsStructure structure2) structure2 a2 - , K1Table "trd" context (IsStructure structure3) structure3 a3 - , K1Table "frt" context (IsStructure structure3) structure4 a4 - , HTable (K1Columns "fst" structure1) - , HTable (K1Columns "snd" structure2) - , HTable (K1Columns "trd" structure3) - , HTable (K1Columns "frt" structure4) - , Labelable context - , a ~ (a1, a2, a3, a4) - , KnownSymbol label - ) => K1Table label context 'True (structure1, structure2, structure3, structure4) a - where - fromK1Columns (hunlabel unlabeler -> (HQuartet a b c d)) = - ( fromK1Columns @"fst" @_ @_ @structure1 a - , fromK1Columns @"snd" @_ @_ @structure2 b - , fromK1Columns @"trd" @_ @_ @structure3 c - , fromK1Columns @"frt" @_ @_ @structure4 d - ) - toK1Columns (a, b, c, d) = hlabel labeler $ HQuartet - { hfst = toK1Columns @"fst" @_ @_ @structure1 a - , hsnd = toK1Columns @"snd" @_ @_ @structure2 b - , htrd = toK1Columns @"trd" @_ @_ @structure3 c - , hfrt = toK1Columns @"frt" @_ @_ @structure4 d - } - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( K1Table "fst" context (IsStructure structure1) structure1 a1 - , K1Table "snd" context (IsStructure structure2) structure2 a2 - , K1Table "trd" context (IsStructure structure3) structure3 a3 - , K1Table "frt" context (IsStructure structure3) structure4 a4 - , K1Table "fft" context (IsStructure structure3) structure5 a5 - , HTable (K1Columns "fst" structure1) - , HTable (K1Columns "snd" structure2) - , HTable (K1Columns "trd" structure3) - , HTable (K1Columns "frt" structure4) - , HTable (K1Columns "fft" structure5) - , Labelable context - , a ~ (a1, a2, a3, a4, a5) - , KnownSymbol label - ) => K1Table label context 'True (structure1, structure2, structure3, structure4, structure5) a - where - fromK1Columns (hunlabel unlabeler -> (HQuintet a b c d e)) = - ( fromK1Columns @"fst" @_ @_ @structure1 a - , fromK1Columns @"snd" @_ @_ @structure2 b - , fromK1Columns @"trd" @_ @_ @structure3 c - , fromK1Columns @"frt" @_ @_ @structure4 d - , fromK1Columns @"fft" @_ @_ @structure5 e - ) - toK1Columns (a, b, c, d, e) = hlabel labeler $ HQuintet - { hfst = toK1Columns @"fst" @_ @_ @structure1 a - , hsnd = toK1Columns @"snd" @_ @_ @structure2 b - , htrd = toK1Columns @"trd" @_ @_ @structure3 c - , hfrt = toK1Columns @"frt" @_ @_ @structure4 d - , hfft = toK1Columns @"fft" @_ @_ @structure5 e - } - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} - - -instance - ( IsStructure structure ~ 'False - , K1Columns label structure ~ HLabel label (Columns structure) - , Columns structure ~ Columns a - , Labelable context - , Table context a - , KnownSymbol label - ) => K1Table label context 'False structure a - where - fromK1Columns = fromColumns . hunlabel unlabeler - toK1Columns = hlabel labeler . toColumns - {-# INLINABLE fromK1Columns #-} - {-# INLINABLE toK1Columns #-} +unreify :: + (-- Rel8able t + --, forall necessity a. Coercible (AField context necessity a) (Field context necessity a) => Coercible (t (Reify context)) (t context) + ) + => t (Reify context) -> t context +unreify = unsafeCoerce diff --git a/src/Rel8/Schema/Generic/Test.hs b/src/Rel8/Schema/Generic/Test.hs index ce6e07e..c4271f0 100644 --- a/src/Rel8/Schema/Generic/Test.hs +++ b/src/Rel8/Schema/Generic/Test.hs @@ -4,8 +4,6 @@ {-# language DerivingStrategies #-} {-# language DuplicateRecordFields #-} -{-# options_ghc -O0 #-} - module Rel8.Schema.Generic.Test ( module Rel8.Schema.Generic.Test ) @@ -17,6 +15,7 @@ import Prelude -- rel8 import Rel8.Schema.Column +import Rel8.Schema.Field import Rel8.Schema.Generic -- text @@ -24,7 +23,7 @@ import Data.Text ( Text ) data Table f = Table - { foo :: Column f (Label "blah" Bool) + { foo :: Column f Bool , bar :: Column f (Maybe Bool) } deriving stock Generic @@ -40,7 +39,7 @@ data TablePair f = TablePair data TableMaybe f = TableMaybe - { foo :: Column f (Label "ABC" [Maybe Bool]) + { foo :: Column f [Maybe Bool] , bars :: HMaybe f (TablePair f, TablePair f) } deriving stock Generic @@ -49,7 +48,7 @@ data TableMaybe f = TableMaybe data TableEither f = TableEither { foo :: Column f Bool - , bars :: HEither f (HMaybe f (TablePair f, TablePair f)) (Column f (Label "XYZ" Char)) + , bars :: HEither f (HMaybe f (TablePair f, TablePair f)) (Column f Char) } deriving stock Generic deriving anyclass Rel8able diff --git a/src/Rel8/Schema/HTable/Either.hs b/src/Rel8/Schema/HTable/Either.hs index 4edea6b..c56aa81 100644 --- a/src/Rel8/Schema/HTable/Either.hs +++ b/src/Rel8/Schema/HTable/Either.hs @@ -2,27 +2,22 @@ {-# language DeriveAnyClass #-} {-# language DeriveGeneric #-} {-# language DerivingStrategies #-} -{-# language FlexibleInstances #-} {-# language StandaloneKindSignatures #-} -{-# language UndecidableInstances #-} -{-# language UndecidableSuperClasses #-} module Rel8.Schema.HTable.Either ( HEitherTable(..) - , HEitherNullifiable ) where -- base -import Data.Kind ( Constraint ) import GHC.Generics ( Generic ) import Prelude () -- rel8 import Rel8.Kind.Necessity ( Necessity( Required ) ) -import Rel8.Schema.Context.Nullify ( HNullifiable, HConstrainTag ) import Rel8.Schema.HTable ( HTable ) import Rel8.Schema.HTable.Identity ( HIdentity(..) ) +import Rel8.Schema.HTable.Label ( HLabel ) import Rel8.Schema.HTable.Nullify ( HNullify ) import qualified Rel8.Schema.Kind as K import Rel8.Schema.Spec ( Spec( Spec ) ) @@ -32,13 +27,8 @@ import Rel8.Type.Tag ( EitherTag ) type HEitherTable :: K.HTable -> K.HTable -> K.HTable data HEitherTable left right context = HEitherTable { htag :: HIdentity ('Spec '["isRight"] 'Required EitherTag) context - , hleft :: HNullify left context - , hright :: HNullify right context + , hleft :: HLabel "Left" (HNullify left) context + , hright :: HLabel "Right" (HNullify right) context } deriving stock Generic deriving anyclass HTable - - -type HEitherNullifiable :: K.HContext -> Constraint -class (HNullifiable context, HConstrainTag context EitherTag) => HEitherNullifiable context -instance (HNullifiable context, HConstrainTag context EitherTag) => HEitherNullifiable context diff --git a/src/Rel8/Schema/HTable/MapTable.hs b/src/Rel8/Schema/HTable/MapTable.hs index 5215e26..982efde 100644 --- a/src/Rel8/Schema/HTable/MapTable.hs +++ b/src/Rel8/Schema/HTable/MapTable.hs @@ -35,13 +35,15 @@ import Rel8.Schema.Dict ( Dict( Dict ) ) type HMapTable :: (a -> Exp b) -> ((a -> Type) -> Type) -> (b -> Type) -> Type -data HMapTable f t g where - HMapTable :: { unHMapTable :: t (Precompose f g) } -> HMapTable f t g +newtype HMapTable f t g = HMapTable + { unHMapTable :: t (Precompose f g) + } type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type -newtype Precompose f g x where - Precompose :: { precomposed :: g (Eval (f x)) } -> Precompose f g x +newtype Precompose f g x = Precompose + { precomposed :: g (Eval (f x)) + } type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type @@ -64,6 +66,7 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where htraverse f (HMapTable x) = HMapTable <$> htraverse (fmap Precompose . f . precomposed) x + {-# INLINABLE htraverse #-} hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c) hdicts = @@ -73,6 +76,7 @@ instance (HTable t, MapSpec f) => HTable (HMapTable f t) where hspecs = HMapTable $ htabulate $ Precompose . mapInfo @f . hfield hspecs + {-# INLINABLE hspecs #-} type MapSpec :: (Spec -> Exp Spec) -> Constraint diff --git a/src/Rel8/Schema/HTable/Maybe.hs b/src/Rel8/Schema/HTable/Maybe.hs index ea452c1..dc0ca33 100644 --- a/src/Rel8/Schema/HTable/Maybe.hs +++ b/src/Rel8/Schema/HTable/Maybe.hs @@ -2,42 +2,32 @@ {-# language DeriveAnyClass #-} {-# language DeriveGeneric #-} {-# language DerivingStrategies #-} -{-# language FlexibleInstances #-} {-# language StandaloneKindSignatures #-} -{-# language UndecidableInstances #-} -{-# language UndecidableSuperClasses #-} module Rel8.Schema.HTable.Maybe ( HMaybeTable(..) - , HMaybeNullifiable ) where -- base -import Data.Kind ( Constraint ) import GHC.Generics ( Generic ) import Prelude -- rel8 import Rel8.Kind.Necessity ( Necessity( Required ) ) -import Rel8.Schema.Context.Nullify ( HConstrainTag, HNullifiable ) import Rel8.Schema.HTable ( HTable ) import Rel8.Schema.HTable.Identity ( HIdentity(..) ) +import Rel8.Schema.HTable.Label ( HLabel ) +import Rel8.Schema.HTable.Nullify ( HNullify ) import qualified Rel8.Schema.Kind as K import Rel8.Schema.Spec ( Spec( Spec ) ) import Rel8.Type.Tag ( MaybeTag ) -import Rel8.Schema.HTable.Nullify ( HNullify ) type HMaybeTable :: K.HTable -> K.HTable data HMaybeTable table context = HMaybeTable { htag :: HIdentity ('Spec '["isJust"] 'Required (Maybe MaybeTag)) context - , hjust :: HNullify table context + , hjust :: HLabel "Just" (HNullify table) context } deriving stock Generic deriving anyclass HTable - - -type HMaybeNullifiable :: K.HContext -> Constraint -class (HNullifiable context, HConstrainTag context MaybeTag) => HMaybeNullifiable context -instance (HNullifiable context, HConstrainTag context MaybeTag) => HMaybeNullifiable context diff --git a/src/Rel8/Schema/HTable/These.hs b/src/Rel8/Schema/HTable/These.hs index a7f19db..890157b 100644 --- a/src/Rel8/Schema/HTable/These.hs +++ b/src/Rel8/Schema/HTable/These.hs @@ -17,6 +17,7 @@ import Prelude import Rel8.Kind.Necessity ( Necessity( Required ) ) import Rel8.Schema.HTable ( HTable ) import Rel8.Schema.HTable.Identity ( HIdentity ) +import Rel8.Schema.HTable.Label ( HLabel ) import Rel8.Schema.HTable.Nullify ( HNullify ) import qualified Rel8.Schema.Kind as K import Rel8.Schema.Spec ( Spec( Spec ) ) @@ -26,9 +27,9 @@ import Rel8.Type.Tag ( MaybeTag ) type HTheseTable :: K.HTable -> K.HTable -> K.HTable data HTheseTable here there context = HTheseTable { hhereTag :: HIdentity ('Spec '["hasHere"] 'Required (Maybe MaybeTag)) context - , hhere :: HNullify here context + , hhere :: HLabel "Here" (HNullify here) context , hthereTag :: HIdentity ('Spec '["hasThere"] 'Required (Maybe MaybeTag)) context - , hthere :: HNullify there context + , hthere :: HLabel "There" (HNullify there) context } deriving stock Generic deriving anyclass HTable diff --git a/src/Rel8/Schema/HTable/Vectorize.hs b/src/Rel8/Schema/HTable/Vectorize.hs index 8fd4ff0..905529a 100644 --- a/src/Rel8/Schema/HTable/Vectorize.hs +++ b/src/Rel8/Schema/HTable/Vectorize.hs @@ -23,7 +23,6 @@ module Rel8.Schema.HTable.Vectorize ( HVectorize , hvectorize, hunvectorize , happend, hempty - , hrelabel ) where @@ -150,10 +149,3 @@ hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield h instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where hlabeler = Precompose . hlabeler . precomposed hunlabeler = Precompose . hunlabeler . precomposed - - -hrelabel :: HLabelable context - => (forall ctx. HLabelable ctx => t ctx -> u ctx) - -> HVectorize list t context - -> HVectorize list u context -hrelabel f (HVectorize (HMapTable table)) = HVectorize (HMapTable (f table)) diff --git a/src/Rel8/Schema/Insert.hs b/src/Rel8/Schema/Insert.hs index f87da7e..b9352b8 100644 --- a/src/Rel8/Schema/Insert.hs +++ b/src/Rel8/Schema/Insert.hs @@ -15,8 +15,8 @@ module Rel8.Schema.Insert ( Insert(..) , OnConflict(..) , Col( RequiredInsert, OptionalInsert ) - , Insertion(..) , Inserts + , Insertion(..) ) where @@ -35,7 +35,7 @@ import Rel8.Schema.Context.Nullify ( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier , runTag, unnull ) -import Rel8.Schema.HTable.Type ( HType(HType) ) +import Rel8.Schema.HTable.Type ( HType( HType ) ) import qualified Rel8.Schema.Kind as K import Rel8.Schema.Name ( Name, Selects ) import Rel8.Schema.Null ( Sql ) diff --git a/src/Rel8/Schema/Structure.hs b/src/Rel8/Schema/Structure.hs index 231ce21..d17add0 100644 --- a/src/Rel8/Schema/Structure.hs +++ b/src/Rel8/Schema/Structure.hs @@ -1,54 +1,17 @@ {-# language DataKinds #-} {-# language StandaloneKindSignatures #-} -{-# language PolyKinds #-} -{-# language TypeFamilies #-} module Rel8.Schema.Structure ( Structure - , Shape( Column, Either, List, Maybe, NonEmpty, These ) - , Shape1 - , Shape2 - , IsStructure ) where -- base -import Data.Kind ( Type ) -import Prelude +import Prelude () -- rel8 -import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Spec ( Spec ) +import Rel8.Schema.Kind ( Context ) -type Structure :: K.Context +type Structure :: Context data Structure a - - -type Shape :: Type -data Shape - = Column Spec - | Either Type Type - | List Type - | Maybe Type - | NonEmpty Type - | These Type Type - - -type Shape1 :: (a -> Shape) -> a -> Type -data Shape1 shape a - - -type Shape2 :: (a -> b -> Shape) -> a -> b -> Type -data Shape2 shape a b - - -type IsStructure :: Type -> Bool -type family IsStructure a where - IsStructure (Shape1 _ _) = 'True - IsStructure (Shape2 _ _ _) = 'True - IsStructure (_, _) = 'True - IsStructure (_, _, _) = 'True - IsStructure (_, _, _, _) = 'True - IsStructure (_, _, _, _, _) = 'True - IsStructure _ = 'False diff --git a/src/Rel8/Table.hs b/src/Rel8/Table.hs index acf659d..cb89a71 100644 --- a/src/Rel8/Table.hs +++ b/src/Rel8/Table.hs @@ -3,8 +3,11 @@ {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language FunctionalDependencies #-} +{-# language LambdaCase #-} +{-# language NamedFieldPuns #-} {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-} +{-# language TypeOperators #-} {-# language UndecidableInstances #-} module Rel8.Table @@ -15,25 +18,39 @@ module Rel8.Table where -- base +import Data.Functor ( ($>) ) import Data.Functor.Identity ( Identity( Identity ) ) import Data.Kind ( Constraint, Type ) -import Prelude +import Data.List.NonEmpty ( NonEmpty ) +import Prelude hiding ( null ) -- rel8 import Rel8.Schema.Context ( Col(..) ) import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler ) import Rel8.Schema.HTable ( HTable ) +import Rel8.Schema.HTable.Either ( HEitherTable(..) ) import Rel8.Schema.HTable.Identity ( HIdentity(..) ) import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel ) +import Rel8.Schema.HTable.List ( HListTable ) +import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) ) +import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable ) +import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify ) import Rel8.Schema.HTable.Pair ( HPair(..) ) import Rel8.Schema.HTable.Quartet ( HQuartet(..) ) import Rel8.Schema.HTable.Quintet ( HQuintet(..) ) +import Rel8.Schema.HTable.These ( HTheseTable(..) ) import Rel8.Schema.HTable.Trio ( HTrio(..) ) import Rel8.Schema.HTable.Type ( HType( HType ) ) +import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize ) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Null ( Sql ) -import Rel8.Schema.Spec ( KnownSpec ) +import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql ) +import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..), KnownSpec ) import Rel8.Type ( DBType ) +import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) ) + +-- these +import Data.These ( These( This, That, These ) ) +import Data.These.Combinators ( justHere, justThere ) -- | @Table@s are one of the foundational elements of Rel8, and describe data @@ -85,6 +102,106 @@ instance Sql DBType a => Table Identity (Identity a) where fromColumns (HType (Result a)) = Identity a +instance (Table Identity a, Table Identity b) => Table Identity (Either a b) + where + type Columns (Either a b) = HEitherTable (Columns a) (Columns b) + type Context (Either a b) = Identity + + toColumns = \case + Left table -> HEitherTable + { htag = HIdentity (Result IsLeft) + , hleft = hlabel labeler (hnullify nullifier (toColumns table)) + , hright = hlabel labeler (hnulls null) + } + Right table -> HEitherTable + { htag = HIdentity (Result IsRight) + , hleft = hlabel labeler (hnulls null) + , hright = hlabel labeler (hnullify nullifier (toColumns table)) + } + + fromColumns HEitherTable {htag, hleft, hright} = case htag of + HIdentity (Result tag) -> case tag of + IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hleft) + IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hright) + where + err = error "Either.fromColumns: mismatch between tag and data" + + +instance Table Identity a => Table Identity [a] where + type Columns [a] = HListTable (Columns a) + type Context [a] = Identity + + toColumns = hvectorize vectorizer . fmap toColumns + fromColumns = fmap fromColumns . hunvectorize unvectorizer + + +instance Table Identity a => Table Identity (Maybe a) where + type Columns (Maybe a) = HMaybeTable (Columns a) + type Context (Maybe a) = Identity + + toColumns = \case + Nothing -> HMaybeTable + { htag = HIdentity (Result Nothing) + , hjust = hlabel labeler (hnulls null) + } + Just table -> HMaybeTable + { htag = HIdentity (Result (Just IsJust)) + , hjust = hlabel labeler (hnullify nullifier (toColumns table)) + } + + fromColumns HMaybeTable {htag, hjust} = case htag of + HIdentity (Result tag) -> tag $> + case hunnullify unnullifier (hunlabel unlabeler hjust) of + Nothing -> error "Maybe.fromColumns: mismatch between tag and data" + Just just -> fromColumns just + + +instance Table Identity a => Table Identity (NonEmpty a) where + type Columns (NonEmpty a) = HNonEmptyTable (Columns a) + type Context (NonEmpty a) = Identity + + toColumns = hvectorize vectorizer . fmap toColumns + fromColumns = fmap fromColumns . hunvectorize unvectorizer + + +instance (Table Identity a, Table Identity b) => Table Identity (These a b) + where + type Columns (These a b) = HTheseTable (Columns a) (Columns b) + type Context (These a b) = Identity + + toColumns tables = HTheseTable + { hhereTag = relabel hhereTag + , hhere = hlabel labeler (hunlabel unlabeler (toColumns hhere)) + , hthereTag = relabel hthereTag + , hthere = hlabel labeler (hunlabel unlabeler (toColumns hthere)) + } + where + HMaybeTable + { htag = hhereTag + , hjust = hhere + } = toColumns (justHere tables) + HMaybeTable + { htag = hthereTag + , hjust = hthere + } = toColumns (justThere tables) + + fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = + case (fromColumns mhere, fromColumns mthere) of + (Just a, Nothing) -> This (fromColumns a) + (Nothing, Just b) -> That (fromColumns b) + (Just a, Just b) -> These (fromColumns a) (fromColumns b) + _ -> error "These.fromColumns: mismatch between tags and data" + where + mhere = HMaybeTable + { htag = relabel hhereTag + , hjust = hlabel labeler (hunlabel unlabeler hhere) + } + mthere = HMaybeTable + { htag = relabel hthereTag + , hjust = hlabel labeler (hunlabel unlabeler hthere) + } + + instance ( Table context a, Table context b , Labelable context @@ -192,3 +309,46 @@ instance type Congruent :: Type -> Type -> Constraint class Columns a ~ Columns b => Congruent a b instance Columns a ~ Columns b => Congruent a b + + +null :: Col Identity ('Spec labels necessity (Maybe a)) +null = Result Nothing + + +nullifier :: () + => SSpec ('Spec labels necessity a) + -> Col Identity ('Spec labels necessity a) + -> Col Identity ('Spec labels necessity (Nullify a)) +nullifier SSpec {nullity} (Result a) = Result $ case nullity of + Null -> a + NotNull -> Just a + + +unnullifier :: () + => SSpec ('Spec labels necessity a) + -> Col Identity ('Spec labels necessity (Nullify a)) + -> Maybe (Col Identity ('Spec labels necessity a)) +unnullifier SSpec {nullity} (Result a) = + case nullity of + Null -> pure $ Result a + NotNull -> Result <$> a + + +vectorizer :: Functor f + => SSpec ('Spec labels necessity a) + -> f (Col Identity ('Spec labels necessity a)) + -> Col Identity ('Spec labels necessity (f a)) +vectorizer _ = Result . fmap (\(Result a) -> a) + + +unvectorizer :: Functor f + => SSpec ('Spec labels necessity a) + -> Col Identity ('Spec labels necessity (f a)) + -> f (Col Identity ('Spec labels necessity a)) +unvectorizer _ (Result results) = Result <$> results + + +relabel :: () + => HIdentity ('Spec labels necessity a) (Col Identity) + -> HIdentity ('Spec relabels necessity a) (Col Identity) +relabel (HIdentity (Result a)) = HIdentity (Result a) diff --git a/src/Rel8/Table/Either.hs b/src/Rel8/Table/Either.hs index 7aafce3..f40decb 100644 --- a/src/Rel8/Table/Either.hs +++ b/src/Rel8/Table/Either.hs @@ -30,23 +30,25 @@ import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate ) import Rel8.Expr ( Expr ) import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr ) import Rel8.Expr.Serialize ( litExpr ) -import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler ) +import Rel8.Schema.Context.Label + ( Labelable + , HLabelable, hlabeler, hunlabeler + ) import Rel8.Schema.Context.Nullify ( Nullifiable, ConstrainTag + , HNullifiable, HConstrainTag , hencodeTag, hdecodeTag , hnullifier, hunnullifier ) -import Rel8.Schema.HTable.Either ( HEitherTable(..), HEitherNullifiable ) +import Rel8.Schema.HTable ( HTable ) +import Rel8.Schema.HTable.Either ( HEitherTable(..) ) import Rel8.Schema.HTable.Identity ( HIdentity(..) ) -import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel ) +import Rel8.Schema.HTable.Label ( hlabel, hunlabel ) import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify ) import Rel8.Schema.Name ( Name ) import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns ) import Rel8.Table.Bool ( bool ) import Rel8.Table.Eq ( EqTable, eqTable ) -import Rel8.Table.Lifted - ( Table2, Columns2, ConstrainHContext2, fromColumns2, toColumns2 - ) import Rel8.Table.Ord ( OrdTable, ordTable ) import Rel8.Table.Recontextualize ( Recontextualize ) import Rel8.Table.Tag ( Tag(..), fromExpr, fromName ) @@ -95,51 +97,17 @@ instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where a <> b = bool a b (isRightTable a) -instance Table2 EitherTable where - type Columns2 EitherTable = HEitherTable - type ConstrainHContext2 EitherTable = HEitherNullifiable - - toColumns2 f g EitherTable {tag, left, right} = HEitherTable - { htag - , hleft = hnullify (hnullifier tag isLeft) $ f left - , hright = hnullify (hnullifier tag isRight) $ g right - } - where - htag = HIdentity (hencodeTag tag) - - fromColumns2 f g HEitherTable {htag = htag, hleft, hright} = - EitherTable - { tag - , left = f $ runIdentity $ - hunnullify (\a -> pure . hunnullifier a) hleft - , right = g $ runIdentity $ - hunnullify (\a -> pure . hunnullifier a) hright - } - where - tag = hdecodeTag $ unHIdentity htag - - {-# INLINABLE fromColumns2 #-} - {-# INLINABLE toColumns2 #-} - - instance ( Table context a, Table context b , Labelable context, Nullifiable context, ConstrainTag context EitherTag ) => Table context (EitherTable a b) where - type Columns (EitherTable a b) = - HEitherTable (HLabel "Left" (Columns a)) (HLabel "Right" (Columns b)) + type Columns (EitherTable a b) = HEitherTable (Columns a) (Columns b) type Context (EitherTable a b) = Context a - toColumns = - toColumns2 - (hlabel labeler . toColumns) - (hlabel labeler . toColumns) - fromColumns = - fromColumns2 - (fromColumns . hunlabel unlabeler) - (fromColumns . hunlabel unlabeler) + toColumns = toColumns2 toColumns toColumns + fromColumns = fromColumns2 fromColumns fromColumns instance @@ -152,15 +120,11 @@ instance instance (EqTable a, EqTable b) => EqTable (EitherTable a b) where - eqTable = - toColumns2 (hlabel hlabeler) (hlabel hlabeler) - (rightTableWith (eqTable @a) (eqTable @b)) + eqTable = toColumns2 id id (rightTableWith (eqTable @a) (eqTable @b)) instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where - ordTable = - toColumns2 (hlabel hlabeler) (hlabel hlabeler) - (rightTableWith (ordTable @a) (ordTable @b)) + ordTable = toColumns2 id id (rightTableWith (ordTable @a) (ordTable @b)) isLeftTable :: EitherTable a b -> Expr Bool @@ -203,3 +167,49 @@ aggregateEitherTable f g EitherTable {tag, left, right} = nameEitherTable :: Name EitherTag -> a -> b -> EitherTable a b nameEitherTable = EitherTable . fromName + + +toColumns2 :: + ( HTable t + , HTable u + , HConstrainTag context EitherTag + , HLabelable context + , HNullifiable context + ) + => (a -> t context) + -> (b -> u context) + -> EitherTable a b + -> HEitherTable t u context +toColumns2 f g EitherTable {tag, left, right} = HEitherTable + { htag + , hleft = hlabel hlabeler $ hnullify (hnullifier tag isLeft) $ f left + , hright = hlabel hlabeler $ hnullify (hnullifier tag isRight) $ g right + } + where + htag = HIdentity (hencodeTag tag) + + +fromColumns2 :: + ( HTable t + , HTable u + , HConstrainTag context EitherTag + , HLabelable context + , HNullifiable context + ) + => (t context -> a) + -> (u context -> b) + -> HEitherTable t u context + -> EitherTable a b +fromColumns2 f g HEitherTable {htag, hleft, hright} = EitherTable + { tag + , left = f $ runIdentity $ + hunnullify (\a -> pure . hunnullifier a) $ + hunlabel hunlabeler + hleft + , right = g $ runIdentity $ + hunnullify (\a -> pure . hunnullifier a) $ + hunlabel hunlabeler + hright + } + where + tag = hdecodeTag $ unHIdentity htag diff --git a/src/Rel8/Table/Lifted.hs b/src/Rel8/Table/Lifted.hs deleted file mode 100644 index 0da9a99..0000000 --- a/src/Rel8/Table/Lifted.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# language ConstraintKinds #-} -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language QuantifiedConstraints #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} -{-# language UndecidableInstances #-} - -module Rel8.Table.Lifted - ( Table1( Columns1, ConstrainHContext1, toColumns1, fromColumns1 ) - , Table2( Columns2, ConstrainHContext2, toColumns2, fromColumns2 ) - , ConstrainContext - ) -where - --- base -import Data.Kind ( Constraint, Type ) -import Prelude () - --- rel8 -import Rel8.Schema.Context ( Col ) -import Rel8.Schema.HTable ( HTable ) -import Rel8.Schema.HTable.Pair -import qualified Rel8.Schema.Kind as K - - -type Table1 :: (Type -> Type) -> Constraint -class Table1 f where - type Columns1 f :: K.HTable -> K.HTable - type ConstrainHContext1 f :: K.HContext -> Constraint - type ConstrainHContext1 _ = DefaultConstrainContext - - toColumns1 :: (ConstrainHContext1 f context, HTable t) - => (a -> t context) - -> f a - -> Columns1 f t context - - fromColumns1 :: (ConstrainHContext1 f context, HTable t) - => (t context -> a) - -> Columns1 f t context - -> f a - - -type Table2 :: (Type -> Type -> Type) -> Constraint -class Table2 p where - type Columns2 p :: K.HTable -> K.HTable -> K.HTable - type ConstrainHContext2 p :: K.HContext -> Constraint - type ConstrainHContext2 _ = DefaultConstrainContext - - toColumns2 :: (ConstrainHContext2 p context, HTable t, HTable u) - => (a -> t context) - -> (b -> u context) - -> p a b - -> Columns2 p t u context - - fromColumns2 :: (ConstrainHContext2 p context, HTable t, HTable u) - => (t context -> a) - -> (u context -> b) - -> Columns2 p t u context - -> p a b - - -instance Table2 (,) where - type Columns2 (,) = HPair - - toColumns2 f g (a, b) = HPair (f a) (g b) - fromColumns2 f g (HPair a b) = (f a, g b) - - -type DefaultConstrainContext :: K.HContext -> Constraint -class DefaultConstrainContext context -instance DefaultConstrainContext context - - -type ConstrainContext :: (K.Context -> Constraint) -> K.HContext -> Constraint -class (forall context. hcontext ~ Col context => constraint context) - => ConstrainContext constraint hcontext -instance (hcontext ~ Col context, constraint context) => - ConstrainContext constraint hcontext diff --git a/src/Rel8/Table/Maybe.hs b/src/Rel8/Table/Maybe.hs index a0421b6..76b7d65 100644 --- a/src/Rel8/Table/Maybe.hs +++ b/src/Rel8/Table/Maybe.hs @@ -24,7 +24,7 @@ where -- base import Data.Functor.Identity ( runIdentity ) import Data.Kind ( Type ) -import Prelude hiding ( null, repeat, undefined, zipWith ) +import Prelude hiding ( null, undefined ) -- rel8 import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate ) @@ -32,15 +32,19 @@ import Rel8.Expr ( Expr ) import Rel8.Expr.Bool ( boolExpr ) import Rel8.Expr.Null ( isNull, isNonNull, null, nullify ) import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr ) -import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler ) +import Rel8.Schema.Context.Label + ( Labelable, HLabelable, hlabeler, hunlabeler + ) import Rel8.Schema.Context.Nullify ( Nullifiable, ConstrainTag + , HNullifiable, HConstrainTag , hencodeTag, hdecodeTag , hnullifier, hunnullifier ) +import Rel8.Schema.HTable ( HTable ) import Rel8.Schema.HTable.Identity ( HIdentity(..) ) -import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel ) -import Rel8.Schema.HTable.Maybe ( HMaybeTable(..), HMaybeNullifiable ) +import Rel8.Schema.HTable.Label ( hlabel, hunlabel ) +import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) ) import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify ) import Rel8.Schema.Name ( Name ) import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql, nullable ) @@ -51,9 +55,6 @@ import Rel8.Table.Alternative ) import Rel8.Table.Bool ( bool ) import Rel8.Table.Eq ( EqTable, eqTable ) -import Rel8.Table.Lifted - ( Table1, Columns1, ConstrainHContext1, fromColumns1, toColumns1 - ) import Rel8.Table.Ord ( OrdTable, ordTable ) import Rel8.Table.Recontextualize ( Recontextualize ) import Rel8.Table.Tag ( Tag(..), fromExpr, fromName ) @@ -127,40 +128,17 @@ instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where mempty = nothingTable -instance Table1 MaybeTable where - type Columns1 MaybeTable = HMaybeTable - type ConstrainHContext1 MaybeTable = HMaybeNullifiable - - toColumns1 f MaybeTable {tag, just} = HMaybeTable - { htag - , hjust = hnullify (hnullifier tag isNonNull) $ f just - } - where - htag = HIdentity (hencodeTag tag) - - fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable - { tag - , just = f $ runIdentity $ - hunnullify (\a -> pure . hunnullifier a) hjust - } - where - tag = hdecodeTag htag - - {-# INLINABLE fromColumns1 #-} - {-# INLINABLE toColumns1 #-} - - instance ( Table context a , Labelable context, Nullifiable context , ConstrainTag context MaybeTag ) => Table context (MaybeTable a) where - type Columns (MaybeTable a) = HMaybeTable (HLabel "Just" (Columns a)) + type Columns (MaybeTable a) = HMaybeTable (Columns a) type Context (MaybeTable a) = Context a - toColumns = toColumns1 (hlabel labeler . toColumns) - fromColumns = fromColumns1 (fromColumns . hunlabel unlabeler) + toColumns = toColumns1 toColumns + fromColumns = fromColumns1 fromColumns instance @@ -171,11 +149,11 @@ instance instance EqTable a => EqTable (MaybeTable a) where - eqTable = toColumns1 (hlabel hlabeler) (justTable (eqTable @a)) + eqTable = toColumns1 id (justTable (eqTable @a)) instance OrdTable a => OrdTable (MaybeTable a) where - ordTable = toColumns1 (hlabel hlabeler) (justTable (ordTable @a)) + ordTable = toColumns1 id (justTable (ordTable @a)) -- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'. @@ -226,3 +204,38 @@ aggregateMaybeTable f MaybeTable {tag = tag@Tag {aggregator, expr}, just} = nameMaybeTable :: Name (Maybe MaybeTag) -> a -> MaybeTable a nameMaybeTable = MaybeTable . fromName + + +toColumns1 :: + ( HTable t + , HConstrainTag context MaybeTag + , HLabelable context + , HNullifiable context + ) + => (a -> t context) + -> MaybeTable a + -> HMaybeTable t context +toColumns1 f MaybeTable {tag, just} = HMaybeTable + { htag + , hjust = hlabel hlabeler $ hnullify (hnullifier tag isNonNull) $ f just + } + where + htag = HIdentity (hencodeTag tag) + + +fromColumns1 :: + ( HTable t + , HConstrainTag context MaybeTag + , HLabelable context + , HNullifiable context + ) + => (t context -> a) + -> HMaybeTable t context + -> MaybeTable a +fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable + { tag + , just = f $ runIdentity $ + hunnullify (\a -> pure . hunnullifier a) (hunlabel hunlabeler hjust) + } + where + tag = hdecodeTag htag diff --git a/src/Rel8/Table/Serialize.hs b/src/Rel8/Table/Serialize.hs index 84902c2..2501d0e 100644 --- a/src/Rel8/Table/Serialize.hs +++ b/src/Rel8/Table/Serialize.hs @@ -31,13 +31,6 @@ import qualified Hasql.Decoders as Hasql import Rel8.Expr ( Expr, Col(..) ) import Rel8.Expr.Serialize ( slitExpr, sparseValue ) import Rel8.Schema.Context ( Col(..) ) -import Rel8.Schema.Context.Identity - ( fromHEitherTable, toHEitherTable - , fromHListTable, toHListTable - , fromHMaybeTable, toHMaybeTable - , fromHNonEmptyTable, toHNonEmptyTable - , fromHTheseTable, toHTheseTable - ) import Rel8.Schema.Context.Label ( labeler, unlabeler ) import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs ) import Rel8.Schema.HTable.Label ( hlabel, hunlabel ) @@ -104,50 +97,38 @@ instance (ToExprs a exprs1, ToExprs b exprs2, x ~ EitherTable exprs1 exprs2) => ToExprs (Either a b) x where fromIdentity = - bimap - (fromIdentity' @exprs1 . hunlabel unlabeler) - (fromIdentity' @exprs2 . hunlabel unlabeler) . - fromHEitherTable + bimap (fromIdentity' @exprs1) (fromIdentity' @exprs2) . + fromColumns toIdentity = - toHEitherTable . - bimap - (hlabel labeler . toIdentity' @exprs1) - (hlabel labeler . toIdentity' @exprs2) + toColumns . + bimap (toIdentity' @exprs1) (toIdentity' @exprs2) instance ToExprs a exprs => ToExprs [a] (ListTable exprs) where - fromIdentity = fmap (fromIdentity' @exprs) . fromHListTable - toIdentity = toHListTable . fmap (toIdentity' @exprs) + fromIdentity = fmap (fromIdentity' @exprs) . fromColumns + toIdentity = toColumns . fmap (toIdentity' @exprs) instance ToExprs a exprs => ToExprs (Maybe a) (MaybeTable exprs) where - fromIdentity = - fmap (fromIdentity' @exprs . hunlabel unlabeler) . - fromHMaybeTable - toIdentity = - toHMaybeTable . - fmap (hlabel labeler . toIdentity' @exprs) + fromIdentity = fmap (fromIdentity' @exprs) . fromColumns + toIdentity = toColumns . fmap (toIdentity' @exprs) instance ToExprs a exprs => ToExprs (NonEmpty a) (NonEmptyTable exprs) where - fromIdentity = fmap (fromIdentity' @exprs) . fromHNonEmptyTable - toIdentity = toHNonEmptyTable . fmap (toIdentity' @exprs) + fromIdentity = fmap (fromIdentity' @exprs) . fromColumns + toIdentity = toColumns . fmap (toIdentity' @exprs) instance (ToExprs a exprs1, ToExprs b exprs2, x ~ TheseTable exprs1 exprs2) => ToExprs (These a b) x where fromIdentity = - bimap - (fromIdentity' @exprs1 . hunlabel unlabeler) - (fromIdentity' @exprs2 . hunlabel unlabeler) . - fromHTheseTable + bimap (fromIdentity' @exprs1) (fromIdentity' @exprs2) . + fromColumns toIdentity = - toHTheseTable . - bimap - (hlabel labeler . toIdentity' @exprs1) - (hlabel labeler . toIdentity' @exprs2) + toColumns . + bimap (toIdentity' @exprs1) (toIdentity' @exprs2) instance (ToExprs a exprs1, ToExprs b exprs2, x ~ (exprs1, exprs2)) => @@ -251,22 +232,22 @@ instance (KnownSpec spec, x ~ Col Expr spec) => type FromExprs :: Type -> Type -type family FromExprs a where - FromExprs (Expr a) = a - FromExprs (Col Expr spec) = Col Identity spec - FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b) - FromExprs (ListTable a) = [FromExprs a] - FromExprs (MaybeTable a) = Maybe (FromExprs a) - FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a) - FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b) - FromExprs (a, b) = (FromExprs a, FromExprs b) - FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c) - FromExprs (a, b, c, d) = - (FromExprs a, FromExprs b, FromExprs c, FromExprs d) - FromExprs (a, b, c, d, e) = - (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e) - FromExprs (t Expr) = t Identity - FromExprs (t (Col Expr)) = t (Col Identity) +type family FromExprs a +type instance FromExprs (Expr a) = a +type instance FromExprs (Col Expr spec) = Col Identity spec +type instance FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b) +type instance FromExprs (ListTable a) = [FromExprs a] +type instance FromExprs (MaybeTable a) = Maybe (FromExprs a) +type instance FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a) +type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b) +type instance FromExprs (a, b) = (FromExprs a, FromExprs b) +type instance FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c) +type instance FromExprs (a, b, c, d) = + (FromExprs a, FromExprs b, FromExprs c, FromExprs d) +type instance FromExprs (a, b, c, d, e) = + (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e) +type instance FromExprs (t Expr) = t Identity +type instance FromExprs (t (Col Expr)) = t (Col Identity) -- | @Serializable@ witnesses the one-to-one correspondence between the type diff --git a/src/Rel8/Table/These.hs b/src/Rel8/Table/These.hs index 5756f1d..75d0abb 100644 --- a/src/Rel8/Table/These.hs +++ b/src/Rel8/Table/These.hs @@ -34,23 +34,24 @@ import Rel8.Aggregate ( Aggregate ) import Rel8.Expr ( Expr ) import Rel8.Expr.Bool ( (&&.), not_ ) import Rel8.Expr.Null ( isNonNull ) -import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler ) +import Rel8.Schema.Context.Label + ( Labelable + , HLabelable, hlabeler, hunlabeler + ) import Rel8.Schema.Context.Nullify ( Nullifiable, ConstrainTag + , HNullifiable, HConstrainTag , hencodeTag, hdecodeTag , hnullifier, hunnullifier ) -import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel ) +import Rel8.Schema.HTable ( HTable ) +import Rel8.Schema.HTable.Label ( hlabel, hunlabel ) import Rel8.Schema.HTable.Identity ( HIdentity(..) ) -import Rel8.Schema.HTable.Maybe ( HMaybeNullifiable ) import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify ) import Rel8.Schema.HTable.These ( HTheseTable(..) ) import Rel8.Schema.Name ( Name ) import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns ) import Rel8.Table.Eq ( EqTable, eqTable ) -import Rel8.Table.Lifted - ( Table2, Columns2, ConstrainHContext2, fromColumns2, toColumns2 - ) import Rel8.Table.Maybe ( MaybeTable(..) , maybeTable, justTable, nothingTable @@ -117,66 +118,16 @@ instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) => } -instance Table2 TheseTable where - type Columns2 TheseTable = HTheseTable - type ConstrainHContext2 TheseTable = HMaybeNullifiable - - toColumns2 f g TheseTable {here, there} = HTheseTable - { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here)) - , hhere = - hnullify (hnullifier (tag here) isNonNull) $ f (just here) - , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there)) - , hthere = - hnullify (hnullifier (tag there) isNonNull) $ g (just there) - } - - fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = - TheseTable - { here = - let - tag = hdecodeTag $ unHIdentity hhereTag - in - MaybeTable - { tag - , just = f $ - runIdentity $ - hunnullify (\a -> pure . hunnullifier a) - hhere - } - , there = - let - tag = hdecodeTag $ unHIdentity hthereTag - in - MaybeTable - { tag - , just = g $ - runIdentity $ - hunnullify (\a -> pure . hunnullifier a) - hthere - } - } - - {-# INLINABLE fromColumns2 #-} - {-# INLINABLE toColumns2 #-} - - instance ( Table context a, Table context b , Labelable context, Nullifiable context, ConstrainTag context MaybeTag ) => Table context (TheseTable a b) where - type Columns (TheseTable a b) = - HTheseTable (HLabel "Here" (Columns a)) (HLabel "There" (Columns b)) + type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b) type Context (TheseTable a b) = Context a - toColumns = - toColumns2 - (hlabel labeler . toColumns) - (hlabel labeler . toColumns) - fromColumns = - fromColumns2 - (fromColumns . hunlabel unlabeler) - (fromColumns . hunlabel unlabeler) + toColumns = toColumns2 toColumns toColumns + fromColumns = fromColumns2 fromColumns fromColumns instance @@ -189,15 +140,11 @@ instance instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where - eqTable = - toColumns2 (hlabel hlabeler) (hlabel hlabeler) - (thoseTable (eqTable @a) (eqTable @b)) + eqTable = toColumns2 id id (thoseTable (eqTable @a) (eqTable @b)) instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where - ordTable = - toColumns2 (hlabel hlabeler) (hlabel hlabeler) - (thoseTable (ordTable @a) (ordTable @b)) + ordTable = toColumns2 id id (thoseTable (ordTable @a) (ordTable @b)) toHereTag :: Tag "isJust" a -> Tag "hasHere" a @@ -277,3 +224,63 @@ nameTheseTable here there a b = { here = nameMaybeTable here a , there = nameMaybeTable there b } + + +toColumns2 :: + ( HTable t + , HTable u + , HConstrainTag context MaybeTag + , HLabelable context + , HNullifiable context + ) + => (a -> t context) + -> (b -> u context) + -> TheseTable a b + -> HTheseTable t u context +toColumns2 f g TheseTable {here, there} = HTheseTable + { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here)) + , hhere = + hlabel hlabeler $ hnullify (hnullifier (tag here) isNonNull) $ f (just here) + , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there)) + , hthere = + hlabel hlabeler $ hnullify (hnullifier (tag there) isNonNull) $ g (just there) + } + + +fromColumns2 :: + ( HTable t + , HTable u + , HConstrainTag context MaybeTag + , HLabelable context + , HNullifiable context + ) + => (t context -> a) + -> (u context -> b) + -> HTheseTable t u context + -> TheseTable a b +fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable + { here = + let + tag = hdecodeTag $ unHIdentity hhereTag + in + MaybeTable + { tag + , just = f $ + runIdentity $ + hunnullify (\a -> pure . hunnullifier a) $ + hunlabel hunlabeler + hhere + } + , there = + let + tag = hdecodeTag $ unHIdentity hthereTag + in + MaybeTable + { tag + , just = g $ + runIdentity $ + hunnullify (\a -> pure . hunnullifier a) $ + hunlabel hunlabeler + hthere + } + } diff --git a/src/Rel8/Type/Array.hs b/src/Rel8/Type/Array.hs index 59d976d..ff80058 100644 --- a/src/Rel8/Type/Array.hs +++ b/src/Rel8/Type/Array.hs @@ -32,6 +32,7 @@ array TypeInformation {typeName} = fromPrimArray . Opaleye.CastExpr (typeName <> "[]") . Opaleye.ArrayExpr . toList +{-# INLINABLE array #-} listTypeInformation :: () diff --git a/src/Rel8/Type/Tag.hs b/src/Rel8/Type/Tag.hs index 5762dd6..0933580 100644 --- a/src/Rel8/Type/Tag.hs +++ b/src/Rel8/Type/Tag.hs @@ -19,7 +19,7 @@ import Prelude import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 -import Rel8.Expr ( Expr ) +import {-# SOURCE #-} Rel8.Expr ( Expr ) import Rel8.Expr.Eq ( (==.) ) import Rel8.Expr.Opaleye ( zipPrimExprsWith ) import Rel8.Expr.Serialize ( litExpr )