git.iko.soy/schematic
on master help sign in
state of total mess
commitdebbecc2b1fb5c8efc0045e550f8df54caf6e43e authorDenis Redozubov <denis.redozubov@gmail.com> dateWed 31 May 2017, 14:00 (9 years ago) parentfb0244e
5 files changed+120−15
compare with master
unifiedsplit
schematic.cabal+1 src/Data/Schematic.hs+53−8 src/Data/Schematic/Migration.hs+59−6 src/Data/Schematic/Schema.hs+1−1 src/Data/Schematic/Utils.hs+6
schematic.cabal+1
@@ -17,6 +17,7 @@ cabal-version: >=1.10
1717
1818library
1919 exposed-modules: Data.Schematic
20+ -- , Data.Schematic.Class
2021 , Data.Schematic.Instances
2122 , Data.Schematic.Path
2223 , Data.Schematic.Schema
src/Data/Schematic.hs+53−8
@@ -1,3 +1,6 @@
1+{-# OPTIONS -fprint-explicit-kinds #-}
2+{-# LANGUAGE AllowAmbiguousTypes #-}
3+
14module Data.Schematic
25 ( module Data.Schematic.Schema
36 , module Data.Schematic.Utils
@@ -19,6 +22,7 @@ import Data.Schematic.Migration
1922import Data.Schematic.Schema
2023import Data.Schematic.Utils
2124import Data.Schematic.Validation
25+import Data.Singletons.Prelude
2226import Data.Text as T
2327
2428
@@ -38,28 +42,69 @@ parseAndValidateJson v =
3842 Left em -> ValidationError em
3943 Right () -> Valid jsonRepr
4044
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+
4161parseAndValidateTopVersionJson
42− :: forall proxy v. (FromJSON (JsonRepr (TopVersion v)), Known (Sing (TopVersion v)))
43− => proxy (v :: Versioned)
62+ :: forall proxy (v :: Versioned)
63+ . (Known (Sing (TopVersion (AllVersions v))))
64+ => proxy v
4465 -> J.Value
45− -> ParseResult (JsonRepr (TopVersion v))
66+ -> ParseResult (JsonRepr (TopVersion (AllVersions v)))
4667parseAndValidateTopVersionJson _ v =
4768 case parseEither parseJSON v of
4869 Left s -> DecodingError $ T.pack s
4970 Right jsonRepr ->
5071 let
51− validate = validateJsonRepr (known :: Sing (TopVersion v)) [] jsonRepr
72+ validate =
73+ validateJsonRepr (known :: Sing (TopVersion (AllVersions v))) [] jsonRepr
5274 res = runIdentity . runValidationTEither $ validate
5375 in case res of
5476 Left em -> ValidationError em
5577 Right () -> Valid jsonRepr
5678
5779parseAndValidateVersionedJson
58− :: forall proxy v . ()
59− => proxy (v :: Versioned)
80+ :: forall proxy rav av (v :: Versioned) rs tv
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
60101 -> J.Value
61− -> ParseResult (JsonRepr (TopVersion v))
62−parseAndValidateVersionedJson = undefined
102+ -> ParseResult (JsonRepr tv)
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"
63108
64109decodeAndValidateJson
65110 :: forall schema
src/Data/Schematic/Migration.hs+59−6
@@ -3,12 +3,14 @@
33
44module Data.Schematic.Migration where
55
6+import Data.Kind
67import Data.Schematic.Path
78import Data.Schematic.Schema
89import Data.Schematic.Utils
910import Data.Singletons.Prelude hiding (All)
1011import Data.Singletons.TypeLits
11−import Data.Vinyl
12+import Data.Vinyl hiding (Dict)
13+
1214
1315data Path
1416 = PKey Symbol -- traverse into the object by key
@@ -70,14 +72,65 @@ type family SchemaByRevision (r :: Revision) (vd :: Versioned) :: Schema where
7072 SchemaByRevision r ('Versioned s (m ': ms)) =
7173 SchemaByRevision r ('Versioned (Snd (ApplyMigration m s)) ms)
7274
73−type family TopVersion (vd :: Versioned) :: Schema where
74− TopVersion ('Versioned s '[]) = s
75− TopVersion ('Versioned s (m ': ms)) =
76− TopVersion ('Versioned (Snd (ApplyMigration m s)) ms)
75+-- type family Reverse (acc :: [(Revision, Schema)]) (rs :: [(Revision, Schema)]) :: [(Revision, Schema)] where
76+-- Reverse acc '[] = acc
77+-- Reverse acc (h ': tl) = Reverse (h ': acc) tl
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
77127
78128class MigrateSchema (a :: Schema) (b :: Schema) where
79129 migrate :: JsonRepr a -> JsonRepr b
80130
131+instance MigrateSchema a a where
132+ migrate = id
133+
81134data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol
82135
83136data instance Sing (a :: Action) where
@@ -137,7 +190,7 @@ type VS =
137190 '[ 'Migration "test_revision"
138191 '[ 'Diff '[ 'PKey "foo" ] ('Update ('SchemaText '[])) ] ]
139192
140−jsonExample :: JsonRepr (TopVersion VS)
193+jsonExample :: JsonRepr (TopVersion (AllVersions VS))
141194jsonExample = ReprObject $
142195 FieldRepr (ReprText "foo")
143196 :& FieldRepr (ReprOptional (Just (ReprText "bar")))
src/Data/Schematic/Schema.hs+1−1
@@ -297,4 +297,4 @@ class FalseConstraint a
297297type family TopLevel (schema :: Schema) :: Constraint where
298298 TopLevel ('SchemaArray acs s) = ()
299299 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
3434
3535instance (Known (Sing a), Known (Rec Sing tl)) => Known (Rec Sing (a ': tl)) where
3636 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