git.iko.soy/schematic
on master help sign in
state of total mess
debbeccDenis Redozubov
schematic.cabal+1
compare with master
unifiedsplit
@@ -17,6 +17,7 @@ cabal-version: >=1.10
17
17
18library
18library
19 exposed-modules: Data.Schematic
19 exposed-modules: Data.Schematic
20+ -- , Data.Schematic.Class
20 , Data.Schematic.Instances
21 , Data.Schematic.Instances
21 , Data.Schematic.Path
22 , Data.Schematic.Path
22 , Data.Schematic.Schema
23 , Data.Schematic.Schema
src/Data/Schematic.hs+53−8
@@ -1,3 +1,6 @@
1+{-# OPTIONS -fprint-explicit-kinds #-}
2+{-# LANGUAGE AllowAmbiguousTypes #-}
3+
1module Data.Schematic
4module Data.Schematic
2 ( module Data.Schematic.Schema
5 ( module Data.Schematic.Schema
3 , module Data.Schematic.Utils
6 , module Data.Schematic.Utils
@@ -19,6 +22,7 @@ import Data.Schematic.Migration
19import Data.Schematic.Schema
22import Data.Schematic.Schema
20import Data.Schematic.Utils
23import Data.Schematic.Utils
21import Data.Schematic.Validation
24import Data.Schematic.Validation
25+import Data.Singletons.Prelude
22import Data.Text as T
26import Data.Text as T
23
27
24
28
@@ -38,28 +42,69 @@ parseAndValidateJson v =
38 Left em -> ValidationError em
42 Left em -> ValidationError em
39 Right () -> Valid jsonRepr
43 Right () -> Valid jsonRepr
40
44
45+parseAndValidateJsonBySing
46+ :: forall schema proxy
47+ . (J.FromJSON (JsonRepr schema), TopLevel schema)
48+ => Sing schema
49+ -> J.Value
50+ -> ParseResult (JsonRepr schema)
51+parseAndValidateJsonBySing sschema v = case parseEither parseJSON v of
52+ Left s -> DecodingError $ T.pack s
53+ Right jsonRepr ->
54+ let
55+ validate = validateJsonRepr sschema [] jsonRepr
56+ res = runIdentity . runValidationTEither $ validate
57+ in case res of
58+ Left em -> ValidationError em
59+ Right () -> Valid jsonRepr
60+
41parseAndValidateTopVersionJson
61parseAndValidateTopVersionJson
62+ :: forall proxy (v :: Versioned)
42− :: forall proxy v. (FromJSON (JsonRepr (TopVersion v)), Known (Sing (TopVersion v)))
63+ . (Known (Sing (TopVersion (AllVersions v))))
43− => proxy (v :: Versioned)
64+ => proxy v
44 -> J.Value
65 -> J.Value
45− -> ParseResult (JsonRepr (TopVersion v))
66+ -> ParseResult (JsonRepr (TopVersion (AllVersions v)))
46parseAndValidateTopVersionJson _ v =
67parseAndValidateTopVersionJson _ v =
47 case parseEither parseJSON v of
68 case parseEither parseJSON v of
48 Left s -> DecodingError $ T.pack s
69 Left s -> DecodingError $ T.pack s
49 Right jsonRepr ->
70 Right jsonRepr ->
50 let
71 let
72+ validate =
51− validate = validateJsonRepr (known :: Sing (TopVersion v)) [] jsonRepr
73+ validateJsonRepr (known :: Sing (TopVersion (AllVersions v))) [] jsonRepr
52 res = runIdentity . runValidationTEither $ validate
74 res = runIdentity . runValidationTEither $ validate
53 in case res of
75 in case res of
54 Left em -> ValidationError em
76 Left em -> ValidationError em
55 Right () -> Valid jsonRepr
77 Right () -> Valid jsonRepr
56
78
57parseAndValidateVersionedJson
79parseAndValidateVersionedJson
58− :: forall proxy v . ()
80+ :: forall proxy rav av (v :: Versioned) rs tv
59− => proxy (v :: Versioned)
81+ . ( Known (Sing (AllVersions v))
82+ , Migratable (SchemaPairs (AllVersions v))
83+ , (Known (Sing (TopVersion (AllVersions v))))
84+ , (Known (Sing (SchemaPairs (AllVersions v)))))
85+ => proxy v
86+ -> J.Value
87+ -> ParseResult (JsonRepr (TopVersion (AllVersions v)))
88+parseAndValidateVersionedJson _ v =
89+ let
90+ rss :: Sing (SchemaPairs (AllVersions v))
91+ rss = known
92+ stv :: Sing (TopVersion (AllVersions v))
93+ stv = known
94+ in parseAndValidateVersionedJsonByVersions stv rss v
95+
96+parseAndValidateVersionedJsonByVersions
97+ :: forall (rs :: [(Revision, Schema)]) tv proxy
98+ . (Migratable rs)
99+ => proxy (tv :: Schema)
100+ -> Sing rs
60 -> J.Value
101 -> J.Value
61− -> ParseResult (JsonRepr (TopVersion v))
102+ -> ParseResult (JsonRepr tv)
62−parseAndValidateVersionedJson = undefined
103+parseAndValidateVersionedJsonByVersions stv srs value = case srs of
104+ SNil -> DecodingError "blabla"
105+ SCons (STuple2 r s) tl -> case parseAndValidateJsonBySing s value of
106+ Valid a -> Valid $ migrate a
107+ _ -> DecodingError "dummy plug"
63
108
64decodeAndValidateJson
109decodeAndValidateJson
65 :: forall schema
110 :: forall schema
src/Data/Schematic/Migration.hs+59−6
@@ -3,12 +3,14 @@
3
3
4module Data.Schematic.Migration where
4module Data.Schematic.Migration where
5
5
6+import Data.Kind
6import Data.Schematic.Path
7import Data.Schematic.Path
7import Data.Schematic.Schema
8import Data.Schematic.Schema
8import Data.Schematic.Utils
9import Data.Schematic.Utils
9import Data.Singletons.Prelude hiding (All)
10import Data.Singletons.Prelude hiding (All)
10import Data.Singletons.TypeLits
11import Data.Singletons.TypeLits
11−import Data.Vinyl
12+import Data.Vinyl hiding (Dict)
13+
12
14
13data Path
15data Path
14 = PKey Symbol -- traverse into the object by key
16 = PKey Symbol -- traverse into the object by key
@@ -70,14 +72,65 @@ type family SchemaByRevision (r :: Revision) (vd :: Versioned) :: Schema where
70 SchemaByRevision r ('Versioned s (m ': ms)) =
72 SchemaByRevision r ('Versioned s (m ': ms)) =
71 SchemaByRevision r ('Versioned (Snd (ApplyMigration m s)) ms)
73 SchemaByRevision r ('Versioned (Snd (ApplyMigration m s)) ms)
72
74
73−type family TopVersion (vd :: Versioned) :: Schema where
75+-- type family Reverse (acc :: [(Revision, Schema)]) (rs :: [(Revision, Schema)]) :: [(Revision, Schema)] where
74− TopVersion ('Versioned s '[]) = s
76+-- Reverse acc '[] = acc
75− TopVersion ('Versioned s (m ': ms)) =
77+-- Reverse acc (h ': tl) = Reverse (h ': acc) tl
76− TopVersion ('Versioned (Snd (ApplyMigration m s)) ms)
78+
79+type family Migratable (rs :: [(Revision, Schema)]) :: Constraint where
80+ -- constraint duplication
81+ Migratable ('(r,s) ': '(r', s') ': tl) =
82+ (Known (Sing s), MigrateSchema s s', TopLevel s, Migratable ('(r',s') ': tl))
83+ Migratable ('(r,s) ': '[]) = (TopLevel s, Known (Sing s))
84+ -- Migratable '[] = ('True ~ 'False)
85+
86+-- data NonEmpty a = a :| [a]
87+
88+-- data instance Sing (ne :: NonEmpty a) where
89+-- SNECons :: Known (Sing e), Known (Sing l))=> Sing (e :: k) -> Sing (l :: [k]) -> Sing (e ':| l)
90+
91+data Revisions = Revisions
92+ Schema -- top version
93+ [(Revision, Schema)]
94+
95+data instance Sing (rs :: Revisions) where
96+ SRevisions
97+ :: (Known (Sing schema), Known (Sing rps), Known (Dict (ElemOf schema prs)))
98+ => Sing schema
99+ -> Sing rps
100+ -> Sing ('Revisions schema rps)
101+
102+-- -- | Heterogenous list with a proof of element schema included in the list itself.
103+-- data ElemList :: k -> [k] -> Type where
104+-- Singl :: Known (Sing schema) => Sing schema -> ElemList schema '[schema]
105+-- KeepProof :: Known (Sing new) => Sing new -> ElemList schema ss -> ElemList schema (new ': ss)
106+-- NewProof :: Known (Sing new) => Sing new -> ElemList schema ss -> ElemList new (new ': ss)
107+
108+type family ElemOf (e :: k) (l :: [(a,k)]) :: Constraint where
109+ ElemOf e '[] = 'True ~ 'False
110+ ElemOf e ( '(a, e) ': es) = ()
111+ ElemOf e (n ': es) = ElemOf e es
112+
113+-- | Extracts revision/schema pairs from @Versioned@ in reverse order.
114+type family AllVersions (vd :: Versioned) :: Revisions where
115+ AllVersions ('Versioned s ms) = AllVersions' ('Revisions s '[ '("initial", s) ]) ms
116+
117+type family AllVersions' (acc :: Revisions) (ms :: [Migration]) :: Revisions where
118+ AllVersions' acc '[] = acc
119+ AllVersions' ('Revisions tv rs) (m ': ms) =
120+ AllVersions' ('Revisions (Snd (ApplyMigration m tv)) (rs :++ '[(ApplyMigration m tv)])) ms
121+
122+type family TopVersion (rs :: Revisions) :: Schema where
123+ TopVersion ('Revisions s rs) = s
124+
125+type family SchemaPairs (rs :: Revisions) :: [(Revision, Schema)] where
126+ SchemaPairs ('Revisions s rs) = rs
77
127
78class MigrateSchema (a :: Schema) (b :: Schema) where
128class MigrateSchema (a :: Schema) (b :: Schema) where
79 migrate :: JsonRepr a -> JsonRepr b
129 migrate :: JsonRepr a -> JsonRepr b
80
130
131+instance MigrateSchema a a where
132+ migrate = id
133+
81data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol
134data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol
82
135
83data instance Sing (a :: Action) where
136data instance Sing (a :: Action) where
@@ -137,7 +190,7 @@ type VS =
137 '[ 'Migration "test_revision"
190 '[ 'Migration "test_revision"
138 '[ 'Diff '[ 'PKey "foo" ] ('Update ('SchemaText '[])) ] ]
191 '[ 'Diff '[ 'PKey "foo" ] ('Update ('SchemaText '[])) ] ]
139
192
140−jsonExample :: JsonRepr (TopVersion VS)
193+jsonExample :: JsonRepr (TopVersion (AllVersions VS))
141jsonExample = ReprObject $
194jsonExample = ReprObject $
142 FieldRepr (ReprText "foo")
195 FieldRepr (ReprText "foo")
143 :& FieldRepr (ReprOptional (Just (ReprText "bar")))
196 :& FieldRepr (ReprOptional (Just (ReprText "bar")))
src/Data/Schematic/Schema.hs+1−1
@@ -297,4 +297,4 @@ class FalseConstraint a
297type family TopLevel (schema :: Schema) :: Constraint where
297type family TopLevel (schema :: Schema) :: Constraint where
298 TopLevel ('SchemaArray acs s) = ()
298 TopLevel ('SchemaArray acs s) = ()
299 TopLevel ('SchemaObject o) = ()
299 TopLevel ('SchemaObject o) = ()
300− TopLevel spec = FalseConstraint spec
300+ TopLevel spec = 'True ~ 'False
src/Data/Schematic/Utils.hs+6
@@ -34,3 +34,9 @@ instance Known (Rec Sing '[]) where
34
34
35instance (Known (Sing a), Known (Rec Sing tl)) => Known (Rec Sing (a ': tl)) where
35instance (Known (Sing a), Known (Rec Sing tl)) => Known (Rec Sing (a ': tl)) where
36 known = known :& known
36 known = known :& known
37+
38+data Dict c where
39+ Dict :: c => Dict c
40+
41+instance c => Known (Dict c) where
42+ known = Dict