@@ -11,11 +11,62 @@ import Data.Singletons.Prelude hiding (All)
1111import Data.Singletons.TypeLits
1212import Data.Vinyl
1313
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)
1465
1566class MigrateSchema (a :: Schema) (b :: Schema) where
1667 migrate :: JsonRepr a -> JsonRepr b
1768
18−data Action = AddKey Symbol Schema | Update Schema | DeleteKey
69+data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol
1970
2071data instance Sing (a :: Action) where
2172 SAddKey
@@ -42,49 +93,16 @@ data instance Sing (diff :: Diff) where
4293 -> Sing (a :: Action)
4394 -> Sing ('Diff jp a)
4495
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−
7896-- | User-provided name of the revision.
7997type Revision = Symbol
8098
8199data Migration = Migration Revision [Diff]
82100
83−type family TypedMigration (s :: Schema) (m :: Migration) :: Constraint where
84− TypedMigration s ('Migration r ds) = (TypedDiffList s ds)
101+-- type family TypedMigration (s :: Schema) (m :: Migration) :: Constraint where
102+-- TypedMigration s ('Migration r ds) = (TypedDiffList s ds)
85103
86−type family TypedMigrationSchema (s :: Schema) (m :: Migration) :: (Symbol, Schema) where
87− TypedMigrationSchema s ('Migration r ds) = '(r, TypedDiffListSchema s ds)
104+-- type family TypedMigrationSchema (s :: Schema) (m :: Migration) :: (Symbol, Schema) where
105+-- TypedMigrationSchema s ('Migration r ds) = '(r, TypedDiffListSchema s ds)
88106
89107data instance Sing (m :: Migration) where
90108 SMigration
@@ -95,12 +113,12 @@ data instance Sing (m :: Migration) where
95113
96114data Versioned = Versioned Schema [Migration]
97115
98−type family TypedVersioned (s :: Schema) (ms :: [Migration]) :: Constraint where
99− TypedVersioned s '[] = ()
100− TypedVersioned s (h ': tl) =
101− ( TypedMigration s h
102− , MigrateSchema s (Snd (TypedMigrationSchema s h))
103− , TypedVersioned (Snd (TypedMigrationSchema s h)) tl )
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 )
104122
105123type family TypedVersionedSchema
106124
@@ -130,4 +148,4 @@ type VS =
130148-- jsonExample = ReprObject $
131149-- FieldRepr (ReprText "foo")
132150-- :& FieldRepr (ReprOptional (Just (ReprText "bar")))
133−-- :& RNil
151+-- :& Nil