git.iko.soy/rel8
on b97cd4e help sign in
rel8/src/Rel8/Schema/HTable/MapTable.hs
85 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
18 ( HMapTable(..)
19 , MapSpec(..)
20 , Precompose(..)
21 , HMapTableField(..)
22 )
23where
25-- base
26import Data.Kind ( Constraint, Type )
27import Prelude ( ($), (.), (<$>), fmap )
29-- rel8
30import Rel8.FCF
31import Rel8.Schema.HTable
32import Rel8.Schema.Spec ( Spec, SSpec )
33import qualified Rel8.Schema.Kind as K
34import Rel8.Schema.Dict ( Dict( Dict ) )
37type HMapTable :: (a -> Exp b) -> ((a -> Type) -> Type) -> (b -> Type) -> Type
38data HMapTable f t g where
39 HMapTable :: { unHMapTable :: t (Precompose f g) } -> HMapTable f t g
42type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type
43newtype Precompose f g x where
44 Precompose :: { precomposed :: g (Eval (f x)) } -> Precompose f g x
47type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type
48data HMapTableField f t x where
49 HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))
52instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
53 type HField (HMapTable f t) =
54 HMapTableField f t
56 type HConstrainTable (HMapTable f t) c =
57 HConstrainTable t (ComposeConstraint f c)
59 hfield (HMapTable x) (HMapTableField i) =
60 precomposed (hfield x i)
62 htabulate f =
63 HMapTable $ htabulate (Precompose . f . HMapTableField)
65 htraverse f (HMapTable x) =
66 HMapTable <$> htraverse (fmap Precompose . f . precomposed) x
68 hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c)
69 hdicts =
70 htabulate \(HMapTableField j) ->
71 case hfield (hdicts @_ @(ComposeConstraint f c)) j of
72 Dict -> Dict
74 hspecs =
75 HMapTable $ htabulate $ Precompose . mapInfo @f . hfield hspecs
78type MapSpec :: (Spec -> Exp Spec) -> Constraint
79class MapSpec f where
80 mapInfo :: SSpec x -> SSpec (Eval (f x))
83type ComposeConstraint :: (a -> Exp b) -> (b -> Constraint) -> a -> Constraint
84class c (Eval (f a)) => ComposeConstraint f c a
85instance c (Eval (f a)) => ComposeConstraint f c a