git.iko.soy/rel8
on 137ebed help sign in
rel8/src/Rel8/Schema/HTable/Label.hs
83 lines 2.2 kB history raw
1{-# LANGUAGE DeriveAnyClass #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DerivingStrategies #-}
4{-# LANGUAGE LambdaCase #-}
5{-# language ConstraintKinds #-}
6{-# language DataKinds #-}
7{-# language FlexibleInstances #-}
8{-# language GADTs #-}
9{-# language MultiParamTypeClasses #-}
10{-# language QuantifiedConstraints #-}
11{-# language RankNTypes #-}
12{-# language RecordWildCards #-}
13{-# language ScopedTypeVariables #-}
14{-# language StandaloneKindSignatures #-}
15{-# language TypeFamilies #-}
16{-# language TypeOperators #-}
17{-# language UndecidableInstances #-}
19module Rel8.Schema.HTable.Label
20 ( HLabel, Label
21 , hlabel, hunlabel
22 )
23where
25-- base
26import Data.Proxy ( Proxy( Proxy ) )
27import GHC.TypeLits ( KnownSymbol, Symbol )
28import Prelude
30-- rel8
31import Rel8.Kind.Labels ( SLabels( SCons ) )
32import Rel8.Schema.HTable
33 ( HTable
34 , hfield, htabulate, hspecs
35 )
36import qualified Rel8.Schema.Kind as K
37import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
38import Rel8.FCF
39import Rel8.Schema.HTable.MapTable
40import GHC.Generics (Generic)
43type HLabel :: Symbol -> K.HTable -> K.HTable
44newtype HLabel label table context = HLabel (HMapTable (Label label) table context)
45 deriving stock Generic
46 deriving anyclass HTable
49data Label :: Symbol -> Spec -> Exp Spec
52type instance Eval (Label label ('Spec labels a)) = 'Spec (label : labels) a
55instance KnownSymbol l => MapSpec (Label l) where
56 mapInfo = \case
57 SSpec {..} -> SSpec {labels = SCons Proxy labels, ..}
60hlabel :: (HTable t, KnownSymbol label)
61 => (forall labels a. ()
62 => context ('Spec labels a)
63 -> context ('Spec (label ': labels) a))
64 -> t context
65 -> HLabel label t context
66hlabel labeler a = HLabel $ htabulate $ \(HMapTableField field) ->
67 case hfield hspecs field of
68 SSpec {} -> labeler (hfield a field)
69{-# INLINABLE hlabel #-}
72hunlabel :: (HTable t, KnownSymbol label)
73 => (forall labels a. ()
74 => context ('Spec (label ': labels) a)
75 -> context ('Spec labels a))
76 -> HLabel label t context
77 -> t context
78hunlabel unlabler (HLabel as) =
79 htabulate $ \field ->
80 case hfield hspecs field of
81 SSpec {} -> case hfield as (HMapTableField field) of
82 a -> unlabler a
83{-# INLINABLE hunlabel #-}