git.iko.soy/rel8
on 5b3f06e help sign in
rel8/src/Rel8/Schema/HTable/MapTable.hs
77 lines 2.3 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language BlockArguments #-}
3{-# language ConstraintKinds #-}
4{-# language DataKinds #-}
5{-# language GADTs #-}
6{-# language InstanceSigs #-}
7{-# language MultiParamTypeClasses #-}
8{-# language PolyKinds #-}
9{-# language ScopedTypeVariables #-}
10{-# language StandaloneKindSignatures #-}
11{-# language TypeApplications #-}
12{-# language TypeFamilies #-}
13{-# language UndecidableInstances #-}
14{-# language UndecidableSuperClasses #-}
16module Rel8.Schema.HTable.MapTable ( HMapTable(..), MapSpec(..), Precompose(..), HMapTableField(..) ) where
18-- base
19import Data.Kind ( Constraint, Type )
20import Prelude ( ($), (.), (<$>), fmap )
22-- rel8
23import Rel8.FCF
24import Rel8.Schema.HTable
25import Rel8.Schema.Spec ( Spec, SSpec )
26import qualified Rel8.Schema.Kind as K
27import Rel8.Schema.Dict ( Dict( Dict ) )
30type HMapTable :: (a -> Exp b) -> ((a -> Type) -> Type) -> (b -> Type) -> Type
31data HMapTable f t g where
32 HMapTable :: { unHMapTable :: t (Precompose f g) } -> HMapTable f t g
35type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type
36newtype Precompose f g x where
37 Precompose :: { precomposed :: g (Eval (f x)) } -> Precompose f g x
40type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type
41data HMapTableField f t x where
42 HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))
45instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
46 type HField (HMapTable f t) =
47 HMapTableField f t
49 type HConstrainTable (HMapTable f t) c =
50 HConstrainTable t (ComposeConstraint f c)
52 hfield (HMapTable x) (HMapTableField i) =
53 precomposed (hfield x i)
55 htabulate f =
56 HMapTable $ htabulate (Precompose . f . HMapTableField)
58 htraverse f (HMapTable x) =
59 HMapTable <$> htraverse (fmap Precompose . f . precomposed) x
61 hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c)
62 hdicts =
63 htabulate \(HMapTableField j) ->
64 case hfield (hdicts @_ @(ComposeConstraint f c)) j of
65 Dict -> Dict
67 hspecs =
68 HMapTable $ htabulate $ Precompose . mapInfo @f . hfield hspecs
71type MapSpec :: (Spec -> Exp Spec) -> Constraint
72class MapSpec f where
73 mapInfo :: SSpec x -> SSpec (Eval (f x))
76type ComposeConstraint :: (a -> Exp b) -> (b -> Constraint) -> a -> Constraint
77class c (Eval (f a)) => ComposeConstraint f c a