git.iko.soy/typeable/schematic
on aa474d0 help sign in
typeable/schematic/src/Data/Schematic/Migration.hs
158 lines 5.3 kB history raw
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE TemplateHaskell #-}
4module Data.Schematic.Migration where
6import Data.Kind
7import Data.Schematic.Path
8import Data.Schematic.Schema
9import Data.Singletons.Prelude hiding (All)
10import Data.Singletons.TypeLits
11-- import Data.Vinyl hiding (Dict)
14data Path
15 = PKey Symbol -- traverse into the object by key
16 | PTraverse -- traverse into the array
18data instance Sing (p :: Path) where
19 SPKey :: KnownSymbol s => Sing s -> Sing ('PKey s)
20 SPTraverse :: Sing 'PTraverse
22instance KnownSymbol s => SingI ('PKey s) where
23 sing = SPKey sing
25instance SingI 'PTraverse where
26 sing = SPTraverse
28-- Result type blueprint
29data Builder
30 = BKey Schema Symbol Builder -- field schema
31 | BTraverse Schema Builder -- array schema
32 | BScalar Schema
34-- Working with keys
36type family SchemaByKey (fs :: [(Symbol, Schema)]) (s :: Symbol) :: Schema where
37 SchemaByKey ( '(fn,s) ': tl) fn = s
38 SchemaByKey ( '(a, s) ': tl) fn = SchemaByKey tl fn
40type family DeleteKey (acc :: [(Symbol, Schema)]) (fn :: Symbol) (fs :: [(Symbol, Schema)]) :: [(Symbol, Schema)] where
41 DeleteKey acc fn ('(fn, a) ': tl) = acc :++ tl
42 DeleteKey acc fn (fna ': tl) = acc :++ (fna ': tl)
44type family UpdateKey
45 (fn :: Symbol)
46 (fs :: [(Symbol, Schema)])
47 (s :: Schema) = (r :: [(Symbol, Schema)]) where
48 UpdateKey fn ( '(fn, a) ': tl ) s = ( '(fn, s) ': tl )
49 UpdateKey fn ( '(fs, a) ': tl ) s = ( '(fs, a) ': UpdateKey fn tl s)
51-- schema updates
53type family Build (b :: Builder) :: Schema where
54 Build ('BKey ('SchemaObject fs) fn z) = 'SchemaObject (UpdateKey fn fs (Build z))
55 Build ('BTraverse ('SchemaArray acs s) z) = 'SchemaArray acs (Build z)
56 Build ('BScalar s) = s
58type family MakeBuilder (s :: Schema) (d :: Diff) :: Builder where
59 MakeBuilder s ('Diff '[] a) = 'BScalar (ApplyAction a s)
60 MakeBuilder ('SchemaObject fs) ('Diff ('PKey fn ': tl) a) =
61 'BKey ('SchemaObject fs) fn (MakeBuilder (SchemaByKey fs fn) ('Diff tl a))
62 MakeBuilder ('SchemaArray acs s) ('Diff ('PTraverse ': tl) a) =
63 'BTraverse ('SchemaArray acs s) (MakeBuilder s ('Diff tl a))
65type family ApplyAction (a :: Action) (s :: Schema) :: Schema where
66 ApplyAction ('AddKey fn s) ('SchemaObject fs) = 'SchemaObject ('(fn,s) ': fs)
67 ApplyAction ('DeleteKey fn) ('SchemaObject fs) = 'SchemaObject (DeleteKey '[] fn fs)
68 ApplyAction ('Update s) t = s
70type family ApplyMigration (m :: Migration) (s :: Schema) :: (Revision, Schema) where
71 ApplyMigration ('Migration r '[]) s = '(r, s)
72 ApplyMigration ('Migration r (d ': ds)) s =
73 '(r, Snd (ApplyMigration ('Migration r ds) (Build (MakeBuilder s d))))
75-- working with revisions
77type family SchemaByRevision (r :: Revision) (vd :: Versioned) :: Schema where
78 SchemaByRevision r ('Versioned s (('Migration r ds) ': ms)) =
79 Snd (ApplyMigration ('Migration r ds) s)
80 SchemaByRevision r ('Versioned s (m ': ms)) =
81 SchemaByRevision r ('Versioned (Snd (ApplyMigration m s)) ms)
83type family InitialSchema (v :: Versioned) = (s :: Schema) where
84 InitialSchema ('Versioned s ms) = s
86type family ElemOf (e :: k) (l :: [(a,k)]) :: Constraint where
87 ElemOf e '[] = 'True ~ 'False
88 ElemOf e ( '(a, e) ': es) = ()
89 ElemOf e (n ': es) = ElemOf e es
91-- | Extracts revision/schema pairs from @Versioned@ in reverse order.
92type family AllVersions (vd :: Versioned) :: [(Revision, Schema)] where
93 AllVersions ('Versioned s ms) = Reverse (AllVersions' '[ '("initial", s) ] ms)
95type family AllVersions' (acc :: [(Revision, Schema)]) (ms :: [Migration]) = (r :: [(Revision, Schema)]) where
96 AllVersions' acc '[] = acc
97 AllVersions' ( '(rh, sh) ': tl ) (m ': ms) =
98 AllVersions' ( '(rh, sh) ': ApplyMigration m sh ': tl ) ms
100type family TopVersion (rs :: [(Revision, Schema)]) :: Schema where
101 TopVersion ( '(rh, sh) ': tl) = sh
103class MigrateSchema (a :: Schema) (b :: Schema) where
104 migrate :: JsonRepr a -> JsonRepr b
106data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol
108data instance Sing (a :: Action) where
109 SAddKey
110 :: (SingI n, SingI s)
111 => Sing n
112 -> Sing s
113 -> Sing ('AddKey n s)
114 SUpdate :: (SingI s) => Sing s -> Sing ('Update s)
115 SDeleteKey :: KnownSymbol s => Sing s -> Sing ('DeleteKey s)
117-- | User-supplied atomic difference between schemas.
118-- Migrations can consists of many differences.
119data Diff = Diff [Path] Action
121data instance Sing (diff :: Diff) where
122 SDiff
123 :: (SingI jp, SingI a)
124 => Sing (jp :: [Path])
125 -> Sing (a :: Action)
126 -> Sing ('Diff jp a)
128-- | User-provided name of the revision.
129type Revision = Symbol
131data Migration = Migration Revision [Diff]
133data instance Sing (m :: Migration) where
134 SMigration
135 :: (KnownSymbol r, SingI ds)
136 => Sing r
137 -> Sing ds
138 -> Sing ('Migration r ds)
140data Versioned = Versioned Schema [Migration]
142data instance Sing (v :: Versioned) where
143 SVersioned
144 :: (SingI s, SingI ms)
145 => Sing (s :: Schema) -- base version
146 -> Sing (ms :: [Migration]) -- a bunch of migrations
147 -> Sing ('Versioned s ms)
149data MList :: [Schema] -> Type where
150 MNil :: (SingI s, TopLevel s) => MList '[s]
151 (:&&)
152 :: (SingI s, TopLevel s)
153 => proxy s
154 -> (JsonRepr h -> JsonRepr s)
155 -> MList (h ': tl)
156 -> MList (s ': h ': tl)
158infixr 7 :&&