mirror of
https://github.com/circuithub/rel8.git
synced 2024-09-11 16:05:41 +03:00
Remove Labelable type class; we don't really need labels at the type level anymore
This commit is contained in:
parent
70ce05d8d1
commit
d1c1bd7ced
@ -79,7 +79,6 @@ library
|
||||
|
||||
Rel8.Kind.Algebra
|
||||
Rel8.Kind.Context
|
||||
Rel8.Kind.Labels
|
||||
|
||||
Rel8.Generic.Construction
|
||||
Rel8.Generic.Construction.ADT
|
||||
@ -115,7 +114,6 @@ library
|
||||
Rel8.Query.Values
|
||||
|
||||
Rel8.Schema.Context
|
||||
Rel8.Schema.Context.Label
|
||||
Rel8.Schema.Context.Nullify
|
||||
Rel8.Schema.Dict
|
||||
Rel8.Schema.HTable
|
||||
|
@ -270,7 +270,6 @@ module Rel8
|
||||
, evaluate
|
||||
|
||||
-- * Implementation details
|
||||
, Labelable
|
||||
, HKDT(..)
|
||||
) where
|
||||
|
||||
@ -317,7 +316,6 @@ import Rel8.Query.SQL (showQuery)
|
||||
import Rel8.Query.Set
|
||||
import Rel8.Query.These
|
||||
import Rel8.Query.Values
|
||||
import Rel8.Schema.Context.Label
|
||||
import Rel8.Schema.HTable
|
||||
import Rel8.Schema.Name
|
||||
import Rel8.Schema.Null hiding ( nullable )
|
||||
|
@ -33,7 +33,6 @@ import qualified Opaleye.Internal.PackMap as Opaleye
|
||||
-- rel8
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Schema.Context ( Interpretation(..) )
|
||||
import Rel8.Schema.Context.Label ( Labelable(..) )
|
||||
import Rel8.Schema.HTable.Identity ( HIdentity(..), HType )
|
||||
import Rel8.Schema.Name ( Name )
|
||||
import Rel8.Schema.Null ( Sql )
|
||||
@ -62,7 +61,7 @@ instance Interpretation Aggregate where
|
||||
data Col Aggregate _spec where
|
||||
A :: ()
|
||||
=> { unA :: !(Aggregate a) }
|
||||
-> Col Aggregate ('Spec labels a)
|
||||
-> Col Aggregate ('Spec a)
|
||||
|
||||
|
||||
instance Sql DBType a => Table Aggregate (Aggregate a) where
|
||||
@ -104,11 +103,6 @@ instance Sql DBType a =>
|
||||
Recontextualize Name Aggregate (Name a) (Aggregate a)
|
||||
|
||||
|
||||
instance Labelable Aggregate where
|
||||
labeler (A aggregate) = A aggregate
|
||||
unlabeler (A aggregate) = A aggregate
|
||||
|
||||
|
||||
-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's
|
||||
-- for the columns in @b@.
|
||||
type Aggregates :: Type -> Type -> Constraint
|
||||
|
@ -20,7 +20,7 @@ import Rel8.Aggregate ( Aggregate, Col( A ) )
|
||||
import Rel8.Expr ( Expr, Col( E ) )
|
||||
import Rel8.FCF ( Eval, Exp )
|
||||
import Rel8.Kind.Context ( SContext(..), Reifiable( contextSing ) )
|
||||
import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
|
||||
import Rel8.Schema.HTable.Identity ( HIdentity(..), HType )
|
||||
import qualified Rel8.Schema.Kind as K
|
||||
import Rel8.Schema.Name ( Name(..), Col( N ) )
|
||||
import Rel8.Schema.Null ( Sql )
|
||||
@ -55,11 +55,11 @@ instance (Reifiable context, Sql DBType a) =>
|
||||
Table (Reify context) (AColumn context a)
|
||||
where
|
||||
type Context (AColumn context a) = Reify context
|
||||
type Columns (AColumn context a) = HIdentity ('Spec '[] a)
|
||||
type Columns (AColumn context a) = HType a
|
||||
type Unreify (AColumn context a) = Column context a
|
||||
|
||||
fromColumns (HIdentity (Reify a)) = sfromColumn contextSing a
|
||||
toColumns = HIdentity . Reify . stoColumn contextSing
|
||||
fromColumns (HType (Reify a)) = sfromColumn contextSing a
|
||||
toColumns = HType . Reify . stoColumn contextSing
|
||||
reify _ = AColumn
|
||||
unreify _ (AColumn a) = a
|
||||
|
||||
@ -77,7 +77,7 @@ instance
|
||||
|
||||
sfromColumn :: ()
|
||||
=> SContext context
|
||||
-> Col context ('Spec labels a)
|
||||
-> Col context ('Spec a)
|
||||
-> AColumn context a
|
||||
sfromColumn = \case
|
||||
SAggregate -> \(A a) -> AColumn a
|
||||
@ -90,7 +90,7 @@ sfromColumn = \case
|
||||
stoColumn :: ()
|
||||
=> SContext context
|
||||
-> AColumn context a
|
||||
-> Col context ('Spec labels a)
|
||||
-> Col context ('Spec a)
|
||||
stoColumn = \case
|
||||
SAggregate -> \(AColumn a) -> A a
|
||||
SExpr -> \(AColumn a) -> E a
|
||||
|
@ -39,7 +39,6 @@ import Rel8.Expr.Opaleye
|
||||
)
|
||||
import Rel8.Expr.Serialize ( litExpr )
|
||||
import Rel8.Schema.Context ( Interpretation, Col )
|
||||
import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
|
||||
import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )
|
||||
import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
|
||||
import Rel8.Schema.Reify ( notReify )
|
||||
@ -128,7 +127,7 @@ instance Sql DBFloating a => Floating (Expr a) where
|
||||
|
||||
instance Interpretation Expr where
|
||||
data Col Expr _spec where
|
||||
E :: {unE :: !(Expr a)} -> Col Expr ('Spec labels a)
|
||||
E :: {unE :: !(Expr a)} -> Col Expr ('Spec a)
|
||||
|
||||
|
||||
instance Sql DBType a => Table Expr (Expr a) where
|
||||
@ -148,8 +147,3 @@ instance Sql DBType a => Recontextualize Expr Result (Expr a) (Identity a)
|
||||
|
||||
|
||||
instance Sql DBType a => Recontextualize Result Expr (Identity a) (Expr a)
|
||||
|
||||
|
||||
instance Labelable Expr where
|
||||
labeler (E a) = E a
|
||||
unlabeler (E a) = E a
|
||||
|
@ -48,7 +48,6 @@ import Rel8.Generic.Construction.Record
|
||||
)
|
||||
import Rel8.Generic.Table.ADT ( GColumnsADT, GColumnsADT' )
|
||||
import Rel8.Generic.Table.Record ( GColumns )
|
||||
import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
|
||||
import Rel8.Schema.HTable ( HTable )
|
||||
import Rel8.Schema.HTable.Identity ( HType )
|
||||
import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
|
||||
@ -64,23 +63,23 @@ import Data.Text ( pack )
|
||||
|
||||
|
||||
type Null :: K.HContext -> Type
|
||||
type Null context = forall labels a. ()
|
||||
=> SSpec ('Spec labels a)
|
||||
-> context ('Spec labels (Nullify a))
|
||||
type Null context = forall a. ()
|
||||
=> SSpec ('Spec a)
|
||||
-> context ('Spec (Nullify a))
|
||||
|
||||
|
||||
type Nullifier :: K.HContext -> Type
|
||||
type Nullifier context = forall labels a. ()
|
||||
=> SSpec ('Spec labels a)
|
||||
-> context ('Spec labels a)
|
||||
-> context ('Spec labels (Nullify a))
|
||||
type Nullifier context = forall a. ()
|
||||
=> SSpec ('Spec a)
|
||||
-> context ('Spec a)
|
||||
-> context ('Spec (Nullify a))
|
||||
|
||||
|
||||
type Unnullifier :: K.HContext -> Type
|
||||
type Unnullifier context = forall labels a. ()
|
||||
=> SSpec ('Spec labels a)
|
||||
-> context ('Spec labels (Nullify a))
|
||||
-> context ('Spec labels a)
|
||||
type Unnullifier context = forall a. ()
|
||||
=> SSpec ('Spec a)
|
||||
-> context ('Spec (Nullify a))
|
||||
-> context ('Spec a)
|
||||
|
||||
|
||||
type NoConstructor :: Symbol -> Symbol -> ErrorMessage
|
||||
@ -222,24 +221,23 @@ class GConstructableADT _Table _Columns f context rep where
|
||||
instance
|
||||
( htable ~ HLabel "tag" (HType Tag)
|
||||
, GConstructableADT' _Table _Columns f context htable rep
|
||||
, HLabelable context
|
||||
)
|
||||
=> GConstructableADT _Table _Columns f context (M1 D meta rep)
|
||||
where
|
||||
gbuildADT toColumns nullifier =
|
||||
gbuildADT' @_Table @_Columns @f @context @htable @rep toColumns nullifier .
|
||||
hlabel hlabeler
|
||||
hlabel
|
||||
|
||||
gunbuildADT fromColumns unnullifier =
|
||||
first (hunlabel hunlabeler) .
|
||||
first hunlabel .
|
||||
gunbuildADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier
|
||||
|
||||
gconstructADT toColumns null nullifier mk =
|
||||
gconstructADT' @_Table @_Columns @f @context @htable @rep toColumns null nullifier
|
||||
(hlabel hlabeler . mk)
|
||||
(hlabel . mk)
|
||||
|
||||
gdeconstructADT fromColumns unnullifier cases =
|
||||
first (hunlabel hunlabeler) .
|
||||
first hunlabel .
|
||||
gdeconstructADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier cases
|
||||
|
||||
|
||||
@ -334,7 +332,6 @@ instance {-# OVERLAPPABLE #-}
|
||||
( HTable (GColumns _Columns rep)
|
||||
, KnownSymbol label
|
||||
, meta ~ 'MetaCons label _fixity _isRecord
|
||||
, HLabelable context
|
||||
, GConstructable _Table _Columns f context rep
|
||||
, GColumnsADT' _Columns htable (M1 C meta rep) ~
|
||||
HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
|
||||
@ -343,7 +340,7 @@ instance {-# OVERLAPPABLE #-}
|
||||
where
|
||||
gbuildADT' toColumns nullifier htable =
|
||||
HProduct htable .
|
||||
hlabel hlabeler .
|
||||
hlabel .
|
||||
hnullify (nullifier tag) .
|
||||
gconstruct @_Table @_Columns @f @context @rep toColumns
|
||||
where
|
||||
@ -354,13 +351,13 @@ instance {-# OVERLAPPABLE #-}
|
||||
, gdeconstruct @_Table @_Columns @f @context @rep fromColumns $
|
||||
runIdentity $
|
||||
hunnullify (\spec -> pure . unnullifier spec) $
|
||||
hunlabel hunlabeler
|
||||
hunlabel
|
||||
a
|
||||
)
|
||||
|
||||
gconstructADT' toColumns _ nullifier mk =
|
||||
HProduct htable .
|
||||
hlabel hlabeler .
|
||||
hlabel .
|
||||
hnullify nullifier .
|
||||
gconstruct @_Table @_Columns @f @context @rep toColumns
|
||||
where
|
||||
@ -375,11 +372,11 @@ instance {-# OVERLAPPABLE #-}
|
||||
a = gdeconstruct @_Table @_Columns @f @context @rep fromColumns $
|
||||
runIdentity $
|
||||
hunnullify (\spec -> pure . unnullifier spec) $
|
||||
hunlabel hunlabeler
|
||||
hunlabel
|
||||
columns
|
||||
tag = Tag $ pack $ symbolVal (Proxy @label)
|
||||
|
||||
gfill null htable = HProduct htable (hlabel hlabeler (hnulls null))
|
||||
gfill null htable = HProduct htable (hlabel (hnulls null))
|
||||
|
||||
|
||||
type GMakeableADT
|
||||
@ -403,7 +400,6 @@ instance
|
||||
, fallback ~ TypeError (NoConstructor datatype name)
|
||||
, fields ~ GFields f (GConstructorADT' name rep fallback)
|
||||
, GMakeableADT' _Table _Columns f context htable name rep fields
|
||||
, HLabelable context
|
||||
, KnownSymbol name
|
||||
)
|
||||
=> GMakeableADT _Table _Columns f context name (M1 D meta rep)
|
||||
@ -414,7 +410,7 @@ instance
|
||||
toColumns null nullifier htable
|
||||
where
|
||||
tag = Tag $ pack $ symbolVal (Proxy @name)
|
||||
htable = hlabel hlabeler (wrap tag)
|
||||
htable = hlabel (wrap tag)
|
||||
|
||||
|
||||
type GMakeableADT'
|
||||
@ -462,8 +458,6 @@ instance {-# OVERLAPS #-}
|
||||
|
||||
instance {-# OVERLAPS #-}
|
||||
( HTable (GColumns _Columns rep)
|
||||
, KnownSymbol name
|
||||
, HLabelable context
|
||||
, GConstructable _Table _Columns f context rep
|
||||
, fields ~ GFields f rep
|
||||
, GColumnsADT' _Columns htable (M1 C ('MetaCons name _fixity _isRecord) rep) ~
|
||||
@ -473,15 +467,13 @@ instance {-# OVERLAPS #-}
|
||||
where
|
||||
gmakeADT' toColumns _ nullifier htable =
|
||||
HProduct htable .
|
||||
hlabel hlabeler .
|
||||
hlabel .
|
||||
hnullify nullifier .
|
||||
gconstruct @_Table @_Columns @f @context @rep toColumns
|
||||
|
||||
|
||||
instance {-# OVERLAPPABLE #-}
|
||||
( HTable (GColumns _Columns rep)
|
||||
, KnownSymbol label
|
||||
, HLabelable context
|
||||
, GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~
|
||||
HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
|
||||
)
|
||||
@ -489,5 +481,5 @@ instance {-# OVERLAPPABLE #-}
|
||||
where
|
||||
gmakeADT' _ null _ htable _ =
|
||||
HProduct htable $
|
||||
hlabel hlabeler $
|
||||
hlabel $
|
||||
hnulls null
|
||||
|
@ -27,15 +27,13 @@ import GHC.Generics
|
||||
)
|
||||
import GHC.TypeLits
|
||||
( ErrorMessage( (:<>:), Text ), TypeError
|
||||
, Symbol, KnownSymbol
|
||||
, Symbol
|
||||
)
|
||||
import Prelude
|
||||
|
||||
-- rel8
|
||||
import Rel8.FCF ( Eval, Exp )
|
||||
import Rel8.Generic.Table.Record ( GColumns )
|
||||
import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
|
||||
import Rel8.Schema.HTable ( HTable )
|
||||
import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
|
||||
import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
|
||||
import qualified Rel8.Schema.Kind as K
|
||||
@ -162,12 +160,9 @@ instance
|
||||
|
||||
instance
|
||||
( Eval (_Table a)
|
||||
, HTable (Eval (_Columns a))
|
||||
, HLabelable context
|
||||
, KnownSymbol label
|
||||
, meta ~ 'MetaSel ('Just label) _su _ss _ds
|
||||
)
|
||||
=> GConstructable _Table _Columns f context (M1 S meta (K1 i a))
|
||||
where
|
||||
gconstruct toColumns = hlabel hlabeler . toColumns (Proxy @a)
|
||||
gdeconstruct fromColumns = fromColumns (Proxy @a) . hunlabel hunlabeler
|
||||
gconstruct toColumns = hlabel . toColumns (Proxy @a)
|
||||
gdeconstruct fromColumns = fromColumns (Proxy @a) . hunlabel
|
||||
|
@ -36,7 +36,6 @@ import Rel8.Generic.Table ( GAlgebra )
|
||||
import qualified Rel8.Generic.Table.Record as G
|
||||
import qualified Rel8.Kind.Algebra as K ( Algebra(..) )
|
||||
import Rel8.Schema.Context ( Col )
|
||||
import Rel8.Schema.Context.Label ( Labelable )
|
||||
import Rel8.Schema.HTable ( HTable )
|
||||
import qualified Rel8.Schema.Kind as K
|
||||
import Rel8.Schema.Reify ( Reify, UnwrapReify )
|
||||
@ -98,16 +97,16 @@ type Rel8able :: K.Rel8able -> Constraint
|
||||
class HTable (GColumns t) => Rel8able t where
|
||||
type GColumns t :: K.HTable
|
||||
|
||||
gfromColumns :: (Labelable context, Reifiable context)
|
||||
gfromColumns :: Reifiable context
|
||||
=> GColumns t (Col (Reify context)) -> t (Reify context)
|
||||
|
||||
gtoColumns :: (Labelable context, Reifiable context)
|
||||
gtoColumns :: Reifiable context
|
||||
=> t (Reify context) -> GColumns t (Col (Reify context))
|
||||
|
||||
greify :: (Labelable context, Reifiable context)
|
||||
greify :: Reifiable context
|
||||
=> t context -> t (Reify context)
|
||||
|
||||
gunreify :: (Labelable context, Reifiable context)
|
||||
gunreify :: Reifiable context
|
||||
=> t (Reify context) -> t context
|
||||
|
||||
type GColumns t = G.GColumns TColumns (GRep t (Reify Result))
|
||||
|
@ -148,10 +148,10 @@ ggtable :: forall algebra _Table _Columns rep context.
|
||||
, Eval (GGTable algebra _Table _Columns context rep)
|
||||
)
|
||||
=> (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)
|
||||
-> (forall a labels. ()
|
||||
=> SSpec ('Spec labels a)
|
||||
-> context ('Spec labels a)
|
||||
-> context ('Spec labels (Nullify a)))
|
||||
-> (forall a. ()
|
||||
=> SSpec ('Spec a)
|
||||
-> context ('Spec a)
|
||||
-> context ('Spec (Nullify a)))
|
||||
-> Eval (GGColumns algebra _Columns rep) context
|
||||
ggtable = case algebraSing @algebra of
|
||||
SProduct -> \table _ -> gtable @_Table @_Columns @_ @rep table
|
||||
|
@ -37,7 +37,6 @@ import Rel8.Generic.Table.Record
|
||||
( GTable, GColumns, gtable
|
||||
, GToExprs, gfromResult, gtoResult
|
||||
)
|
||||
import Rel8.Schema.Context.Label ( HLabelable, hlabeler, labeler, unlabeler )
|
||||
import Rel8.Schema.HTable ( HTable, hmap )
|
||||
import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )
|
||||
import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
|
||||
@ -96,10 +95,10 @@ class GTableADT _Table _Columns context rep where
|
||||
|
||||
gtableADT :: ()
|
||||
=> (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)
|
||||
-> (forall a labels. ()
|
||||
=> SSpec ('Spec labels a)
|
||||
-> context ('Spec labels a)
|
||||
-> context ('Spec labels (Nullify a)))
|
||||
-> (forall a. ()
|
||||
=> SSpec ('Spec a)
|
||||
-> context ('Spec a)
|
||||
-> context ('Spec (Nullify a)))
|
||||
-> GColumnsADT _Columns rep context
|
||||
|
||||
|
||||
@ -136,10 +135,10 @@ type GTableADT'
|
||||
class GTableADT' _Table _Columns htable context rep where
|
||||
gtableADT' :: ()
|
||||
=> (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context)
|
||||
-> (forall a labels. ()
|
||||
=> SSpec ('Spec labels a)
|
||||
-> context ('Spec labels a)
|
||||
-> context ('Spec labels (Nullify a)))
|
||||
-> (forall a. ()
|
||||
=> SSpec ('Spec a)
|
||||
-> context ('Spec a)
|
||||
-> context ('Spec (Nullify a)))
|
||||
-> htable context
|
||||
-> GColumnsADT' _Columns htable rep context
|
||||
|
||||
@ -165,9 +164,7 @@ instance meta ~ 'MetaCons label _fixity _isRecord =>
|
||||
instance {-# OVERLAPPABLE #-}
|
||||
( HTable (GColumns _Columns rep)
|
||||
, GTable _Table _Columns context rep
|
||||
, HLabelable context
|
||||
, meta ~ 'MetaCons label _fixity _isRecord
|
||||
, KnownSymbol label
|
||||
, GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~
|
||||
HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
|
||||
)
|
||||
@ -175,7 +172,7 @@ instance {-# OVERLAPPABLE #-}
|
||||
where
|
||||
gtableADT' table hnullifier htable =
|
||||
HProduct htable $
|
||||
hlabel hlabeler $
|
||||
hlabel $
|
||||
hnullify hnullifier $
|
||||
gtable @_Table @_Columns @_ @rep table
|
||||
|
||||
@ -219,12 +216,12 @@ instance
|
||||
Just rep -> M1 rep
|
||||
_ -> error "ADT.fromColumns: mismatch between tag and data"
|
||||
where
|
||||
tag = (\(HType (R a)) -> a) . hunlabel @_ @"tag" unlabeler
|
||||
tag = (\(HType (R a)) -> a) . hunlabel @"tag"
|
||||
|
||||
gtoResultADT toResult (M1 rep) =
|
||||
gtoResultADT' @_ToExprs @_Columns @_ @exprs toResult tag (Just rep)
|
||||
where
|
||||
tag = hlabel @_ @"tag" labeler . HType . R
|
||||
tag = hlabel @"tag" . HType . R
|
||||
|
||||
|
||||
type GToExprsADT'
|
||||
@ -342,15 +339,15 @@ instance {-# OVERLAPPABLE #-}
|
||||
gfromResultADT' fromResult tag (HProduct a b)
|
||||
| tag a == tag' =
|
||||
M1 . gfromResult @_ToExprs @_Columns @exprs fromResult <$>
|
||||
hunnullify unnullifier (hunlabel unlabeler b)
|
||||
hunnullify unnullifier (hunlabel b)
|
||||
| otherwise = Nothing
|
||||
where
|
||||
tag' = Tag $ pack $ symbolVal (Proxy @label)
|
||||
|
||||
gtoResultADT' toResult tag = \case
|
||||
Nothing -> HProduct (tag tag') (hlabel labeler (hnulls (const null)))
|
||||
Nothing -> HProduct (tag tag') (hlabel (hnulls (const null)))
|
||||
Just (M1 rep) -> HProduct (tag tag') $
|
||||
hlabel labeler $
|
||||
hlabel $
|
||||
hnullify nullifier $
|
||||
gtoResult @_ToExprs @_Columns @exprs toResult rep
|
||||
where
|
||||
|
@ -26,13 +26,11 @@ import GHC.Generics
|
||||
, C, D, S
|
||||
, Meta( MetaSel )
|
||||
)
|
||||
import GHC.TypeLits ( KnownSymbol )
|
||||
import Prelude hiding ( null )
|
||||
|
||||
-- rel8
|
||||
import Rel8.FCF ( Eval, Exp )
|
||||
import Rel8.Schema.Context ( Col )
|
||||
import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
|
||||
import Rel8.Schema.HTable ( HTable )
|
||||
import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
|
||||
import Rel8.Schema.HTable.Product ( HProduct(..) )
|
||||
@ -116,18 +114,15 @@ instance
|
||||
|
||||
|
||||
instance
|
||||
( HTable (Eval (_Columns a))
|
||||
, Eval (_Table a)
|
||||
, HLabelable context
|
||||
, KnownSymbol label
|
||||
( Eval (_Table a)
|
||||
, meta ~ 'MetaSel ('Just label) _su _ss _ds
|
||||
, k1 ~ K1 i a
|
||||
)
|
||||
=> GTable _Table _Columns context (M1 S meta k1)
|
||||
where
|
||||
gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel hunlabeler
|
||||
gtoColumns toColumns (M1 (K1 a)) = hlabel hlabeler (toColumns a)
|
||||
gtable table = hlabel hlabeler (table (Proxy @a))
|
||||
gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel
|
||||
gtoColumns toColumns (M1 (K1 a)) = hlabel (toColumns a)
|
||||
gtable table = hlabel (table (Proxy @a))
|
||||
|
||||
|
||||
type GToExprs
|
||||
@ -193,7 +188,6 @@ instance
|
||||
instance
|
||||
( Eval (_ToExprs exprs a)
|
||||
, HTable (Eval (_Columns exprs))
|
||||
, KnownSymbol label
|
||||
, meta ~ 'MetaSel ('Just label) _su _ss _ds
|
||||
, k1 ~ K1 i exprs
|
||||
, k1' ~ K1 i a
|
||||
@ -201,6 +195,6 @@ instance
|
||||
=> GToExprs _ToExprs _Columns (M1 S meta k1) (M1 S meta k1')
|
||||
where
|
||||
gfromResult fromResult =
|
||||
M1 . K1 . fromResult (Proxy @exprs) . hunlabel hunlabeler
|
||||
M1 . K1 . fromResult (Proxy @exprs) . hunlabel
|
||||
gtoResult toResult (M1 (K1 a)) =
|
||||
hlabel hlabeler (toResult (Proxy @exprs) a)
|
||||
hlabel (toResult (Proxy @exprs) a)
|
||||
|
@ -7,7 +7,6 @@ module Rel8.Kind.Context
|
||||
( Reifiable( contextSing )
|
||||
, SContext(..)
|
||||
, sReifiable
|
||||
, sLabelable
|
||||
)
|
||||
where
|
||||
|
||||
@ -20,7 +19,6 @@ import Rel8.Aggregate ( Aggregate )
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Schema.Dict ( Dict( Dict ) )
|
||||
import Rel8.Schema.Context ( Interpretation )
|
||||
import Rel8.Schema.Context.Label ( Labelable )
|
||||
import Rel8.Schema.Kind ( Context )
|
||||
import Rel8.Schema.Name ( Name )
|
||||
import Rel8.Schema.Reify ( Reify )
|
||||
@ -69,13 +67,3 @@ sReifiable = \case
|
||||
SResult -> Dict
|
||||
SReify context -> case sReifiable context of
|
||||
Dict -> Dict
|
||||
|
||||
|
||||
sLabelable :: SContext context -> Dict Labelable context
|
||||
sLabelable = \case
|
||||
SAggregate -> Dict
|
||||
SExpr -> Dict
|
||||
SName -> Dict
|
||||
SResult -> Dict
|
||||
SReify context -> case sLabelable context of
|
||||
Dict -> Dict
|
||||
|
@ -1,57 +0,0 @@
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language LambdaCase #-}
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language TypeOperators #-}
|
||||
|
||||
module Rel8.Kind.Labels
|
||||
( Labels
|
||||
, SLabels( SNil, SCons )
|
||||
, KnownLabels( labelsSing )
|
||||
, renderLabels
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Data.Kind ( Constraint, Type )
|
||||
import Data.List.NonEmpty ( NonEmpty, nonEmpty )
|
||||
import Data.Maybe ( fromMaybe )
|
||||
import Data.Proxy ( Proxy( Proxy ) )
|
||||
import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
|
||||
import Prelude
|
||||
|
||||
|
||||
type Labels :: Type
|
||||
type Labels = [Symbol]
|
||||
|
||||
|
||||
type SLabels :: Labels -> Type
|
||||
data SLabels labels where
|
||||
SNil :: SLabels '[]
|
||||
SCons :: KnownSymbol label => Proxy label -> SLabels labels -> SLabels (label ': labels)
|
||||
|
||||
|
||||
type KnownLabels :: Labels -> Constraint
|
||||
class KnownLabels labels where
|
||||
labelsSing :: SLabels labels
|
||||
|
||||
|
||||
instance KnownLabels '[] where
|
||||
labelsSing = SNil
|
||||
|
||||
|
||||
instance (KnownSymbol label, KnownLabels labels) =>
|
||||
KnownLabels (label ': labels)
|
||||
where
|
||||
labelsSing = SCons Proxy labelsSing
|
||||
|
||||
|
||||
renderLabels :: SLabels labels -> NonEmpty String
|
||||
renderLabels = fromMaybe (pure "anon") . nonEmpty . go
|
||||
where
|
||||
go :: SLabels labels -> [String]
|
||||
go = \case
|
||||
SNil -> []
|
||||
SCons label labels -> symbolVal label : go labels
|
@ -1,62 +0,0 @@
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
|
||||
module Rel8.Schema.Context.Label
|
||||
( Labelable( labeler, unlabeler )
|
||||
, HLabelable( hlabeler, hunlabeler )
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Data.Kind ( Constraint )
|
||||
import Prelude hiding ( null )
|
||||
|
||||
-- rel8
|
||||
import Rel8.Schema.Context ( Interpretation )
|
||||
import Rel8.Schema.Dict ( Dict( Dict ) )
|
||||
import Rel8.Schema.Kind ( Context, HContext )
|
||||
import Rel8.Schema.Spec ( Spec( Spec ) )
|
||||
import Rel8.Schema.Result ( Col( R ), Result )
|
||||
import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
|
||||
|
||||
|
||||
-- | The @Labelable@ class is an internal implementation detail of Rel8, and
|
||||
-- indicates that we can successfully "name" all columns in a type.
|
||||
type Labelable :: Context -> Constraint
|
||||
class Interpretation context => Labelable context where
|
||||
labeler :: ()
|
||||
=> Col context ('Spec labels a)
|
||||
-> Col context ('Spec (label ': labels) a)
|
||||
|
||||
unlabeler :: ()
|
||||
=> Col context ('Spec (label ': labels) a)
|
||||
-> Col context ('Spec labels a)
|
||||
|
||||
|
||||
instance Labelable Result where
|
||||
labeler (R a) = R a
|
||||
unlabeler (R a) = R a
|
||||
|
||||
|
||||
type HLabelable :: HContext -> Constraint
|
||||
class HLabelable context where
|
||||
hlabeler :: ()
|
||||
=> context ('Spec labels a)
|
||||
-> context ('Spec (label ': labels) a)
|
||||
|
||||
hunlabeler :: ()
|
||||
=> context ('Spec (label ': labels) a)
|
||||
-> context ('Spec labels a)
|
||||
|
||||
|
||||
instance Labelable context => HLabelable (Col context) where
|
||||
hlabeler = labeler
|
||||
hunlabeler = unlabeler
|
||||
|
||||
|
||||
instance HLabelable (Dict (ConstrainDBType constraint)) where
|
||||
hlabeler Dict = Dict
|
||||
hunlabeler Dict = Dict
|
@ -51,31 +51,30 @@ class Interpretation context => Nullifiable context where
|
||||
|
||||
encodeTag ::
|
||||
( Sql (ConstrainTag context) a
|
||||
, KnownSymbol label
|
||||
, Taggable a
|
||||
)
|
||||
=> Tag label a
|
||||
-> Col context ('Spec labels a)
|
||||
-> Col context ('Spec a)
|
||||
|
||||
decodeTag ::
|
||||
( Sql (ConstrainTag context) a
|
||||
, KnownSymbol label
|
||||
, Taggable a
|
||||
)
|
||||
=> Col context ('Spec labels a)
|
||||
=> Col context ('Spec a)
|
||||
-> Tag label a
|
||||
|
||||
nullifier :: ()
|
||||
=> Tag label a
|
||||
-> (Expr a -> Expr Bool)
|
||||
-> SSpec ('Spec labels x)
|
||||
-> Col context ('Spec labels x)
|
||||
-> Col context ('Spec labels (Nullify x))
|
||||
-> SSpec ('Spec x)
|
||||
-> Col context ('Spec x)
|
||||
-> Col context ('Spec (Nullify x))
|
||||
|
||||
unnullifier :: ()
|
||||
=> SSpec ('Spec labels x)
|
||||
-> Col context ('Spec labels (Nullify x))
|
||||
-> Col context ('Spec labels x)
|
||||
=> SSpec ('Spec x)
|
||||
-> Col context ('Spec (Nullify x))
|
||||
-> Col context ('Spec x)
|
||||
|
||||
|
||||
instance Nullifiable Aggregate where
|
||||
@ -147,23 +146,23 @@ class HNullifiable context where
|
||||
|
||||
hencodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
|
||||
=> Tag label a
|
||||
-> context ('Spec labels a)
|
||||
-> context ('Spec a)
|
||||
|
||||
hdecodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
|
||||
=> context ('Spec labels a)
|
||||
=> context ('Spec a)
|
||||
-> Tag label a
|
||||
|
||||
hnullifier :: ()
|
||||
=> Tag label a
|
||||
-> (Expr a -> Expr Bool)
|
||||
-> SSpec ('Spec labels x)
|
||||
-> context ('Spec labels x)
|
||||
-> context ('Spec labels (Nullify x))
|
||||
-> SSpec ('Spec x)
|
||||
-> context ('Spec x)
|
||||
-> context ('Spec (Nullify x))
|
||||
|
||||
hunnullifier :: ()
|
||||
=> SSpec ('Spec labels x)
|
||||
-> context ('Spec labels (Nullify x))
|
||||
-> context ('Spec labels x)
|
||||
=> SSpec ('Spec x)
|
||||
-> context ('Spec (Nullify x))
|
||||
-> context ('Spec x)
|
||||
|
||||
|
||||
instance Nullifiable context => HNullifiable (Col context) where
|
||||
|
@ -15,17 +15,16 @@ import Prelude ()
|
||||
|
||||
-- rel8
|
||||
import Rel8.Schema.HTable ( HTable )
|
||||
import Rel8.Schema.HTable.Identity ( HIdentity(..) )
|
||||
import Rel8.Schema.HTable.Identity ( HType )
|
||||
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 ( EitherTag )
|
||||
|
||||
|
||||
type HEitherTable :: K.HTable -> K.HTable -> K.HTable
|
||||
data HEitherTable left right context = HEitherTable
|
||||
{ htag :: HIdentity ('Spec '["isRight"] EitherTag) context
|
||||
{ htag :: HLabel "isRight" (HType EitherTag) context
|
||||
, hleft :: HLabel "Left" (HNullify left) context
|
||||
, hright :: HLabel "Right" (HNullify right) context
|
||||
}
|
||||
|
@ -25,10 +25,10 @@ import Rel8.Schema.Spec ( Spec( Spec ), KnownSpec, specSing )
|
||||
|
||||
|
||||
type HType :: Type -> K.HTable
|
||||
type HType a = HIdentity ('Spec '[] a)
|
||||
type HType a = HIdentity ('Spec a)
|
||||
|
||||
|
||||
pattern HType :: context ('Spec '[] a) -> HType a context
|
||||
pattern HType :: context ('Spec a) -> HType a context
|
||||
pattern HType a = HIdentity a
|
||||
{-# COMPLETE HType #-}
|
||||
|
||||
|
@ -1,83 +1,58 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# language ConstraintKinds #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language QuantifiedConstraints #-}
|
||||
{-# language RankNTypes #-}
|
||||
{-# language RecordWildCards #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
|
||||
module Rel8.Schema.HTable.Label
|
||||
( HLabel, Label
|
||||
, hlabel, hunlabel
|
||||
( HLabel, hlabel, hrelabel, hunlabel
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Data.Kind ( Type )
|
||||
import Data.Proxy ( Proxy( Proxy ) )
|
||||
import GHC.TypeLits ( KnownSymbol, Symbol )
|
||||
import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
|
||||
import Prelude
|
||||
|
||||
-- rel8
|
||||
import Rel8.Kind.Labels ( SLabels( SCons ) )
|
||||
import Rel8.Schema.HTable
|
||||
( HTable
|
||||
, hfield, htabulate, hspecs
|
||||
)
|
||||
import qualified Rel8.Schema.Kind as K
|
||||
import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
|
||||
import Rel8.FCF
|
||||
import Rel8.Schema.HTable.MapTable
|
||||
import GHC.Generics (Generic)
|
||||
import Rel8.Schema.Spec ( Spec, SSpec(..) )
|
||||
|
||||
|
||||
type HLabel :: Symbol -> K.HTable -> K.HTable
|
||||
newtype HLabel label table context = HLabel (HMapTable (Label label) table context)
|
||||
deriving stock Generic
|
||||
deriving anyclass HTable
|
||||
newtype HLabel label table context = HLabel (table context)
|
||||
|
||||
|
||||
data Label :: Symbol -> Spec -> Exp Spec
|
||||
type HLabelField :: Symbol -> K.HTable -> Spec -> Type
|
||||
newtype HLabelField label table spec = HLabelField (HField table spec)
|
||||
|
||||
|
||||
type instance Eval (Label label ('Spec labels a)) = 'Spec (label : labels) a
|
||||
instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where
|
||||
type HField (HLabel label table) = HLabelField label table
|
||||
type HConstrainTable (HLabel label table) constraint =
|
||||
HConstrainTable table constraint
|
||||
|
||||
hfield (HLabel a) (HLabelField field) = hfield a field
|
||||
htabulate f = HLabel (htabulate (f . HLabelField))
|
||||
htraverse f (HLabel a) = HLabel <$> htraverse f a
|
||||
hdicts = HLabel (hdicts @table)
|
||||
hspecs = HLabel $ htabulate $ \field -> case hfield (hspecs @table) field of
|
||||
SSpec {..} -> SSpec {labels = symbolVal (Proxy @label) : labels, ..}
|
||||
|
||||
|
||||
instance KnownSymbol l => MapSpec (Label l) where
|
||||
mapInfo = \case
|
||||
SSpec {..} -> SSpec {labels = SCons Proxy labels, ..}
|
||||
|
||||
|
||||
hlabel :: (HTable t, KnownSymbol label)
|
||||
=> (forall labels a. ()
|
||||
=> context ('Spec labels a)
|
||||
-> context ('Spec (label ': labels) a))
|
||||
-> t context
|
||||
-> HLabel label t context
|
||||
hlabel labeler a = HLabel $ htabulate $ \(HMapTableField field) ->
|
||||
case hfield hspecs field of
|
||||
SSpec {} -> labeler (hfield a field)
|
||||
hlabel :: forall label t context. t context -> HLabel label t context
|
||||
hlabel = HLabel
|
||||
{-# INLINABLE hlabel #-}
|
||||
|
||||
|
||||
hunlabel :: (HTable t, KnownSymbol label)
|
||||
=> (forall labels a. ()
|
||||
=> context ('Spec (label ': labels) a)
|
||||
-> context ('Spec labels a))
|
||||
-> HLabel label t context
|
||||
-> t context
|
||||
hunlabel unlabler (HLabel as) =
|
||||
htabulate $ \field ->
|
||||
case hfield hspecs field of
|
||||
SSpec {} -> case hfield as (HMapTableField field) of
|
||||
a -> unlabler a
|
||||
hrelabel :: forall label' label t context. HLabel label t context -> HLabel label' t context
|
||||
hrelabel = hlabel . hunlabel
|
||||
{-# INLINABLE hrelabel #-}
|
||||
|
||||
|
||||
hunlabel :: forall label t context. HLabel label t context -> t context
|
||||
hunlabel (HLabel a) = a
|
||||
{-# INLINABLE hunlabel #-}
|
||||
|
@ -15,17 +15,16 @@ import Prelude
|
||||
|
||||
-- rel8
|
||||
import Rel8.Schema.HTable ( HTable )
|
||||
import Rel8.Schema.HTable.Identity ( HIdentity(..) )
|
||||
import Rel8.Schema.HTable.Identity ( HType )
|
||||
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 )
|
||||
|
||||
|
||||
type HMaybeTable :: K.HTable -> K.HTable
|
||||
data HMaybeTable table context = HMaybeTable
|
||||
{ htag :: HIdentity ('Spec '["isJust"] (Maybe MaybeTag)) context
|
||||
{ htag :: HLabel "isJust" (HType (Maybe MaybeTag)) context
|
||||
, hjust :: HLabel "Just" (HNullify table) context
|
||||
}
|
||||
deriving stock Generic
|
||||
|
@ -10,6 +10,7 @@
|
||||
{-# language NamedFieldPuns #-}
|
||||
{-# language QuantifiedConstraints #-}
|
||||
{-# language RankNTypes #-}
|
||||
{-# language RecordWildCards #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language TypeFamilies #-}
|
||||
@ -50,25 +51,24 @@ newtype HNullify table context = HNullify (HMapTable Nullify table context)
|
||||
data Nullify :: Spec -> Exp Spec
|
||||
|
||||
|
||||
type instance Eval (Nullify ('Spec labels a)) =
|
||||
'Spec labels (Type.Nullify a)
|
||||
type instance Eval (Nullify ('Spec a)) =
|
||||
'Spec (Type.Nullify a)
|
||||
|
||||
|
||||
instance MapSpec Nullify where
|
||||
mapInfo = \case
|
||||
SSpec{labels, info, nullity} -> SSpec
|
||||
{ labels
|
||||
, info
|
||||
, nullity = case nullity of
|
||||
SSpec {nullity, ..} -> SSpec
|
||||
{ nullity = case nullity of
|
||||
Null -> Null
|
||||
NotNull -> Null
|
||||
, ..
|
||||
}
|
||||
|
||||
|
||||
hnulls :: HTable t
|
||||
=> (forall labels a. ()
|
||||
=> SSpec ('Spec labels a)
|
||||
-> context ('Spec labels (Type.Nullify a)))
|
||||
=> (forall a. ()
|
||||
=> SSpec ('Spec a)
|
||||
-> context ('Spec (Type.Nullify a)))
|
||||
-> HNullify t context
|
||||
hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
|
||||
spec@SSpec {} -> null spec
|
||||
@ -76,10 +76,10 @@ hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspe
|
||||
|
||||
|
||||
hnullify :: HTable t
|
||||
=> (forall labels a. ()
|
||||
=> SSpec ('Spec labels a)
|
||||
-> context ('Spec labels a)
|
||||
-> context ('Spec labels (Type.Nullify a)))
|
||||
=> (forall a. ()
|
||||
=> SSpec ('Spec a)
|
||||
-> context ('Spec a)
|
||||
-> context ('Spec (Type.Nullify a)))
|
||||
-> t context
|
||||
-> HNullify t context
|
||||
hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
|
||||
@ -89,10 +89,10 @@ hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) ->
|
||||
|
||||
|
||||
hunnullify :: (HTable t, Apply m)
|
||||
=> (forall labels a. ()
|
||||
=> SSpec ('Spec labels a)
|
||||
-> context ('Spec labels (Type.Nullify a))
|
||||
-> m (context ('Spec labels a)))
|
||||
=> (forall a. ()
|
||||
=> SSpec ('Spec a)
|
||||
-> context ('Spec (Type.Nullify a))
|
||||
-> m (context ('Spec a)))
|
||||
-> HNullify t context
|
||||
-> m (t context)
|
||||
hunnullify unnullifier (HNullify as) =
|
||||
|
@ -15,19 +15,18 @@ import Prelude
|
||||
|
||||
-- rel8
|
||||
import Rel8.Schema.HTable ( HTable )
|
||||
import Rel8.Schema.HTable.Identity ( HIdentity )
|
||||
import Rel8.Schema.HTable.Identity ( HType )
|
||||
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 )
|
||||
|
||||
|
||||
type HTheseTable :: K.HTable -> K.HTable -> K.HTable
|
||||
data HTheseTable here there context = HTheseTable
|
||||
{ hhereTag :: HIdentity ('Spec '["hasHere"] (Maybe MaybeTag)) context
|
||||
{ hhereTag :: HLabel "hereTag" (HType (Maybe MaybeTag)) context
|
||||
, hhere :: HLabel "Here" (HNullify here) context
|
||||
, hthereTag :: HIdentity ('Spec '["hasThere"] (Maybe MaybeTag)) context
|
||||
, hthereTag :: HLabel "thereTag" (HType (Maybe MaybeTag)) context
|
||||
, hthere :: HLabel "There" (HNullify there) context
|
||||
}
|
||||
deriving stock Generic
|
||||
|
@ -32,7 +32,6 @@ import Data.List.NonEmpty ( NonEmpty )
|
||||
import Prelude
|
||||
|
||||
-- rel8
|
||||
import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
|
||||
import Rel8.Schema.Dict ( Dict( Dict ) )
|
||||
import qualified Rel8.Schema.Kind as K
|
||||
import Rel8.Schema.HTable
|
||||
@ -78,7 +77,7 @@ newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) t
|
||||
data Vectorize :: (Type -> Type) -> Spec -> Exp Spec
|
||||
|
||||
|
||||
type instance Eval (Vectorize list ('Spec labels a)) = 'Spec labels (list a)
|
||||
type instance Eval (Vectorize list ('Spec a)) = 'Spec (list a)
|
||||
|
||||
|
||||
instance Vector list => MapSpec (Vectorize list) where
|
||||
@ -92,10 +91,10 @@ instance Vector list => MapSpec (Vectorize list) where
|
||||
|
||||
|
||||
hvectorize :: (HTable t, Unzip f, Vector list)
|
||||
=> (forall labels a. ()
|
||||
=> SSpec ('Spec labels a)
|
||||
-> f (context ('Spec labels a))
|
||||
-> context' ('Spec labels (list a)))
|
||||
=> (forall a. ()
|
||||
=> SSpec ('Spec a)
|
||||
-> f (context ('Spec a))
|
||||
-> context' ('Spec (list a)))
|
||||
-> f (t context)
|
||||
-> HVectorize list t context'
|
||||
hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
|
||||
@ -105,10 +104,10 @@ hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
|
||||
|
||||
|
||||
hunvectorize :: (HTable t, Zip f, Vector list)
|
||||
=> (forall labels a. ()
|
||||
=> SSpec ('Spec labels a)
|
||||
-> context ('Spec labels (list a))
|
||||
-> f (context' ('Spec labels a)))
|
||||
=> (forall a. ()
|
||||
=> SSpec ('Spec a)
|
||||
-> context ('Spec (list a))
|
||||
-> f (context' ('Spec a)))
|
||||
-> HVectorize list t context
|
||||
-> f (t context')
|
||||
hunvectorize unvectorizer (HVectorize table) =
|
||||
@ -119,12 +118,12 @@ hunvectorize unvectorizer (HVectorize table) =
|
||||
|
||||
|
||||
happend :: (HTable t, Vector list) =>
|
||||
( forall labels a. ()
|
||||
( forall a. ()
|
||||
=> Nullity a
|
||||
-> TypeInformation (Unnullify a)
|
||||
-> context ('Spec labels (list a))
|
||||
-> context ('Spec labels (list a))
|
||||
-> context ('Spec labels (list a))
|
||||
-> context ('Spec (list a))
|
||||
-> context ('Spec (list a))
|
||||
-> context ('Spec (list a))
|
||||
)
|
||||
-> HVectorize list t context
|
||||
-> HVectorize list t context
|
||||
@ -136,16 +135,11 @@ happend append (HVectorize as) (HVectorize bs) = HVectorize $
|
||||
|
||||
|
||||
hempty :: HTable t =>
|
||||
( forall labels a. ()
|
||||
( forall a. ()
|
||||
=> Nullity a
|
||||
-> TypeInformation (Unnullify a)
|
||||
-> context ('Spec labels [a])
|
||||
-> context ('Spec [a])
|
||||
)
|
||||
-> HVectorize [] t context
|
||||
hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of
|
||||
SSpec {nullity, info} -> empty nullity info
|
||||
|
||||
|
||||
instance HLabelable g => HLabelable (Precompose (Vectorize list) g) where
|
||||
hlabeler = Precompose . hlabeler . precomposed
|
||||
hunlabeler = Precompose . hunlabeler . precomposed
|
||||
|
@ -28,7 +28,6 @@ import Prelude
|
||||
-- rel8
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Schema.Context ( Interpretation, Col )
|
||||
import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
|
||||
import Rel8.Schema.HTable.Identity ( HIdentity( HType ), HType )
|
||||
import Rel8.Schema.Null ( Sql )
|
||||
import Rel8.Schema.Reify ( notReify )
|
||||
@ -84,12 +83,7 @@ instance Sql DBType a => Recontextualize Name Name (Name a) (Name a)
|
||||
|
||||
instance Interpretation Name where
|
||||
data Col Name _spec where
|
||||
N :: {unN :: !(Name a)} -> Col Name ('Spec labels a)
|
||||
|
||||
|
||||
instance Labelable Name where
|
||||
labeler (N a) = N a
|
||||
unlabeler (N a) = N a
|
||||
N :: {unN :: !(Name a)} -> Col Name ('Spec a)
|
||||
|
||||
|
||||
-- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for
|
||||
|
@ -23,7 +23,6 @@ import Prelude
|
||||
|
||||
-- rel8
|
||||
import Rel8.Schema.Context ( Interpretation, Col )
|
||||
import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
|
||||
import Rel8.Schema.HTable ( HTable, hmap )
|
||||
import Rel8.Schema.Kind ( Context )
|
||||
|
||||
@ -36,11 +35,6 @@ 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)
|
||||
|
||||
|
||||
hreify :: HTable t => t (Col context) -> t (Col (Reify context))
|
||||
hreify = hmap Reify
|
||||
|
||||
|
@ -6,7 +6,6 @@
|
||||
|
||||
module Rel8.Schema.Result
|
||||
( Col( R, unR ), Result
|
||||
, relabel
|
||||
, null, nullifier, unnullifier
|
||||
, vectorizer, unvectorizer
|
||||
)
|
||||
@ -17,7 +16,6 @@ import Prelude hiding ( null )
|
||||
|
||||
-- rel8
|
||||
import Rel8.Schema.Context ( Interpretation( Col ) )
|
||||
import Rel8.Schema.HTable.Identity ( HIdentity(..) )
|
||||
import Rel8.Schema.Kind ( Context )
|
||||
import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) )
|
||||
import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
|
||||
@ -33,32 +31,26 @@ data Result a
|
||||
|
||||
instance Interpretation Result where
|
||||
data Col Result _spec where
|
||||
R :: {unR :: !a} -> Col Result ('Spec labels a)
|
||||
R :: {unR :: !a} -> Col Result ('Spec a)
|
||||
|
||||
|
||||
relabel :: ()
|
||||
=> HIdentity ('Spec labels a) (Col Result)
|
||||
-> HIdentity ('Spec relabels a) (Col Result)
|
||||
relabel (HIdentity (R a)) = HIdentity (R a)
|
||||
|
||||
|
||||
null :: Col Result ('Spec labels (Maybe a))
|
||||
null :: Col Result ('Spec (Maybe a))
|
||||
null = R Nothing
|
||||
|
||||
|
||||
nullifier :: ()
|
||||
=> SSpec ('Spec labels a)
|
||||
-> Col Result ('Spec labels a)
|
||||
-> Col Result ('Spec labels (Nullify a))
|
||||
=> SSpec ('Spec a)
|
||||
-> Col Result ('Spec a)
|
||||
-> Col Result ('Spec (Nullify a))
|
||||
nullifier SSpec {nullity} (R a) = R $ case nullity of
|
||||
Null -> a
|
||||
NotNull -> Just a
|
||||
|
||||
|
||||
unnullifier :: ()
|
||||
=> SSpec ('Spec labels a)
|
||||
-> Col Result ('Spec labels (Nullify a))
|
||||
-> Maybe (Col Result ('Spec labels a))
|
||||
=> SSpec ('Spec a)
|
||||
-> Col Result ('Spec (Nullify a))
|
||||
-> Maybe (Col Result ('Spec a))
|
||||
unnullifier SSpec {nullity} (R a) =
|
||||
case nullity of
|
||||
Null -> pure $ R a
|
||||
@ -66,14 +58,14 @@ unnullifier SSpec {nullity} (R a) =
|
||||
|
||||
|
||||
vectorizer :: Functor f
|
||||
=> SSpec ('Spec labels a)
|
||||
-> f (Col Result ('Spec labels a))
|
||||
-> Col Result ('Spec labels (f a))
|
||||
=> SSpec ('Spec a)
|
||||
-> f (Col Result ('Spec a))
|
||||
-> Col Result ('Spec (f a))
|
||||
vectorizer _ = R . fmap unR
|
||||
|
||||
|
||||
unvectorizer :: Functor f
|
||||
=> SSpec ('Spec labels a)
|
||||
-> Col Result ('Spec labels (f a))
|
||||
-> f (Col Result ('Spec labels a))
|
||||
=> SSpec ('Spec a)
|
||||
-> Col Result ('Spec (f a))
|
||||
-> f (Col Result ('Spec a))
|
||||
unvectorizer _ (R results) = R <$> results
|
||||
|
@ -13,27 +13,26 @@ where
|
||||
|
||||
-- base
|
||||
import Data.Kind ( Constraint, Type )
|
||||
import Prelude ()
|
||||
import Prelude
|
||||
|
||||
-- rel8
|
||||
import Rel8.Kind.Labels ( Labels, SLabels, KnownLabels, labelsSing )
|
||||
import Rel8.Schema.Null ( Nullity, Sql, Unnullify, nullable )
|
||||
import Rel8.Type ( DBType, typeInformation )
|
||||
import Rel8.Type.Information ( TypeInformation )
|
||||
|
||||
|
||||
type Spec :: Type
|
||||
data Spec = Spec Labels Type
|
||||
newtype Spec = Spec Type
|
||||
|
||||
|
||||
type SSpec :: Spec -> Type
|
||||
data SSpec spec where
|
||||
SSpec ::
|
||||
{ labels :: SLabels labels
|
||||
{ labels :: [String]
|
||||
, info :: TypeInformation (Unnullify a)
|
||||
, nullity :: Nullity a
|
||||
}
|
||||
-> SSpec ('Spec labels a)
|
||||
-> SSpec ('Spec a)
|
||||
|
||||
|
||||
type KnownSpec :: Spec -> Constraint
|
||||
@ -41,14 +40,9 @@ class KnownSpec spec where
|
||||
specSing :: SSpec spec
|
||||
|
||||
|
||||
instance
|
||||
( KnownLabels labels
|
||||
, Sql DBType a
|
||||
)
|
||||
=> KnownSpec ('Spec labels a)
|
||||
where
|
||||
instance Sql DBType a => KnownSpec ('Spec a) where
|
||||
specSing = SSpec
|
||||
{ labels = labelsSing
|
||||
{ labels = []
|
||||
, info = typeInformation
|
||||
, nullity = nullable
|
||||
}
|
||||
|
@ -31,47 +31,47 @@ import Rel8.Schema.Spec ( Spec( Spec ), SSpec( SSpec, nullity ) )
|
||||
|
||||
type ConstrainDBType :: (Type -> Constraint) -> Spec -> Constraint
|
||||
class
|
||||
( forall c labels a. ()
|
||||
=> (spec ~ 'Spec labels a)
|
||||
( forall c a. ()
|
||||
=> (spec ~ 'Spec a)
|
||||
=> (forall x. (constraint x => c x)) => Sql c a
|
||||
)
|
||||
=> ConstrainDBType constraint spec
|
||||
instance
|
||||
( spec ~ 'Spec labels a
|
||||
( spec ~ 'Spec a
|
||||
, Sql constraint a
|
||||
)
|
||||
=> ConstrainDBType constraint spec
|
||||
|
||||
|
||||
dbTypeNullity :: Dict (ConstrainDBType c) ('Spec l a) -> Nullity a
|
||||
dbTypeNullity :: Dict (ConstrainDBType c) ('Spec a) -> Nullity a
|
||||
dbTypeNullity = step2 . step1
|
||||
where
|
||||
step1 :: Dict (ConstrainDBType c) ('Spec l a) -> Dict (Sql c) a
|
||||
step1 :: Dict (ConstrainDBType c) ('Spec a) -> Dict (Sql c) a
|
||||
step1 Dict = Dict
|
||||
|
||||
step2 :: Dict (Sql c) a -> Nullity a
|
||||
step2 Dict = nullable
|
||||
|
||||
|
||||
dbTypeDict :: Dict (ConstrainDBType c) ('Spec l a) -> Dict c (Unnullify a)
|
||||
dbTypeDict :: Dict (ConstrainDBType c) ('Spec a) -> Dict c (Unnullify a)
|
||||
dbTypeDict = step2 . step1
|
||||
where
|
||||
step1 :: Dict (ConstrainDBType c) ('Spec l a) -> Dict (Sql c) a
|
||||
step1 :: Dict (ConstrainDBType c) ('Spec a) -> Dict (Sql c) a
|
||||
step1 Dict = Dict
|
||||
|
||||
step2 :: Dict (Sql c) a -> Dict c (Unnullify a)
|
||||
step2 Dict = Dict
|
||||
|
||||
|
||||
fromNullityDict :: Nullity a -> Dict c (Unnullify a) -> Dict (ConstrainDBType c) ('Spec l a)
|
||||
fromNullityDict :: Nullity a -> Dict c (Unnullify a) -> Dict (ConstrainDBType c) ('Spec a)
|
||||
fromNullityDict Null Dict = Dict
|
||||
fromNullityDict NotNull Dict = Dict
|
||||
|
||||
|
||||
nullifier :: ()
|
||||
=> SSpec ('Spec labels a)
|
||||
-> Dict (ConstrainDBType c) ('Spec labels a)
|
||||
-> Dict (ConstrainDBType c) ('Spec labels (Nullify a))
|
||||
=> SSpec ('Spec a)
|
||||
-> Dict (ConstrainDBType c) ('Spec a)
|
||||
-> Dict (ConstrainDBType c) ('Spec (Nullify a))
|
||||
nullifier SSpec {} dict = case dbTypeDict dict of
|
||||
Dict -> case dbTypeNullity dict of
|
||||
Null -> Dict
|
||||
@ -79,9 +79,9 @@ nullifier SSpec {} dict = case dbTypeDict dict of
|
||||
|
||||
|
||||
unnullifier :: ()
|
||||
=> SSpec ('Spec labels a)
|
||||
-> Dict (ConstrainDBType c) ('Spec labels (Nullify a))
|
||||
-> Dict (ConstrainDBType c) ('Spec labels a)
|
||||
=> SSpec ('Spec a)
|
||||
-> Dict (ConstrainDBType c) ('Spec (Nullify a))
|
||||
-> Dict (ConstrainDBType c) ('Spec a)
|
||||
unnullifier SSpec {nullity} dict = case dbTypeDict dict of
|
||||
Dict -> case nullity of
|
||||
Null -> Dict
|
||||
|
@ -41,11 +41,10 @@ import Rel8.Generic.Table
|
||||
)
|
||||
import Rel8.Generic.Record ( Record(..) )
|
||||
import Rel8.Generic.Reify ( ARep )
|
||||
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(..), HType )
|
||||
import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
|
||||
import Rel8.Schema.HTable.Label ( hlabel, hrelabel, hunlabel )
|
||||
import Rel8.Schema.HTable.List ( HListTable )
|
||||
import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
|
||||
import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
|
||||
@ -61,7 +60,6 @@ import Rel8.Schema.Reify
|
||||
)
|
||||
import Rel8.Schema.Result
|
||||
( Col( R ), Result
|
||||
, relabel
|
||||
, null, nullifier, unnullifier
|
||||
, vectorizer, unvectorizer
|
||||
)
|
||||
@ -247,20 +245,20 @@ instance (Table Result a, Table Result b) => Table Result (Either a b) where
|
||||
|
||||
toColumns = \case
|
||||
Left table -> HEitherTable
|
||||
{ htag = HIdentity (R IsLeft)
|
||||
, hleft = hlabel labeler (hnullify nullifier (toColumns table))
|
||||
, hright = hlabel labeler (hnulls (const null))
|
||||
{ htag = hlabel (HType (R IsLeft))
|
||||
, hleft = hlabel (hnullify nullifier (toColumns table))
|
||||
, hright = hlabel (hnulls (const null))
|
||||
}
|
||||
Right table -> HEitherTable
|
||||
{ htag = HIdentity (R IsRight)
|
||||
, hleft = hlabel labeler (hnulls (const null))
|
||||
, hright = hlabel labeler (hnullify nullifier (toColumns table))
|
||||
{ htag = hlabel (HType (R IsRight))
|
||||
, hleft = hlabel (hnulls (const null))
|
||||
, hright = hlabel (hnullify nullifier (toColumns table))
|
||||
}
|
||||
|
||||
fromColumns HEitherTable {htag, hleft, hright} = case htag of
|
||||
HIdentity (R tag) -> case tag of
|
||||
IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hleft)
|
||||
IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel unlabeler hright)
|
||||
fromColumns HEitherTable {htag, hleft, hright} = case hunlabel htag of
|
||||
HType (R tag) -> case tag of
|
||||
IsLeft -> maybe err (Left . fromColumns) $ hunnullify unnullifier (hunlabel hleft)
|
||||
IsRight -> maybe err (Right . fromColumns) $ hunnullify unnullifier (hunlabel hright)
|
||||
where
|
||||
err = error "Either.fromColumns: mismatch between tag and data"
|
||||
|
||||
@ -279,17 +277,17 @@ instance Table Result a => Table Result (Maybe a) where
|
||||
|
||||
toColumns = \case
|
||||
Nothing -> HMaybeTable
|
||||
{ htag = HIdentity (R Nothing)
|
||||
, hjust = hlabel labeler (hnulls (const null))
|
||||
{ htag = hlabel (HIdentity (R Nothing))
|
||||
, hjust = hlabel (hnulls (const null))
|
||||
}
|
||||
Just table -> HMaybeTable
|
||||
{ htag = HIdentity (R (Just IsJust))
|
||||
, hjust = hlabel labeler (hnullify nullifier (toColumns table))
|
||||
{ htag = hlabel (HIdentity (R (Just IsJust)))
|
||||
, hjust = hlabel (hnullify nullifier (toColumns table))
|
||||
}
|
||||
|
||||
fromColumns HMaybeTable {htag, hjust} = case htag of
|
||||
HIdentity (R tag) -> tag $>
|
||||
case hunnullify unnullifier (hunlabel unlabeler hjust) of
|
||||
fromColumns HMaybeTable {htag, hjust} = case hunlabel htag of
|
||||
HType (R tag) -> tag $>
|
||||
case hunnullify unnullifier (hunlabel hjust) of
|
||||
Nothing -> error "Maybe.fromColumns: mismatch between tag and data"
|
||||
Just just -> fromColumns just
|
||||
|
||||
@ -307,10 +305,10 @@ instance (Table Result a, Table Result b) => Table Result (These a b) where
|
||||
type Context (These a b) = Result
|
||||
|
||||
toColumns tables = HTheseTable
|
||||
{ hhereTag = relabel hhereTag
|
||||
, hhere = hlabel labeler (hunlabel unlabeler (toColumns hhere))
|
||||
, hthereTag = relabel hthereTag
|
||||
, hthere = hlabel labeler (hunlabel unlabeler (toColumns hthere))
|
||||
{ hhereTag = hrelabel hhereTag
|
||||
, hhere = hrelabel (toColumns hhere)
|
||||
, hthereTag = hrelabel hthereTag
|
||||
, hthere = hrelabel (toColumns hthere)
|
||||
}
|
||||
where
|
||||
HMaybeTable
|
||||
@ -330,29 +328,27 @@ instance (Table Result a, Table Result b) => Table Result (These a b) where
|
||||
_ -> error "These.fromColumns: mismatch between tags and data"
|
||||
where
|
||||
mhere = HMaybeTable
|
||||
{ htag = relabel hhereTag
|
||||
, hjust = hlabel labeler (hunlabel unlabeler hhere)
|
||||
{ htag = hrelabel hhereTag
|
||||
, hjust = hrelabel hhere
|
||||
}
|
||||
mthere = HMaybeTable
|
||||
{ htag = relabel hthereTag
|
||||
, hjust = hlabel labeler (hunlabel unlabeler hthere)
|
||||
{ htag = hrelabel hthereTag
|
||||
, hjust = hrelabel hthere
|
||||
}
|
||||
|
||||
|
||||
instance (Table context a, Table context b, Labelable context)
|
||||
instance (Table context a, Table context b)
|
||||
=> Table context (a, b)
|
||||
|
||||
|
||||
instance
|
||||
( Table context a, Table context b, Table context c
|
||||
, Labelable context
|
||||
)
|
||||
=> Table context (a, b, c)
|
||||
|
||||
|
||||
instance
|
||||
( Table context a, Table context b, Table context c, Table context d
|
||||
, Labelable context
|
||||
)
|
||||
=> Table context (a, b, c, d)
|
||||
|
||||
@ -360,7 +356,6 @@ instance
|
||||
instance
|
||||
( Table context a, Table context b, Table context c, Table context d
|
||||
, Table context e
|
||||
, Labelable context
|
||||
)
|
||||
=> Table context (a, b, c, d, e)
|
||||
|
||||
@ -368,7 +363,6 @@ instance
|
||||
instance
|
||||
( Table context a, Table context b, Table context c, Table context d
|
||||
, Table context e, Table context f
|
||||
, Labelable context
|
||||
)
|
||||
=> Table context (a, b, c, d, e, f)
|
||||
|
||||
@ -376,7 +370,6 @@ instance
|
||||
instance
|
||||
( Table context a, Table context b, Table context c, Table context d
|
||||
, Table context e, Table context f, Table context g
|
||||
, Labelable context
|
||||
)
|
||||
=> Table context (a, b, c, d, e, f, g)
|
||||
|
||||
|
@ -32,10 +32,6 @@ import Prelude hiding ( undefined )
|
||||
-- rel8
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Expr.Serialize ( litExpr )
|
||||
import Rel8.Schema.Context.Label
|
||||
( Labelable
|
||||
, HLabelable, hlabeler, hunlabeler
|
||||
)
|
||||
import Rel8.Schema.Context.Nullify
|
||||
( Nullifiable, ConstrainTag
|
||||
, HNullifiable, HConstrainTag
|
||||
@ -111,7 +107,7 @@ instance (Table Expr a, Table Expr b) => Semigroup (EitherTable a b) where
|
||||
|
||||
instance
|
||||
( Table context a, Table context b
|
||||
, Labelable context, Nullifiable context, ConstrainTag context EitherTag
|
||||
, Nullifiable context, ConstrainTag context EitherTag
|
||||
) =>
|
||||
Table context (EitherTable a b)
|
||||
where
|
||||
@ -125,8 +121,8 @@ instance
|
||||
|
||||
|
||||
instance
|
||||
( Nullifiable from, Labelable from, ConstrainTag from EitherTag
|
||||
, Nullifiable to, Labelable to, ConstrainTag to EitherTag
|
||||
( Nullifiable from, ConstrainTag from EitherTag
|
||||
, Nullifiable to, ConstrainTag to EitherTag
|
||||
, Recontextualize from to a1 b1
|
||||
, Recontextualize from to a2 b2
|
||||
)
|
||||
@ -206,7 +202,6 @@ toColumns2 ::
|
||||
( HTable t
|
||||
, HTable u
|
||||
, HConstrainTag context EitherTag
|
||||
, HLabelable context
|
||||
, HNullifiable context
|
||||
)
|
||||
=> (a -> t context)
|
||||
@ -215,18 +210,17 @@ toColumns2 ::
|
||||
-> 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
|
||||
, hleft = hlabel $ hnullify (hnullifier tag isLeft) $ f left
|
||||
, hright = hlabel $ hnullify (hnullifier tag isRight) $ g right
|
||||
}
|
||||
where
|
||||
htag = HIdentity (hencodeTag tag)
|
||||
htag = hlabel $ HType $ hencodeTag tag
|
||||
|
||||
|
||||
fromColumns2 ::
|
||||
( HTable t
|
||||
, HTable u
|
||||
, HConstrainTag context EitherTag
|
||||
, HLabelable context
|
||||
, HNullifiable context
|
||||
)
|
||||
=> (t context -> a)
|
||||
@ -237,12 +231,12 @@ fromColumns2 f g HEitherTable {htag, hleft, hright} = EitherTable
|
||||
{ tag
|
||||
, left = f $ runIdentity $
|
||||
hunnullify (\a -> pure . hunnullifier a) $
|
||||
hunlabel hunlabeler
|
||||
hunlabel
|
||||
hleft
|
||||
, right = g $ runIdentity $
|
||||
hunnullify (\a -> pure . hunnullifier a) $
|
||||
hunlabel hunlabeler
|
||||
hunlabel
|
||||
hright
|
||||
}
|
||||
where
|
||||
tag = hdecodeTag $ unHIdentity htag
|
||||
tag = hdecodeTag $ unHIdentity $ hunlabel htag
|
||||
|
@ -30,9 +30,6 @@ import Prelude hiding ( null, undefined )
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Expr.Bool ( boolExpr )
|
||||
import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
|
||||
import Rel8.Schema.Context.Label
|
||||
( Labelable, HLabelable, hlabeler, hunlabeler
|
||||
)
|
||||
import Rel8.Schema.Context.Nullify
|
||||
( Nullifiable, ConstrainTag
|
||||
, HNullifiable, HConstrainTag
|
||||
@ -131,7 +128,7 @@ instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where
|
||||
|
||||
instance
|
||||
( Table context a
|
||||
, Labelable context, Nullifiable context
|
||||
, Nullifiable context
|
||||
, ConstrainTag context MaybeTag
|
||||
) => Table context (MaybeTable a)
|
||||
where
|
||||
@ -145,8 +142,8 @@ instance
|
||||
|
||||
|
||||
instance
|
||||
( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
|
||||
, Labelable to, Nullifiable to, ConstrainTag to MaybeTag
|
||||
( Nullifiable from, ConstrainTag from MaybeTag
|
||||
, Nullifiable to, ConstrainTag to MaybeTag
|
||||
, Recontextualize from to a b
|
||||
)
|
||||
=> Recontextualize from to (MaybeTable a) (MaybeTable b)
|
||||
@ -222,7 +219,6 @@ nameMaybeTable = MaybeTable . fromName
|
||||
toColumns1 ::
|
||||
( HTable t
|
||||
, HConstrainTag context MaybeTag
|
||||
, HLabelable context
|
||||
, HNullifiable context
|
||||
)
|
||||
=> (a -> t context)
|
||||
@ -230,25 +226,24 @@ toColumns1 ::
|
||||
-> HMaybeTable t context
|
||||
toColumns1 f MaybeTable {tag, just} = HMaybeTable
|
||||
{ htag
|
||||
, hjust = hlabel hlabeler $ hnullify (hnullifier tag isNonNull) $ f just
|
||||
, hjust = hlabel $ hnullify (hnullifier tag isNonNull) $ f just
|
||||
}
|
||||
where
|
||||
htag = HIdentity (hencodeTag tag)
|
||||
htag = hlabel (HType (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
|
||||
fromColumns1 f HMaybeTable {htag, hjust} = MaybeTable
|
||||
{ tag
|
||||
, just = f $ runIdentity $
|
||||
hunnullify (\a -> pure . hunnullifier a) (hunlabel hunlabeler hjust)
|
||||
hunnullify (\a -> pure . hunnullifier a) (hunlabel hjust)
|
||||
}
|
||||
where
|
||||
tag = hdecodeTag htag
|
||||
tag = hdecodeTag (unHIdentity (hunlabel htag))
|
||||
|
@ -17,7 +17,8 @@ where
|
||||
-- base
|
||||
import Data.Foldable ( fold )
|
||||
import Data.Functor.Const ( Const( Const ), getConst )
|
||||
import Data.List.NonEmpty ( NonEmpty, intersperse )
|
||||
import Data.List.NonEmpty ( NonEmpty, intersperse, nonEmpty )
|
||||
import Data.Maybe ( fromMaybe )
|
||||
import Prelude
|
||||
|
||||
-- opaleye
|
||||
@ -26,7 +27,6 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
|
||||
-- rel8
|
||||
import Rel8.Expr ( Expr, Col( E ) )
|
||||
import Rel8.Expr.Opaleye ( toPrimExpr )
|
||||
import Rel8.Kind.Labels ( renderLabels )
|
||||
import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )
|
||||
import Rel8.Schema.Name ( Name( Name ), Col( N ) )
|
||||
import Rel8.Schema.Spec ( SSpec(..) )
|
||||
@ -82,3 +82,7 @@ showNames :: forall a. Table Name a => a -> [String]
|
||||
showNames (toColumns -> names) = getConst $
|
||||
htabulateA @(Columns a) $ \field -> case hfield names field of
|
||||
N (Name name) -> Const [name]
|
||||
|
||||
|
||||
renderLabels :: [String] -> NonEmpty String
|
||||
renderLabels labels = fromMaybe (pure "anon") (nonEmpty labels )
|
||||
|
@ -18,7 +18,6 @@ import Prelude ()
|
||||
|
||||
-- rel8
|
||||
import Rel8.Schema.Context ( Col )
|
||||
import Rel8.Schema.Context.Label ( Labelable )
|
||||
import Rel8.Schema.HTable ( HTable )
|
||||
import qualified Rel8.Schema.Kind as K
|
||||
import Rel8.Schema.Null ( Sql )
|
||||
@ -54,8 +53,6 @@ instance HTable t => Recontextualize from to (t (Col from)) (t (Col to))
|
||||
instance
|
||||
( Recontextualize from to a1 b1
|
||||
, Recontextualize from to a2 b2
|
||||
, Labelable from
|
||||
, Labelable to
|
||||
)
|
||||
=> Recontextualize from to (a1, a2) (b1, b2)
|
||||
|
||||
@ -64,7 +61,6 @@ instance
|
||||
( Recontextualize from to a1 b1
|
||||
, Recontextualize from to a2 b2
|
||||
, Recontextualize from to a3 b3
|
||||
, Labelable from, Labelable to
|
||||
)
|
||||
=> Recontextualize from to (a1, a2, a3) (b1, b2, b3)
|
||||
|
||||
@ -74,7 +70,6 @@ instance
|
||||
, Recontextualize from to a2 b2
|
||||
, Recontextualize from to a3 b3
|
||||
, Recontextualize from to a4 b4
|
||||
, Labelable from, Labelable to
|
||||
)
|
||||
=> Recontextualize from to (a1, a2, a3, a4) (b1, b2, b3, b4)
|
||||
|
||||
@ -85,6 +80,28 @@ instance
|
||||
, Recontextualize from to a3 b3
|
||||
, Recontextualize from to a4 b4
|
||||
, Recontextualize from to a5 b5
|
||||
, Labelable from, Labelable to
|
||||
)
|
||||
=> Recontextualize from to (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)
|
||||
|
||||
|
||||
instance
|
||||
( Recontextualize from to a1 b1
|
||||
, Recontextualize from to a2 b2
|
||||
, Recontextualize from to a3 b3
|
||||
, Recontextualize from to a4 b4
|
||||
, Recontextualize from to a5 b5
|
||||
, Recontextualize from to a6 b6
|
||||
)
|
||||
=> Recontextualize from to (a1, a2, a3, a4, a5, a6) (b1, b2, b3, b4, b5, b6)
|
||||
|
||||
|
||||
instance
|
||||
( Recontextualize from to a1 b1
|
||||
, Recontextualize from to a2 b2
|
||||
, Recontextualize from to a3 b3
|
||||
, Recontextualize from to a4 b4
|
||||
, Recontextualize from to a5 b5
|
||||
, Recontextualize from to a6 b6
|
||||
, Recontextualize from to a7 b7
|
||||
)
|
||||
=> Recontextualize from to (a1, a2, a3, a4, a5, a6, a7) (b1, b2, b3, b4, b5, b6, b7)
|
||||
|
@ -25,7 +25,7 @@ import qualified Rel8.Kind.Algebra as K
|
||||
import Rel8.Kind.Context
|
||||
( SContext( SReify )
|
||||
, Reifiable, contextSing
|
||||
, sLabelable, sReifiable
|
||||
, sReifiable
|
||||
)
|
||||
import Rel8.Generic.Rel8able
|
||||
( Rel8able, Algebra
|
||||
@ -33,7 +33,6 @@ import Rel8.Generic.Rel8able
|
||||
, greify, gunreify
|
||||
)
|
||||
import Rel8.Schema.Context ( Col )
|
||||
import Rel8.Schema.Context.Label ( Labelable )
|
||||
import Rel8.Schema.Dict ( Dict( Dict ) )
|
||||
import qualified Rel8.Schema.Kind as K
|
||||
import Rel8.Schema.HTable ( HConstrainTable, hdicts )
|
||||
@ -54,7 +53,7 @@ import Rel8.Type.Eq ( DBEq )
|
||||
import Rel8.Type.Ord ( DBOrd )
|
||||
|
||||
|
||||
instance (Rel8able t, Labelable context, Reifiable context) =>
|
||||
instance (Rel8able t, Reifiable context) =>
|
||||
Table context (t context)
|
||||
where
|
||||
type Columns (t context) = GColumns t
|
||||
@ -65,20 +64,18 @@ instance (Rel8able t, Labelable context, Reifiable context) =>
|
||||
toColumns = hunreify . gtoColumns . greify
|
||||
|
||||
reify Refl = case contextSing @context of
|
||||
SReify context -> case sLabelable context of
|
||||
Dict -> case sReifiable context of
|
||||
Dict -> greify
|
||||
SReify context -> case sReifiable context of
|
||||
Dict -> greify
|
||||
|
||||
unreify Refl = case contextSing @context of
|
||||
SReify context -> case sLabelable context of
|
||||
Dict -> case sReifiable context of
|
||||
Dict -> gunreify
|
||||
SReify context -> case sReifiable context of
|
||||
Dict -> gunreify
|
||||
|
||||
|
||||
instance
|
||||
( Rel8able t
|
||||
, Labelable from, Reifiable from
|
||||
, Labelable to, Reifiable to
|
||||
, Reifiable from
|
||||
, Reifiable to
|
||||
, Congruent (t from) (t to)
|
||||
)
|
||||
=> Recontextualize from to (t from) (t to)
|
||||
|
@ -36,10 +36,6 @@ import Prelude hiding ( undefined )
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Expr.Bool ( (&&.), not_ )
|
||||
import Rel8.Expr.Null ( isNonNull )
|
||||
import Rel8.Schema.Context.Label
|
||||
( Labelable
|
||||
, HLabelable, hlabeler, hunlabeler
|
||||
)
|
||||
import Rel8.Schema.Context.Nullify
|
||||
( Nullifiable, ConstrainTag
|
||||
, HNullifiable, HConstrainTag
|
||||
@ -136,7 +132,7 @@ instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
|
||||
|
||||
instance
|
||||
( Table context a, Table context b
|
||||
, Labelable context, Nullifiable context, ConstrainTag context MaybeTag
|
||||
, Nullifiable context, ConstrainTag context MaybeTag
|
||||
) => Table context (TheseTable a b)
|
||||
where
|
||||
type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)
|
||||
@ -149,8 +145,8 @@ instance
|
||||
|
||||
|
||||
instance
|
||||
( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
|
||||
, Labelable to, Nullifiable to, ConstrainTag to MaybeTag
|
||||
( Nullifiable from, ConstrainTag from MaybeTag
|
||||
, Nullifiable to, ConstrainTag to MaybeTag
|
||||
, Recontextualize from to a1 b1
|
||||
, Recontextualize from to a2 b2
|
||||
) =>
|
||||
@ -285,7 +281,6 @@ toColumns2 ::
|
||||
( HTable t
|
||||
, HTable u
|
||||
, HConstrainTag context MaybeTag
|
||||
, HLabelable context
|
||||
, HNullifiable context
|
||||
)
|
||||
=> (a -> t context)
|
||||
@ -293,12 +288,12 @@ toColumns2 ::
|
||||
-> TheseTable a b
|
||||
-> HTheseTable t u context
|
||||
toColumns2 f g TheseTable {here, there} = HTheseTable
|
||||
{ hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))
|
||||
{ hhereTag = hlabel $ HType $ hencodeTag (toHereTag (tag here))
|
||||
, hhere =
|
||||
hlabel hlabeler $ hnullify (hnullifier (tag here) isNonNull) $ f (just here)
|
||||
, hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))
|
||||
hlabel $ hnullify (hnullifier (tag here) isNonNull) $ f (just here)
|
||||
, hthereTag = hlabel $ HType $ hencodeTag (toThereTag (tag there))
|
||||
, hthere =
|
||||
hlabel hlabeler $ hnullify (hnullifier (tag there) isNonNull) $ g (just there)
|
||||
hlabel $ hnullify (hnullifier (tag there) isNonNull) $ g (just there)
|
||||
}
|
||||
|
||||
|
||||
@ -306,7 +301,6 @@ fromColumns2 ::
|
||||
( HTable t
|
||||
, HTable u
|
||||
, HConstrainTag context MaybeTag
|
||||
, HLabelable context
|
||||
, HNullifiable context
|
||||
)
|
||||
=> (t context -> a)
|
||||
@ -316,26 +310,26 @@ fromColumns2 ::
|
||||
fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
|
||||
{ here =
|
||||
let
|
||||
tag = hdecodeTag $ unHIdentity hhereTag
|
||||
tag = hdecodeTag $ unHIdentity $ hunlabel hhereTag
|
||||
in
|
||||
MaybeTable
|
||||
{ tag
|
||||
, just = f $
|
||||
runIdentity $
|
||||
hunnullify (\a -> pure . hunnullifier a) $
|
||||
hunlabel hunlabeler
|
||||
hunlabel
|
||||
hhere
|
||||
}
|
||||
, there =
|
||||
let
|
||||
tag = hdecodeTag $ unHIdentity hthereTag
|
||||
tag = hdecodeTag $ unHIdentity $ hunlabel hthereTag
|
||||
in
|
||||
MaybeTable
|
||||
{ tag
|
||||
, just = g $
|
||||
runIdentity $
|
||||
hunnullify (\a -> pure . hunnullifier a) $
|
||||
hunlabel hunlabeler
|
||||
hunlabel
|
||||
hthere
|
||||
}
|
||||
}
|
||||
|
Loading…
Reference in New Issue
Block a user