schemas (empty) → 0.1.0.0
raw patch · 15 files changed
+2046/−0 lines, 15 filesdep +QuickCheckdep +aesondep +aeson-prettysetup-changed
Dependencies added: QuickCheck, aeson, aeson-pretty, base, bifunctors, bytestring, free, generic-lens, generics-sop, hashable, hspec, lens, lens-aeson, pretty-simple, profunctors, schemas, scientific, text, transformers, unordered-containers, vector
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- example/Person.hs +122/−0
- example/Person2.hs +484/−0
- example/Person3.hs +75/−0
- schemas.cabal +69/−0
- src/Schemas.hs +78/−0
- src/Schemas/Class.hs +194/−0
- src/Schemas/Internal.hs +388/−0
- src/Schemas/SOP.hs +106/−0
- src/Schemas/Untyped.hs +295/−0
- test/Generators.hs +77/−0
- test/Main.hs +2/−0
- test/SchemasSpec.hs +119/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for schemas++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Pepe Iborra++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 Pepe Iborra 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
+ example/Person.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+module Person where++import Data.Generics.Labels ()+import GHC.Generics+import qualified Generics.SOP as SOP+import Schemas+import Schemas.SOP++data Education = NoEducation | Degree {unDegree :: String} | PhD {unPhD :: String}+ deriving (Generic, Eq, Show)++instance HasSchema Education where+ schema = union'+ [alt "NoEducation" #_NoEducation+ ,alt "PhD" #_PhD+ ,alt "Degree" #_Degree+ ]++data Person = Person+ { name :: String+ , age :: Int+ , addresses :: [String]+ , studies :: Education+ }+ deriving (Generic, Eq, Show)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)++instance HasSchema Person where+ schema = gSchema defOptions++pepe :: Person+pepe = Person+ "Pepe"+ 38+ ["2 Edward Square", "La Mar 10"]+ (PhD "Computer Science")++-- >>> import Data.Aeson.Encode.Pretty+-- >>> import qualified Data.ByteString.Lazy.Char8 as B+-- >>> B.putStrLn $ encodePretty $ encode pepe+-- {+-- "addresses": [+-- "2 Edward Square",+-- "La Mar 10"+-- ],+-- "age": 38,+-- "studies": {+-- "PhD": "Computer Science"+-- },+-- "name": "Pepe"+-- }++-- >>> B.putStrLn $ encodePretty $ encode (theSchema @Person)+-- {+-- "Record": {+-- "addresses": {+-- "schema": {+-- "Array": {+-- "Prim": "String"+-- }+-- }+-- },+-- "age": {+-- "schema": {+-- "Prim": "Int"+-- }+-- },+-- "studies": {+-- "schema": {+-- "Union": [+-- {+-- "schema": {+-- "Empty": {}+-- },+-- "constructor": "NoEducation"+-- },+-- {+-- "schema": {+-- "Prim": "String"+-- },+-- "constructor": "PhD"+-- },+-- {+-- "schema": {+-- "Prim": "String"+-- },+-- "constructor": "Degree"+-- }+-- ]+-- }+-- },+-- "name": {+-- "schema": {+-- "Prim": "String"+-- }+-- }+-- }+-- }++-- >>> import Text.Pretty.Simple+-- >>> pPrintNoColor $ decode @Person $ encode pepe+-- Right+-- ( Person+-- { name = "Pepe"+-- , age = 38+-- , addresses =+-- [ "2 Edward Square"+-- , "La Mar 10"+-- ]+-- , studies =+-- ( PhD { unPhD = "Computer Science" } )+-- }+-- )
+ example/Person2.hs view
@@ -0,0 +1,484 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+module Person2 where++import Control.Applicative+import Data.Generics.Labels ()+import Data.String+import GHC.Exts (IsList(..))+import Person+import Schemas++-- | The v2 of the Person schema adds a new optional field 'religion'+-- and renames 'studies' to 'education'+data Person2 = Person2+ { name :: String+ , age :: Int+ , addresses :: [String]+ , religion :: (Maybe Religion) -- new+ , education :: Education -- renamed+ }+ deriving (Eq, Show)++data Religion = Catholic | Anglican | Muslim | Hindu+ deriving (Bounded, Enum, Eq, Show)++instance HasSchema Religion where+ schema = enum (fromString . show) (fromList enumerate)++enumerate :: (Bounded a, Enum a) => [a]+enumerate = [minBound ..]++instance HasSchema Person2 where+ schema =+ record+ $ Person2+ <$> field "name" Person2.name+ <*> field "age" Person2.age+ <*> field "addresses" Person2.addresses+ <*> optField "religion" Person2.religion+ <*> (field "education" Person2.education <|> field "studies" Person2.education)++pepe2 :: Person2+pepe2 = Person2 "Pepe"+ 38+ ["2 Edward Square", "La Mar 10"]+ Nothing+ (PhD "Computer Science")++-- Person2 can be encoded in multiple ways, so the canonic encoding includes all ways+-- {+-- "#1": {+-- "education": {+-- "PhD": "Computer Science"+-- },+-- "addresses": [+-- "2 Edward Square",+-- "La Mar 10"+-- ],+-- "age": 38,+-- "name": "Pepe"+-- },+-- "#2": {+-- "addresses": [+-- "2 Edward Square",+-- "La Mar 10"+-- ],+-- "age": 38,+-- "studies": {+-- "PhD": "Computer Science"+-- },+-- "name": "Pepe"+-- }+-- }+-- >>> import qualified Data.ByteString.Lazy.Char8 as B+-- >>> import Data.Aeson.Encode.Pretty+-- >>> B.putStrLn $ encodePretty $ encode pepe2+-- {+-- "#1": {+-- "education": {+-- "PhD": "Computer Science"+-- },+-- "addresses": [+-- "2 Edward Square",+-- "La Mar 10"+-- ],+-- "age": 38,+-- "name": "Pepe"+-- },+-- "#2": {+-- "addresses": [+-- "2 Edward Square",+-- "La Mar 10"+-- ],+-- "age": 38,+-- "studies": {+-- "PhD": "Computer Science"+-- },+-- "name": "Pepe"+-- }+-- }++-- Person2 is a subtype of Person therefore we can encode a Person2 as a Person+-- >>> import qualified Data.ByteString.Lazy.Char8 as B+-- >>> import Data.Aeson.Encode.Pretty+-- >>> B.putStrLn $ encodePretty $ encodeTo (theSchema @Person) <*> pure pepe2+-- {+-- "addresses": [+-- "2 Edward Square",+-- "La Mar 10"+-- ],+-- "age": 38,+-- "studies": {+-- "PhD": "Computer Science"+-- },+-- "name": "Pepe"+-- }+++-- We can also upgrade a Person into a Person2, because the new field is optional+-- >>> import Text.Pretty.Simple+-- >>> pPrintNoColor $ decodeFrom @Person2 (theSchema @Person) <*> pure (encode pepe)+-- Just+-- ( Right+-- ( Person2+-- { name = "Pepe"+-- , age = 38+-- , addresses =+-- [ "2 Edward Square"+-- , "La Mar 10"+-- ]+-- , religion = Nothing+-- , education = PhD { unPhD = "Computer Science" }+-- }+-- )+-- )++-- >>> B.putStrLn $ encodePretty $ encode (theSchema @Person2)+-- {+-- "AllOf": [+-- {+-- "Record": {+-- "education": {+-- "schema": {+-- "Union": [+-- {+-- "schema": {+-- "Empty": {}+-- },+-- "constructor": "NoEducation"+-- },+-- {+-- "schema": {+-- "Prim": "String"+-- },+-- "constructor": "PhD"+-- },+-- {+-- "schema": {+-- "Prim": "String"+-- },+-- "constructor": "Degree"+-- }+-- ]+-- }+-- },+-- "religion": {+-- "schema": {+-- "Enum": [+-- "Catholic",+-- "Anglican",+-- "Muslim",+-- "Hindu"+-- ]+-- },+-- "isRequired": false+-- },+-- "addresses": {+-- "schema": {+-- "Array": {+-- "Prim": "String"+-- }+-- }+-- },+-- "age": {+-- "schema": {+-- "Prim": "Int"+-- }+-- },+-- "name": {+-- "schema": {+-- "Prim": "String"+-- }+-- }+-- }+-- },+-- {+-- "Record": {+-- "religion": {+-- "schema": {+-- "Enum": [+-- "Catholic",+-- "Anglican",+-- "Muslim",+-- "Hindu"+-- ]+-- },+-- "isRequired": false+-- },+-- "addresses": {+-- "schema": {+-- "Array": {+-- "Prim": "String"+-- }+-- }+-- },+-- "age": {+-- "schema": {+-- "Prim": "Int"+-- }+-- },+-- "studies": {+-- "schema": {+-- "Union": [+-- {+-- "schema": {+-- "Empty": {}+-- },+-- "constructor": "NoEducation"+-- },+-- {+-- "schema": {+-- "Prim": "String"+-- },+-- "constructor": "PhD"+-- },+-- {+-- "schema": {+-- "Prim": "String"+-- },+-- "constructor": "Degree"+-- }+-- ]+-- }+-- },+-- "name": {+-- "schema": {+-- "Prim": "String"+-- }+-- }+-- }+-- }+-- ]+-- }++-- >>> import qualified Data.ByteString.Lazy.Char8 as B+-- {+-- "Record": {+-- "education": {+-- "schema": {+-- "Union": [+-- {+-- "schema": {+-- "Empty": {}+-- },+-- "constructor": "NoEducation"+-- },+-- {+-- "schema": {+-- "Prim": "String"+-- },+-- "constructor": "PhD"+-- },+-- {+-- "schema": {+-- "Prim": "String"+-- },+-- "constructor": "Degree"+-- }+-- ]+-- }+-- },+-- "religion": {+-- "schema": {+-- "Enum": [+-- "Catholic",+-- "Anglican",+-- "Muslim",+-- "Hindu"+-- ]+-- },+-- "isRequired": false+-- },+-- "addresses": {+-- "schema": {+-- "Array": {+-- "Prim": "String"+-- }+-- }+-- },+-- "age": {+-- "schema": {+-- "Prim": "Int"+-- }+-- },+-- "name": {+-- "schema": {+-- "Prim": "String"+-- }+-- }+-- }+-- }+-- {+-- "Record": {+-- "religion": {+-- "schema": {+-- "Enum": [+-- "Catholic",+-- "Anglican",+-- "Muslim",+-- "Hindu"+-- ]+-- },+-- "isRequired": false+-- },+-- "addresses": {+-- "schema": {+-- "Array": {+-- "Prim": "String"+-- }+-- }+-- },+-- "age": {+-- "schema": {+-- "Prim": "Int"+-- }+-- },+-- "studies": {+-- "schema": {+-- "Union": [+-- {+-- "schema": {+-- "Empty": {}+-- },+-- "constructor": "NoEducation"+-- },+-- {+-- "schema": {+-- "Prim": "String"+-- },+-- "constructor": "PhD"+-- },+-- {+-- "schema": {+-- "Prim": "String"+-- },+-- "constructor": "Degree"+-- }+-- ]+-- }+-- },+-- "name": {+-- "schema": {+-- "Prim": "String"+-- }+-- }+-- }+-- }+-- >>> import Data.Aeson.Encode.Pretty+-- >>> mapM_ (B.putStrLn . encodePretty . encode) (versions $ theSchema @Person2)+-- {+-- "Record": {+-- "education": {+-- "schema": {+-- "Union": [+-- {+-- "schema": {+-- "Empty": {}+-- },+-- "constructor": "NoEducation"+-- },+-- {+-- "schema": {+-- "Prim": "String"+-- },+-- "constructor": "PhD"+-- },+-- {+-- "schema": {+-- "Prim": "String"+-- },+-- "constructor": "Degree"+-- }+-- ]+-- }+-- },+-- "religion": {+-- "schema": {+-- "Enum": [+-- "Catholic",+-- "Anglican",+-- "Muslim",+-- "Hindu"+-- ]+-- },+-- "isRequired": false+-- },+-- "addresses": {+-- "schema": {+-- "Array": {+-- "Prim": "String"+-- }+-- }+-- },+-- "age": {+-- "schema": {+-- "Prim": "Int"+-- }+-- },+-- "name": {+-- "schema": {+-- "Prim": "String"+-- }+-- }+-- }+-- }+-- {+-- "Record": {+-- "religion": {+-- "schema": {+-- "Enum": [+-- "Catholic",+-- "Anglican",+-- "Muslim",+-- "Hindu"+-- ]+-- },+-- "isRequired": false+-- },+-- "addresses": {+-- "schema": {+-- "Array": {+-- "Prim": "String"+-- }+-- }+-- },+-- "age": {+-- "schema": {+-- "Prim": "Int"+-- }+-- },+-- "studies": {+-- "schema": {+-- "Union": [+-- {+-- "schema": {+-- "Empty": {}+-- },+-- "constructor": "NoEducation"+-- },+-- {+-- "schema": {+-- "Prim": "String"+-- },+-- "constructor": "PhD"+-- },+-- {+-- "schema": {+-- "Prim": "String"+-- },+-- "constructor": "Degree"+-- }+-- ]+-- }+-- },+-- "name": {+-- "schema": {+-- "Prim": "String"+-- }+-- }+-- }+-- }
+ example/Person3.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+module Person3 where++import Control.Applicative+import Data.Generics.Labels ()+import Person+import Person2+import Schemas++-- | v3 adds recursive field 'spouse', which leads to cycles+data Person3 = Person3+ { name :: String+ , age :: Int+ , addresses :: [String]+ , spouse :: Maybe Person3+ , religion :: Maybe Religion+ , education :: Education+ }+ deriving (Eq, Show)++instance HasSchema Person3 where+ schema = record+ $ Person3 <$> field "name" Person3.name+ <*> field "age" Person3.age+ <*> field "addresses" Person3.addresses+ <*> optField "spouse" Person3.spouse+ <*> optField "religion" Person3.religion+ <*> (field "studies" Person3.education <|> field "education" Person3.education)++laura3, pepe3 :: Person3++-- pepe3 has a cycle with laura3+pepe3 = Person3+ "Pepe"+ 38+ ["2 Edward Square", "La Mar 10"]+ (Just laura3)+ Nothing+ (PhD "Computer Science")++-- laura3 has a cycle with pepe3+laura3 = pepe3 { name = "Laura"+ , spouse = Just pepe3+ , education = Degree "English"+ , addresses = ["2 Edward Square"]+ , religion = Just Catholic+ }++-- >>> import qualified Data.ByteString.Lazy.Char8 as B+-- >>> import Data.Aeson.Encode.Pretty+-- >>> B.putStrLn $ encodePretty $ finiteEncode 4 laura3+-- {+-- "L": {+-- "spouse": {+-- "L": {}+-- },+-- "religion": "Catholic",+-- "addresses": [+-- "2 Edward Square"+-- ],+-- "age": 38,+-- "studies": {+-- "Degree": "English"+-- },+-- "name": "Laura"+-- }+-- }++-- Unpacking infinite data is not supported currently+-- >>> decode @Person3 (finiteEncode 4 pepe3)+-- Left (MissingRecordField {name = "name", context = ["spouse"]})
+ schemas.cabal view
@@ -0,0 +1,69 @@+cabal-version: 2.0+name: schemas+version: 0.1.0.0+synopsis: schema guided serialization+-- description:+-- bug-reports:+license: BSD3+license-file: LICENSE+author: Pepe Iborra+maintainer: pepeiborra@gmail.com+-- copyright:+category: Data+build-type: Simple+extra-source-files: CHANGELOG.md++library+ exposed-modules:+ Schemas+ Schemas.Class+ Schemas.Internal+ Schemas.SOP+ Schemas.Untyped+ -- other-modules:+ -- other-extensions:+ build-depends: base ^>=4.12.0.0+ , aeson+ , aeson-pretty+ , bifunctors+ , bytestring+ , free+ , generic-lens+ , generics-sop >= 0.5.0.0+ , hashable+ , lens+ , lens-aeson+ , pretty-simple+ , profunctors+ , scientific+ , text+ , transformers+ , unordered-containers+ , vector+ hs-source-dirs: src+ default-language: Haskell2010+ default-extensions: TypeApplications, OverloadedStrings, LambdaCase++test-suite spec+ default-language: Haskell2010+ default-extensions: TypeApplications+ type: exitcode-stdio-1.0+ hs-source-dirs: example, test+ main-is: Main.hs+ other-modules: Person+ , Person2+ , Person3+ , SchemasSpec+ , Generators+ build-depends: aeson+ , aeson-pretty+ , base+ , bytestring+ , generic-lens+ , generics-sop+ , hspec+ , lens+ , pretty-simple+ , QuickCheck+ , schemas+ , text
+ src/Schemas.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE PatternSynonyms #-}+module Schemas+ (+ -- * Schemas+ Field(..)+ , Schema(.., Empty, Union)+ , _Empty+ , _Union+ -- ** functions for working with schemas+ , Mismatch(..)+ , Trace+ , isSubtypeOf+ , versions+ , coerce+ , finite+ , validate+ , validatorsFor+ -- * Typed schemas+ , TypedSchema+ , TypedSchemaFlex+ , HasSchema(..)+ , theSchema+ , extractSchema+ -- ** Construction+ , enum+ , readShow+ , list+ , vector+ , stringMap+ , viaJSON+ , viaIso+ , Key(..)+ -- *** Applicative record definition+ , record+ , RecordField+ , RecordFields+ , field+ , fieldWith+ , fieldWith'+ , optField+ , optFieldWith+ , optFieldEither+ , optFieldEitherWith+ , optFieldGeneral+ , fieldName+ , fieldNameL+ , overFieldNames+ , extractFields+ , liftMaybe+ , liftEither+ -- *** Unions+ , union+ , union'+ , UnionTag(..)+ , alt+ , altWith+ -- * Encoding+ , encode+ , decode+ , encodeTo+ , decodeFrom+ , encodeWith+ , decodeWith+ , encodeToWith+ , decodeFromWith+ , DecodeError(..)+ -- * working with recursive schemas+ , finiteValue+ , finiteEncode+ -- * Reexports+ , Profunctor(..)+ )+ where++import Data.Profunctor+import Schemas.Class+import Schemas.Internal+import Schemas.Untyped
+ src/Schemas/Class.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Schemas.Class where++import Control.Lens hiding (_Empty, Empty, enum, (<.>))+import Data.Aeson (Value)+import Data.Biapplicative+import Data.Generics.Labels ()+import Data.Hashable+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as Map+import Data.HashSet (HashSet)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe+import Data.Scientific+import Data.Text (Text, pack, unpack)+import Data.Vector (Vector)+import Numeric.Natural+import Schemas.Internal+import Schemas.Untyped++-- HasSchema class and instances+-- -----------------------------------------------------------------------------------++class HasSchema a where+ schema :: TypedSchema a++instance HasSchema () where+ schema = mempty++instance HasSchema Bool where+ schema = viaJSON "Bool"++instance HasSchema Double where+ schema = viaJSON "Double"++instance HasSchema Scientific where+ schema = viaJSON "Double"++instance HasSchema Int where+ schema = viaJSON "Int"++instance HasSchema Integer where+ schema = viaJSON "Integer"++instance HasSchema Natural where+ schema = viaJSON "Natural"++instance {-# OVERLAPPING #-} HasSchema String where+ schema = string++instance HasSchema Text where+ schema = viaJSON "String"++instance {-# OVERLAPPABLE #-} HasSchema a => HasSchema [a] where+ schema = list schema++instance HasSchema a => HasSchema (Vector a) where+ schema = TArray schema id id++instance (Eq a, Hashable a, HasSchema a) => HasSchema (HashSet a) where+ schema = list schema++instance HasSchema a => HasSchema (NonEmpty a) where+ schema = list schema++instance HasSchema Field where+ schema = record $ Field <$> field "schema" fieldSchema <*> fmap+ (fromMaybe True)+ (optField "isRequired" (\x -> if isRequired x then Nothing else Just False))++instance HasSchema a => HasSchema (Identity a) where+ schema = dimap runIdentity Identity schema++instance HasSchema Schema where+ schema = union'+ [ alt "StringMap" #_StringMap+ , alt "Array" #_Array+ , alt "Enum" #_Enum+ , alt "Record" #_Record+ , alt "Empty" _Empty+ , alt "AllOf" #_AllOf+ , alt "Prim" #_Prim+ , altWith unionSchema "Union" _Union+ , alt "OneOf" #_OneOf+ ]+ where+ unionSchema = list (record $ (,) <$> field "constructor" fst <*> field "schema" snd)++instance HasSchema Value where+ schema = viaJSON "JSON"++instance (HasSchema a, HasSchema b) => HasSchema (a,b) where+ schema = record $ (,) <$> field "$1" fst <*> field "$2" snd++instance (HasSchema a, HasSchema b, HasSchema c) => HasSchema (a,b,c) where+ schema = record $ (,,) <$> field "$1" (view _1) <*> field "$2" (view _2) <*> field "$3" (view _3)++instance (HasSchema a, HasSchema b, HasSchema c, HasSchema d) => HasSchema (a,b,c,d) where+ schema =+ record+ $ (,,,)+ <$> field "$1" (view _1)+ <*> field "$2" (view _2)+ <*> field "$3" (view _3)+ <*> field "$4" (view _4)++instance (HasSchema a, HasSchema b, HasSchema c, HasSchema d, HasSchema e) => HasSchema (a,b,c,d,e) where+ schema =+ record+ $ (,,,,)+ <$> field "$1" (view _1)+ <*> field "$2" (view _2)+ <*> field "$3" (view _3)+ <*> field "$4" (view _4)+ <*> field "$5" (view _5)++instance (HasSchema a, HasSchema b) => HasSchema (Either a b) where+ schema = union' [alt "Left" #_Left, alt "Right" #_Right]++instance (Eq key, Hashable key, HasSchema a, Key key) => HasSchema (HashMap key a) where+ schema = dimap toKeyed fromKeyed $ stringMap schema+ where+ fromKeyed :: HashMap Text a -> HashMap key a+ fromKeyed = Map.fromList . map (first fromKey) . Map.toList+ toKeyed :: HashMap key a -> HashMap Text a+ toKeyed = Map.fromList . map (first toKey) . Map.toList++class Key a where+ fromKey :: Text -> a+ toKey :: a -> Text++instance Key Text where+ fromKey = id+ toKey = id++instance Key String where+ fromKey = unpack+ toKey = pack++-- HasSchema aware combinators+-- -----------------------------------------------------------------------------------++theSchema :: forall a . HasSchema a => Schema+theSchema = extractSchema (schema @a)++validatorsFor :: forall a . HasSchema a => Validators+validatorsFor = extractValidators (schema @a)++-- | encode using the default schema+encode :: HasSchema a => a -> Value+encode = encodeWith schema++encodeTo :: HasSchema a => Schema -> Maybe (a -> Value)+encodeTo = encodeToWith schema++-- | Encode a value into a finite representation by enforcing a max depth+finiteEncode :: forall a. HasSchema a => Natural -> a -> Value+finiteEncode d = finiteValue (validatorsFor @a) d (theSchema @a) . encode++decode :: HasSchema a => Value -> Either [(Trace, DecodeError)] a+decode = decodeWith schema++decodeFrom :: HasSchema a => Schema -> Maybe (Value -> Either [(Trace, DecodeError)] a)+decodeFrom = decodeFromWith schema++-- | Coerce from 'sub' to 'sup'Returns 'Nothing' if 'sub' is not a subtype of 'sup'+coerce :: forall sub sup . (HasSchema sub, HasSchema sup) => Value -> Maybe Value+coerce = case isSubtypeOf (validatorsFor @sub) (theSchema @sub) (theSchema @sup) of+ Right cast -> Just . cast+ _ -> const Nothing++field :: HasSchema a => Text -> (from -> a) -> RecordFields from a+field = fieldWith schema++optField :: forall a from. HasSchema a => Text -> (from -> Maybe a) -> RecordFields from (Maybe a)+optField n get = optFieldWith (lmap get $ liftMaybe (schema @a)) n++optFieldEither+ :: forall a from e+ . HasSchema a+ => Text+ -> (from -> Either e a)+ -> e+ -> RecordFields from (Either e a)+optFieldEither n x e = optFieldGeneral (lmap x $ liftEither schema) n (Left e)++alt :: HasSchema a => Text -> Prism' from a -> UnionTag from+alt = altWith schema
+ src/Schemas/Internal.hs view
@@ -0,0 +1,388 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS -Wno-name-shadowing #-}+module Schemas.Internal where++import Control.Alternative.Free+import Control.Applicative (Alternative (..))+import Control.Exception+import Control.Lens hiding (Empty, enum, (<.>))+import Control.Monad+import Control.Monad.Trans.Except+import Data.Aeson (Value)+import qualified Data.Aeson as A+import Data.Biapplicative+import Data.Either+import Data.Foldable (asum)+import Data.Functor.Compose+import Data.Generics.Labels ()+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as Map+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.Text (Text, pack)+import Data.Tuple+import Data.Typeable (Typeable)+import Data.Vector (Vector)+import qualified Data.Vector as V+import GHC.Exts (IsList (..))+import Prelude hiding (lookup)+import Schemas.Untyped++-- Typed schemas+-- --------------------------------------------------------------------------------++-- | @TypedSchemaFlex enc dec@ is a schema for encoding to @enc@ and decoding to @dec@.+-- Usually we want @enc@ and @dec@ to be the same type but this flexibility comes in handy+-- when composing typed schemas.+data TypedSchemaFlex from a where+ TEnum :: (NonEmpty (Text, a)) -> (from -> Text) -> TypedSchemaFlex from a+ TArray :: TypedSchema b -> (Vector b -> a) -> (from -> Vector b) -> TypedSchemaFlex from a+ TMap :: TypedSchema b -> (HashMap Text b -> a) -> (from -> HashMap Text b) -> TypedSchemaFlex from a+ -- | Encoding and decoding support all alternatives+ TAllOf :: NonEmpty (TypedSchemaFlex from a) -> TypedSchemaFlex from a+ -- | Decoding from all alternatives, but encoding only to one+ TOneOf :: NonEmpty (TypedSchemaFlex from a) -> TypedSchemaFlex from a+ TEmpty :: a -> TypedSchemaFlex from a+ TPrim :: Text -> (Value -> A.Result a) -> (from -> Value) -> TypedSchemaFlex from a+ -- TTry is used to implement 'optField' on top of 'optFieldWith'+ -- it could be exposed to provide some form of error handling, but currently is not+ TTry :: TypedSchemaFlex a b -> (a' -> Maybe a) -> TypedSchemaFlex a' b+ RecordSchema :: RecordFields from a -> TypedSchemaFlex from a++enum :: Eq a => (a -> Text) -> (NonEmpty a) -> TypedSchema a+enum showF opts = TEnum alts (fromMaybe (error "invalid alt") . flip lookup altMap)+ where+ altMap = fmap swap $ alts --TODO fast lookup+ alts = opts <&> \x -> (showF x, x)++stringMap :: TypedSchema a -> TypedSchema (HashMap Text a)+stringMap sc = TMap sc id id++list :: IsList l => TypedSchema (Item l) -> TypedSchema l+list schema = TArray schema (fromList . V.toList) (V.fromList . toList)++vector :: TypedSchema a -> TypedSchema (Vector a)+vector sc = TArray sc id id++viaJSON :: (A.FromJSON a, A.ToJSON a) => Text -> TypedSchema a+viaJSON n = TPrim n A.fromJSON A.toJSON++viaIso :: Iso' a b -> TypedSchema a -> TypedSchema b+viaIso iso sc = withIso iso $ \from to -> dimap to from sc++string :: TypedSchema String+string = viaJSON "String"++readShow :: (Read a, Show a) => TypedSchema a+readShow = dimap show read string++instance Functor (TypedSchemaFlex from) where+ fmap = rmap++instance Profunctor TypedSchemaFlex where+ dimap _ f (TEmpty a ) = TEmpty (f a)+ dimap g f (TTry sc try) = TTry (rmap f sc) (try . g)+ dimap g f (TAllOf scc ) = TAllOf (dimap g f <$> scc)+ dimap g f (TOneOf scc ) = TOneOf (dimap g f <$> scc)+ dimap g f (TEnum opts fromf) = TEnum (second f <$> opts) (fromf . g)+ dimap g f (TArray sc tof fromf) = TArray sc (f . tof) (fromf . g)+ dimap g f (TMap sc tof fromf) = TMap sc (f . tof) (fromf . g)+ dimap g f (TPrim n tof fromf) = TPrim n (fmap f . tof) (fromf . g)+ dimap g f (RecordSchema sc) = RecordSchema (dimap g f sc)++instance Monoid a => Monoid (TypedSchemaFlex f a) where+ mempty = TEmpty mempty++instance Semigroup a => Semigroup (TypedSchemaFlex f a) where+ TEmpty a <> TEmpty b = TEmpty (a <> b)+ TEmpty{} <> x = x+ x <> TEmpty{} = x+ TAllOf aa <> b = TAllOf (aa <> [b])+ a <> TAllOf bb = TAllOf ([a] <> bb)+ a <> b = TAllOf [a,b]++type TypedSchema a = TypedSchemaFlex a a++-- --------------------------------------------------------------------------------+-- Applicative records++data RecordField from a where+ RequiredAp :: { fieldName :: Text+ , fieldTypedSchema :: TypedSchemaFlex from a+ } -> RecordField from a+ OptionalAp :: { fieldName :: Text+ , fieldTypedSchema :: TypedSchemaFlex from a+ , fieldDefValue :: a+ } -> RecordField from a++fieldNameL :: Lens' (RecordField from a) Text+fieldNameL f (RequiredAp n sc) = (`RequiredAp` sc) <$> f n+fieldNameL f OptionalAp{..} = (\fieldName -> OptionalAp{..}) <$> f fieldName++instance Profunctor RecordField where+ dimap f g (RequiredAp name sc) = RequiredAp name (dimap f g sc)+ dimap f g (OptionalAp name sc def) = OptionalAp name (dimap f g sc) (g def)++newtype RecordFields from a = RecordFields {getRecordFields :: Alt (RecordField from) a}+ deriving newtype (Alternative, Applicative, Functor, Monoid, Semigroup)++instance Profunctor RecordFields where+ dimap f g = RecordFields . hoistAlt (lmap f) . fmap g . getRecordFields++overFieldNames :: (Text -> Text) -> RecordFields from a -> RecordFields from a+overFieldNames f = RecordFields . hoistAlt ((over fieldNameL f)) . getRecordFields++-- | Define a record schema using applicative syntax+record :: RecordFields from a -> TypedSchemaFlex from a+record = RecordSchema++fieldWith :: TypedSchema a -> Text -> (from -> a) -> RecordFields from a+fieldWith schema n get = fieldWith' (lmap get schema) n++fieldWith' :: TypedSchemaFlex from a -> Text -> RecordFields from a+fieldWith' schema n = RecordFields $ liftAlt (RequiredAp n schema)++data TryFailed = TryFailed+ deriving (Exception, Show, Typeable)++-- | Project a schema through a Prism. The resulting schema is empty if the Prism doesn't fit+liftPrism :: Prism s t a b -> TypedSchemaFlex a b -> TypedSchemaFlex s t+liftPrism p sc = withPrism p $ \t f -> rmap t (TTry sc (either (const Nothing) Just . f))++-- | Use this to build schemas for 'optFieldWith'. The resulting schema is empty for the Nothing case+liftMaybe :: TypedSchemaFlex a b -> TypedSchemaFlex (Maybe a) (Maybe b)+liftMaybe = liftPrism _Just++-- | Use this to build schemas for 'optFieldEitherWith'. The resulting schema is empty for the Left case+liftEither :: TypedSchemaFlex a b -> TypedSchemaFlex (Either c a) (Either c b)+liftEither = liftPrism _Right++-- | A generalized version of 'optField'. Does not handle infinite/circular data.+optFieldWith+ :: forall a from+ . TypedSchemaFlex from (Maybe a)+ -> Text+ -> RecordFields from (Maybe a)+optFieldWith schema n = RecordFields $ liftAlt (OptionalAp n schema Nothing)++optFieldGeneral+ :: forall a from+ . TypedSchemaFlex from a+ -> Text+ -> a+ -> RecordFields from a+optFieldGeneral schema n def = RecordFields $ liftAlt (OptionalAp n schema def)++-- | A generalized version of 'optFieldEither'. Does not handle infinite/circular data+optFieldEitherWith+ :: TypedSchemaFlex from (Either e a) -> Text -> e -> RecordFields from (Either e a)+optFieldEitherWith schema n e = optFieldGeneral schema n (Left e)++-- | Extract all the field groups (from alternatives) in the record+extractFields :: RecordFields from a -> [[(Text, Field)]]+extractFields = extractFieldsHelper extractField+ where+ extractField :: RecordField from a -> (Text, Field)+ extractField (RequiredAp n sc) = (n,) . (`Field` True) $ extractSchema sc+ extractField (OptionalAp n sc _) = (n,) . (`Field` False) $ extractSchema sc++extractFieldsHelper :: (forall a . RecordField from a -> b) -> RecordFields from a -> [[b]]+extractFieldsHelper f = runAlt_ (\x -> (f x : []) : []) . getRecordFields++-- --------------------------------------------------------------------------------+-- Typed Unions++union :: (NonEmpty (Text, TypedSchema a)) -> TypedSchema a+union args = TOneOf (mk <$> args)+ where+ mk (name, sc) = RecordSchema $ fieldWith' sc name++data UnionTag from where+ UnionTag :: Text -> Prism' from b -> TypedSchema b -> UnionTag from++altWith :: TypedSchema a -> Text -> Prism' from a -> UnionTag from+altWith sc n p = UnionTag n p sc++union' :: (NonEmpty (UnionTag from)) -> TypedSchema from+union' args = union $ args <&> \(UnionTag c p sc) -> (c, liftPrism p sc)++-- --------------------------------------------------------------------------------+-- Schema extraction from a TypedSchema++-- | Extract an untyped schema that can be serialized+extractSchema :: TypedSchemaFlex from a -> Schema+extractSchema (TPrim n _ _) = Prim n+extractSchema (TTry sc _) = extractSchema sc+extractSchema (TOneOf scc) = OneOf $ extractSchema <$> scc+extractSchema (TAllOf scc) = AllOf $ extractSchema <$> scc+extractSchema TEmpty{} = Empty+extractSchema (TEnum opts _) = Enum (fst <$> opts)+extractSchema (TArray sc _ _) = Array $ extractSchema sc+extractSchema (TMap sc _ _) = StringMap $ extractSchema sc+extractSchema (RecordSchema rs) = foldMap (Record . fromList) $ extractFields rs++-- | Returns all the primitive validators embedded in this typed schema+extractValidators :: TypedSchemaFlex from a -> Validators+extractValidators (TPrim n parse _) =+ [ ( n+ , (\x -> case parse x of+ A.Success _ -> Nothing+ A.Error e -> Just (pack e)+ )+ )+ ]+extractValidators (TOneOf scc) = foldMap extractValidators scc+extractValidators (TAllOf scc) = foldMap extractValidators scc+extractValidators (TArray sc _ _) = extractValidators sc+extractValidators (TMap sc _ _) = extractValidators sc+extractValidators (TTry sc _) = extractValidators sc+extractValidators (RecordSchema rs) = mconcat+ $ mconcat (extractFieldsHelper (extractValidators . fieldTypedSchema) rs)+extractValidators _ = []++-- ---------------------------------------------------------------------------------------+-- Encoding to JSON++-- | Given a value and its typed schema, produce a JSON record using the 'RecordField's+encodeWith :: TypedSchemaFlex from a -> from -> Value+ -- TODO Better error messages to help debug partial schemas ?+encodeWith sc = either (throw . head) id . runExcept . go sc where+ go :: TypedSchemaFlex from a -> from -> Except [SomeException] Value+ go (TAllOf scc) x = encodeAlternatives <$> traverse (`go` x) scc+ go (TOneOf scc) x = asum (fmap (`go` x) scc)+ go (TTry sc try ) x = go sc =<< maybe (throwE [toException TryFailed]) pure (try x)+ go (TEnum _ fromf ) b = pure $ A.String (fromf b)+ go (TPrim _ _ fromf ) b = pure $ fromf b+ go (TEmpty _ ) _ = pure emptyValue+ go (TArray sc _ fromf) b = A.Array <$> go sc `traverse` fromf b+ go (TMap sc _ fromf) b = A.Object <$> go sc `traverse` fromf b+ go (RecordSchema rec ) x = do+ fields' <- traverse((`catchE` \_ -> pure Nothing) . fmap Just . sequence) fields+ case NE.nonEmpty (catMaybes fields') of+ Nothing -> throwE [] -- NOTE test+ Just fields' -> pure $ encodeAlternatives $ fmap (A.Object . fromList . catMaybes) fields'+ where+ fields = extractFieldsHelper (extractField x) rec++ extractField b RequiredAp {..} = Just . (fieldName,) <$> go fieldTypedSchema b+ extractField b OptionalAp {..} = (Just . (fieldName,) <$> go fieldTypedSchema b) `catchE` \_ -> pure Nothing++encodeToWith :: TypedSchema a -> Schema -> Maybe (a -> Value)+encodeToWith sc target = case isSubtypeOf (extractValidators sc) (extractSchema sc) target of+ Right cast -> Just $ cast . encodeWith sc+ _ -> Nothing++-- --------------------------------------------------------------------------+-- Decoding++data DecodeError+ = VE Mismatch+ | TriedAndFailed+ deriving (Eq, Show)++-- | Runs a schema as a function @enc -> dec@. Loops for infinite/circular data+runSchema :: TypedSchemaFlex enc dec -> enc -> Either [DecodeError] dec+runSchema sc = runExcept . go sc+ where+ go :: forall from a. TypedSchemaFlex from a -> from -> Except [DecodeError] a+ go (TEmpty a ) _ = pure a+ go (TTry sc try) from = maybe (throwE [TriedAndFailed]) (go sc) (try from)+ go (TPrim n toF fromF) from = case toF (fromF from) of+ A.Success a -> pure a+ A.Error e -> failWith (PrimError n (pack e))+ go (TEnum opts fromF) from = case lookup enumValue opts of+ Just x -> pure x+ Nothing -> failWith $ InvalidEnumValue enumValue (fst <$> opts)+ where enumValue = fromF from+ go (TMap _sc toF fromF) from = pure $ toF (fromF from)+ go (TArray _sc toF fromF) from = pure $ toF (fromF from)+ go (TAllOf scc ) from = msum $ (`go` from) <$> scc+ go (TOneOf scc ) from = msum $ (`go` from) <$> scc+ go (RecordSchema fields ) from = runAlt f (getRecordFields fields)+ where+ f :: RecordField from b -> Except [DecodeError] b+ f RequiredAp{..} = go fieldTypedSchema from+ f OptionalAp{..} = go fieldTypedSchema from++ failWith e = throwE [VE e]++-- | Given a JSON 'Value' and a typed schema, extract a Haskell value+decodeWith :: TypedSchemaFlex from a -> Value -> Either [(Trace, DecodeError)] a+-- TODO merge runSchema and decodeWith ?+-- TODO change decode type to reflect partiality due to TTry?+decodeWith sc = runExcept . go [] sc+ where+ failWith ctx e = throwE [(reverse ctx, VE e)]++ go+ :: [Text]+ -> TypedSchemaFlex from a+ -> Value+ -> Except [(Trace, DecodeError)] a+ go ctx (TEnum opts _) (A.String x) =+ maybe (failWith ctx (InvalidEnumValue x (fst <$> opts))) pure+ $ lookup x opts+ go ctx (TArray sc tof _) (A.Array x) =+ tof <$> traverse (go ("[]" : ctx) sc) x+ go ctx (TMap sc tof _) (A.Object x) = tof <$> traverse (go ("[]" : ctx) sc) x+ go _tx (TEmpty a) _ = pure a+ go ctx (RecordSchema rec) o@A.Object{} = do+ let alts = decodeAlternatives o+ asum $ concatMap+ (\(A.Object fields, _encodedPath) ->+ getCompose $ runAlt (Compose . (: []) . f fields) (getRecordFields rec)+ )+ alts+ where+ f :: A.Object -> RecordField from a -> Except [(Trace, DecodeError)] a+ f fields (RequiredAp n sc) = case Map.lookup n fields of+ Just v -> go (n : ctx) sc v+ Nothing -> case sc of+ TArray _ tof' _ -> pure $ tof' []+ _ -> failWith ctx (MissingRecordField n)+ f fields OptionalAp {..} = case Map.lookup fieldName fields of+ Just v -> go (fieldName : ctx) fieldTypedSchema v+ Nothing -> pure fieldDefValue++ -- The TAllOf case is probably wrong. I suspect TAllOf should decode very much like TOneOf+ go ctx (TAllOf scc) v = asum $ map+ (\(v', i) -> go+ (pack (show i) : ctx)+ (fromMaybe (error "TAllOf") $ selectPath i (NE.toList scc))+ v'+ )+ (decodeAlternatives v)+ go ctx (TOneOf scc ) x = asum [ go ctx sc x | sc <- NE.toList scc ]++ go ctx (TPrim n tof _) x = case tof x of+ A.Error e -> failWith ctx (PrimError n (pack e))+ A.Success a -> pure a+ go ctx (TTry sc _try) x = go ctx sc x+ go ctx s x = failWith ctx (ValueMismatch (extractSchema s) x)++decodeFromWith :: TypedSchema a -> Schema -> Maybe (Value -> Either [(Trace, DecodeError)] a)+decodeFromWith sc source = case isSubtypeOf (extractValidators sc) source (extractSchema sc) of+ Right cast -> Just $ decodeWith sc . cast+ _ -> Nothing++-- ----------------------------------------------+-- Utils++runAlt_ :: (Alternative g, Monoid m) => (forall a. f a -> g m) -> Alt f b -> g m+runAlt_ f = fmap getConst . getCompose . runAlt (Compose . fmap Const . f)++(<.>) :: Functor f => (b -> c) -> (a -> f b) -> a -> f c+f <.> g = fmap f . g++infixr 9 <.>+
+ src/Schemas/SOP.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Schemas.SOP+ ( gSchema+ , gRecordFields+ , Options(..)+ , defOptions+ , FieldEncode+ )+where++import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.Profunctor+import Data.Text (Text, pack)+import Generics.SOP as SOP+import Schemas.Class+import Schemas.Internal++data Options = Options+ { fieldLabelModifier :: String -> String+ , constructorTagModifier :: String -> String+ }++defOptions :: Options+defOptions = Options id id++fieldSchemaC :: Proxy FieldEncode+fieldSchemaC = Proxy++gSchema :: forall a. (HasDatatypeInfo a, All2 FieldEncode (Code a)) => Options -> TypedSchema a+gSchema opts = case datatypeInfo (Proxy @a) of+ (Newtype _ _ ci ) -> dimap (unZ . unSOP . from) (to . SOP . Z) $ gSchemaNP opts ci+ (ADT _ _ (ci :* Nil) _) -> dimap (unZ . unSOP . from) (to . SOP . Z) $ gSchemaNP opts ci+ (ADT _ _ cis _) -> dimap (unSOP . from) (to . SOP) $ gSchemaNS opts cis++gRecordFields :: forall a xs. (HasDatatypeInfo a, All FieldEncode xs, Code a ~ '[xs]) => Options -> RecordFields a a+gRecordFields opts = case datatypeInfo (Proxy @a) of+ (Newtype _ _ ci ) -> dimap (unZ . unSOP . from) (to . SOP . Z) $ gRecordFields' opts ci+ (ADT _ _ (ci :* Nil) _) -> dimap (unZ . unSOP . from) (to . SOP . Z) $ gRecordFields' opts ci+++gSchemaNS :: forall xss . All2 FieldEncode xss => Options -> NP ConstructorInfo xss -> TypedSchema (NS (NP I) xss)+gSchemaNS opts =+ union+ . NE.fromList+ . hcollapse+ . hczipWith3 (Proxy :: Proxy (All FieldEncode)) mk (injections @_ @(NP I)) (ejections @_ @(NP I))+ where+ mk+ :: forall (xs :: [*])+ . All FieldEncode xs+ => Injection (NP I) xss xs+ -> Ejection (NP I) xss xs+ -> ConstructorInfo xs+ -> K (Text, TypedSchema (NS (NP I) xss)) xs+ mk (Fn inject) (Fn eject) ci = K+ ( cons+ , dimap (unComp . eject . K) (unK . inject . fromJust) (liftMaybe $ gSchemaNP opts ci)+ )+ where cons = pack (constructorTagModifier opts (constructorName ci))++gSchemaNP+ :: forall (xs :: [*])+ . (All FieldEncode xs)+ => Options+ -> ConstructorInfo xs+ -> TypedSchema (NP I xs)+gSchemaNP opts = record . gRecordFields' opts++gRecordFields'+ :: forall (xs :: [*])+ . (All FieldEncode xs)+ => Options+ -> ConstructorInfo xs+ -> RecordFields (NP I xs) (NP I xs)+gRecordFields' opts ci =+ hsequence $+ hczipWith fieldSchemaC mk fieldNames projections+ where+ mk :: (FieldEncode x) => K String x -> Projection I xs x -> RecordFields (NP I xs) x+ mk (K theFieldName) (Fn proj) =+ fieldEncoder (pack $ fieldLabelModifier opts theFieldName) (dimap K unI proj)++ fieldNames :: NP (K String) xs+ fieldNames = case ci of+ SOP.Record _ theFieldNames -> hmap (K . SOP.fieldName) theFieldNames+ SOP.Infix{} -> hmap (K . ("$" ++) . show . unK) (numbers 1)+ SOP.Constructor{} -> hmap (K . ("$" ++) . show . unK) (numbers 1)++ numbers :: forall k (fields :: [k]) . SListI fields => Int -> NP (K Int) fields+ numbers no = case sList :: SList fields of+ SNil -> Nil+ SCons -> K no :* numbers (no + 1)++class FieldEncode a where fieldEncoder :: Text -> (from -> a) -> RecordFields from a++instance {-# OVERLAPPABLE #-} HasSchema a => FieldEncode a where fieldEncoder = field+instance HasSchema a => FieldEncode (Maybe a) where fieldEncoder = optField
+ src/Schemas/Untyped.hs view
@@ -0,0 +1,295 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS -Wno-name-shadowing #-}++module Schemas.Untyped where++import Control.Lens hiding (Empty, enum, (<.>))+import Control.Monad+import Control.Monad.Trans.Except+import Data.Aeson (Value)+import qualified Data.Aeson as A+import Data.Aeson.Lens+import Data.Biapplicative+import Data.Either+import Data.Foldable (asum)+import Data.Generics.Labels ()+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as Map+import Data.List (find)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.Text (Text, pack, unpack)+import GHC.Exts (IsList (..))+import GHC.Generics (Generic)+import Numeric.Natural+import Prelude hiding (lookup)+import Text.Read++-- Schemas+-- --------------------------------------------------------------------------------++data Schema+ = Array Schema+ | StringMap Schema+ | Enum (NonEmpty Text)+ | Record (HashMap Text Field)+ | AllOf (NonEmpty Schema) -- ^ Encoding and decoding work for all alternatives+ | OneOf (NonEmpty Schema) -- ^ Decoding works for all alternatives, encoding only for one+ | Prim Text -- ^ Carries the name of primitive type+ deriving (Eq, Generic, Show)++instance Monoid Schema where mempty = Empty+instance Semigroup Schema where+ Empty <> x = x+ x <> Empty = x+ AllOf aa <> b = AllOf (aa <> [b])+ b <> AllOf aa = AllOf ([b] <> aa)+ a <> b = AllOf [a,b]++data Field = Field+ { fieldSchema :: Schema+ , isRequired :: Bool -- ^ defaults to True+ }+ deriving (Eq, Generic, Show)++pattern Empty :: Schema+pattern Empty <- Record [] where Empty = Record []++pattern Union :: NonEmpty (Text, Schema) -> Schema+pattern Union alts <- (preview _Union -> Just alts) where+ Union alts = review _Union alts++_Empty :: Prism' Schema ()+_Empty = prism' build match+ where+ build () = Record []++ match (Record []) = Just ()+ match _ = Nothing++_Union :: Prism' Schema (NonEmpty (Text, Schema))+_Union = prism' build match+ where+ build = OneOf . fmap (\(n,sc) -> Record [(n, Field sc True)])++ match (OneOf scc) = traverse viewAlt scc+ match _ = Nothing++ viewAlt :: Schema -> Maybe (Text, Schema)+ viewAlt (Record [(n,Field sc True)]) = Just (n, sc)+ viewAlt _ = Nothing++-- --------------------------------------------------------------------------------+-- Finite schemes++-- | Ensure that a 'Schema' is finite by enforcing a max depth.+-- The result is guaranteed to be a supertype of the input.+finite :: Natural -> Schema -> Schema+finite = go+ where+ go :: Natural -> Schema -> Schema+ go 0 _ = Empty+ go d (Record opts) = Record $ fromList $ mapMaybe+ (\(fieldname, Field sc isOptional) -> case go (max 0 (pred d)) sc of+ Empty -> Nothing+ sc' -> Just (fieldname, Field sc' isOptional)+ )+ (Map.toList opts)+ go d (Array sc ) = Array (go (max 0 (pred d)) sc)+ go d (StringMap sc ) = StringMap (go (max 0 (pred d)) sc)+ go d (AllOf opts) = let d' = max 0 (pred d) in AllOf (finite d' <$> opts)+ go d (OneOf opts) = let d' = max 0 (pred d) in OneOf (finite d' <$> opts)+ go _ other = other++-- | Ensure that a 'Value' is finite by enforcing a max depth in a schema preserving way+finiteValue :: Validators -> Natural -> Schema -> Value -> Value+finiteValue validators d sc+ | Right cast <- isSubtypeOf validators sc (finite d sc) = cast+ | otherwise = error "bug in isSubtypeOf"++-- ------------------------------------------------------------------------------------------------------+-- Versions++-- | Flattens alternatives. Returns a schema without 'AllOf' constructors+versions :: Schema -> NonEmpty Schema+versions (AllOf scc) = join $ traverse versions scc+versions (OneOf scc) = OneOf <$> traverse versions scc+versions (Record fields) = Record <$> ((traverse . #fieldSchema) versions fields)+versions (Array sc) = Array <$> versions sc+versions (StringMap sc) = StringMap <$> versions sc+versions x = [x]++-- ------------------------------------------------------------------------------------------------------+-- Validation++type Trace = [Text]++data Mismatch+ = MissingRecordField { name :: Text}+ | InvalidEnumValue { given :: Text, options :: NonEmpty Text}+ | InvalidConstructor { name :: Text}+ | InvalidUnionValue { contents :: Value}+ | SchemaMismatch {a, b :: Schema}+ | ValueMismatch {expected :: Schema, got :: Value}+ | EmptyAllOf+ | PrimValidatorMissing { name :: Text }+ | PrimError {name, primError :: Text}+ | InvalidChoice{choiceNumber :: Int}+ deriving (Eq, Show)++type Validators = HashMap Text ValidatePrim+type ValidatePrim = Value -> Maybe Text++-- | Structural validation of a JSON value against a schema+-- Ignores extraneous fields in records+validate :: Validators -> Schema -> Value -> [(Trace, Mismatch)]+validate validators sc v = either (fmap (first reverse)) (\() -> []) $ runExcept (go [] sc v) where+ failWith :: Trace -> Mismatch -> Except [(Trace, Mismatch)] ()+ failWith ctx e = throwE [(ctx, e)]++ go :: Trace -> Schema -> Value -> Except [(Trace, Mismatch)] ()+ go ctx (Prim n) x = case Map.lookup n validators of+ Nothing -> failWith ctx (PrimValidatorMissing n)+ Just v -> case v x of+ Nothing -> pure ()+ Just err -> failWith ctx (PrimError n err)+ go ctx (StringMap sc) (A.Object xx) = ifor_ xx $ \i -> go (i : ctx) sc+ go ctx (Array sc) (A.Array xx) =+ ifor_ xx $ \i -> go (pack ("[" <> show i <> "]") : ctx) sc+ go ctx (Enum opts) (A.String s) =+ if s `elem` opts then pure () else failWith ctx (InvalidEnumValue s opts)+ go ctx (Record ff) (A.Object xx) = ifor_ ff $ \n (Field sc opt) ->+ case (opt, Map.lookup n xx) of+ (_ , Just y ) -> go (n : ctx) sc y+ (True, Nothing) -> pure ()+ _ -> failWith ctx (MissingRecordField n)+ go ctx (Union constructors) v@(A.Object xx) = case toList xx of+ [(n, v)] | Just sc <- lookup n constructors -> go (n : ctx) sc v+ | otherwise -> failWith ctx (InvalidConstructor n)+ _ -> throwE [(ctx, InvalidUnionValue v)]+ go ctx (OneOf scc) v = case decodeAlternatives v of+ [(v, 0)] -> msum $ fmap (\sc -> go ctx sc v) scc+ alts -> msum $ fmap+ (\(v, n) ->+ fromMaybe (failWith ctx (InvalidChoice n)) $ selectPath n $ fmap+ (\sc -> go (pack (show n) : ctx) sc v)+ (toList scc)+ )+ alts+ go ctx (AllOf scc) v = go ctx (OneOf scc) v+ go ctx a b = failWith ctx (ValueMismatch a b)++-- ------------------------------------------------------------------------------------------------------+-- Subtype relation++-- | @sub `isSubtypeOf` sup@ returns a witness that @sub@ is a subtype of @sup@, i.e. a cast function @sub -> sup@+--+-- > Array Bool `isSubtypeOf` Bool+-- Just <function>+-- > Record [("a", Bool)] `isSubtypeOf` Record [("a", Number)]+-- Nothing+isSubtypeOf :: Validators -> Schema -> Schema -> Either [(Trace, Mismatch)] (Value -> Value)+isSubtypeOf validators sub sup = runExcept $ go [] sup sub+ where+ failWith :: Trace -> Mismatch -> Except [(Trace, Mismatch)] a+ failWith ctx m = throwE [(reverse ctx, m)]++ -- TODO go: fix confusing order of arguments+ go :: Trace -> Schema -> Schema -> Except [(Trace,Mismatch)] (Value -> Value)+ go _tx Empty _ = pure $ const emptyValue+ go _tx (Array _) Empty = pure $ const (A.Array [])+ go _tx (Record _) Empty = pure $ const emptyValue+ go _tx (StringMap _) Empty = pure $ const emptyValue+ go _tx OneOf{} Empty = pure $ const emptyValue+ go _tx (Prim a) (Prim b ) = guard (a == b) >> pure id+ go ctx (Array a) (Array b) = do+ f <- go ("[]" : ctx) a b+ pure $ over (_Array . traverse) f+ go ctx (StringMap a) (StringMap b) = do+ f <- go ("Map" : ctx) a b+ pure $ over (_Object . traverse) f+ go _tx a (Array b) | a == b = pure (A.Array . fromList . (: []))+ go _tx (Enum opts) (Enum opts') | all (`elem` opts') opts = pure id+ go ctx (Union opts) (Union opts') = do+ ff <- forM opts' $ \(n, sc) -> do+ sc' <- maybe (failWith ctx $ InvalidConstructor n) pure $ lookup n (toList opts)+ f <- go (n : ctx) sc sc'+ return $ over (_Object . ix n) f+ return (foldr (.) id ff)+ go ctx (Record opts) (Record opts') = do+ forM_ (Map.toList opts) $ \(n, f@(Field _ _)) ->+ guard $ not (isRequired f) || Map.member n opts'+ ff <- forM (Map.toList opts') $ \(n', f'@(Field sc' _)) -> do+ case Map.lookup n' opts of+ Nothing -> do+ pure $ over (_Object) (Map.delete n')+ Just f@(Field sc _) -> do+ guard (not (isRequired f) || isRequired f')+ witness <- go (n' : ctx) sc sc'+ pure $ over (_Object . ix n') witness+ return (foldr (.) id ff)+ go ctx (AllOf sup) sub = do+ (i, c) <- msum $ imap (\i sup' -> (i,) <$> go ( tag i : ctx) sup' sub) sup+ return $ \v -> A.object [(tag i, c v)]+ go ctx sup (AllOf scc) = asum+ [ go ctx sup b <&> \f ->+ fromMaybe+ ( error+ $ "failed to upcast an AllOf value due to missing entry: "+ <> field+ )+ . preview (_Object . ix (pack field) . to f)+ | (i, b) <- zip [(1 :: Int) ..] (NE.toList scc)+ , let field = "#" <> show i+ ]+ go ctx sup (OneOf [sub]) = go ctx sup sub+ go ctx sup (OneOf sub ) = do+ alts <- traverse (\sc -> (sc, ) <$> go ctx sup sc) sub+ return $ \v -> head $ mapMaybe+ (\(sc, f) -> if null (validate validators sc v) then Just (f v) else Nothing)+ (toList alts)+ go ctx (OneOf sup) sub = asum $ fmap (\x -> go ctx x sub) sup+ go _tx a b | a == b = pure id+ go ctx a b = failWith ctx (SchemaMismatch a b)++-- ----------------------------------------------+-- Utils++type Path = Int++selectPath :: Path -> [a] -> Maybe a+selectPath 0 (x : _) = Just x+selectPath n (_ : xx) = selectPath (pred n) xx+selectPath _ _ = Nothing++tag :: Int -> Text+tag i = "#" <> pack (show i)++decodeAlternatives :: Value -> [(Value, Path)]+decodeAlternatives obj@(A.Object x) =+ case+ [ (v, n) | (unpack -> '#' : (readMaybe -> Just n), v) <- Map.toList x ]+ of+ [] -> [(obj, 0)]+ other -> other+decodeAlternatives x = [(x,0)]++encodeAlternatives :: NonEmpty Value -> Value+encodeAlternatives [x] = x+encodeAlternatives xx = A.object $ fromList [ (tag i, x) | (i,x) <- zip [(1::Int)..] (toList xx) ]++-- | Generalized lookup for Foldables+lookup :: (Eq a, Foldable f) => a -> f (a,b) -> Maybe b+lookup a = fmap snd . find ((== a) . fst)++-- Is there more than one choice here ? Maybe this should be configuration+emptyValue :: Value+emptyValue = A.object []
+ test/Generators.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Generators where++import Control.Lens (review)+import Control.Monad+import Data.Text (Text)+import GHC.Exts (IsList (..))+import Numeric.Natural+import Schemas+import Test.QuickCheck++hasOneOf :: Schema -> Bool+hasOneOf (Array sc) = hasOneOf sc+hasOneOf (StringMap sc) = hasOneOf sc+hasOneOf (Record ff) = any (hasOneOf . fieldSchema) ff+hasOneOf (AllOf scc) = any hasOneOf scc+hasOneOf (OneOf _) = True+hasOneOf _ = False++hasAllOf :: Schema -> Bool+hasAllOf (Array sc) = hasAllOf sc+hasAllOf (StringMap sc) = hasAllOf sc+hasAllOf (Record ff) = any (hasAllOf . fieldSchema) ff+hasAllOf (OneOf scc) = any hasAllOf scc+hasAllOf (AllOf _) = True+hasAllOf _ = False++instance Arbitrary Schema where+ arbitrary = sized genSchema+ shrink (Record fields) =+ [Record [(n,Field sc' req)] | (n,Field sc req) <- toList fields, sc' <- shrink sc]+ shrink (AllOf scc) = [AllOf [sc'] | sc <- toList scc, sc' <- shrink sc]+ shrink (OneOf scc) = [OneOf [sc'] | sc <- toList scc, sc' <- shrink sc]+ shrink (Array sc) = [sc]+ shrink (StringMap sc) = [sc]+ shrink _ = []++newtype SmallNatural = SmallNatural Natural+ deriving (Eq, Ord, Num)+ deriving newtype Show++instance Arbitrary (SmallNatural) where+ arbitrary = fromIntegral <$> choose (0::Int, 10)+ shrink 0 = []+ shrink n = [n-1]++fieldNames :: [Text]+fieldNames = ["field1", "field2", "field3"]++constructorNames :: [Text]+constructorNames = ["constructor1", "constructor2"]++genSchema :: Int -> Gen (Schema)+genSchema 0 = elements [Empty, Prim "A", Prim "B"]+genSchema n = frequency+ [ (10,) $ Record <$> do+ nfields <- choose (1,2)+ fieldArgs <- replicateM nfields (scale (`div` 2) arbitrary)+ return $ fromList (zipWith (\n (sc,a) -> (n, Field sc a)) fieldNames fieldArgs)+ , (10,) $ Array <$> scale(`div`2) arbitrary+ , (10,) $ Enum <$> do+ n <- choose (1,2)+ return $ fromList $ take n ["Enum1", "Enum2"]+ , (1,) $ AllOf . fromList <$> listOf1 (genSchema (n`div`10))+ , (1,) $ OneOf . fromList <$> listOf1 (genSchema (n`div`10))+ , (5,) $ review _Union <$> do+ nconstructors <- choose (1,2)+ args <- replicateM nconstructors (genSchema (n`div`nconstructors))+ return $ fromList $ zip constructorNames args+ , (50,) $ genSchema 0+ ]
+ test/Main.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+
+ test/SchemasSpec.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+module SchemasSpec where++import Control.Exception+import qualified Data.Aeson as A+import Data.Either+import Data.Maybe+import Generators+import Person+import Person2+import Person3+import Schemas+import System.Timeout+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Text.Show.Functions ()++spec :: Spec+spec = do+ describe "encoding" $ do+ prop "is the inverse of decoding" $ \(sc :: Schema) ->+ decode (encode sc) == Right sc+ describe "versions" $ do+ prop "eliminates AllOf" $ \sc -> all (not . hasAllOf) (versions sc)+ describe "finite" $ do+ it "is reflexive (in absence of OneOf)" $ forAll (sized genSchema `suchThat` (not . hasOneOf)) $ \sc ->+ sc `shouldBeSubtypeOf` sc+ it "always produces a supertype (in absence of OneOf)" $+ forAll (sized genSchema `suchThat` (not . hasOneOf)) $ \sc ->+ forAll arbitrary $ \(SmallNatural size) ->+ all (\sc -> isRight $ isSubtypeOf primValidators sc (finite size sc)) (versions sc)+ describe "isSubtypeOf" $ do+ it "subtypes can add fields" $ do+ Record [makeField "a" prim True, makeField "def" prim True]+ `shouldBeSubtypeOf` Record [makeField "def" prim True]+ Record [makeField "a" prim False, makeField "def" prim True]+ `shouldBeSubtypeOf` Record [makeField "def" prim True]+ it "subtypes cannot turn a Required makeField into Optional" $ do+ Record [makeField "a" prim False]+ `shouldNotBeSubtypeOf` Record [makeField "a" prim True]+ it "subtypes can turn an Optional makeField into Required" $ do+ Record [makeField "a" prim True]+ `shouldBeSubtypeOf` Record [makeField "a" prim False]+ it "subtypes can relax the type of a field" $ do+ Record [makeField "a" (Array prim) True]+ `shouldBeSubtypeOf` Record [makeField "a" prim True]+ it "subtypes cannot remove Required fields" $ do+ Record [makeField "def" prim True] `shouldNotBeSubtypeOf` Record+ [makeField "def" prim True, makeField "a" prim True]+ it "subtypes can remove Optional fields" $ do+ Record [makeField "def" prim True] `shouldBeSubtypeOf` Record+ [makeField "def" prim True, makeField "a" prim (False)]+ it "subtypes can add enum choices" $ do+ Enum ["A", "def"] `shouldBeSubtypeOf` Enum ["def"]+ it "subtypes cannot remove enum choices" $ do+ Enum ["def"] `shouldNotBeSubtypeOf` Enum ["A"]+ it "subtypes can remove constructors" $ do+ Union [constructor' "B" Empty]+ `shouldBeSubtypeOf` Union [constructor' "A" Empty, constructor' "B" Empty]+ it "subtypes cannot add constructors" $ do+ Union [constructor' "A" prim, constructor' "B" Empty]+ `shouldNotBeSubtypeOf` Union [constructor' "A" (prim)]+ it "subtypes can expand an array" $ do+ Array prim `shouldBeSubtypeOf` prim+ it "subtypes cannot drop an array" $ do+ prim `shouldNotBeSubtypeOf` Array prim+ describe "examples" $ do+ describe "Schemas" $ do+ prop "finite(schema @Schema) is a supertype of (schema @Schema)" $ \(SmallNatural n) ->+ theSchema @Schema `shouldBeSubtypeOf` finite n (theSchema @Schema)+ describe "Person" $ do+ it "decode is the inverse of encode (applicative)" $ do+ decode (encode pepe) `shouldBe` Right pepe+ describe "Person2" $ do+ it "Person2 < Person" $ do+ theSchema @Person2 `shouldBeSubtypeOf` theSchema @Person+ it "pepe2 `as` Person" $ do+ let encoder = encodeTo (theSchema @Person)+ encoder `shouldSatisfy` isJust+ decode (fromJust encoder pepe2) `shouldBe` Right pepe+ it "pepe `as` Person2" $ do+ let decoder = decodeFrom (theSchema @Person)+ decoder `shouldSatisfy` isJust+ fromJust decoder (encode pepe) `shouldBe` Right pepe2+ it "Person < Person2" $ do+ theSchema @Person `shouldBeSubtypeOf` theSchema @Person2+ describe "Person3" $ do+ it "finiteEncode works as expected" $ shouldLoop $ evaluate $ A.encode+ (finiteEncode 4 laura3)++shouldBeSubtypeOf :: Schema -> Schema -> Expectation+shouldBeSubtypeOf a b = case isSubtypeOf primValidators a b of+ Right _ -> pure ()+ _ -> expectationFailure $ show a <> " should be a subtype of " <> show b++shouldNotBeSubtypeOf :: Schema -> Schema -> Expectation+shouldNotBeSubtypeOf a b = case isSubtypeOf primValidators a b of+ Right _ -> expectationFailure $ show a <> " should not be a subtype of " <> show b+ _ -> pure ()++shouldLoop :: (Show a, Eq a) => IO a -> Expectation+shouldLoop act = timeout 1000000 act `shouldReturn` Nothing++shouldNotLoop :: (Show a, Eq a) => IO a -> Expectation+shouldNotLoop act = timeout 1000000 act `shouldNotReturn` Nothing++makeField :: a -> Schema -> Bool -> (a, Field)+makeField n t isReq = (n, Field t isReq)++constructor' :: a -> b -> (a, b)+constructor' n t = (n, t)++prim = Prim "A"++primValidators = validatorsFor @(Schema, Double, Int, Bool)