schematic (empty) → 0.1.0.0
raw patch · 12 files changed
+815/−0 lines, 12 filesdep +HUnitdep +aesondep +basesetup-changed
Dependencies added: HUnit, aeson, base, deriving-compat, hspec, hspec-core, hspec-discover, hspec-smallcheck, regex-compat, schematic, scientific, singletons, smallcheck, smallcheck-series, text, unordered-containers, validationt, vector, vinyl
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- schematic.cabal +121/−0
- src/Data/Schematic.hs +31/−0
- src/Data/Schematic/Instances.hs +23/−0
- src/Data/Schematic/Path.hs +50/−0
- src/Data/Schematic/Schema.hs +300/−0
- src/Data/Schematic/Utils.hs +36/−0
- src/Data/Schematic/Validation.hs +165/−0
- test/SchemaSpec.hs +51/−0
- test/Spec.hs +1/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for schematic++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017, Denis Redozubov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Denis Redozubov nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ schematic.cabal view
@@ -0,0 +1,121 @@+-- Initial schematic.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++name: schematic+version: 0.1.0.0+synopsis: JSON-biased spec and validation tool+-- description:+license: BSD3+license-file: LICENSE+author: Denis Redozubov+maintainer: denis.redozubov@gmail.com+-- copyright:+category: Data+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10++library+ exposed-modules: Data.Schematic+ , Data.Schematic.Instances+ , Data.Schematic.Path+ , Data.Schematic.Schema+ , Data.Schematic.Validation+ , Data.Schematic.Utils+ ghc-options: -Wall+ -- other-modules:+ default-extensions: ConstraintKinds+ , DataKinds+ , DefaultSignatures+ , DeriveFunctor+ , DeriveFoldable+ , DeriveGeneric+ , DeriveDataTypeable+ , FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , GADTs+ , KindSignatures+ , InstanceSigs+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLists+ , OverloadedStrings+ , PolyKinds+ , QuasiQuotes+ , PartialTypeSignatures+ , RankNTypes+ , RecordWildCards+ , StandaloneDeriving+ , ScopedTypeVariables+ , TemplateHaskell+ , TypeApplications+ , TypeFamilies+ , TypeInType+ , TypeOperators+ , TypeSynonymInstances+ , UndecidableInstances+ build-depends: base >=4.9 && <4.10+ , aeson >= 1+ , deriving-compat+ , regex-compat+ , scientific+ , singletons+ , smallcheck+ , smallcheck-series+ , text+ , unordered-containers+ , validationt >= 0.1.0.1+ , vector+ , vinyl+ hs-source-dirs: src+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ 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+ , MultiParamTypeClasses+ , OverloadedLists+ , OverloadedStrings+ , PolyKinds+ , QuasiQuotes+ , PartialTypeSignatures+ , RecordWildCards+ , ScopedTypeVariables+ , TemplateHaskell+ , TypeApplications+ , TypeFamilies+ , TypeInType+ , TypeOperators+ , TypeSynonymInstances+ build-depends: HUnit+ , aeson >= 1+ , base >=4.9 && <4.10+ , hspec >= 2.2.0+ , hspec-core+ , hspec-discover+ , hspec-smallcheck+ , regex-compat+ , schematic+ , smallcheck+ , smallcheck-series+ , singletons+ , text+ , unordered-containers+ , validationt >= 0.1.0.1+ , vinyl+ other-modules: SchemaSpec
+ src/Data/Schematic.hs view
@@ -0,0 +1,31 @@+module Data.Schematic+ ( module Data.Schematic.Schema+ , module Data.Schematic.Utils+ , parseAndValidateJson+ ) where++import Control.Monad.Validation+import Data.Aeson as J+import Data.Aeson.Types as J+import Data.Functor.Identity+import Data.Schematic.Schema+import Data.Schematic.Utils+import Data.Schematic.Validation+import Data.Text as T+++parseAndValidateJson+ :: forall schema+ . (J.FromJSON (JsonRepr schema), TopLevel schema, Known (Sing schema))+ => J.Value+ -> ParseResult (JsonRepr schema)+parseAndValidateJson v =+ case parseEither parseJSON v of+ Left s -> DecodingError $ T.pack s+ Right jsonRepr ->+ let+ validate = validateJsonRepr (known :: Sing schema) [] jsonRepr+ res = runIdentity . runValidationTEither $ validate+ in case res of+ Left em -> ValidationError em+ Right () -> Valid jsonRepr
+ src/Data/Schematic/Instances.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.Schematic.Instances where++import Data.Scientific+import Data.Vector as V+import Data.Vinyl+import Test.SmallCheck.Series+++instance Monad m => Serial m (Rec f '[]) where+ series = cons0 RNil++instance (Serial m (f a), Serial m (Rec f as), Monad m)+ => Serial m (Rec f (a ': as)) where+ series = cons2 (:&)++instance Serial m a => Serial m (V.Vector a) where+ series = V.fromList <$> series++instance Monad m => Serial m Scientific where+ series = scientific <$> series <*> series
+ src/Data/Schematic/Path.hs view
@@ -0,0 +1,50 @@+module Data.Schematic.Path where++import Data.Foldable as F+import Data.Monoid+import Data.Schematic.Utils+import Data.Singletons+import Data.Singletons.Prelude+import Data.Singletons.TypeLits+import Data.Text as T+++data PathSegment = Key Symbol | Ix Nat++data instance Sing (jp :: PathSegment) where+ SKey :: (KnownSymbol k, Known (Sing k)) => Sing (k :: Symbol) -> Sing ('Key k)+ SIx :: (KnownNat n, Known (Sing n)) => Sing (n :: Nat) -> Sing ('Ix n)++instance (KnownSymbol k, Known (Sing k))+ => Known (Sing ('Key k)) where+ known = SKey known++instance (KnownNat n, Known (Sing n))+ => Known (Sing ('Ix n)) where+ known = SIx known++data DemotedPathSegment = DKey Text | DIx Integer+ deriving (Show)++-- | Textual representation of json path.+newtype JSONPath = JSONPath Text+ deriving (Show)++demotePath :: Sing (ps :: [PathSegment]) -> [DemotedPathSegment]+demotePath = go []+ where+ go :: [DemotedPathSegment] -> Sing (ps :: [PathSegment]) -> [DemotedPathSegment]+ go acc SNil = acc+ go acc (SCons p ps) = go (acc ++ [demote p]) ps+ demote :: Sing (ps :: PathSegment) -> DemotedPathSegment+ demote (SKey s) = DKey $ T.pack $ symbolVal s+ demote (SIx n) = DIx $ natVal n++demotedPathToText :: [DemotedPathSegment] -> JSONPath+demotedPathToText = JSONPath . F.foldl' renderPathSegment ""+ where+ renderPathSegment acc (DKey t) = acc <> "." <> t+ renderPathSegment acc (DIx n) = acc <> "[" <> T.pack (show n) <> "]"++pathToText :: Sing (ps :: [PathSegment]) -> JSONPath+pathToText = demotedPathToText . demotePath
+ src/Data/Schematic/Schema.hs view
@@ -0,0 +1,300 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fprint-explicit-kinds #-}++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.Schematic.Utils+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+++type family All (c :: k -> Constraint) (s :: [k]) :: Constraint where+ All c '[] = ()+ All c (a ': as) = (c a, All c as)++type family CRepr (s :: Schema) :: Type where+ CRepr ('SchemaText cs) = TextConstraint+ CRepr ('SchemaNumber cs) = NumberConstraint+ CRepr ('SchemaObject fs) = (String, Schema)+ CRepr ('SchemaArray ar s) = ArrayConstraint++data TextConstraint+ = TEq Nat+ | TLe Nat+ | TGt Nat+ | TRegex Symbol+ | TEnum [Symbol]+ 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, Known (Sing s)) => Sing s -> Sing ('TRegex s)+ STEnum :: (All KnownSymbol ss, Known (Sing ss)) => Sing ss -> Sing ('TEnum ss)++instance (KnownNat n) => Known (Sing ('TEq n)) where known = STEq known+instance (KnownNat n) => Known (Sing ('TGt n)) where known = STGt known+instance (KnownNat n) => Known (Sing ('TLe n)) where known = STLe known+instance (KnownSymbol s, Known (Sing s)) => Known (Sing ('TRegex s)) where known = STRegex known+instance (All KnownSymbol ss, Known (Sing ss)) => Known (Sing ('TEnum ss)) where known = STEnum known++instance Eq (Sing ('TEq n)) where _ == _ = True+instance Eq (Sing ('TLe n)) where _ == _ = True+instance Eq (Sing ('TGt n)) where _ == _ = True+instance Eq (Sing ('TRegex t)) where _ == _ = True+instance Eq (Sing ('TEnum ss)) where _ == _ = True++data NumberConstraint+ = NLe Nat+ | NGt Nat+ | NEq Nat+ 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)++instance KnownNat n => Known (Sing ('NEq n)) where known = SNEq known+instance KnownNat n => Known (Sing ('NGt n)) where known = SNGt known+instance KnownNat n => Known (Sing ('NLe n)) where known = SNLe known++instance Eq (Sing ('NEq n)) where _ == _ = True+instance Eq (Sing ('NLe n)) where _ == _ = True+instance Eq (Sing ('NGt n)) where _ == _ = True++data ArrayConstraint+ = AEq Nat+ deriving (Generic)++data instance Sing (ac :: ArrayConstraint) where+ SAEq :: KnownNat n => Sing n -> Sing ('AEq n)++instance KnownNat n => Known (Sing ('AEq n)) where known = SAEq known++instance Eq (Sing ('AEq n)) where _ == _ = True++data Schema+ = SchemaText [TextConstraint]+ | SchemaNumber [NumberConstraint]+ | SchemaObject [(Symbol, Schema)]+ | SchemaArray [ArrayConstraint] Schema+ | SchemaNull+ | SchemaOptional Schema+ deriving (Generic)++data instance Sing (schema :: Schema) where+ SSchemaText :: Known (Sing tcs) => Sing tcs -> Sing ('SchemaText tcs)+ SSchemaNumber :: Known (Sing ncs) => Sing ncs -> Sing ('SchemaNumber ncs)+ SSchemaArray :: (Known (Sing acs), Known (Sing schema)) => Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)+ SSchemaObject :: Known (Sing fields) => Sing fields -> Sing ('SchemaObject fields)+ SSchemaOptional :: Known (Sing s) => Sing s -> Sing ('SchemaOptional s)+ SSchemaNull :: Sing 'SchemaNull++instance Known (Sing sl) => Known (Sing ('SchemaText sl)) where+ known = SSchemaText known+instance Known (Sing sl) => Known (Sing ('SchemaNumber sl)) where+ known = SSchemaNumber known+instance Known (Sing 'SchemaNull) where+ known = SSchemaNull+instance (Known (Sing ac), Known (Sing s)) => Known (Sing ('SchemaArray ac s)) where+ known = SSchemaArray known known+instance Known (Sing stl) => Known (Sing ('SchemaObject stl)) where+ known = SSchemaObject known+instance Known (Sing s) => Known (Sing ('SchemaOptional s)) where+ known = SSchemaOptional known++instance Eq (Sing ('SchemaText cs)) where _ == _ = True+instance Eq (Sing ('SchemaNumber cs)) where _ == _ = True+instance Eq (Sing 'SchemaNull) where _ == _ = True+instance Eq (Sing ('SchemaArray as s)) where _ == _ = True+instance Eq (Sing ('SchemaObject cs)) where _ == _ = True+instance Eq (Sing ('SchemaOptional s)) where _ == _ = True++data FieldRepr :: (Symbol, Schema) -> Type where+ FieldRepr+ :: (Known (Sing schema), KnownSymbol name)+ => JsonRepr schema+ -> FieldRepr '(name, schema)++knownFieldName+ :: forall proxy (fieldName :: Symbol) schema+ . KnownSymbol fieldName+ => proxy '(fieldName, schema)+ -> Text+knownFieldName _ = T.pack $ symbolVal (Proxy @fieldName)++knownFieldSchema+ :: forall proxy fieldName schema+ . Known (Sing schema)+ => proxy '(fieldName, schema)+ -> Sing schema+knownFieldSchema _ = known++deriving instance Show (JsonRepr schema) => Show (FieldRepr '(name, schema))++instance Eq (JsonRepr schema) => Eq (FieldRepr '(name, schema)) where+ FieldRepr a == FieldRepr b = a == b++instance+ ( KnownSymbol name+ , Known (Sing schema)+ , Serial m (JsonRepr schema) )+ => Serial m (FieldRepr '(name, schema)) where+ series = FieldRepr <$> series++data JsonRepr :: Schema -> Type where+ ReprText :: Text -> JsonRepr ('SchemaText cs)+ ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)+ ReprNull :: JsonRepr 'SchemaNull+ ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)+ ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)+ ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)++instance Show (JsonRepr ('SchemaText cs)) where+ show (ReprText t) = "ReprText " P.++ show t++instance Show (JsonRepr ('SchemaNumber cs)) where+ show (ReprNumber n) = "ReprNumber " P.++ show n++instance Show (JsonRepr 'SchemaNull) where show _ = "ReprNull"++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+ show (ReprObject fs) = "ReprObject " P.++ show fs++instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where+ show (ReprOptional s) = "ReprOptional " P.++ show s++instance (Monad m, Serial m Text)+ => Serial m (JsonRepr ('SchemaText cs)) where+ series = cons1 ReprText++instance (Monad m, Serial m Scientific)+ => Serial m (JsonRepr ('SchemaNumber cs)) where+ series = cons1 ReprNumber++instance Monad m => Serial m (JsonRepr 'SchemaNull) where+ series = cons0 ReprNull++instance (Serial m (V.Vector (JsonRepr s)))+ => Serial m (JsonRepr ('SchemaArray cs s)) where+ series = cons1 ReprArray++instance (Serial m (JsonRepr s))+ => Serial m (JsonRepr ('SchemaOptional s)) where+ series = cons1 ReprOptional++instance (Monad m, Serial m (Rec FieldRepr fs))+ => Serial m (JsonRepr ('SchemaObject fs)) where+ series = cons1 ReprObject++instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where+ ReprObject a == ReprObject b = a == b++instance Eq (JsonRepr ('SchemaText cs)) where+ ReprText a == ReprText b = a == b++instance Eq (JsonRepr ('SchemaNumber cs)) where+ ReprNumber a == ReprNumber b = a == b++instance Eq (JsonRepr 'SchemaNull) where+ ReprNull == ReprNull = True++instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaArray as s)) where+ ReprArray a == ReprArray b = a == b++instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaOptional s)) where+ ReprOptional a == ReprOptional b = a == b++fromOptional+ :: (Known (Sing s))+ => Sing ('SchemaOptional s)+ -> J.Value+ -> Parser (Maybe (JsonRepr s))+fromOptional _ = parseJSON++instance Known (Sing schema) => J.FromJSON (JsonRepr schema) where+ parseJSON value = case known :: Sing schema 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+ 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+ Nothing -> fail "schematext"+ SSchemaNumber _ -> case H.lookup fieldName h of+ Just v -> 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+ Nothing -> fail "schemaarray"+ SSchemaObject _ -> case H.lookup fieldName h of+ Just v -> FieldRepr <$> parseJSON v+ Nothing -> fail "schemaobject"+ SSchemaOptional _ -> case H.lookup fieldName h of+ Just v -> FieldRepr <$> parseJSON v+ Nothing -> fail "schemaoptional"+ (fieldRepr :&) <$> demoteFields tl h+ ReprObject <$> withObject "Object" (demoteFields fs) value++instance J.ToJSON (JsonRepr a) where+ toJSON ReprNull = J.Null+ toJSON (ReprText t) = J.String t+ toJSON (ReprNumber n) = J.Number n+ toJSON (ReprOptional s) = case s of+ Just v -> toJSON v+ Nothing -> J.Null+ toJSON (ReprArray v) = J.Array $ toJSON <$> v+ toJSON (ReprObject r) = J.Object . H.fromList . fold $ r+ where+ extract :: forall name s . (KnownSymbol name)+ => FieldRepr '(name, s)+ -> (Text, Value)+ extract (FieldRepr s) = (T.pack $ symbolVal $ Proxy @name, toJSON s)+ fold :: Rec FieldRepr fs -> [(Text, J.Value)]+ fold = \case+ RNil -> []+ fr@(FieldRepr _) :& tl -> (extract fr) : fold tl++class FalseConstraint a++type family TopLevel (schema :: Schema) :: Constraint where+ TopLevel ('SchemaArray acs s) = ()+ TopLevel ('SchemaObject o) = ()+ TopLevel spec = FalseConstraint spec
+ src/Data/Schematic/Utils.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Data.Schematic.Utils where++import Data.Proxy+import Data.Singletons+import Data.Singletons.Prelude+import Data.Singletons.TypeLits+import Data.Vinyl hiding (Dict)+++class Known a where+ known :: a++instance Known (Proxy a) where+ known = Proxy++instance KnownNat n => Known (Sing n) where+ known = SNat++instance KnownSymbol s => Known (Sing s) where+ known = SSym++instance (Known (Sing a), Known (Sing b)) => Known (Sing '(a,b)) where+ known = STuple2 known known++instance Known (Sing '[]) where known = SNil++instance (Known (Sing a), Known (Sing as)) => Known (Sing (a ': as)) where+ known = SCons known known++instance Known (Rec Sing '[]) where+ known = RNil++instance (Known (Sing a), Known (Rec Sing tl)) => Known (Rec Sing (a ': tl)) where+ known = known :& known
+ src/Data/Schematic/Validation.hs view
@@ -0,0 +1,165 @@+module Data.Schematic.Validation where++import Control.Monad+import Control.Monad.Validation+import Data.Foldable+import Data.Functor.Identity+import Data.Monoid+import Data.Schematic.Path+import Data.Schematic.Schema+import Data.Schematic.Utils ()+import Data.Scientific+import Data.Singletons.Prelude+import Data.Singletons.TypeLits+import Data.Text as T+import Data.Vector as V+import Data.Vinyl+import Prelude as P+import Text.Regex+++type Validation a = ValidationT ErrorMap Identity a++type ErrorMap = MonoidMap Text [Text]++data ParseResult a+ = Valid a+ | DecodingError Text+ | ValidationError ErrorMap+ deriving (Show, Eq, Functor)++validateTextConstraint+ :: JSONPath+ -> Text+ -> Sing (tcs :: TextConstraint)+ -> Validation ()+validateTextConstraint (JSONPath path) t = \case+ STEq n -> do+ let+ nlen = 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+ 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+ 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+ 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)+ unless predicate warn+ STEnum ss -> do+ let+ matching :: Sing (s :: [Symbol]) -> Bool+ matching SNil = False+ matching (SCons s@SSym fs) = T.pack (symbolVal s) == t || matching fs+ errMsg = path <> " must be one of " <> T.pack (show (fromSing ss))+ warn = vWarning $ mmSingleton path (pure errMsg)+ unless (matching ss) warn++validateNumberConstraint+ :: JSONPath+ -> Scientific+ -> Sing (tcs :: NumberConstraint)+ -> Validation ()+validateNumberConstraint (JSONPath path) num = \case+ SNEq n -> do+ let+ nlen = 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+ 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+ predicate = fromIntegral nlen <= num+ errMsg = path <> " should be <= " <> T.pack (show nlen)+ warn = vWarning $ mmSingleton path (pure errMsg)+ unless predicate warn++validateArrayConstraint+ :: JSONPath+ -> V.Vector a+ -> Sing (tcs :: ArrayConstraint)+ -> Validation ()+validateArrayConstraint (JSONPath path) v = \case+ SAEq n -> do+ let+ nlen = natVal n+ predicate = nlen == fromIntegral (V.length v)+ errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)+ warn = vWarning $ mmSingleton path (pure errMsg)+ unless predicate warn++validateJsonRepr+ :: Sing schema+ -> [DemotedPathSegment]+ -> JsonRepr schema+ -> Validation ()+validateJsonRepr sschema dpath jr = case jr of+ ReprText t -> case sschema of+ SSchemaText scs -> do+ let+ process :: Sing (cs :: [TextConstraint]) -> Validation ()+ process SNil = pure ()+ process (SCons c cs) = do+ validateTextConstraint (demotedPathToText dpath) t c+ process cs+ process scs+ ReprNumber n -> case sschema of+ SSchemaNumber scs -> do+ let+ process :: Sing (cs :: [NumberConstraint]) -> Validation ()+ process SNil = pure ()+ process (SCons c cs) = do+ validateNumberConstraint (demotedPathToText dpath) n c+ process cs+ process scs+ ReprNull -> pure ()+ ReprArray v -> case sschema of+ SSchemaArray acs s -> do+ let+ process :: Sing (cs :: [ArrayConstraint]) -> Validation ()+ process SNil = pure ()+ process (SCons c cs) = do+ validateArrayConstraint (demotedPathToText dpath) v c+ process cs+ process acs+ for_ (V.indexed v) $ \(ix, jr') -> do+ let newPath = dpath <> pure (DIx $ fromIntegral ix)+ validateJsonRepr s newPath jr'+ ReprOptional d -> case sschema of+ SSchemaOptional ss -> case d of+ Just x -> validateJsonRepr ss dpath x+ Nothing -> pure ()+ ReprObject fs -> case sschema of+ SSchemaObject _ -> go fs+ where+ go :: Rec FieldRepr (ts :: [ (Symbol, Schema) ] ) -> Validation ()+ go RNil = pure ()+ go (f@(FieldRepr d) :& ftl) = do+ let newPath = dpath <> [DKey (knownFieldName f)]+ validateJsonRepr (knownFieldSchema f) newPath d+ go ftl
+ test/SchemaSpec.hs view
@@ -0,0 +1,51 @@+module SchemaSpec (spec, main) where++import Control.Monad+import Data.Aeson+import Data.Proxy+import Data.Schematic+import Data.Singletons+import Data.Vinyl+import Test.Hspec+import Test.Hspec.SmallCheck+import Test.SmallCheck+import Test.SmallCheck.Series.Instances+++type SchemaExample+ = SchemaObject+ '[ '("foo", SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))+ , '("bar", SchemaOptional (SchemaText '[TRegex "\\w+"]))]++exampleTest :: JsonRepr (SchemaOptional (SchemaText '[TEq 3]))+exampleTest = ReprOptional (Just (ReprText "lil"))++exampleNumber :: JsonRepr (SchemaNumber '[NGt 10])+exampleNumber = ReprNumber 12++exampleArray :: JsonRepr (SchemaArray '[AEq 1] (SchemaNumber '[NGt 10]))+exampleArray = ReprArray [exampleNumber]++exampleObject :: JsonRepr SchemaExample+exampleObject = ReprObject $ FieldRepr exampleArray+ :& FieldRepr (ReprOptional (Just (ReprText "barval")))+ :& RNil++jsonExample :: JsonRepr SchemaExample+jsonExample = ReprObject $+ FieldRepr (ReprArray [ReprNumber 12])+ :& FieldRepr (ReprOptional (Just (ReprText "tes")))+ :& RNil++-- schemaExample :: Sing SchemaExample+-- schemaExample = known++spec :: Spec+spec = do+ -- it "show/read JsonRepr properly" $+ -- read (show example) == example+ it "decode/encode JsonRepr properly" $+ decode (encode jsonExample) == Just jsonExample++main :: IO ()+main = hspec spec
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}