@@ -3,7 +3,6 @@
33
44module Data.Schematic.Migration where
55
6−import Data.Kind
76import Data.Schematic.Path
87import Data.Schematic.Schema
98import Data.Schematic.Utils
@@ -21,47 +20,51 @@ data instance Sing (p :: Path) where
2120
2221-- Result type blueprint
2322data Builder
24− = BKey Schema Symbol Build -- field schema
23+ = BKey Schema Symbol Builder -- field schema
2524 | BTraverse Schema Builder -- array schema
2625 | BScalar Schema
2726
2827-- Working with keys
2928
3029type family SchemaByKey (fs :: [(Symbol, Schema)]) (s :: Symbol) :: Schema where
31− SchemaByKey ( '(a, s) ': tl) fn = SchemaByKey tl fn
3230 SchemaByKey ( '(fn,s) ': tl) fn = s
31+ SchemaByKey ( '(a, s) ': tl) fn = SchemaByKey tl fn
3332
34−type family DeleteKey (acc :: [(Symbol, Schema)]) (fn :: Symbol) (fs :: [(Symbol, Schema)]) :: Schema where
33+type family DeleteKey (acc :: [(Symbol, Schema)]) (fn :: Symbol) (fs :: [(Symbol, Schema)]) :: [(Symbol, Schema)] where
3534 DeleteKey acc fn ('(fn, a) ': tl) = acc :++ tl
3635 DeleteKey acc fn (fna ': tl) = acc :++ (fna ': tl)
3736
3837type family UpdateKey (acc :: [(Symbol, Schema)]) (fn :: Symbol) (fs :: [(Symbol, Schema)]) (s :: Schema) :: [(Symbol, Schema)] where
3938 UpdateKey acc fn ( '(fn, n) ': tl ) s = '(fn, s) ': tl
40− UpdateKey acc fn ( '(a, n) ': tl) s = acc :++ '(a, n) ': UpdateKey fn tl
39+ UpdateKey acc fn ( '(a, n) ': tl) s = UpdateKey (acc :++ '[ '(a,n) ]) fn tl s
4140
42−type family Build (z :: Builder) :: Schema where
43− Build ('BKey (SchemaObject fs) fn z) = UpdateKey '[] fn fs (Build z)
44− Build ('BTraverse (SchemaArray acs s) z) = SchemaArray acs (Build z)
41+type family Build (b :: Builder) :: Schema where
42+ Build ('BKey ('SchemaObject fs) fn z) = 'SchemaObject (UpdateKey '[] fn fs (Build z))
43+ Build ('BTraverse ('SchemaArray acs s) z) = 'SchemaArray acs (Build z)
4544 Build ('BScalar s) = s
4645
4746type family MakeBuilder (s :: Schema) (d :: Diff) :: Builder where
48− MakeBuilder s ('Diff '[] a) = BScalar (ApplyAction a s)
47+ MakeBuilder s ('Diff '[] a) = 'BScalar (ApplyAction a s)
4948 MakeBuilder ('SchemaObject fs) ('Diff ('PKey fn ': tl) a) =
50− BKey ('SchemaObject fs) fn (MakeBuilder (SchemaByKey fn fs) ('Diff tl a))
49+ 'BKey ('SchemaObject fs) fn (MakeBuilder (SchemaByKey fs fn) ('Diff tl a))
5150 MakeBuilder ('SchemaArray acs s) ('Diff ('PTraverse ': tl) a) =
52− MakeBuilder ('SchemaArray acs s) (MakeBuilder s ('Diff tl a))
51+ 'BTraverse ('SchemaArray acs s) (MakeBuilder s ('Diff tl a))
5352
5453type family ApplyAction (a :: Action) (s :: Schema) :: Schema where
5554 ApplyAction ('AddKey fn s) ('SchemaObject fs) = 'SchemaObject ('(fn,s) ': fs)
56− ApplyAction ('DeleteKey fn) ('SchemaObject fs) = 'SchemaObject (DeleteKey fn fs)
55+ ApplyAction ('DeleteKey fn) ('SchemaObject fs) = 'SchemaObject (DeleteKey '[] fn fs)
5756 ApplyAction ('Update s) t = s
5857
59−data instance Sing (z :: Builder) where
60− SZipper
61− :: (Known (Sing ts), Known (Sing s))
62− => Sing ts
63− -> Sing s
64− -> Sing (Builder ts s)
58+type family ApplyMigration (m :: Migration) (s :: Schema) :: (Revision, Schema) where
59+ ApplyMigration ('Migration r '[]) s = '(r, s)
60+ ApplyMigration ('Migration r (d ': ds)) s =
61+ '(r, Snd (ApplyMigration ('Migration r ds) (Build (MakeBuilder s d))))
62+
63+type family SchemaByRevision (r :: Revision) (vd :: Versioned) :: Schema where
64+ SchemaByRevision r ('Versioned s (('Migration r ds) ': ms)) =
65+ Snd (ApplyMigration ('Migration r ds) s)
66+ SchemaByRevision r ('Versioned s (m ': ms)) =
67+ SchemaByRevision r ('Versioned (Snd (ApplyMigration m s)) ms)
6568
6669class MigrateSchema (a :: Schema) (b :: Schema) where
6770 migrate :: JsonRepr a -> JsonRepr b
@@ -75,21 +78,22 @@ data instance Sing (a :: Action) where
7578 -> Sing s
7679 -> Sing ('AddKey n s)
7780 SUpdate :: Known (Sing s) => Sing s -> Sing ('Update s)
78− SDelete :: Sing 'DeleteKey
81+ SDeleteKey :: KnownSymbol s => Sing s -> Sing ('DeleteKey s)
7982
8083instance (Known (Sing n), Known (Sing s)) => Known (Sing ('AddKey n s)) where
8184 known = SAddKey known known
8285instance (Known (Sing s)) => Known (Sing ('Update s)) where known = SUpdate known
83−instance Known (Sing 'DeleteKey) where known = SDelete
86+instance (KnownSymbol s, Known (Sing s)) => Known (Sing ('DeleteKey s)) where
87+ known = SDeleteKey known
8488
8589-- | User-supplied atomic difference between schemas.
8690-- Migrations can consists of many differences.
87−data Diff = Diff [PathSegment] Action
91+data Diff = Diff [Path] Action
8892
8993data instance Sing (diff :: Diff) where
9094 SDiff
9195 :: (Known (Sing jp), Known (Sing a))
92− => Sing (jp :: [PathSegment])
96+ => Sing (jp :: [Path])
9397 -> Sing (a :: Action)
9498 -> Sing ('Diff jp a)
9599
@@ -98,12 +102,6 @@ type Revision = Symbol
98102
99103data Migration = Migration Revision [Diff]
100104
101−-- type family TypedMigration (s :: Schema) (m :: Migration) :: Constraint where
102−-- TypedMigration s ('Migration r ds) = (TypedDiffList s ds)
103−
104−-- type family TypedMigrationSchema (s :: Schema) (m :: Migration) :: (Symbol, Schema) where
105−-- TypedMigrationSchema s ('Migration r ds) = '(r, TypedDiffListSchema s ds)
106−
107105data instance Sing (m :: Migration) where
108106 SMigration
109107 :: (KnownSymbol r, Known (Sing ds))
@@ -113,27 +111,15 @@ data instance Sing (m :: Migration) where
113111
114112data Versioned = Versioned Schema [Migration]
115113
116−-- type family TypedVersioned (s :: Schema) (ms :: [Migration]) :: Constraint where
117−-- TypedVersioned s '[] = ()
118−-- TypedVersioned s (h ': tl) =
119−-- ( TypedMigration s h
120−-- , MigrateSchema s (Snd (TypedMigrationSchema s h))
121−-- , TypedVersioned (Snd (TypedMigrationSchema s h)) tl )
122−
123114type family TypedVersionedSchema
124115
125116data instance Sing (v :: Versioned) where
126117 SVersioned
127− :: (Known (Sing s), Known (Sing ms), TypedMigration s m)
118+ :: (Known (Sing s), Known (Sing ms))
128119 => Sing (s :: Schema) -- base version
129120 -> Sing (ms :: [Migration]) -- a bunch of migrations
130121 -> Sing ('Versioned s ms)
131122
132−type family HeadVersion (vd :: Versioned) :: Schema where
133− HeadVersion ('Versioned s '[]) = s
134− HeadVersion ('Versioned s (m ': tl)) =
135− HeadVersion ('Versioned (Snd (TypedMigrationSchema s m)) tl)
136−
137123type SchemaExample
138124 = 'SchemaObject
139125 '[ '("foo", 'SchemaArray '[ 'AEq 1] ( 'SchemaNumber '[ 'NGt 10 ]))
@@ -142,10 +128,10 @@ type SchemaExample
142128type VS =
143129 'Versioned SchemaExample
144130 '[ 'Migration "test_revision"
145− '[ 'Diff '[ 'Key "foo" ] ('Update ('SchemaText '[])) ] ]
131+ '[ 'Diff '[ 'PKey "foo" ] ('Update ('SchemaText '[])) ] ]
146132
147−-- jsonExample :: JsonRepr (HeadVersion VS)
148−-- jsonExample = ReprObject $
149−-- FieldRepr (ReprText "foo")
150−-- :& FieldRepr (ReprOptional (Just (ReprText "bar")))
151−-- :& Nil
133+jsonExample :: JsonRepr (SchemaByRevision "test_revision" VS)
134+jsonExample = ReprObject $
135+ FieldRepr (ReprText "foo")
136+ :& FieldRepr (ReprOptional (Just (ReprText "bar")))
137+ :& RNil