git.iko.soy/schematic
on master help sign in
Builder rewrite
f2a852dDenis Redozubov
src/Data/Schematic/Migration.hs+63−45
compare with master
unifiedsplit
@@ -11,11 +11,62 @@ import Data.Singletons.Prelude hiding (All)
11import Data.Singletons.TypeLits
11import Data.Singletons.TypeLits
12import Data.Vinyl
12import Data.Vinyl
13
13
14+data Path
15+ = PKey Symbol -- traverse into the object by key
16+ | PTraverse -- traverse into the array
17+
18+data instance Sing (p :: Path) where
19+ SPKey :: KnownSymbol s => Sing s -> Sing ('PKey s)
20+ SPTraverse :: Sing 'PTraverse
21+
22+-- Result type blueprint
23+data Builder
24+ = BKey Schema Symbol Build -- field schema
25+ | BTraverse Schema Builder -- array schema
26+ | BScalar Schema
27+
28+-- Working with keys
29+
30+type 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
33+
34+type family DeleteKey (acc :: [(Symbol, Schema)]) (fn :: Symbol) (fs :: [(Symbol, Schema)]) :: Schema where
35+ DeleteKey acc fn ('(fn, a) ': tl) = acc :++ tl
36+ DeleteKey acc fn (fna ': tl) = acc :++ (fna ': tl)
37+
38+type 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
40+ UpdateKey acc fn ( '(a, n) ': tl) s = acc :++ '(a, n) ': UpdateKey fn tl
41+
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)
45+ Build ('BScalar s) = s
46+
47+type family MakeBuilder (s :: Schema) (d :: Diff) :: Builder where
48+ MakeBuilder s ('Diff '[] a) = BScalar (ApplyAction a s)
49+ MakeBuilder ('SchemaObject fs) ('Diff ('PKey fn ': tl) a) =
50+ BKey ('SchemaObject fs) fn (MakeBuilder (SchemaByKey fn fs) ('Diff tl a))
51+ MakeBuilder ('SchemaArray acs s) ('Diff ('PTraverse ': tl) a) =
52+ MakeBuilder ('SchemaArray acs s) (MakeBuilder s ('Diff tl a))
53+
54+type family ApplyAction (a :: Action) (s :: Schema) :: Schema where
55+ ApplyAction ('AddKey fn s) ('SchemaObject fs) = 'SchemaObject ('(fn,s) ': fs)
56+ ApplyAction ('DeleteKey fn) ('SchemaObject fs) = 'SchemaObject (DeleteKey fn fs)
57+ ApplyAction ('Update s) t = s
58+
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)
14
65
15class MigrateSchema (a :: Schema) (b :: Schema) where
66class MigrateSchema (a :: Schema) (b :: Schema) where
16 migrate :: JsonRepr a -> JsonRepr b
67 migrate :: JsonRepr a -> JsonRepr b
17
68
18−data Action = AddKey Symbol Schema | Update Schema | DeleteKey
69+data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol
19
70
20data instance Sing (a :: Action) where
71data instance Sing (a :: Action) where
21 SAddKey
72 SAddKey
@@ -42,49 +93,16 @@ data instance Sing (diff :: Diff) where
42 -> Sing (a :: Action)
93 -> Sing (a :: Action)
43 -> Sing ('Diff jp a)
94 -> Sing ('Diff jp a)
44
95
45−type family TypedDiffList (s :: Schema) (ds :: [Diff]) :: Constraint where
46− TypedDiffList s '[] = ()
47− TypedDiffList s (d ': tl) = (TypedDiff s d, TypedDiffList s tl)
48−
49−-- here
50−type family TypedDiffListSchema (s :: Schema) (ds :: [Diff]) :: Schema where
51− TypedDiffListSchema s '[] = s
52− TypedDiffListSchema s (d ': tl) = TypedDiffListSchema (TypedDiffSchema s d) tl
53−
54−type family TypedDiff (s :: Schema) (d :: Diff) :: Constraint where
55− TypedDiff s ('Diff ps a) = TypedSubSchema s ps
56−
57−type family TypedDiffSchema (s :: Schema) (d :: Diff) :: Schema where
58− TypedDiffSchema s ('Diff ps a) = TypedSubSchemaSchema s ps
59−
60−type family TypedSubSchema (s :: Schema) (p :: [PathSegment]) :: Constraint where
61− TypedSubSchema s '[] = ()
62− TypedSubSchema s (h ': tl) = TypedSubSchema (TraverseStep s h) tl
63−
64−-- issue here
65−type family TypedSubSchemaSchema (s :: Schema) (p :: [PathSegment]) :: Schema where
66− TypedSubSchemaSchema s (h ': tl) = TypedSubSchemaSchema (TraverseStep s h) tl
67−
68−type family TraverseStep (s :: Schema) (ps :: PathSegment) :: Schema where
69− TraverseStep ('SchemaArray acs s) ('Ix n) = s
70− TraverseStep ('SchemaObject ( '(fn, s) ': tl)) ('Key fn) = s
71− TraverseStep ('SchemaObject ( h ': tl)) ('Key fn) =
72− TraverseStep ('SchemaObject tl) ('Key fn)
73−
74−type family SubSchema (s :: Schema) (p :: [PathSegment]) where
75− SubSchema s '[] = s
76− SubSchema s (h ': tl) = SubSchema (TraverseStep s h) tl
77−
78-- | User-provided name of the revision.
96-- | User-provided name of the revision.
79type Revision = Symbol
97type Revision = Symbol
80
98
81data Migration = Migration Revision [Diff]
99data Migration = Migration Revision [Diff]
82
100
83−type family TypedMigration (s :: Schema) (m :: Migration) :: Constraint where
101+-- type family TypedMigration (s :: Schema) (m :: Migration) :: Constraint where
84− TypedMigration s ('Migration r ds) = (TypedDiffList s ds)
102+-- TypedMigration s ('Migration r ds) = (TypedDiffList s ds)
85
103
86−type family TypedMigrationSchema (s :: Schema) (m :: Migration) :: (Symbol, Schema) where
104+-- type family TypedMigrationSchema (s :: Schema) (m :: Migration) :: (Symbol, Schema) where
87− TypedMigrationSchema s ('Migration r ds) = '(r, TypedDiffListSchema s ds)
105+-- TypedMigrationSchema s ('Migration r ds) = '(r, TypedDiffListSchema s ds)
88
106
89data instance Sing (m :: Migration) where
107data instance Sing (m :: Migration) where
90 SMigration
108 SMigration
@@ -95,12 +113,12 @@ data instance Sing (m :: Migration) where
95
113
96data Versioned = Versioned Schema [Migration]
114data Versioned = Versioned Schema [Migration]
97
115
98−type family TypedVersioned (s :: Schema) (ms :: [Migration]) :: Constraint where
116+-- type family TypedVersioned (s :: Schema) (ms :: [Migration]) :: Constraint where
99− TypedVersioned s '[] = ()
117+-- TypedVersioned s '[] = ()
100− TypedVersioned s (h ': tl) =
118+-- TypedVersioned s (h ': tl) =
101− ( TypedMigration s h
119+-- ( TypedMigration s h
102− , MigrateSchema s (Snd (TypedMigrationSchema s h))
120+-- , MigrateSchema s (Snd (TypedMigrationSchema s h))
103− , TypedVersioned (Snd (TypedMigrationSchema s h)) tl )
121+-- , TypedVersioned (Snd (TypedMigrationSchema s h)) tl )
104
122
105type family TypedVersionedSchema
123type family TypedVersionedSchema
106
124
@@ -130,4 +148,4 @@ type VS =
130-- jsonExample = ReprObject $
148-- jsonExample = ReprObject $
131-- FieldRepr (ReprText "foo")
149-- FieldRepr (ReprText "foo")
132-- :& FieldRepr (ReprOptional (Just (ReprText "bar")))
150-- :& FieldRepr (ReprOptional (Just (ReprText "bar")))
133−-- :& RNil
151+-- :& Nil