schematic 0.1.3.0 → 0.1.4.0
raw patch · 4 files changed
+213/−16 lines, 4 files
Files
- schematic.cabal +2/−1
- src/Data/Schematic.hs +32/−4
- src/Data/Schematic/Migration.hs +158/−0
- test/SchemaSpec.hs +21/−11
schematic.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: schematic-version: 0.1.3.0+version: 0.1.4.0 synopsis: JSON-biased spec and validation tool -- description: license: BSD3@@ -18,6 +18,7 @@ library exposed-modules: Data.Schematic , Data.Schematic.Instances+ , Data.Schematic.Migration , Data.Schematic.Path , Data.Schematic.Schema , Data.Schematic.Validation
src/Data/Schematic.hs view
@@ -7,9 +7,12 @@ , module Data.Schematic.Utils , decodeAndValidateJson , parseAndValidateJson+ , parseAndValidateJsonBy , parseAndValidateVersionedJson , parseAndValidateTopVersionJson , decodeAndValidateVersionedJson+ , parseAndValidateWithMList+ , decodeAndValidateVersionedWithMList , isValid , isDecodingError , isValidationError@@ -46,6 +49,13 @@ Left em -> ValidationError em Right () -> Valid jsonRepr +parseAndValidateJsonBy+ :: (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)+ => proxy schema+ -> J.Value+ -> ParseResult (JsonRepr schema)+parseAndValidateJsonBy _ = parseAndValidateJson+ parseAndValidateTopVersionJson :: forall proxy (v :: Versioned) . (SingI (TopVersion (AllVersions v)))@@ -93,6 +103,16 @@ -> ParseResult (JsonRepr (Snd (Head (AllVersions v)))) parseAndValidateVersionedJson _ v = mparse (sing :: Sing (AllVersions v)) v +parseAndValidateWithMList+ :: MList revisions+ -> J.Value+ -> ParseResult (JsonRepr (Head revisions))+parseAndValidateWithMList MNil v = parseAndValidateJson v+parseAndValidateWithMList ((:&&) p f tl) v = case parseAndValidateJsonBy p v of+ Valid a -> Valid a+ DecodingError _ -> f <$> parseAndValidateWithMList tl v+ ValidationError _ -> f <$> parseAndValidateWithMList tl v+ decodeAndValidateJson :: forall schema . (J.FromJSON (JsonRepr schema), TopLevel schema, SingI schema)@@ -111,7 +131,15 @@ Nothing -> DecodingError "malformed json" Just x -> parseAndValidateVersionedJson vp x -decodeAndValidate- :: MList revisions- ->-decodeAndValidate = undefined+type family MapSnd (l :: [(a,k)]) = (r :: [k]) where+ MapSnd '[] = '[]+ MapSnd ( '(a, b) ': tl) = b ': MapSnd tl++decodeAndValidateVersionedWithMList+ :: proxy versioned+ -> MList (MapSnd (AllVersions versioned))+ -> BL.ByteString+ -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))+decodeAndValidateVersionedWithMList _ mlist bs = case decode bs of+ Nothing -> DecodingError "malformed json"+ Just x -> parseAndValidateWithMList mlist x
+ src/Data/Schematic/Migration.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Schematic.Migration where++import Data.Kind+import Data.Schematic.Path+import Data.Schematic.Schema+import Data.Singletons.Prelude hiding (All)+import Data.Singletons.TypeLits+-- import Data.Vinyl hiding (Dict)+++data Path+ = PKey Symbol -- traverse into the object by key+ | PTraverse -- traverse into the array++data instance Sing (p :: Path) where+ SPKey :: KnownSymbol s => Sing s -> Sing ('PKey s)+ SPTraverse :: Sing 'PTraverse++instance KnownSymbol s => SingI ('PKey s) where+ sing = SPKey sing++instance SingI 'PTraverse where+ sing = SPTraverse++-- Result type blueprint+data Builder+ = BKey Schema Symbol Builder -- field schema+ | BTraverse Schema Builder -- array schema+ | BScalar Schema++-- Working with keys++type family SchemaByKey (fs :: [(Symbol, Schema)]) (s :: Symbol) :: Schema where+ SchemaByKey ( '(fn,s) ': tl) fn = s+ SchemaByKey ( '(a, s) ': tl) fn = SchemaByKey tl fn++type family DeleteKey (acc :: [(Symbol, Schema)]) (fn :: Symbol) (fs :: [(Symbol, Schema)]) :: [(Symbol, Schema)] where+ DeleteKey acc fn ('(fn, a) ': tl) = acc :++ tl+ DeleteKey acc fn (fna ': tl) = acc :++ (fna ': tl)++type family UpdateKey+ (fn :: Symbol)+ (fs :: [(Symbol, Schema)])+ (s :: Schema) = (r :: [(Symbol, Schema)]) where+ UpdateKey fn ( '(fn, a) ': tl ) s = ( '(fn, s) ': tl )+ UpdateKey fn ( '(fs, a) ': tl ) s = ( '(fs, a) ': UpdateKey fn tl s)++-- schema updates++type family Build (b :: Builder) :: Schema where+ Build ('BKey ('SchemaObject fs) fn z) = 'SchemaObject (UpdateKey fn fs (Build z))+ Build ('BTraverse ('SchemaArray acs s) z) = 'SchemaArray acs (Build z)+ Build ('BScalar s) = s++type family MakeBuilder (s :: Schema) (d :: Diff) :: Builder where+ MakeBuilder s ('Diff '[] a) = 'BScalar (ApplyAction a s)+ MakeBuilder ('SchemaObject fs) ('Diff ('PKey fn ': tl) a) =+ 'BKey ('SchemaObject fs) fn (MakeBuilder (SchemaByKey fs fn) ('Diff tl a))+ MakeBuilder ('SchemaArray acs s) ('Diff ('PTraverse ': tl) a) =+ 'BTraverse ('SchemaArray acs s) (MakeBuilder s ('Diff tl a))++type family ApplyAction (a :: Action) (s :: Schema) :: Schema where+ ApplyAction ('AddKey fn s) ('SchemaObject fs) = 'SchemaObject ('(fn,s) ': fs)+ ApplyAction ('DeleteKey fn) ('SchemaObject fs) = 'SchemaObject (DeleteKey '[] fn fs)+ ApplyAction ('Update s) t = s++type family ApplyMigration (m :: Migration) (s :: Schema) :: (Revision, Schema) where+ ApplyMigration ('Migration r '[]) s = '(r, s)+ ApplyMigration ('Migration r (d ': ds)) s =+ '(r, Snd (ApplyMigration ('Migration r ds) (Build (MakeBuilder s d))))++-- working with revisions++type family SchemaByRevision (r :: Revision) (vd :: Versioned) :: Schema where+ SchemaByRevision r ('Versioned s (('Migration r ds) ': ms)) =+ Snd (ApplyMigration ('Migration r ds) s)+ SchemaByRevision r ('Versioned s (m ': ms)) =+ SchemaByRevision r ('Versioned (Snd (ApplyMigration m s)) ms)++type family InitialSchema (v :: Versioned) = (s :: Schema) where+ InitialSchema ('Versioned s ms) = s++type family ElemOf (e :: k) (l :: [(a,k)]) :: Constraint where+ ElemOf e '[] = 'True ~ 'False+ ElemOf e ( '(a, e) ': es) = ()+ ElemOf e (n ': es) = ElemOf e es++-- | Extracts revision/schema pairs from @Versioned@ in reverse order.+type family AllVersions (vd :: Versioned) :: [(Revision, Schema)] where+ AllVersions ('Versioned s ms) = Reverse (AllVersions' '[ '("initial", s) ] ms)++type family AllVersions' (acc :: [(Revision, Schema)]) (ms :: [Migration]) = (r :: [(Revision, Schema)]) where+ AllVersions' acc '[] = acc+ AllVersions' ( '(rh, sh) ': tl ) (m ': ms) =+ AllVersions' ( '(rh, sh) ': ApplyMigration m sh ': tl ) ms++type family TopVersion (rs :: [(Revision, Schema)]) :: Schema where+ TopVersion ( '(rh, sh) ': tl) = sh++class MigrateSchema (a :: Schema) (b :: Schema) where+ migrate :: JsonRepr a -> JsonRepr b++data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol++data instance Sing (a :: Action) where+ SAddKey+ :: (SingI n, SingI s)+ => Sing n+ -> Sing s+ -> Sing ('AddKey n s)+ SUpdate :: (SingI s) => Sing s -> Sing ('Update s)+ SDeleteKey :: KnownSymbol s => Sing s -> Sing ('DeleteKey s)++-- | User-supplied atomic difference between schemas.+-- Migrations can consists of many differences.+data Diff = Diff [Path] Action++data instance Sing (diff :: Diff) where+ SDiff+ :: (SingI jp, SingI a)+ => Sing (jp :: [Path])+ -> Sing (a :: Action)+ -> Sing ('Diff jp a)++-- | User-provided name of the revision.+type Revision = Symbol++data Migration = Migration Revision [Diff]++data instance Sing (m :: Migration) where+ SMigration+ :: (KnownSymbol r, SingI ds)+ => Sing r+ -> Sing ds+ -> Sing ('Migration r ds)++data Versioned = Versioned Schema [Migration]++data instance Sing (v :: Versioned) where+ SVersioned+ :: (SingI s, SingI ms)+ => Sing (s :: Schema) -- base version+ -> Sing (ms :: [Migration]) -- a bunch of migrations+ -> Sing ('Versioned s ms)++data MList :: [Schema] -> Type where+ MNil :: (SingI s, TopLevel s) => MList '[s]+ (:&&)+ :: (SingI s, TopLevel s)+ => proxy s+ -> (JsonRepr h -> JsonRepr s)+ -> MList (h ': tl)+ -> MList (s ': h ': tl)++infixr 7 :&&
test/SchemaSpec.hs view
@@ -52,18 +52,23 @@ schemaJsonTopVersion :: ByteString schemaJsonTopVersion = "{ \"foo\": 42, \"bar\": \"bar\" }" +topObject+ :: JsonRepr+ ('SchemaObject+ '[ '("foo", 'SchemaNumber '[])+ , '("bar", 'SchemaText '[])])+topObject = ReprObject $+ FieldRepr (ReprNumber 42)+ :& FieldRepr (ReprText "test")+ :& RNil+ instance- MigrateSchema- ('SchemaObject- '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10 ])),- '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))])- ('SchemaObject- '[ '("foo", 'SchemaNumber '[]), '("bar", 'SchemaText '[])])+ MigrateSchema+ SchemaExample+ ('SchemaObject+ '[ '("foo", 'SchemaNumber '[]), '("bar", 'SchemaText '[])]) where- migrate _ = ReprObject $- FieldRepr (ReprNumber 42)- :& FieldRepr (ReprText "test")- :& RNil+ migrate = const topObject spec :: Spec spec = do@@ -83,7 +88,12 @@ it "validates versioned json" $ do decodeAndValidateVersionedJson (Proxy @VS) schemaJson `shouldSatisfy` isValid-+ it "validates with Migration List" $ do+ decodeAndValidateVersionedWithMList+ (Proxy @VS)+ ((:&&) (Proxy @(SchemaByRevision "test_revision" VS)) (const topObject) MNil)+ schemaJson+ `shouldSatisfy` isValid main :: IO () main = hspec spec