diff --git a/rel8.cabal b/rel8.cabal index 94f1035..c9d58cd 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -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 diff --git a/src/Rel8.hs b/src/Rel8.hs index 872aa0b..2f76ff0 100644 --- a/src/Rel8.hs +++ b/src/Rel8.hs @@ -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 ) diff --git a/src/Rel8/Aggregate.hs b/src/Rel8/Aggregate.hs index 9af8ff4..2df57f5 100644 --- a/src/Rel8/Aggregate.hs +++ b/src/Rel8/Aggregate.hs @@ -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 diff --git a/src/Rel8/Column.hs b/src/Rel8/Column.hs index 4405d7f..a348520 100644 --- a/src/Rel8/Column.hs +++ b/src/Rel8/Column.hs @@ -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 diff --git a/src/Rel8/Expr.hs b/src/Rel8/Expr.hs index adb95a5..0808590 100644 --- a/src/Rel8/Expr.hs +++ b/src/Rel8/Expr.hs @@ -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 diff --git a/src/Rel8/Generic/Construction/ADT.hs b/src/Rel8/Generic/Construction/ADT.hs index 9368bdf..7546139 100644 --- a/src/Rel8/Generic/Construction/ADT.hs +++ b/src/Rel8/Generic/Construction/ADT.hs @@ -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 diff --git a/src/Rel8/Generic/Construction/Record.hs b/src/Rel8/Generic/Construction/Record.hs index fb9c43c..a9e15f6 100644 --- a/src/Rel8/Generic/Construction/Record.hs +++ b/src/Rel8/Generic/Construction/Record.hs @@ -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 diff --git a/src/Rel8/Generic/Rel8able.hs b/src/Rel8/Generic/Rel8able.hs index f63bc0c..4a8fa69 100644 --- a/src/Rel8/Generic/Rel8able.hs +++ b/src/Rel8/Generic/Rel8able.hs @@ -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)) diff --git a/src/Rel8/Generic/Table.hs b/src/Rel8/Generic/Table.hs index 37167a6..f98a445 100644 --- a/src/Rel8/Generic/Table.hs +++ b/src/Rel8/Generic/Table.hs @@ -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 diff --git a/src/Rel8/Generic/Table/ADT.hs b/src/Rel8/Generic/Table/ADT.hs index b0aeae1..c858735 100644 --- a/src/Rel8/Generic/Table/ADT.hs +++ b/src/Rel8/Generic/Table/ADT.hs @@ -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 diff --git a/src/Rel8/Generic/Table/Record.hs b/src/Rel8/Generic/Table/Record.hs index 8220fee..f048b89 100644 --- a/src/Rel8/Generic/Table/Record.hs +++ b/src/Rel8/Generic/Table/Record.hs @@ -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) diff --git a/src/Rel8/Kind/Context.hs b/src/Rel8/Kind/Context.hs index b39ba50..13ca95c 100644 --- a/src/Rel8/Kind/Context.hs +++ b/src/Rel8/Kind/Context.hs @@ -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 diff --git a/src/Rel8/Kind/Labels.hs b/src/Rel8/Kind/Labels.hs deleted file mode 100644 index 80ed8b6..0000000 --- a/src/Rel8/Kind/Labels.hs +++ /dev/null @@ -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 diff --git a/src/Rel8/Schema/Context/Label.hs b/src/Rel8/Schema/Context/Label.hs deleted file mode 100644 index 689e642..0000000 --- a/src/Rel8/Schema/Context/Label.hs +++ /dev/null @@ -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 diff --git a/src/Rel8/Schema/Context/Nullify.hs b/src/Rel8/Schema/Context/Nullify.hs index df93e40..71e9f55 100644 --- a/src/Rel8/Schema/Context/Nullify.hs +++ b/src/Rel8/Schema/Context/Nullify.hs @@ -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 diff --git a/src/Rel8/Schema/HTable/Either.hs b/src/Rel8/Schema/HTable/Either.hs index a47f13f..796ba28 100644 --- a/src/Rel8/Schema/HTable/Either.hs +++ b/src/Rel8/Schema/HTable/Either.hs @@ -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 } diff --git a/src/Rel8/Schema/HTable/Identity.hs b/src/Rel8/Schema/HTable/Identity.hs index d59187e..e7e7929 100644 --- a/src/Rel8/Schema/HTable/Identity.hs +++ b/src/Rel8/Schema/HTable/Identity.hs @@ -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 #-} diff --git a/src/Rel8/Schema/HTable/Label.hs b/src/Rel8/Schema/HTable/Label.hs index 2bf4c87..5ff95a3 100644 --- a/src/Rel8/Schema/HTable/Label.hs +++ b/src/Rel8/Schema/HTable/Label.hs @@ -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 #-} diff --git a/src/Rel8/Schema/HTable/Maybe.hs b/src/Rel8/Schema/HTable/Maybe.hs index df880c2..e2fa8fa 100644 --- a/src/Rel8/Schema/HTable/Maybe.hs +++ b/src/Rel8/Schema/HTable/Maybe.hs @@ -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 diff --git a/src/Rel8/Schema/HTable/Nullify.hs b/src/Rel8/Schema/HTable/Nullify.hs index d06ed82..935349a 100644 --- a/src/Rel8/Schema/HTable/Nullify.hs +++ b/src/Rel8/Schema/HTable/Nullify.hs @@ -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) = diff --git a/src/Rel8/Schema/HTable/These.hs b/src/Rel8/Schema/HTable/These.hs index 7c80390..5b143ac 100644 --- a/src/Rel8/Schema/HTable/These.hs +++ b/src/Rel8/Schema/HTable/These.hs @@ -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 diff --git a/src/Rel8/Schema/HTable/Vectorize.hs b/src/Rel8/Schema/HTable/Vectorize.hs index 782b708..52e7bec 100644 --- a/src/Rel8/Schema/HTable/Vectorize.hs +++ b/src/Rel8/Schema/HTable/Vectorize.hs @@ -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 diff --git a/src/Rel8/Schema/Name.hs b/src/Rel8/Schema/Name.hs index 5fe7db1..78856ad 100644 --- a/src/Rel8/Schema/Name.hs +++ b/src/Rel8/Schema/Name.hs @@ -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 diff --git a/src/Rel8/Schema/Reify.hs b/src/Rel8/Schema/Reify.hs index 9647286..0678cc2 100644 --- a/src/Rel8/Schema/Reify.hs +++ b/src/Rel8/Schema/Reify.hs @@ -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 diff --git a/src/Rel8/Schema/Result.hs b/src/Rel8/Schema/Result.hs index e3d8462..eb6f6d2 100644 --- a/src/Rel8/Schema/Result.hs +++ b/src/Rel8/Schema/Result.hs @@ -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 diff --git a/src/Rel8/Schema/Spec.hs b/src/Rel8/Schema/Spec.hs index 6084be8..88bea69 100644 --- a/src/Rel8/Schema/Spec.hs +++ b/src/Rel8/Schema/Spec.hs @@ -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 } diff --git a/src/Rel8/Schema/Spec/ConstrainDBType.hs b/src/Rel8/Schema/Spec/ConstrainDBType.hs index 0e88f31..2f5ecd0 100644 --- a/src/Rel8/Schema/Spec/ConstrainDBType.hs +++ b/src/Rel8/Schema/Spec/ConstrainDBType.hs @@ -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 diff --git a/src/Rel8/Table.hs b/src/Rel8/Table.hs index 8077c29..0867103 100644 --- a/src/Rel8/Table.hs +++ b/src/Rel8/Table.hs @@ -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) diff --git a/src/Rel8/Table/Either.hs b/src/Rel8/Table/Either.hs index 92b8d4f..b4b3889 100644 --- a/src/Rel8/Table/Either.hs +++ b/src/Rel8/Table/Either.hs @@ -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 diff --git a/src/Rel8/Table/Maybe.hs b/src/Rel8/Table/Maybe.hs index 275dcdf..a17de42 100644 --- a/src/Rel8/Table/Maybe.hs +++ b/src/Rel8/Table/Maybe.hs @@ -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)) diff --git a/src/Rel8/Table/Name.hs b/src/Rel8/Table/Name.hs index 42da6cc..00fa16b 100644 --- a/src/Rel8/Table/Name.hs +++ b/src/Rel8/Table/Name.hs @@ -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 ) diff --git a/src/Rel8/Table/Recontextualize.hs b/src/Rel8/Table/Recontextualize.hs index f173a58..0116803 100644 --- a/src/Rel8/Table/Recontextualize.hs +++ b/src/Rel8/Table/Recontextualize.hs @@ -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) diff --git a/src/Rel8/Table/Rel8able.hs b/src/Rel8/Table/Rel8able.hs index 5867483..099a5de 100644 --- a/src/Rel8/Table/Rel8able.hs +++ b/src/Rel8/Table/Rel8able.hs @@ -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) diff --git a/src/Rel8/Table/These.hs b/src/Rel8/Table/These.hs index 441d50e..62ae06d 100644 --- a/src/Rel8/Table/These.hs +++ b/src/Rel8/Table/These.hs @@ -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 } }