git.iko.soy/rel8
on 11bcbbb help sign in
rel8/src/Rel8/Schema/HTable/MapTable.hs
79 lines 2.4 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language BlockArguments #-}
3{-# language ConstraintKinds #-}
4{-# language DataKinds #-}
5{-# language FlexibleInstances #-}
6{-# language GADTs #-}
7{-# language InstanceSigs #-}
8{-# language MultiParamTypeClasses #-}
9{-# language PolyKinds #-}
10{-# language ScopedTypeVariables #-}
11{-# language StandaloneKindSignatures #-}
12{-# language TypeApplications #-}
13{-# language TypeFamilies #-}
14{-# language UndecidableInstances #-}
15{-# language UndecidableSuperClasses #-}
17module Rel8.Schema.HTable.MapTable ( HMapTable(..), MapSpec(..), Precompose(..), HMapTableField(..) ) where
19-- base
20import Data.Kind ( Constraint, Type )
21import Prelude ( ($), (.), (<$>), fmap )
23-- rel8
24import Rel8.FCF
25import Rel8.Schema.HTable
26import Rel8.Schema.Spec ( Spec, SSpec )
27import qualified Rel8.Schema.Kind as K
28import Rel8.Schema.Dict ( Dict( Dict ) )
31type HMapTable :: (a -> Exp b) -> ((a -> Type) -> Type) -> (b -> Type) -> Type
32data HMapTable f t g where
33 HMapTable :: { unHMapTable :: t (Precompose f g) } -> HMapTable f t g
36type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type
37newtype Precompose f g x where
38 Precompose :: { precomposed :: g (Eval (f x)) } -> Precompose f g x
41type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type
42data HMapTableField f t x where
43 HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))
46instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
47 type HField (HMapTable f t) =
48 HMapTableField f t
50 type HConstrainTable (HMapTable f t) c =
51 HConstrainTable t (ComposeConstraint f c)
53 hfield (HMapTable x) (HMapTableField i) =
54 precomposed (hfield x i)
56 htabulate f =
57 HMapTable $ htabulate (Precompose . f . HMapTableField)
59 htraverse f (HMapTable x) =
60 HMapTable <$> htraverse (fmap Precompose . f . precomposed) x
62 hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c)
63 hdicts =
64 htabulate \(HMapTableField j) ->
65 case hfield (hdicts @_ @(ComposeConstraint f c)) j of
66 Dict -> Dict
68 hspecs =
69 HMapTable $ htabulate $ Precompose . mapInfo @f . hfield hspecs
72type MapSpec :: (Spec -> Exp Spec) -> Constraint
73class MapSpec f where
74 mapInfo :: SSpec x -> SSpec (Eval (f x))
77type ComposeConstraint :: (a -> Exp b) -> (b -> Constraint) -> a -> Constraint
78class c (Eval (f a)) => ComposeConstraint f c a
79instance c (Eval (f a)) => ComposeConstraint f c a