git.iko.soy/rel8
on db148ff help sign in
rel8/src/Rel8/Schema/HTable/MapTable.hs
89 lines 2.5 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
38newtype HMapTable f t g = HMapTable
39 { unHMapTable :: t (Precompose f g)
40 }
43type Precompose :: (a -> Exp b) -> (b -> Type) -> a -> Type
44newtype Precompose f g x = Precompose
45 { precomposed :: g (Eval (f x))
46 }
49type HMapTableField :: (Spec -> Exp a) -> K.HTable -> a -> Type
50data HMapTableField f t x where
51 HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))
54instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
55 type HField (HMapTable f t) =
56 HMapTableField f t
58 type HConstrainTable (HMapTable f t) c =
59 HConstrainTable t (ComposeConstraint f c)
61 hfield (HMapTable x) (HMapTableField i) =
62 precomposed (hfield x i)
64 htabulate f =
65 HMapTable $ htabulate (Precompose . f . HMapTableField)
67 htraverse f (HMapTable x) =
68 HMapTable <$> htraverse (fmap Precompose . f . precomposed) x
69 {-# INLINABLE htraverse #-}
71 hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c)
72 hdicts =
73 htabulate \(HMapTableField j) ->
74 case hfield (hdicts @_ @(ComposeConstraint f c)) j of
75 Dict -> Dict
77 hspecs =
78 HMapTable $ htabulate $ Precompose . mapInfo @f . hfield hspecs
79 {-# INLINABLE hspecs #-}
82type MapSpec :: (Spec -> Exp Spec) -> Constraint
83class MapSpec f where
84 mapInfo :: SSpec x -> SSpec (Eval (f x))
87type ComposeConstraint :: (a -> Exp b) -> (b -> Constraint) -> a -> Constraint
88class c (Eval (f a)) => ComposeConstraint f c a
89instance c (Eval (f a)) => ComposeConstraint f c a