mirror of
https://github.com/circuithub/rel8.git
synced 2024-08-17 20:00:23 +03:00
Complete overhaul of Rel8.Schema.Generic
This commit is contained in:
parent
09e449bc48
commit
5e4df5096c
@ -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:
|
||||
|
@ -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
|
||||
|
||||
|
||||
|
@ -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 )
|
||||
|
@ -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)
|
||||
|
@ -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)
|
@ -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
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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))
|
||||
|
@ -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 )
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
}
|
||||
}
|
||||
|
@ -32,6 +32,7 @@ array TypeInformation {typeName} =
|
||||
fromPrimArray .
|
||||
Opaleye.CastExpr (typeName <> "[]") .
|
||||
Opaleye.ArrayExpr . toList
|
||||
{-# INLINABLE array #-}
|
||||
|
||||
|
||||
listTypeInformation :: ()
|
||||
|
@ -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 )
|
||||
|
Loading…
Reference in New Issue
Block a user