schematic 0.1.4.0 → 0.1.5.0
raw patch · 8 files changed
+204/−76 lines, 8 filesdep +lens
Dependencies added: lens
Files
- ChangeLog.md +5/−0
- schematic.cabal +5/−1
- src/Data/Schematic.hs +5/−3
- src/Data/Schematic/Lens.hs +66/−0
- src/Data/Schematic/Migration.hs +8/−13
- src/Data/Schematic/Schema.hs +55/−51
- src/Data/Schematic/Validation.hs +8/−8
- test/LensSpec.hs +52/−0
ChangeLog.md view
@@ -1,5 +1,10 @@ # Revision history for schematic ++## 0.1.5.0 -- 2017-08-22++Lens compatibility for typed json objects.+ ## 0.1.0.0 -- YYYY-mm-dd * First version. Released on an unsuspecting world.
schematic.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: schematic-version: 0.1.4.0+version: 0.1.5.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.Lens , Data.Schematic.Migration , Data.Schematic.Path , Data.Schematic.Schema@@ -52,6 +53,7 @@ , TemplateHaskell , TypeApplications , TypeFamilies+ , TypeFamilyDependencies , TypeInType , TypeOperators , TypeSynonymInstances@@ -112,6 +114,7 @@ , hspec-core , hspec-discover , hspec-smallcheck+ , lens , regex-compat , schematic , smallcheck@@ -123,3 +126,4 @@ , validationt >= 0.1.0.1 , vinyl other-modules: SchemaSpec+ , LensSpec
src/Data/Schematic.hs view
@@ -3,6 +3,7 @@ module Data.Schematic ( module Data.Schematic.Schema+ , module Data.Schematic.Lens , module Data.Schematic.Migration , module Data.Schematic.Utils , decodeAndValidateJson@@ -25,6 +26,7 @@ import Data.Aeson.Types as J import Data.ByteString.Lazy as BL import Data.Functor.Identity+import Data.Schematic.Lens import Data.Schematic.Migration import Data.Schematic.Schema import Data.Schematic.Utils@@ -109,9 +111,9 @@ -> 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+ Valid a -> Valid a+ DecodingError _ -> f <$> parseAndValidateWithMList tl v+ ValidationError _ -> f <$> parseAndValidateWithMList tl v decodeAndValidateJson :: forall schema
+ src/Data/Schematic/Lens.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE InstanceSigs #-}++module Data.Schematic.Lens where++import Data.Proxy+import Data.Schematic.Schema+import Data.Vinyl+import Data.Vinyl.Functor+import Data.Vinyl.TypeLevel (Nat(..))+import GHC.TypeLits (Symbol)+++-- | A partial relation that gives the index of a value in a list.+type family FIndex (r :: Symbol) (rs :: [(Symbol, Schema)]) :: Nat where+ FIndex r ( '(fn, s) ': rs) = 'Z+ FIndex r ( s ': rs) = 'S (FIndex r rs)++class i ~ FIndex fn rs => FElem (fn :: Symbol) (rs :: [(Symbol, Schema)]) (i :: Nat) where+ type ByRevision fn rs i :: Schema+ flens+ :: Functor g+ => proxy fn+ -> (FieldRepr '(fn, (ByRevision fn rs i)) -> g (FieldRepr '(fn, (ByRevision fn rs i))))+ -> Rec FieldRepr rs+ -> g (Rec FieldRepr rs)++ -- | For Vinyl users who are not using the @lens@ package, we provide a getter.+ fget+ :: proxy fn+ -> Rec FieldRepr rs+ -> FieldRepr '(fn, (ByRevision fn 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,+ -- and so we do not take a proxy argument here.+ fput+ :: FieldRepr '(fn, ByRevision fn rs i)+ -> Rec FieldRepr rs+ -> Rec FieldRepr rs++instance FElem fn ('(fn, r) ': rs) 'Z where+ type ByRevision fn ('(fn, r) ': rs) 'Z = r++ flens _ f (x :& xs) = fmap (:& xs) (f x)+ {-# INLINE flens #-}++ fget k = getConst . flens k Const+ {-# INLINE fget #-}++ fput y = getIdentity . flens Proxy (\_ -> Identity y)+ {-# INLINE fput #-}++instance (FIndex r (s ': rs) ~ 'S i, FElem r rs i) => FElem r (s ': rs) ('S i) where+ type ByRevision fn (s ': rs) ('S i) = ByRevision fn rs i++ flens p f (x :& xs) = fmap (x :&) (flens p f xs)+ {-# INLINE flens #-}++ fget k = getConst . flens k Const+ {-# INLINE fget #-}++ fput y = getIdentity . flens Proxy (\_ -> Identity y)+ {-# INLINE fput #-}
src/Data/Schematic/Migration.hs view
@@ -8,7 +8,6 @@ import Data.Schematic.Schema import Data.Singletons.Prelude hiding (All) import Data.Singletons.TypeLits--- import Data.Vinyl hiding (Dict) data Path@@ -16,7 +15,7 @@ | PTraverse -- traverse into the array data instance Sing (p :: Path) where- SPKey :: KnownSymbol s => Sing s -> Sing ('PKey s)+ SPKey :: Sing s -> Sing ('PKey s) SPTraverse :: Sing 'PTraverse instance KnownSymbol s => SingI ('PKey s) where@@ -107,12 +106,11 @@ data instance Sing (a :: Action) where SAddKey- :: (SingI n, SingI s)- => Sing n+ :: Sing n -> Sing s -> Sing ('AddKey n s)- SUpdate :: (SingI s) => Sing s -> Sing ('Update s)- SDeleteKey :: KnownSymbol s => Sing s -> Sing ('DeleteKey s)+ SUpdate :: Sing s -> Sing ('Update s)+ SDeleteKey :: Sing s -> Sing ('DeleteKey s) -- | User-supplied atomic difference between schemas. -- Migrations can consists of many differences.@@ -120,8 +118,7 @@ data instance Sing (diff :: Diff) where SDiff- :: (SingI jp, SingI a)- => Sing (jp :: [Path])+ :: Sing (jp :: [Path]) -> Sing (a :: Action) -> Sing ('Diff jp a) @@ -132,8 +129,7 @@ data instance Sing (m :: Migration) where SMigration- :: (KnownSymbol r, SingI ds)- => Sing r+ :: Sing r -> Sing ds -> Sing ('Migration r ds) @@ -141,15 +137,14 @@ data instance Sing (v :: Versioned) where SVersioned- :: (SingI s, SingI ms)- => Sing (s :: Schema) -- base version+ :: 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)+ :: (TopLevel s, SingI s) => proxy s -> (JsonRepr h -> JsonRepr s) -> MList (h ': tl)
src/Data/Schematic/Schema.hs view
@@ -5,26 +5,25 @@ module Data.Schematic.Schema where -import Control.Applicative-import Control.Monad-import Data.Aeson as J-import Data.Aeson.Types as J-import Data.HashMap.Strict as H-import Data.Kind-import Data.Maybe-import Data.Schematic.Instances ()--import Data.Scientific-import Data.Singletons.Prelude.List hiding (All)-import Data.Singletons.TH-import Data.Singletons.TypeLits-import Data.Text as T-import Data.Vector as V-import Data.Vinyl hiding (Dict)-import Data.Vinyl.TypeLevel hiding (Nat)-import GHC.Generics (Generic)-import Prelude as P-import Test.SmallCheck.Series+import Control.Applicative ()+import Control.Monad+import Data.Aeson as J+import Data.Aeson.Types as J+import Data.HashMap.Strict as H+import Data.Kind+import Data.Maybe+import Data.Schematic.Instances ()+import Data.Scientific+import Data.Singletons.Prelude.List hiding (All)+import Data.Singletons.TH+import Data.Singletons.TypeLits+import Data.Text as T+import Data.Vector as V+import Data.Vinyl hiding (Dict)+import qualified Data.Vinyl.TypeLevel as V+import GHC.Generics (Generic)+import Prelude as P+import Test.SmallCheck.Series type family All (c :: k -> Constraint) (s :: [k]) :: Constraint where@@ -46,11 +45,11 @@ deriving (Generic) data instance Sing (tc :: TextConstraint) where- STEq :: (KnownNat n) => Sing n -> Sing ('TEq n)- STLe :: (KnownNat n) => Sing n -> Sing ('TLe n)- STGt :: (KnownNat n) => Sing n -> Sing ('TGt n)- STRegex :: (KnownSymbol s, SingI s) => Sing s -> Sing ('TRegex s)- STEnum :: (All KnownSymbol ss, SingI ss) => Sing ss -> Sing ('TEnum ss)+ STEq :: Sing n -> Sing ('TEq n)+ STLe :: Sing n -> Sing ('TLe n)+ STGt :: Sing n -> Sing ('TGt n)+ STRegex :: Sing s -> Sing ('TRegex s)+ STEnum :: All KnownSymbol ss => Sing ss -> Sing ('TEnum ss) instance (KnownNat n) => SingI ('TEq n) where sing = STEq sing instance (KnownNat n) => SingI ('TGt n) where sing = STGt sing@@ -71,9 +70,9 @@ deriving (Generic) data instance Sing (nc :: NumberConstraint) where- SNEq :: KnownNat n => Sing n -> Sing ('NEq n)- SNGt :: KnownNat n => Sing n -> Sing ('NGt n)- SNLe :: KnownNat n => Sing n -> Sing ('NLe n)+ SNEq :: Sing n -> Sing ('NEq n)+ SNGt :: Sing n -> Sing ('NGt n)+ SNLe :: Sing n -> Sing ('NLe n) instance KnownNat n => SingI ('NEq n) where sing = SNEq sing instance KnownNat n => SingI ('NGt n) where sing = SNGt sing@@ -88,7 +87,7 @@ deriving (Generic) data instance Sing (ac :: ArrayConstraint) where- SAEq :: KnownNat n => Sing n -> Sing ('AEq n)+ SAEq :: Sing n -> Sing ('AEq n) instance KnownNat n => SingI ('AEq n) where sing = SAEq sing @@ -104,11 +103,11 @@ deriving (Generic) data instance Sing (schema :: Schema) where- SSchemaText :: SingI tcs => Sing tcs -> Sing ('SchemaText tcs)- SSchemaNumber :: SingI ncs => Sing ncs -> Sing ('SchemaNumber ncs)- SSchemaArray :: (SingI acs, SingI schema) => Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)- SSchemaObject :: SingI fields => Sing fields -> Sing ('SchemaObject fields)- SSchemaOptional :: SingI s => Sing s -> Sing ('SchemaOptional s)+ SSchemaText :: Sing tcs -> Sing ('SchemaText tcs)+ SSchemaNumber :: Sing ncs -> Sing ('SchemaNumber ncs)+ SSchemaArray :: Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)+ SSchemaObject :: Sing fields -> Sing ('SchemaObject fields)+ SSchemaOptional :: Sing s -> Sing ('SchemaOptional s) SSchemaNull :: Sing 'SchemaNull instance SingI sl => SingI ('SchemaText sl) where@@ -137,6 +136,10 @@ => JsonRepr schema -> FieldRepr '(name, schema) +-- | Forgetful Functor Ufr+toJsonRepr :: FieldRepr '(fn, sch) -> JsonRepr sch+toJsonRepr (FieldRepr x) = x+ knownFieldName :: forall proxy (fieldName :: Symbol) schema . KnownSymbol fieldName@@ -182,7 +185,7 @@ instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where show (ReprArray v) = "ReprArray " P.++ show v -instance RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where+instance V.RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where show (ReprObject fs) = "ReprObject " P.++ show fs instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where@@ -238,37 +241,38 @@ instance SingI schema => J.FromJSON (JsonRepr schema) where parseJSON value = case sing :: Sing schema of- SSchemaText _ -> withText "String" (pure . ReprText) value- SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value- SSchemaNull -> case value of+ SSchemaText _ -> withText "String" (pure . ReprText) value+ SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value+ SSchemaNull -> case value of J.Null -> pure ReprNull _ -> typeMismatch "Null" value- so@(SSchemaOptional _) -> ReprOptional <$> fromOptional so value- SSchemaArray _ _ -> withArray "Array" (fmap ReprArray . traverse parseJSON) value- SSchemaObject fs -> do+ so@(SSchemaOptional s) -> withSingI s $ ReprOptional <$> fromOptional so value+ SSchemaArray sa sb -> withSingI sa $ withSingI sb+ $ withArray "Array" (fmap ReprArray . traverse parseJSON) value+ SSchemaObject fs -> do let demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s) demoteFields SNil _ = pure RNil demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do let fieldName = T.pack $ symbolVal (Proxy @fn) fieldRepr <- case s of- SSchemaText _ -> case H.lookup fieldName h of- Just v -> FieldRepr <$> parseJSON v+ SSchemaText so -> case H.lookup fieldName h of+ Just v -> withSingI so $ FieldRepr <$> parseJSON v Nothing -> fail "schematext"- SSchemaNumber _ -> case H.lookup fieldName h of- Just v -> FieldRepr <$> parseJSON v+ SSchemaNumber so -> case H.lookup fieldName h of+ Just v -> withSingI so $ FieldRepr <$> parseJSON v Nothing -> fail "schemanumber" SSchemaNull -> case H.lookup fieldName h of Just v -> FieldRepr <$> parseJSON v Nothing -> fail "schemanull"- SSchemaArray _ _ -> case H.lookup fieldName h of- Just v -> FieldRepr <$> parseJSON v+ SSchemaArray sa sb -> case H.lookup fieldName h of+ Just v -> withSingI sa $ withSingI sb $ FieldRepr <$> parseJSON v Nothing -> fail "schemaarray"- SSchemaObject _ -> case H.lookup fieldName h of- Just v -> FieldRepr <$> parseJSON v+ SSchemaObject so -> case H.lookup fieldName h of+ Just v -> withSingI so $ FieldRepr <$> parseJSON v Nothing -> fail "schemaobject"- SSchemaOptional _ -> case H.lookup fieldName h of- Just v -> FieldRepr <$> parseJSON v+ SSchemaOptional so -> case H.lookup fieldName h of+ Just v -> withSingI so $ FieldRepr <$> parseJSON v Nothing -> fail "schemaoptional" (fieldRepr :&) <$> demoteFields tl h ReprObject <$> withObject "Object" (demoteFields fs) value
src/Data/Schematic/Validation.hs view
@@ -48,28 +48,28 @@ validateTextConstraint (JSONPath path) t = \case STEq n -> do let- nlen = natVal n+ nlen = withKnownNat n $ natVal n predicate = nlen == (fromIntegral $ T.length t) errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn STLe n -> do let- nlen = natVal n+ nlen = withKnownNat n $ natVal n predicate = nlen <= (fromIntegral $ T.length t) errMsg = "length of " <> path <> " should be <= " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn STGt n -> do let- nlen = natVal n+ nlen = withKnownNat n $ natVal n predicate = nlen > (fromIntegral $ T.length t) errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn STRegex r -> do let- regex = symbolVal r+ regex = withKnownSymbol r $ symbolVal r predicate = maybe False (const True) $ matchRegex (mkRegex regex) (T.unpack t) errMsg = path <> " must match " <> T.pack (show regex) warn = vWarning $ mmSingleton path (pure errMsg)@@ -91,21 +91,21 @@ validateNumberConstraint (JSONPath path) num = \case SNEq n -> do let- nlen = natVal n+ nlen = withKnownNat n $ natVal n predicate = fromIntegral nlen == num errMsg = path <> " should be == " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn SNGt n -> do let- nlen = natVal n+ nlen = withKnownNat n $ natVal n predicate = num > fromIntegral nlen errMsg = path <> " should be > " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg) unless predicate warn SNLe n -> do let- nlen = natVal n+ nlen = withKnownNat n $ natVal n predicate = fromIntegral nlen <= num errMsg = path <> " should be <= " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg)@@ -119,7 +119,7 @@ validateArrayConstraint (JSONPath path) v = \case SAEq n -> do let- nlen = natVal n+ nlen = withKnownNat n $ natVal n predicate = nlen == fromIntegral (V.length v) errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen) warn = vWarning $ mmSingleton path (pure errMsg)
+ test/LensSpec.hs view
@@ -0,0 +1,52 @@+module LensSpec (spec, main) where++import Control.Lens+import Data.Kind+import Data.Proxy+import Data.Schematic+import Data.Vinyl+import Test.Hspec+++type ArraySchema = 'SchemaArray '[AEq 1] ('SchemaNumber '[NGt 10])++type ArrayField = '("foo", ArraySchema)++type FieldsSchema =+ '[ ArrayField, '("bar", 'SchemaOptional ('SchemaText '[TEnum '["foo", "bar"]]))]++type SchemaExample = 'SchemaObject FieldsSchema++arrayData :: JsonRepr ArraySchema+arrayData = ReprArray [ReprNumber 13]++arrayField :: FieldRepr ArrayField+arrayField = FieldRepr arrayData++objectData :: Rec FieldRepr FieldsSchema+objectData = FieldRepr arrayData+ :& FieldRepr (ReprOptional (Just (ReprText "foo")))+ :& RNil++exampleData :: JsonRepr SchemaExample+exampleData = ReprObject objectData++spec :: Spec+spec = do+ let+ newFooVal = FieldRepr $ ReprArray [ReprNumber 15]+ fooProxy = Proxy @"foo"+ it "gets the field from an object" $ do+ fget fooProxy objectData == arrayField+ it "sets the object field" $ do+ fget fooProxy (fput newFooVal objectData) == newFooVal++ describe "(using lens library) " $ do+ it "get the field from an object" $ do+ objectData ^. flens (Proxy @"foo") == arrayField+ it "sets the object field" $ do+ set (flens (Proxy @"foo")) newFooVal objectData ^. flens (Proxy @"foo")+ == newFooVal++main :: IO ()+main = hspec spec