schematic 0.4.0.0 → 0.4.1.0
raw patch · 10 files changed
+114/−74 lines, 10 files
Files
- ChangeLog.md +4/−0
- schematic.cabal +1/−28
- src/Data/Schematic.hs +0/−4
- src/Data/Schematic/DSL.hs +0/−1
- src/Data/Schematic/Lens.hs +17/−18
- src/Data/Schematic/Migration.hs +29/−2
- test/HelpersSpec.hs +6/−0
- test/JsonSchemaSpec.hs +7/−0
- test/LensSpec.hs +9/−4
- test/SchemaSpec.hs +41/−17
ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for schematic +## 0.4.1.0 -- 2017-11-01++flens and fget now use type application syntax+ ## 0.4.0.0 -- 2017-10-17 Object building DSL, more convenience helpers, MCons simplified with Tagged
schematic.cabal view
@@ -1,5 +1,5 @@ name: schematic-version: 0.4.0.0+version: 0.4.1.0 synopsis: JSON-biased spec and validation tool license: BSD3 license-file: LICENSE@@ -85,33 +85,6 @@ hs-source-dirs: test main-is: Spec.hs default-language: Haskell2010- default-extensions: ConstraintKinds- , DataKinds- , DeriveFunctor- , DeriveFoldable- , DeriveGeneric- , DeriveDataTypeable- , FlexibleContexts- , FlexibleInstances- , FunctionalDependencies- , GADTs- , KindSignatures- , InstanceSigs- , LambdaCase- , MultiParamTypeClasses- , OverloadedLists- , OverloadedStrings- , PolyKinds- , QuasiQuotes- , PartialTypeSignatures- , RecordWildCards- , ScopedTypeVariables- , TemplateHaskell- , TypeApplications- , TypeFamilies- , TypeInType- , TypeOperators- , TypeSynonymInstances build-depends: HUnit , aeson >= 1 , base >=4.9 && <4.11
src/Data/Schematic.hs view
@@ -107,10 +107,6 @@ Nothing -> DecodingError "malformed json" Just x -> parseAndValidateJson x -type family MapSnd (l :: [(a,k)]) = (r :: [k]) where- MapSnd '[] = '[]- MapSnd ( '(a, b) ': tl) = b ': MapSnd tl- decodeAndValidateVersionedWithMList :: Monad m => proxy versioned
src/Data/Schematic/DSL.hs view
@@ -4,7 +4,6 @@ import Data.Kind import Data.Schematic.Lens-import Data.Schematic.Migration import Data.Schematic.Schema import Data.Scientific import Data.Singletons
src/Data/Schematic/Lens.hs view
@@ -19,7 +19,6 @@ ) where import Data.Profunctor-import Data.Proxy import Data.Schematic.Schema import Data.Scientific import Data.Singletons@@ -36,20 +35,20 @@ FIndex r ( '(r, s) ': rs) = 'Z FIndex r ( s ': rs) = 'S (FIndex r rs) +type Flens fn f g rs i+ = Functor g+ => (f '(fn, (ByField fn rs i)) -> g (f '(fn, (ByField fn rs i))))+ -> Rec f rs+ -> g (Rec f rs)++type FGetter fn f rs i = Rec f rs -> f '(fn, (ByField fn rs i))+ class i ~ FIndex fn rs => FElem (fn :: Symbol) (rs :: [(Symbol, Schema)]) (i :: Nat) where type ByField fn rs i :: Schema- flens- :: Functor g- => proxy fn- -> (f '(fn, (ByField fn rs i)) -> g (f '(fn, (ByField fn rs i))))- -> Rec f rs- -> g (Rec f rs)+ flens :: Flens fn f g rs i -- | For Vinyl users who are not using the @lens@ package, we provide a getter.- fget- :: proxy fn- -> Rec f rs- -> f '(fn, (ByField fn rs i))+ fget :: FGetter fn f rs i -- | For Vinyl users who are not using the @lens@ package, we also provide a -- setter. In general, it will be unambiguous what field is being written to,@@ -62,25 +61,25 @@ instance FElem fn ('(fn, r) ': rs) 'Z where type ByField fn ('(fn, r) ': rs) 'Z = r - flens _ f (x :& xs) = fmap (:& xs) (f x)+ flens f (x :& xs) = fmap (:& xs) (f x) {-# INLINE flens #-} - fget k = getConst . flens k Const+ fget = getConst . flens Const {-# INLINE fget #-} - fput y = getIdentity . flens Proxy (\_ -> Identity y)+ fput y = getIdentity . flens (\_ -> Identity y) {-# INLINE fput #-} instance (FIndex r (s ': rs) ~ 'S i, FElem r rs i) => FElem r (s ': rs) ('S i) where type ByField r (s ': rs) ('S i) = ByField r rs i - flens p f (x :& xs) = fmap (x :&) (flens p f xs)+ flens f (x :& xs) = fmap (x :&) (flens f xs) {-# INLINE flens #-} - fget k = getConst . flens k Const+ fget = getConst . flens Const {-# INLINE fget #-} - fput y = getIdentity . flens Proxy (\_ -> Identity y)+ fput y = getIdentity . flens (\_ -> Identity y) {-# INLINE fput #-} -- This is an internal convenience helpers stolen from the @lens@ library.@@ -144,7 +143,7 @@ ( ByField fn ss i ~ s , FElem fn ss i , FSubset rs ss is) => FSubset ( '(fn,s) ': rs) ss (i ': is) where- fsubset = lens (\ss -> fget Proxy ss :& fcast ss) set+ fsubset = lens (\ss -> fget @fn ss :& fcast ss) set where set :: Rec f ss -> Rec f ( '(fn,s) ': rs) -> Rec f ss set ss (r :& rs) = fput r $ freplace rs ss
src/Data/Schematic/Migration.hs view
@@ -4,11 +4,15 @@ module Data.Schematic.Migration where import Data.Kind+import Data.Schematic.DSL+import Data.Schematic.Lens import Data.Schematic.Path import Data.Tagged import Data.Schematic.Schema-import Data.Singletons.Prelude hiding (All)+import Data.Singletons.Prelude hiding (All, (:.)) import Data.Singletons.TypeLits+import Data.Vinyl+import Data.Vinyl.Functor data Path@@ -92,7 +96,8 @@ 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+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@@ -150,3 +155,25 @@ -> MList m (s ': h ': tl) infixr 7 :&&++migrateObject+ :: forall m fs fh. (FSubset fs fs (FImage fs fs), Monad m)+ => (Rec (Tagged fs :. FieldRepr) fh -> m (Rec (Tagged fs :. FieldRepr) fs))+ -> Tagged ('SchemaObject fs) (JsonRepr ('SchemaObject fh) -> m (JsonRepr ('SchemaObject fs)))+migrateObject f = Tagged $ \(ReprObject r) -> do+ res <- f $ rmap (Compose . Tagged) r+ pure $ withRepr @('SchemaObject fs) res++shrinkObject+ :: forall rs ss m+ . ( Monad m, FSubset rs ss (FImage rs ss) )+ => Tagged+ ('SchemaObject rs)+ (JsonRepr ('SchemaObject ss) -> m (JsonRepr ('SchemaObject rs)))+shrinkObject = Tagged $ \(ReprObject r) -> pure $ ReprObject $ fcast r++type family MapSnd (l :: [(a,k)]) = (r :: [k]) where+ MapSnd '[] = '[]+ MapSnd ( '(a, b) ': tl) = b ': MapSnd tl++type MigrationList m vs = MList m (MapSnd (AllVersions vs))
test/HelpersSpec.hs view
@@ -1,5 +1,11 @@ {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# LANGUAGE LambdaCase #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedStrings #-}+ module HelpersSpec (spec, main) where import Control.Lens
test/JsonSchemaSpec.hs view
@@ -1,3 +1,10 @@+{-# LANGUAGE LambdaCase #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+ module JsonSchemaSpec (spec, main) where import Data.Aeson as J
test/LensSpec.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+ module LensSpec (spec, main) where import Control.Lens@@ -298,15 +303,15 @@ newFooVal = FieldRepr $ ReprArray [ReprNumber 15] fooProxy = Proxy @"foo" it "gets the field from an object" $ do- fget fooProxy objectData `shouldBe` arrayField+ fget @"foo" objectData `shouldBe` arrayField it "sets the object field" $ do- fget fooProxy (fput newFooVal objectData) `shouldBe` newFooVal+ fget @"foo" (fput newFooVal objectData) `shouldBe` newFooVal describe "(using lens library) " $ do it "get the field from an object" $ do- objectData ^. flens (Proxy @"foo") `shouldBe` arrayField+ objectData ^. flens @"foo" `shouldBe` arrayField it "sets the object field" $ do- set (flens (Proxy @"foo")) newFooVal objectData ^. flens (Proxy @"foo")+ set (flens @"foo") newFooVal objectData ^. flens @"foo" `shouldBe` newFooVal main :: IO ()
test/SchemaSpec.hs view
@@ -1,7 +1,17 @@ {-# OPTIONS_GHC -fprint-potential-instances #-} +{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+ module SchemaSpec (spec, main) where +import Control.Lens import Data.Aeson import Data.ByteString.Lazy import Data.Functor.Identity@@ -22,29 +32,43 @@ :& field @"foo" [12] :& RNil -type TestMigration =- 'Migration "test_revision"- '[ 'Diff '[ 'PKey "bar" ] ('Update ('SchemaText '[]))- , 'Diff '[ 'PKey "foo" ] ('Update ('SchemaNumber '[])) ]+type AddQuuz =+ 'Migration "add_field_quuz"+ '[ 'Diff '[] ('AddKey "quuz" (SchemaNumber '[])) ] -type VS = 'Versioned SchemaExample '[ TestMigration ]+type DeleteQuuz =+ 'Migration "remove_field_quuz"+ '[ 'Diff '[] ( 'DeleteKey "quuz") ] +type SwapFields =+ 'Migration "swap_fields"+ '[ 'Diff '[ 'PKey "bar" ] ('Update+ ('SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10])))+ , 'Diff '[ 'PKey "foo" ] ('Update+ ('SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))) ]++type Migrations = '[ AddQuuz+ , DeleteQuuz ]+ -- , SwapFields ]++type VersionedJson = 'Versioned SchemaExample Migrations++migrationList :: MigrationList Identity VersionedJson+migrationList+ = (migrateObject (\r -> Identity $ field @"quuz" 42 :& r))+ :&& shrinkObject+ -- :&& (migrateObject (\r -> Identity+ -- $ field @"foo" (r ^. flens (Proxy @"bar") . _Just . optionalRepr)+ -- :& field @"bar" (r ^. flens (Proxy @"foo") . arrayRepr)+ -- :& RNil))+ :&& MNil+ schemaJson :: ByteString schemaJson = "{\"foo\": [13], \"bar\": null}" schemaJson2 :: ByteString schemaJson2 = "{\"foo\": [3], \"bar\": null}" -topObject- :: JsonRepr- ('SchemaObject- '[ '("foo", 'SchemaNumber '[])- , '("bar", 'SchemaText '[])])-topObject = ReprObject $- FieldRepr (ReprNumber 42)- :& FieldRepr (ReprText "test")- :& RNil- spec :: Spec spec = do -- it "show/read JsonRepr properly" $@@ -65,8 +89,8 @@ -- `shouldSatisfy` isValid it "validates versioned json with a migration list" $ do decodeAndValidateVersionedWithPureMList- (Proxy @VS)- (Tagged (const $ Identity topObject) :&& MNil)+ (Proxy @VersionedJson)+ migrationList schemaJson `shouldSatisfy` isValid