git.iko.soy/schematic
on 6cc400e help sign in
schematic/src/Data/Schematic/Migration.hs
179 lines 6.0 kB history raw
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE TemplateHaskell #-}
4module Data.Schematic.Migration where
6import Data.Kind
7import Data.Schematic.DSL
8import Data.Schematic.Lens
9import Data.Schematic.Path
10import Data.Schematic.Schema
11import Data.Singletons.Prelude hiding (All, (:.))
12import Data.Singletons.TypeLits
13import Data.Tagged
14import Data.Vinyl
15import Data.Vinyl.Functor
18data Path
19 = PKey Symbol -- traverse into the object by key
20 | PTraverse -- traverse into the array
22data instance Sing (p :: Path) where
23 SPKey :: Sing s -> Sing ('PKey s)
24 SPTraverse :: Sing 'PTraverse
26instance KnownSymbol s => SingI ('PKey s) where
27 sing = SPKey sing
29instance SingI 'PTraverse where
30 sing = SPTraverse
32-- Result type blueprint
33data Builder
34 = BKey Schema Symbol Builder -- field schema
35 | BTraverse Schema Builder -- array schema
36 | BScalar Schema
38-- Working with keys
40type family SchemaByKey (fs :: [(Symbol, Schema)]) (s :: Symbol) :: Schema where
41 SchemaByKey ( '(fn,s) ': tl) fn = s
42 SchemaByKey ( '(a, s) ': tl) fn = SchemaByKey tl fn
44type family DeleteKey (acc :: [(Symbol, Schema)]) (fn :: Symbol) (fs :: [(Symbol, Schema)]) :: [(Symbol, Schema)] where
45 DeleteKey acc fn ('(fn, a) ': tl) = acc ++ tl
46 DeleteKey acc fn (fna ': tl) = acc ++ (fna ': tl)
48type family UpdateKey
49 (fn :: Symbol)
50 (fs :: [(Symbol, Schema)])
51 (s :: Schema) = (r :: [(Symbol, Schema)]) where
52 UpdateKey fn ( '(fn, a) ': tl ) s = ( '(fn, s) ': tl )
53 UpdateKey fn ( '(fs, a) ': tl ) s = ( '(fs, a) ': UpdateKey fn tl s)
55-- schema updates
57type family Build (b :: Builder) :: Schema where
58 Build ('BKey ('SchemaObject fs) fn z) = 'SchemaObject (UpdateKey fn fs (Build z))
59 Build ('BTraverse ('SchemaArray acs s) z) = 'SchemaArray acs (Build z)
60 Build ('BScalar s) = s
62type family MakeBuilder (s :: Schema) (d :: Diff) :: Builder where
63 MakeBuilder s ('Diff '[] a) = 'BScalar (ApplyAction a s)
64 MakeBuilder ('SchemaObject fs) ('Diff ('PKey fn ': tl) a) =
65 'BKey ('SchemaObject fs) fn (MakeBuilder (SchemaByKey fs fn) ('Diff tl a))
66 MakeBuilder ('SchemaArray acs s) ('Diff ('PTraverse ': tl) a) =
67 'BTraverse ('SchemaArray acs s) (MakeBuilder s ('Diff tl a))
69type family ApplyAction (a :: Action) (s :: Schema) :: Schema where
70 ApplyAction ('AddKey fn s) ('SchemaObject fs) = 'SchemaObject ('(fn,s) ': fs)
71 ApplyAction ('DeleteKey fn) ('SchemaObject fs) = 'SchemaObject (DeleteKey '[] fn fs)
72 ApplyAction ('Update s) t = s
74type family ApplyMigration (m :: Migration) (s :: Schema) :: (Revision, Schema) where
75 ApplyMigration ('Migration r '[]) s = '(r, s)
76 ApplyMigration ('Migration r (d ': ds)) s =
77 '(r, Snd (ApplyMigration ('Migration r ds) (Build (MakeBuilder s d))))
79-- working with revisions
81type family SchemaByRevision (r :: Revision) (vd :: Versioned) :: Schema where
82 SchemaByRevision r ('Versioned s (('Migration r ds) ': ms)) =
83 Snd (ApplyMigration ('Migration r ds) s)
84 SchemaByRevision r ('Versioned s (m ': ms)) =
85 SchemaByRevision r ('Versioned (Snd (ApplyMigration m s)) ms)
87type family InitialSchema (v :: Versioned) = (s :: Schema) where
88 InitialSchema ('Versioned s ms) = s
90type family ElemOf (e :: k) (l :: [(a,k)]) :: Constraint where
91 ElemOf e '[] = 'True ~ 'False
92 ElemOf e ( '(a, e) ': es) = ()
93 ElemOf e (n ': es) = ElemOf e es
95-- | Extracts revision/schema pairs from @Versioned@ in reverse order.
96type family AllVersions (vd :: Versioned) :: [(Revision, Schema)] where
97 AllVersions ('Versioned s ms) = Reverse (AllVersions' '[ '("initial", s) ] ms)
99type family AllVersions' (acc :: [(Revision, Schema)]) (ms :: [Migration])
100 = (r :: [(Revision, Schema)]) where
101 AllVersions' acc '[] = acc
102 AllVersions' ( '(rh, sh) ': tl ) (m ': ms) =
103 AllVersions' ( '(rh, sh) ': ApplyMigration m sh ': tl ) ms
105type family TopVersion (rs :: [(Revision, Schema)]) :: Schema where
106 TopVersion ( '(rh, sh) ': tl) = sh
108data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol
110data instance Sing (a :: Action) where
111 SAddKey
112 :: Sing n
113 -> Sing s
114 -> Sing ('AddKey n s)
115 SUpdate :: Sing s -> Sing ('Update s)
116 SDeleteKey :: Sing s -> Sing ('DeleteKey s)
118-- | User-supplied atomic difference between schemas.
119-- Migrations can consists of many differences.
120data Diff = Diff [Path] Action
122data instance Sing (diff :: Diff) where
123 SDiff
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 :: Sing r
136 -> Sing ds
137 -> Sing ('Migration r ds)
139data Versioned = Versioned Schema [Migration]
141data instance Sing (v :: Versioned) where
142 SVersioned
143 :: Sing (s :: Schema) -- base version
144 -> Sing (ms :: [Migration]) -- a bunch of migrations
145 -> Sing ('Versioned s ms)
147type DataMigration s m h = Tagged s (JsonRepr h -> m (JsonRepr s))
149data MList :: (Type -> Type) -> [Schema] -> Type where
150 MNil :: (Monad m, SingI s, TopLevel s) => MList m '[s]
151 (:&&)
152 :: (TopLevel s, SingI s)
153 => DataMigration s m h
154 -> MList m (h ': tl)
155 -> MList m (s ': h ': tl)
157infixr 7 :&&
159migrateObject
160 :: forall m fs fh. (FSubset fs fs (FImage fs fs), Monad m)
161 => (Rec (Tagged fs :. FieldRepr) fh -> m (Rec (Tagged fs :. FieldRepr) fs))
162 -> Tagged ('SchemaObject fs) (JsonRepr ('SchemaObject fh) -> m (JsonRepr ('SchemaObject fs)))
163migrateObject f = Tagged $ \(ReprObject r) -> do
164 res <- f $ rmap (Compose . Tagged) r
165 pure $ withRepr @('SchemaObject fs) res
167shrinkObject
168 :: forall rs ss m
169 . ( Monad m, FSubset rs ss (FImage rs ss) )
170 => Tagged
171 ('SchemaObject rs)
172 (JsonRepr ('SchemaObject ss) -> m (JsonRepr ('SchemaObject rs)))
173shrinkObject = Tagged $ \(ReprObject r) -> pure $ ReprObject $ fcast r
175type family MapSnd (l :: [(a,k)]) = (r :: [k]) where
176 MapSnd '[] = '[]
177 MapSnd ( '(a, b) ': tl) = b ': MapSnd tl
179type MigrationList m vs = MList m (MapSnd (AllVersions vs))