git.iko.soy/rel8
on f47423e help sign in
rel8/src/Rel8/Schema/HTable/MapTable.hs
91 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 ScopedTypeVariables #-}
10{-# language StandaloneKindSignatures #-}
11{-# language TypeApplications #-}
12{-# language TypeFamilies #-}
13{-# language UndecidableInstances #-}
14{-# language UndecidableSuperClasses #-}
16module Rel8.Schema.HTable.MapTable
17 ( HMapTable(..)
18 , MapSpec(..)
19 , Precompose(..)
20 , HMapTableField(..)
21 )
22where
24-- base
25import Data.Kind ( Constraint, Type )
26import Prelude
28-- rel8
29import Rel8.FCF ( Exp, Eval )
30import Rel8.Schema.HTable
31 ( HTable, HConstrainTable, HField
32 , hfield, htabulate, htraverse, hdicts, hspecs
33 )
34import Rel8.Schema.Spec ( Spec )
35import qualified Rel8.Schema.Kind as K
36import Rel8.Schema.Dict ( Dict( Dict ) )
39type HMapTable :: (Type -> Exp Type) -> K.HTable -> K.HTable
40newtype HMapTable f t context = HMapTable
41 { unHMapTable :: t (Precompose f context)
42 }
45type Precompose :: (Type -> Exp Type) -> K.Context -> K.Context
46newtype Precompose f g x = Precompose
47 { precomposed :: g (Eval (f x))
48 }
51type HMapTableField :: (Type -> Exp Type) -> K.HTable -> K.Context
52data HMapTableField f t x where
53 HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))
56instance (HTable t, MapSpec f) => HTable (HMapTable f t) where
57 type HField (HMapTable f t) =
58 HMapTableField f t
60 type HConstrainTable (HMapTable f t) c =
61 HConstrainTable t (ComposeConstraint f c)
63 hfield (HMapTable x) (HMapTableField i) =
64 precomposed (hfield x i)
66 htabulate f =
67 HMapTable $ htabulate (Precompose . f . HMapTableField)
69 htraverse f (HMapTable x) =
70 HMapTable <$> htraverse (fmap Precompose . f . precomposed) x
71 {-# INLINABLE htraverse #-}
73 hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c)
74 hdicts =
75 htabulate \(HMapTableField j) ->
76 case hfield (hdicts @_ @(ComposeConstraint f c)) j of
77 Dict -> Dict
79 hspecs =
80 HMapTable $ htabulate $ Precompose . mapInfo @f . hfield hspecs
81 {-# INLINABLE hspecs #-}
84type MapSpec :: (Type -> Exp Type) -> Constraint
85class MapSpec f where
86 mapInfo :: Spec x -> Spec (Eval (f x))
89type ComposeConstraint :: (Type -> Exp Type) -> (Type -> Constraint) -> Type -> Constraint
90class c (Eval (f a)) => ComposeConstraint f c a
91instance c (Eval (f a)) => ComposeConstraint f c a