git.iko.soy/typeable/schematic
on master help sign in
yay, it compiles
0ae6fb8Denis Redozubov
src/Data/Schematic/Migration.hs+33−47
compare with master
unifiedsplit
@@ -3,7 +3,6 @@
3
3
4module Data.Schematic.Migration where
4module Data.Schematic.Migration where
5
5
6−import Data.Kind
7import Data.Schematic.Path
6import Data.Schematic.Path
8import Data.Schematic.Schema
7import Data.Schematic.Schema
9import Data.Schematic.Utils
8import Data.Schematic.Utils
@@ -21,47 +20,51 @@ data instance Sing (p :: Path) where
21
20
22-- Result type blueprint
21-- Result type blueprint
23data Builder
22data Builder
24− = BKey Schema Symbol Build -- field schema
23+ = BKey Schema Symbol Builder -- field schema
25 | BTraverse Schema Builder -- array schema
24 | BTraverse Schema Builder -- array schema
26 | BScalar Schema
25 | BScalar Schema
27
26
28-- Working with keys
27-- Working with keys
29
28
30type family SchemaByKey (fs :: [(Symbol, Schema)]) (s :: Symbol) :: Schema where
29type family SchemaByKey (fs :: [(Symbol, Schema)]) (s :: Symbol) :: Schema where
31− SchemaByKey ( '(a, s) ': tl) fn = SchemaByKey tl fn
32 SchemaByKey ( '(fn,s) ': tl) fn = s
30 SchemaByKey ( '(fn,s) ': tl) fn = s
31+ SchemaByKey ( '(a, s) ': tl) fn = SchemaByKey tl fn
33
32
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
35 DeleteKey acc fn ('(fn, a) ': tl) = acc :++ tl
34 DeleteKey acc fn ('(fn, a) ': tl) = acc :++ tl
36 DeleteKey acc fn (fna ': tl) = acc :++ (fna ': tl)
35 DeleteKey acc fn (fna ': tl) = acc :++ (fna ': tl)
37
36
38type family UpdateKey (acc :: [(Symbol, Schema)]) (fn :: Symbol) (fs :: [(Symbol, Schema)]) (s :: Schema) :: [(Symbol, Schema)] where
37type family UpdateKey (acc :: [(Symbol, Schema)]) (fn :: Symbol) (fs :: [(Symbol, Schema)]) (s :: Schema) :: [(Symbol, Schema)] where
39 UpdateKey acc fn ( '(fn, n) ': tl ) s = '(fn, s) ': tl
38 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
41
40
42−type family Build (z :: Builder) :: Schema where
41+type family Build (b :: Builder) :: Schema where
43− Build ('BKey (SchemaObject fs) fn z) = UpdateKey '[] fn fs (Build z)
42+ Build ('BKey ('SchemaObject fs) fn z) = 'SchemaObject (UpdateKey '[] fn fs (Build z))
44− Build ('BTraverse (SchemaArray acs s) z) = SchemaArray acs (Build z)
43+ Build ('BTraverse ('SchemaArray acs s) z) = 'SchemaArray acs (Build z)
45 Build ('BScalar s) = s
44 Build ('BScalar s) = s
46
45
47type family MakeBuilder (s :: Schema) (d :: Diff) :: Builder where
46type 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)
49 MakeBuilder ('SchemaObject fs) ('Diff ('PKey fn ': tl) a) =
48 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))
51 MakeBuilder ('SchemaArray acs s) ('Diff ('PTraverse ': tl) a) =
50 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))
53
52
54type family ApplyAction (a :: Action) (s :: Schema) :: Schema where
53type family ApplyAction (a :: Action) (s :: Schema) :: Schema where
55 ApplyAction ('AddKey fn s) ('SchemaObject fs) = 'SchemaObject ('(fn,s) ': fs)
54 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)
57 ApplyAction ('Update s) t = s
56 ApplyAction ('Update s) t = s
58
57
59−data instance Sing (z :: Builder) where
58+type family ApplyMigration (m :: Migration) (s :: Schema) :: (Revision, Schema) where
60− SZipper
59+ ApplyMigration ('Migration r '[]) s = '(r, s)
61− :: (Known (Sing ts), Known (Sing s))
60+ ApplyMigration ('Migration r (d ': ds)) s =
62− => Sing ts
61+ '(r, Snd (ApplyMigration ('Migration r ds) (Build (MakeBuilder s d))))
63− -> Sing s
62+
64− -> Sing (Builder ts s)
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)
65
68
66class MigrateSchema (a :: Schema) (b :: Schema) where
69class MigrateSchema (a :: Schema) (b :: Schema) where
67 migrate :: JsonRepr a -> JsonRepr b
70 migrate :: JsonRepr a -> JsonRepr b
@@ -75,21 +78,22 @@ data instance Sing (a :: Action) where
75 -> Sing s
78 -> Sing s
76 -> Sing ('AddKey n s)
79 -> Sing ('AddKey n s)
77 SUpdate :: Known (Sing s) => Sing s -> Sing ('Update s)
80 SUpdate :: Known (Sing s) => Sing s -> Sing ('Update s)
78− SDelete :: Sing 'DeleteKey
81+ SDeleteKey :: KnownSymbol s => Sing s -> Sing ('DeleteKey s)
79
82
80instance (Known (Sing n), Known (Sing s)) => Known (Sing ('AddKey n s)) where
83instance (Known (Sing n), Known (Sing s)) => Known (Sing ('AddKey n s)) where
81 known = SAddKey known known
84 known = SAddKey known known
82instance (Known (Sing s)) => Known (Sing ('Update s)) where known = SUpdate known
85instance (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
84
88
85-- | User-supplied atomic difference between schemas.
89-- | User-supplied atomic difference between schemas.
86-- Migrations can consists of many differences.
90-- Migrations can consists of many differences.
87−data Diff = Diff [PathSegment] Action
91+data Diff = Diff [Path] Action
88
92
89data instance Sing (diff :: Diff) where
93data instance Sing (diff :: Diff) where
90 SDiff
94 SDiff
91 :: (Known (Sing jp), Known (Sing a))
95 :: (Known (Sing jp), Known (Sing a))
92− => Sing (jp :: [PathSegment])
96+ => Sing (jp :: [Path])
93 -> Sing (a :: Action)
97 -> Sing (a :: Action)
94 -> Sing ('Diff jp a)
98 -> Sing ('Diff jp a)
95
99
@@ -98,12 +102,6 @@ type Revision = Symbol
98
102
99data Migration = Migration Revision [Diff]
103data Migration = Migration Revision [Diff]
100
104
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−
107data instance Sing (m :: Migration) where
105data instance Sing (m :: Migration) where
108 SMigration
106 SMigration
109 :: (KnownSymbol r, Known (Sing ds))
107 :: (KnownSymbol r, Known (Sing ds))
@@ -113,27 +111,15 @@ data instance Sing (m :: Migration) where
113
111
114data Versioned = Versioned Schema [Migration]
112data Versioned = Versioned Schema [Migration]
115
113
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−
123type family TypedVersionedSchema
114type family TypedVersionedSchema
124
115
125data instance Sing (v :: Versioned) where
116data instance Sing (v :: Versioned) where
126 SVersioned
117 SVersioned
127− :: (Known (Sing s), Known (Sing ms), TypedMigration s m)
118+ :: (Known (Sing s), Known (Sing ms))
128 => Sing (s :: Schema) -- base version
119 => Sing (s :: Schema) -- base version
129 -> Sing (ms :: [Migration]) -- a bunch of migrations
120 -> Sing (ms :: [Migration]) -- a bunch of migrations
130 -> Sing ('Versioned s ms)
121 -> Sing ('Versioned s ms)
131
122
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−
137type SchemaExample
123type SchemaExample
138 = 'SchemaObject
124 = 'SchemaObject
139 '[ '("foo", 'SchemaArray '[ 'AEq 1] ( 'SchemaNumber '[ 'NGt 10 ]))
125 '[ '("foo", 'SchemaArray '[ 'AEq 1] ( 'SchemaNumber '[ 'NGt 10 ]))
@@ -142,10 +128,10 @@ type SchemaExample
142type VS =
128type VS =
143 'Versioned SchemaExample
129 'Versioned SchemaExample
144 '[ 'Migration "test_revision"
130 '[ 'Migration "test_revision"
145− '[ 'Diff '[ 'Key "foo" ] ('Update ('SchemaText '[])) ] ]
131+ '[ 'Diff '[ 'PKey "foo" ] ('Update ('SchemaText '[])) ] ]
146
132
147−-- jsonExample :: JsonRepr (HeadVersion VS)
133+jsonExample :: JsonRepr (SchemaByRevision "test_revision" VS)
148−-- jsonExample = ReprObject $
134+jsonExample = ReprObject $
149−-- FieldRepr (ReprText "foo")
135+ FieldRepr (ReprText "foo")
150−-- :& FieldRepr (ReprOptional (Just (ReprText "bar")))
136+ :& FieldRepr (ReprOptional (Just (ReprText "bar")))
151−-- :& Nil
137+ :& RNil