schemas 0.3.0.2 → 0.4.0.0
raw patch · 18 files changed
+890/−641 lines, 18 filesdep +mtldep ~base
Dependencies added: mtl
Dependency ranges changed: base
Files
- CHANGELOG.md +12/−0
- example/Person.hs +10/−10
- example/Person2.hs +146/−215
- example/Person3.hs +7/−1
- schemas.cabal +8/−2
- src/Schemas.hs +20/−14
- src/Schemas/Attempt.hs +82/−0
- src/Schemas/Class.hs +23/−23
- src/Schemas/Delay.hs +19/−0
- src/Schemas/Internal.hs +312/−255
- src/Schemas/OpenApi2.hs +6/−4
- src/Schemas/SOP.hs +12/−13
- src/Schemas/Untyped.hs +23/−17
- test/Generators.hs +1/−1
- test/Looper.hs +23/−0
- test/Schemas/OpenApi2Spec.hs +7/−4
- test/Schemas/SOPSpec.hs +12/−8
- test/SchemasSpec.hs +167/−74
CHANGELOG.md view
@@ -1,6 +1,18 @@ # Revision history for schemas+## 0.4 -- 2019-12-20+* Handle non-termination as an effect in decoding+* Union api made more consistent across tagged and non tagged+* (internal) More principled TypedSchema ADT based on Sum Profunctors+* Total version of 'liftPrism'+* 'theSchema' renamed to 'schemaFor'+* Bugfixes for decoding+ ## 0.3.0.2 -- 2019-10-29 * Show circular schemas++## 0.4.0+* 'oneOf' and 'liftPrism' now have a better type signature+* 'UnionTag' renamed to 'UnionAlt' ## 0.3.0.1 -- 2019-10-25 * Fix a bug that made OpenApi2 generation diverge.
example/Person.hs view
@@ -19,10 +19,10 @@ deriving (Generic, Eq, Show) instance HasSchema Education where- schema = union'- [alt "NoEducation" #_NoEducation- ,alt "PhD" #_PhD- ,alt "Degree" #_Degree+ schema = union+ [("NoEducation", alt #_NoEducation)+ ,("PhD", alt #_PhD)+ ,("Degree", alt #_Degree) ] data Person = Person@@ -59,7 +59,7 @@ -- "name": "Pepe" -- } --- >>> B.putStrLn $ encodePretty $ encode (theSchema @Person)+-- >>> B.putStrLn $ encodePretty $ encode (schemaFor @Person) -- { -- "Record": { -- "addresses": {@@ -71,7 +71,7 @@ -- }, -- "age": { -- "schema": {--- "Prim": "Int"+-- "Prim": "Integer" -- } -- }, -- "studies": {@@ -79,9 +79,9 @@ -- "Union": [ -- { -- "schema": {--- "Empty": {}+-- "Prim": "String" -- },--- "constructor": "NoEducation"+-- "constructor": "Degree" -- }, -- { -- "schema": {@@ -91,9 +91,9 @@ -- }, -- { -- "schema": {--- "Prim": "String"+-- "Record": {} -- },--- "constructor": "Degree"+-- "constructor": "NoEducation" -- } -- ] -- }
example/Person2.hs view
@@ -66,63 +66,48 @@ -- Person2 can be encoded in multiple ways, so the canonic encoding includes all ways -- >>> import qualified Data.ByteString.Lazy.Char8 as B -- >>> import Data.Aeson.Encode.Pretty--- >>> B.putStrLn $ encodePretty $ encodeTo (theSchema @Person2) pepe2+-- >>> import Data.Either+-- >>> B.putStrLn $ encodePretty $ fromRight undefined (encodeTo (schemaFor @Person2)) 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": {+-- "education": [+-- { -- "PhD": "Computer Science" -- },--- "name": "Pepe"--- }+-- {+-- "Degree": "Engineering"+-- }+-- ],+-- "addresses": [+-- "2 Edward Square",+-- "La Mar 10"+-- ],+-- "age": 38,+-- "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": {+-- "education": [+-- { -- "PhD": "Computer Science" -- },--- "name": "Pepe"--- }+-- {+-- "Degree": "Engineering"+-- }+-- ],+-- "addresses": [+-- "2 Edward Square",+-- "La Mar 10"+-- ],+-- "age": 38,+-- "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+-- >>> B.putStrLn $ encodePretty $ fromRight undefined (encodeTo (schemaFor @Person)) pepe2 -- { -- "addresses": [ -- "2 Edward Square",@@ -138,165 +123,109 @@ -- 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" }--- }--- )+-- >>> pPrintNoColor $ fromRight undefined (decodeFrom @Person2 (schemaFor @Person)) (encode pepe)+-- Right +-- ( Person2 +-- { name = "Pepe" +-- , age = Just 38+-- , addresses = +-- [ "2 Edward Square" +-- , "La Mar 10" +-- ] +-- , religion = Nothing+-- , education = PhD { unPhD = "Computer Science" } :| []+-- } -- ) --- >>> B.putStrLn $ encodePretty $ encode (theSchema @Person2)+-- >>> B.putStrLn $ encodePretty $ encode (schemaFor @Person2) -- {--- "AllOf": [--- {--- "Record": {--- "education": {--- "schema": {--- "Union": [--- {--- "schema": {--- "Empty": {}--- },--- "constructor": "NoEducation"+-- "Record": {+-- "education": {+-- "schema": {+-- "Array": {+-- "Union": [+-- {+-- "schema": {+-- "Prim": "String" -- },--- {--- "schema": {--- "Prim": "String"--- },--- "constructor": "PhD"+-- "constructor": "Degree"+-- },+-- {+-- "schema": {+-- "Prim": "String" -- },--- {--- "schema": {--- "Prim": "String"--- },--- "constructor": "Degree"--- }--- ]--- }--- },--- "religion": {--- "schema": {--- "Enum": [--- "Catholic",--- "Anglican",--- "Muslim",--- "Hindu"--- ]--- },--- "isRequired": false--- },--- "addresses": {--- "schema": {--- "Array": {--- "Prim": "String"+-- "constructor": "PhD"+-- },+-- {+-- "schema": {+-- "Record": {}+-- },+-- "constructor": "NoEducation" -- }--- }--- },--- "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"--- }+-- "religion": {+-- "schema": {+-- "Enum": [+-- "Catholic",+-- "Anglican",+-- "Muslim",+-- "Hindu"+-- ]+-- },+-- "isRequired": false+-- },+-- "addresses": {+-- "schema": {+-- "Array": {+-- "Prim": "String" -- } -- }+-- },+-- "age": {+-- "schema": {+-- "Prim": "Integer"+-- },+-- "isRequired": false+-- },+-- "name": {+-- "schema": {+-- "Prim": "String"+-- } -- }--- ]+-- } -- } --- >>> import qualified Data.ByteString.Lazy.Char8 as B+-- >>> import Data.Aeson.Encode.Pretty+-- >>> mapM_ (B.putStrLn . encodePretty . encode) (extractSchema $ schema @Person2) -- { -- "Record": { -- "education": { -- "schema": {--- "Union": [--- {--- "schema": {--- "Empty": {}--- },--- "constructor": "NoEducation"--- },--- {--- "schema": {--- "Prim": "String"+-- "Array": {+-- "Union": [+-- {+-- "schema": {+-- "Prim": "String"+-- },+-- "constructor": "Degree" -- },--- "constructor": "PhD"--- },--- {--- "schema": {--- "Prim": "String"+-- {+-- "schema": {+-- "Prim": "String"+-- },+-- "constructor": "PhD" -- },--- "constructor": "Degree"--- }--- ]+-- {+-- "schema": {+-- "Record": {}+-- },+-- "constructor": "NoEducation"+-- }+-- ]+-- } -- } -- }, -- "religion": {@@ -319,8 +248,9 @@ -- }, -- "age": { -- "schema": {--- "Prim": "Int"--- }+-- "Prim": "Integer"+-- },+-- "isRequired": false -- }, -- "name": { -- "schema": {@@ -351,17 +281,18 @@ -- }, -- "age": { -- "schema": {--- "Prim": "Int"--- }+-- "Prim": "Integer"+-- },+-- "isRequired": false -- }, -- "studies": { -- "schema": { -- "Union": [ -- { -- "schema": {--- "Empty": {}+-- "Prim": "String" -- },--- "constructor": "NoEducation"+-- "constructor": "Degree" -- }, -- { -- "schema": {@@ -371,9 +302,9 @@ -- }, -- { -- "schema": {--- "Prim": "String"+-- "Record": {} -- },--- "constructor": "Degree"+-- "constructor": "NoEducation" -- } -- ] -- }@@ -385,32 +316,32 @@ -- } -- } -- }--- >>> import Data.Aeson.Encode.Pretty--- >>> mapM_ (B.putStrLn . encodePretty . encode) (versions $ theSchema @Person2) -- { -- "Record": { -- "education": { -- "schema": {--- "Union": [--- {--- "schema": {--- "Empty": {}--- },--- "constructor": "NoEducation"--- },--- {--- "schema": {--- "Prim": "String"+-- "Array": {+-- "Union": [+-- {+-- "schema": {+-- "Prim": "String"+-- },+-- "constructor": "Degree" -- },--- "constructor": "PhD"--- },--- {--- "schema": {--- "Prim": "String"+-- {+-- "schema": {+-- "Prim": "String"+-- },+-- "constructor": "PhD" -- },--- "constructor": "Degree"--- }--- ]+-- {+-- "schema": {+-- "Record": {}+-- },+-- "constructor": "NoEducation"+-- }+-- ]+-- } -- } -- }, -- "religion": {@@ -433,7 +364,7 @@ -- }, -- "age": { -- "schema": {--- "Prim": "Int"+-- "Prim": "Integer" -- } -- }, -- "name": {@@ -465,7 +396,7 @@ -- }, -- "age": { -- "schema": {--- "Prim": "Int"+-- "Prim": "Integer" -- } -- }, -- "studies": {@@ -473,9 +404,9 @@ -- "Union": [ -- { -- "schema": {--- "Empty": {}+-- "Prim": "String" -- },--- "constructor": "NoEducation"+-- "constructor": "Degree" -- }, -- { -- "schema": {@@ -485,9 +416,9 @@ -- }, -- { -- "schema": {--- "Prim": "String"+-- "Record": {} -- },--- "constructor": "Degree"+-- "constructor": "NoEducation" -- } -- ] -- }
example/Person3.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedLabels #-}@@ -7,6 +10,8 @@ import Control.Applicative import Data.Generics.Labels ()+import GHC.Generics+import qualified Generics.SOP as SOP import Person import Person2 import Schemas@@ -20,7 +25,8 @@ , religion :: Maybe Religion , education :: [Education] }- deriving (Eq, Show)+ deriving (Generic, Eq, Show)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) instance HasSchema Person3 where schema = named "Person3"
schemas.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: schemas-version: 0.3.0.2+version: 0.4.0.0 synopsis: schema guided serialization description: Schemas is a Haskell library for serializing and deserializing data in JSON.@@ -46,11 +46,14 @@ Schemas.Class Schemas.Internal Schemas.OpenApi2+ Schemas.Delay+ Schemas.Attempt Schemas.SOP Schemas.Untyped -- other-modules: -- other-extensions:- build-depends: base ^>=4.12.0.0+-- upper bounds on base are mandatory+ build-depends: base >= 4.12 && < 100 , aeson , bifunctors , bytestring@@ -59,6 +62,7 @@ , hashable , lens , lens-aeson+ , mtl , profunctors , scientific , text@@ -80,6 +84,7 @@ , Person2 , Person3 , Person4+ , Looper , SchemasSpec , Schemas.OpenApi2Spec , Schemas.SOPSpec@@ -92,6 +97,7 @@ , generics-sop , hspec , lens+ , mtl , pretty-simple , QuickCheck , schemas
src/Schemas.hs view
@@ -42,6 +42,8 @@ , TypedSchema , HasSchema(..) -- ** Construction+ , emptySchema+ , pureSchema , enum , readShow , list@@ -51,6 +53,7 @@ , stringMap , viaJSON , viaIso+ , named -- *** Applicative record definition , record , RecordFields@@ -70,15 +73,16 @@ -- *** Partial schemas , liftJust , liftRight- , liftPrism- -- *** Unions+ -- *** Discriminated Unions , union- , union' , alt , altWith- , UnionTag- , oneOf- -- * Encoding+ , UnionAlt+ -- *** Undiscriminated unions+ , Typed.oneOf+ , eitherSchema+ , liftPrism+ -- ** Encoding , encode , decode , encodeTo@@ -87,25 +91,28 @@ , decodeWith , encodeToWith , decodeFromWith- , DecodeError - -- * working with recursive schemas- , named+ -- ** Results+ , Result+ , runResult -- * Untyped schemas- , Schema(.., Empty, Union)+ , Schema(.., Unit, Union) , Field(..)- , _Empty+ , _Unit , _Union -- ** Extraction , extractSchema- , theSchema+ , schemaFor -- ** Functions , Mismatch(..) , Trace+ , TracedMismatches , isSubtypeOf , coerce+ -- * Validation , validate+ , extractValidators , validatorsFor -- * Reexports , Profunctor(..)@@ -114,6 +121,5 @@ import Data.Profunctor import Schemas.Class-import Schemas.Internal+import Schemas.Internal as Typed import Schemas.Untyped-
+ src/Schemas/Attempt.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+module Schemas.Attempt where++import Control.Applicative+import Data.Functor.Classes+import Control.Monad.Except+import Data.Maybe++-- | An applicative error type+data Attempt e a+ = Success a+ | Failure e+ deriving (Eq, Functor, Foldable, Traversable, Show)++instance Eq e => Eq1 (Attempt e) where+ liftEq _ (Failure e) (Failure e') = e == e'+ liftEq eq0 (Success a) (Success a') = eq0 a a'+ liftEq _ _ _ = False++instance Show e => Show1 (Attempt e) where+ liftShowsPrec _ _ p (Failure e) = showsPrec p e+ liftShowsPrec shows0 _ _ (Success a) = shows "Success " . shows0 0 a++instance Monoid e => Applicative (Attempt e) where+ pure = Success+ Success f <*> Success a = Success (f a)+ Failure e <*> Failure e' = Failure (e <> e')+ Failure e <*> _ = Failure e+ _ <*> Failure e = Failure e++instance Monoid e => Alternative (Attempt e) where+ empty = Failure mempty+ Success a <|> _ = Success a+ _ <|> Success b = Success b+ Failure e <|> Failure e' = Failure (e <> e')++instance Monoid e => Monad (Attempt e) where+ return = pure+ Success a >>= k = k a+ Failure e >>= _ = Failure e++instance Monoid e => MonadPlus (Attempt e)++instance Monoid e => MonadError e (Attempt e) where+ throwError = Failure+ catchError (Failure e) h = h e+ catchError (Success a) _ = Success a++bindAttempt :: Attempt e a -> (a -> Attempt e b) -> Attempt e b+bindAttempt (Success a) k = k a+bindAttempt (Failure e) _ = Failure e++runAttempt :: Attempt e a -> Either e a+runAttempt = execAttempt++execAttempt :: MonadError e f => Attempt e a -> f a+execAttempt (Success x) = pure x+execAttempt (Failure e) = throwError e++-- | Partitions a result successes and failures+partitionAttempts :: [Attempt e a] -> ([e], [a])+partitionAttempts xx = (mapMaybe attemptFailure xx, mapMaybe attemptSuccess xx)++attemptFailure :: Attempt a1 a2 -> Maybe a1+attemptFailure Success{} = Nothing+attemptFailure (Failure e) = Just e++attemptSuccess :: Attempt e a -> Maybe a+attemptSuccess (Success a) = Just a+attemptSuccess Failure{} = Nothing++isSuccess :: Attempt e a -> Bool+isSuccess Success{} = True+isSuccess _ = False++isFailure :: Attempt e a -> Bool+isFailure Failure{} = True+isFailure _ = False
src/Schemas/Class.hs view
@@ -33,7 +33,7 @@ schema :: TypedSchema a instance HasSchema () where- schema = mempty+ schema = TPure () instance HasSchema Bool where schema = viaJSON "Boolean"@@ -77,16 +77,16 @@ deriving instance HasSchema SchemaName instance HasSchema Schema where- schema = named "Schema" $ union'- [ alt "StringMap" $ prism' StringMap (\case StringMap x -> Just x ; _ -> Nothing)- , alt "Array" $ prism' Array (\case Array x -> Just x ; _ -> Nothing)- , alt "Enum" $ prism' Enum (\case Enum x -> Just x ; _ -> Nothing)- , alt "Record" $ prism' Record (\case Record x -> Just x ; _ -> Nothing)- , alt "Empty" _Empty- , alt "Prim" $ prism' Prim (\case Prim x -> Just x ; _ -> Nothing)- , altWith unionSchema "Union" _Union- , alt "OneOf" $ prism' OneOf (\case OneOf x -> Just x ; _ -> Nothing)- , altWith namedSchema "Named" $ prism' (uncurry Named) (\case Named s sc -> Just (s,sc) ; _ -> Nothing)+ schema = named "Schema" $ union+ [ ("StringMap", alt $ prism' StringMap (\case StringMap x -> Just x ; _ -> Nothing))+ , ("Array", alt $ prism' Array (\case Array x -> Just x ; _ -> Nothing))+ , ("Enum", alt $ prism' Enum (\case Enum x -> Just x ; _ -> Nothing))+ , ("Record", alt $ prism' Record (\case Record x -> Just x ; _ -> Nothing))+ , ("Prim", alt $ prism' Prim (\case Prim x -> Just x ; _ -> Nothing))+ , ("Union",altWith unionSchema _Union)+ , ("OneOf", alt $ prism' OneOf (\case OneOf x -> Just x ; _ -> Nothing))+ , ("Named", altWith namedSchema $ prism' (uncurry Named) (\case Named s sc -> Just (s,sc) ; _ -> Nothing))+ , ("Empty", alt $ prism' (const Empty) (\case Empty -> Just () ; _ -> Nothing)) ] where namedSchema = record $ (,) <$> field "name" fst <*> field "schema" snd@@ -127,8 +127,8 @@ <*> field "$5" (view _5) instance (HasSchema a, HasSchema b) => HasSchema (Either a b) where- schema = union' [alt "Left" _Left, alt "Right" _Right]- <> union' [alt "left" _Left, alt "right" _Right]+ schema = union [("Left", alt _Left), ("Right", alt _Right)+ ,("left", alt _Left), ("right", alt _Right)] instance (Eq key, Hashable key, HasSchema a, Key key) => HasSchema (HashMap key a) where schema = dimap toKeyed fromKeyed $ stringMap schema@@ -153,34 +153,34 @@ -- HasSchema aware combinators -- ----------------------------------------------------------------------------------- -- | Extract the default 'Schema' for a type-theSchema :: forall a . HasSchema a => Schema-theSchema = case extractSchema (schema @a) of x :| _ -> x+schemaFor :: forall a . HasSchema a => Schema+schemaFor = case extractSchema (schema @a) of x :| _ -> x validatorsFor :: forall a . HasSchema a => Validators validatorsFor = extractValidators (schema @a) -- | encode using the default schema-encode :: HasSchema a => a -> Value+encode :: HasSchema a => (a -> Value) encode = encodeWith schema -- | Attempt to encode to the target schema using the default schema. -- First encodes using the default schema, then computes a coercion -- applying 'isSubtypeOf', and then applies the coercion to the encoded data.-encodeTo :: HasSchema a => Schema -> Either [(Trace, Mismatch)] (a -> Value)+encodeTo :: HasSchema a => Schema -> Either TracedMismatches (a -> Value) encodeTo = encodeToWith schema -- | Decode using the default schema.-decode :: HasSchema a => Value -> Either [(Trace, DecodeError)] a+decode :: HasSchema a => Value -> Result a decode = decodeWith schema -- | Apply `isSubtypeOf` to construct a coercion from the source schema to the default schema, -- apply the coercion to the data, and attempt to decode using the default schema.-decodeFrom :: HasSchema a => Schema -> Either [(Trace, DecodeError)] (Value -> Either [(Trace, DecodeError)] a)+decodeFrom :: HasSchema a => Schema -> Result (Value -> Result a) decodeFrom = decodeFromWith schema --- | Coerce from 'sub' to 'sup'Returns 'Nothing' if 'sub' is not a subtype of 'sup'+-- | 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+coerce = case isSubtypeOf (validatorsFor @sub) (schemaFor @sub) (schemaFor @sup) of Right cast -> Just . cast _ -> const Nothing @@ -200,8 +200,8 @@ -> (from -> Either e a) -> e -> RecordFields from (Either e a)-optFieldEither n x e = optFieldGeneral (lmap x $ liftRight schema) n (Left e)+optFieldEither n f e = optFieldEitherWith (lmap f (liftRight schema)) n e -- | @alt name prism@ introduces a discriminated union alternative with the default schema-alt :: HasSchema a => Text -> Prism' from a -> UnionTag from+alt :: HasSchema a => Prism' from a -> UnionAlt from alt = altWith schema
+ src/Schemas/Delay.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+module Schemas.Delay where++import Control.Monad.Trans.Iter+import Numeric.Natural++type DelayT m = IterT m+type Delay = Iter++lift :: Monad m => Iter a -> IterT m a+lift = liftIter++runDelay :: Monad m => Natural -> DelayT m a -> m (Maybe a)+runDelay n = retract . cutoff (fromIntegral n)++runDelayUnbounded :: Monad m => DelayT m a -> m a+runDelayUnbounded = retract
src/Schemas/Internal.hs view
@@ -1,30 +1,35 @@+{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-}-{-# OPTIONS -Wno-name-shadowing #-}+{-# OPTIONS -Wno-name-shadowing #-}+ module Schemas.Internal where import Control.Alternative.Free-import Control.Applicative (Alternative (..))-import Control.Exception+import Control.Applicative (Alternative (..), optional) import Control.Lens hiding (Empty, allOf, enum, (<.>))-import Control.Monad-import Control.Monad.Trans.Except+import Control.Monad.Except+import Control.Monad.Trans.Iter+import Control.Monad.State import Data.Aeson (Value) import qualified Data.Aeson as A import Data.Biapplicative+import Data.Bitraversable import Data.Coerce import Data.Either import Data.Foldable (asum)@@ -32,6 +37,7 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map import qualified Data.HashSet as Set+import Data.List (find) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Maybe@@ -42,8 +48,10 @@ import qualified Data.Vector as V import Data.Void import GHC.Exts (IsList (..))+import Numeric.Natural import Prelude hiding (lookup)-import Schemas.Untyped+import Schemas.Attempt as Attempt+import Schemas.Untyped as U import Unsafe.Coerce @@ -66,21 +74,50 @@ -- | 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's also crucial for implementing unions on top of TOneOf- -- it could be exposed to provide some form of error handling, but currently is not- TTry ::Text -> TypedSchemaFlex a b -> (a' -> Maybe a) -> TypedSchemaFlex a' b+ TOneOf :: TypedSchemaFlex from' a'+ -> TypedSchemaFlex from'' a''+ -> (Either a' a'' -> a)+ -> (from -> Either from' from'')+ -> TypedSchemaFlex from a+ TPure :: a -> TypedSchemaFlex from a+ TEmpty :: (Void -> a) -> (from -> Void) -> TypedSchemaFlex from a+ TPrim :: Text -> (Value -> A.Result a) -> (from -> Value) -> TypedSchemaFlex from a RecordSchema ::RecordFields from a -> TypedSchemaFlex from a instance Show (TypedSchemaFlex from a) where show = show . NE.head . extractSchema -type TypedSchema a = TypedSchemaFlex a a+instance Functor (TypedSchemaFlex from) where+ fmap = rmap +instance Profunctor TypedSchemaFlex where+ dimap g f (TEmpty tof fromf) = TEmpty (f . tof) (fromf . g)+ dimap _ f (TPure a) = TPure (f a)+ dimap g f (TNamed n sc tof fromf) = TNamed n sc (f . tof) (fromf . g)+ dimap g f (TAllOf scc ) = TAllOf (dimap g f <$> scc)+ dimap g f (TOneOf sca scb to fr ) = TOneOf sca scb (f . to) (fr . g)+ 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 (TypedSchemaFlex Void Void) where+ mempty = emptySchema++instance Semigroup (TypedSchemaFlex f a) where+ -- | Allows defining multiple schemas for the same thing, effectively implementing versioning.+ -- a <> b | pTraceShow ("Semigroup TypedSchema", a,b) False= undefined+ x <> TEmpty{} = x+ TEmpty{} <> x = x+ TAllOf aa <> b = allOf (aa <> [b])+ a <> TAllOf bb = allOf ([a] <> bb)+ a <> b = allOf [a, b]++ sconcat = allOf++type TypedSchema a = TypedSchemaFlex a a+ -- | @named n sc@ annotates a schema with a name, allowing for circular schemas. named :: SchemaName -> TypedSchemaFlex from' a -> TypedSchemaFlex from' a named n sc = TNamed n sc id id@@ -125,47 +162,29 @@ readShow :: (Read a, Show a) => TypedSchema a readShow = dimap show read string --- | The schema of undiscriminated unions. Prefer using 'union' where possible-oneOf :: NonEmpty (TypedSchemaFlex from a) -> TypedSchemaFlex from a-oneOf [x] = x-oneOf x = TOneOf $ sconcat $ fmap f x where- f (TOneOf xx) = xx- f (x ) = [x]--instance Functor (TypedSchemaFlex from) where- fmap = rmap--instance Profunctor (TypedSchemaFlex) where- dimap g f (TNamed n sc tof fromf) = TNamed n sc (f . tof) (fromf . g)- dimap _ f (TEmpty a ) = TEmpty (f a)- dimap g f (TTry n sc try ) = TTry n (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+-- | 'eitherSchema' and 'emptySchema' make 'TypedSchemaFlex' an almost instance of 'SumProfunctor' (no 'Choice')+eitherSchema+ :: TypedSchemaFlex from a+ -> TypedSchemaFlex from' a'+ -> TypedSchemaFlex (Either from from') (Either a a')+eitherSchema sc sc' = TOneOf sc sc' id id -instance Semigroup (TypedSchemaFlex f a) where- -- | Allows defining multiple schemas for the same thing, effectively implementing versioning.- TEmpty a <> TEmpty _ = TEmpty a- TEmpty{} <> x = x- x <> TEmpty{} = x- TAllOf aa <> b = allOf (aa <> [b])- a <> TAllOf bb = allOf ([a] <> bb)- a <> b = allOf [a, b]+-- | The vacuous schema+emptySchema :: TypedSchema Void+emptySchema = TEmpty id id - sconcat = allOf+-- | The schema that can be decoded but not encoded+pureSchema :: a -> TypedSchemaFlex from a+pureSchema = TPure allOf :: NonEmpty (TypedSchemaFlex from a) -> TypedSchemaFlex from a-allOf [x] = x-allOf x = TAllOf $ sconcat $ fmap f x where- f (TAllOf xx) = xx+allOf x = allOf' $ sconcat $ fmap f x where+ f (TAllOf xx) = NE.toList xx+ f TEmpty{} = [] f x = [x]+ allOf' [] = error "empty allOf"+ allOf' [x] = x+ allOf' x = TAllOf $ NE.fromList x -- -------------------------------------------------------------------------------- -- Applicative records@@ -175,9 +194,9 @@ , fieldTypedSchema :: TypedSchemaFlex from a } -> RecordField from a OptionalAp ::{ fieldName :: Text- , fieldTypedSchema :: TypedSchemaFlex from a- , fieldDefValue :: a- } -> RecordField from a+ , fieldTypedSchema :: TypedSchemaFlex from a+ , fieldDefaultValue :: a+ } -> RecordField from a -- | Lens for the 'fieldName' attribute fieldNameL :: Lens' (RecordField from a) Text@@ -186,8 +205,8 @@ (\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)+ dimap f g (RequiredAp name sc) = RequiredAp name (dimap f g sc)+ dimap f g (OptionalAp name sc v) = OptionalAp name (dimap f g sc) (g v) -- | An 'Alternative' profunctor for defining record schemas with versioning --@@ -219,42 +238,43 @@ fieldWith' :: TypedSchemaFlex from a -> Text -> RecordFields from a fieldWith' (schema) n = RecordFields $ liftAlt (RequiredAp n schema) --- | Project a schema through a Prism. Returns a partial schema.--- When encoding/decoding a value that doesn't fit the prism,+-- | Project a schema through a Prism.+liftPrism :: Prism s t a b -> TypedSchemaFlex a b -> TypedSchemaFlex t t -> TypedSchemaFlex s t+liftPrism p sc otherwise = withPrism p $ \t f -> TOneOf otherwise sc (either id t) f++-- | Returns a partial schema.+-- When encoding/decoding a Nothing value, -- an optional field will be omitted, and a required field will cause -- this alternative to be aborted.-liftPrism :: Text -> Prism s t a b -> TypedSchemaFlex a b -> TypedSchemaFlex s t-liftPrism n p sc =- withPrism p $ \t f -> rmap t (TTry n sc (either (const Nothing) Just . f))---- | @liftJust = liftPrism _Just@ liftJust :: TypedSchemaFlex a b -> TypedSchemaFlex (Maybe a) (Maybe b)-liftJust = liftPrism "Just" _Just+liftJust sc = liftPrism _Just sc $ TEmpty absurd $ error "liftJust" --- | @liftRight = liftPrism _Right@+-- | Returns a partial schema.+-- When encoding/decoding a Left value,+-- an optional field will be omitted, and a required field will cause+-- this alternative to be aborted. liftRight :: TypedSchemaFlex a b -> TypedSchemaFlex (Either c a) (Either c b)-liftRight = liftPrism "Right" _Right+liftRight sc = liftPrism _Right sc $ TEmpty absurd $ error "liftRight" --- | 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)+optFieldWith = optFieldGeneral Nothing -- | The most general introduction form for optional alts optFieldGeneral- :: forall a from . TypedSchemaFlex from a -> Text -> a -> RecordFields from a-optFieldGeneral schema n def = RecordFields $ liftAlt (OptionalAp n schema def)+ :: forall a from . a ->TypedSchemaFlex from a -> Text -> RecordFields from a+optFieldGeneral def schema n = RecordFields $ liftAlt (OptionalAp n schema def) --- | A generalized version of 'optFieldEither'. Does not handle infinite/circular data+-- | A generalized version of 'optFieldEither'. optFieldEitherWith :: TypedSchemaFlex from (Either e a) -> Text -> e -> RecordFields from (Either e a)-optFieldEitherWith schema n e = optFieldGeneral schema n (Left e)+optFieldEitherWith sc n e = optFieldGeneral (Left e) sc n extractFieldsHelper :: Alternative f@@ -266,40 +286,43 @@ -- -------------------------------------------------------------------------------- -- Typed Unions --- | The schema of discriminated unions---++-- | An alternative in a union type+data UnionAlt from where+ UnionAlt :: Prism' from b -> TypedSchema b -> UnionAlt from++-- | Declare an alternative in a union type+altWith :: TypedSchema a -> Prism' from a -> UnionAlt from+altWith sc p = UnionAlt p sc++-- | Discriminated unions that record the name of the chosen constructor in the schema -- @--- import Schemas--- import "generic-lens" Data.Generics.Labels ()--- import GHC.Generics--- -- data Education = Degree Text | PhD Text | NoEducation -- -- schemaEducation = union'--- [ alt \"NoEducation\" #_NoEducation--- , alt \"Degree\" #_Degree--- , alt \"PhD\" #_PhD+-- [ (\"NoEducation\", alt #_NoEducation)+-- , (\"Degree\" , alt #_Degree)+-- , (\"PhD\" , alt #_PhD) -- ] -- @---- | Given a non empty set of tagged partial schemas, constructs the schema that applies--- them in order and selects the first successful match.-union :: (NonEmpty (Text, TypedSchema a)) -> TypedSchema a-union args = oneOf (mk <$> args)- where mk (name, sc) = RecordSchema $ fieldWith' sc name---- | Existential wrapper for convenient definition of discriminated unions-data UnionTag from where- UnionTag ::Text -> Prism' from b -> TypedSchema b -> UnionTag from---- | @altWith name prism schema@ introduces a discriminated union alternative-altWith :: TypedSchema a -> Text -> Prism' from a -> UnionTag from-altWith sc n p = UnionTag n p sc+union :: (NonEmpty ((Text,UnionAlt from))) -> TypedSchema from+union (a :| rest) = go (a:rest) where+ go ((n, UnionAlt p sc) : rest) = liftPrism p (RecordSchema $ fieldWith' sc n) $ go rest+ go [] = TEmpty absurd (error "incomplete union definition") --- | Given a non empty set of constructors, construct the schema that selects the first--- matching constructor-union' :: (NonEmpty (UnionTag from)) -> TypedSchema from-union' args = union $ args <&> \(UnionTag c p sc) -> (c, liftPrism c p sc)+-- | Undiscriminated union that do not record the name of the constructor in the schema+-- data Education = Degree Text | PhD Text | NoEducation+--+-- schemaEducation = oneOf+-- [ alt #_NoEducation+-- , alt #_Degree+-- , alt #_PhD+-- ]+-- @+oneOf :: (NonEmpty (UnionAlt from)) -> TypedSchema from+oneOf (a :| rest) = go (a:rest) where+ go (UnionAlt p sc : rest) = liftPrism p sc $ go rest+ go [] = TEmpty absurd (error "incomplete oneOf definition") -- -------------------------------------------------------------------------------- -- Schema extraction from a TypedSchema@@ -311,17 +334,20 @@ -- Beware when using on schemas with multiple alternatives, -- as the number of versions is exponential. extractSchema :: TypedSchemaFlex from a -> NonEmpty Schema+-- extractSchema xx | pTraceShow ("extractSchema") False = undefined+extractSchema TPure{} = pure Unit extractSchema (TNamed n sc _ _) = Named n <$> extractSchema sc extractSchema (TPrim n _ _ ) = pure $ Prim n-extractSchema (TTry _ sc _ ) = extractSchema sc-extractSchema (TOneOf scc ) = pure $ OneOf $ extractSchema =<< scc+extractSchema (TOneOf s s' _ _) = (<>) <$> extractSchema s <*> extractSchema s' extractSchema (TAllOf scc ) = extractSchema =<< scc-extractSchema (TEmpty{} ) = pure $ Empty extractSchema (TEnum opts _ ) = pure $ Enum (fst <$> opts)-extractSchema (TArray sc _ _ ) = Array <$> extractSchema sc+extractSchema (TArray sc _ _ ) = Array <$> extractSchema sc extractSchema (TMap sc _ _ ) = StringMap <$> extractSchema sc extractSchema (RecordSchema rs) =- fromList $ foldMap (\x -> pure (Record (fromList x))) (extractFields rs)+ case foldMap (\x -> pure (Record (fromList x))) (extractFields rs) of+ [] -> pure Empty+ other -> fromList other+extractSchema TEmpty{} = pure Empty -- | Extract all the field groups (from alternatives) in the record extractFields :: RecordFields from to -> [[(Text, Field)]]@@ -347,53 +373,92 @@ ) ) ]- go (TOneOf scc ) = foldMap go scc+ go (TOneOf a b _ _) = go a <> go b go (TAllOf scc ) = foldMap go scc go (TArray sc _ _) = go sc go (TMap sc _ _) = go sc- go (TTry _ sc _) = go sc go (RecordSchema rs) = mconcat $ mconcat (extractFieldsHelper (pure . go . fieldTypedSchema) rs) go _ = [] -- ---------------------------------------------------------------------------------------+-- Results++type TracedMismatches = [(Trace, Mismatch)]++newtype IterAltT m a = IterAlt {runIterAlt :: IterT m a}+ deriving newtype (Applicative, Functor, Monad, MonadError e, MonadState s, MonadTrans, MonadFree Identity, Eq, Show)++instance (MonadPlus m) => Alternative (IterAltT m) where+ empty = IterAlt (lift empty)+ IterAlt (IterT ma) <|> IterAlt (IterT mb) = IterAlt $ IterT $+ do a <- optional ma+ case a of+ Nothing -> mb+ Just (Left done) -> pure (Left done)+ Just (Right more_a) -> do+ b <- optional mb+ case b of+ Nothing -> pure $ Right more_a+ Just (Left done) -> pure (Left done)+ Just (Right more_b) -> pure $ Right (more_a <|> more_b)+++runDelay :: Monad m => Natural -> IterAltT m a -> m (Maybe a)+runDelay n = retract . cutoff (fromIntegral n) . runIterAlt++-- | A monad encapsulating failure as well as non-termination+newtype Result a = Result { getResult :: IterAltT (Attempt TracedMismatches) a}+ deriving newtype (Applicative, Alternative, Functor, Monad, MonadError TracedMismatches, MonadFree Identity, Eq, Show)++liftAttempt :: Attempt TracedMismatches a -> Result a+liftAttempt = Result . lift++-- | Run a 'Result' up with bounded depth. Returns nothing if it runs out of steps.+runResult :: MonadError TracedMismatches g => Natural -> Result a -> g (Maybe a)+runResult maxSteps = execAttempt . runDelay maxSteps . getResult++-- --------------------------------------------------------------------------------------- -- Encoding to JSON -type E = [(Trace, Mismatch)]+type Partial = IterT Maybe --- | Given a typed schema, produce a JSON encoder to the firt version returned by 'extractSchema'-encodeWith :: TypedSchemaFlex from a -> from -> Value-encodeWith sc = fromRight (error "Internal error")- $ encodeToWith sc (NE.head $ extractSchema sc)+-- | Given a typed schema, produce a JSON encoder to the first version produced by 'extractSchema'+encodeWith :: TypedSchemaFlex from a -> (from -> Value)+encodeWith sc = ensureSuccess encoder+ where+ encoder = encodeToWith sc (NE.head $ extractSchema sc)+ ensureSuccess = either (error.show) id -- | Given source and target schemas, produce a JSON encoder-encodeToWith :: TypedSchemaFlex from a -> Schema -> Either E (from -> Value)-encodeToWith sc target =- (\m -> either (throw . AllAlternativesFailed) id . runExcept . m)- <$> runExcept (go [] [] sc (target))+encodeToWith :: TypedSchemaFlex from a -> Schema -> Either TracedMismatches (from -> Value)+encodeToWith sc target = runAttempt $+ (fmap.fmap) (fromMaybe (error "Empty schema")) $+ (go [] [] sc (target)) where- failWith ctx m = throwE [(reverse ctx, m)]+ failWith ctx m = throwError [(reverse ctx, m)] go :: forall from a- . [(SchemaName, Except E (Void -> Except E Value))]+ . [(SchemaName, Attempt TracedMismatches (Void -> Maybe Value))] -> Trace -> TypedSchemaFlex from a -> Schema- -> Except E (from -> Except E Value)+ -> Attempt TracedMismatches (from -> Maybe Value)+ -- go _ _ sc s | pTraceShow ("encode", sc, s) False = undefined go env ctx (TNamed n sct _ fromf) (Named n' sc) | n == n' = case lookup n env of- Just res -> do- -- TODO understand why this delay is necessary- return $ unsafeDelay $ lmap (unsafeCoerce . fromf) <$> res+ Just res ->+ lmap (unsafeCoerce . fromf) <$> res Nothing ->- let res = go ((n, resDyn) : env) ctx sct sc+ let res = go ((n, resDynLater) : env) ctx sct sc resDyn = lmap unsafeCoerce <$> res+ resDynLater = (pure . fromMaybe (error "impossible") . attemptSuccess) resDyn in lmap fromf <$> res- go _ _tx TEmpty{} Array{} = pure $ pure . const (A.Array [])- go _ _tx TEmpty{} Record{} = pure $ pure . const (A.Object [])- go _ _tx TEmpty{} StringMap{} = pure $ pure . const (A.Object [])- go _ _tx TEmpty{} OneOf{} = pure $ pure . const emptyValue+ go _ _ _ Empty = pure $ pure . const emptyValue+ go _ _tx TPure{} Array{} = pure $ pure . const (A.Array [])+ go _ _tx TPure{} StringMap{} = pure $ pure . const (emptyValue)+ go _ _tx (TEmpty _ _) _ = pure $ const empty go _ ctx (TPrim n _ fromf) (Prim n') | n == n' = pure $ pure . fromf | otherwise = failWith ctx (PrimMismatch n n')@@ -408,84 +473,70 @@ Nothing -> pure $ pure . A.String . fromf Just xx -> failWith ctx $ MissingEnumChoices xx go n ctx (TAllOf scc) t = asum $ imap (\i sc -> go n (tag i : ctx) sc t) scc- go n ctx (TOneOf scc) t = do- alts <- itraverse (\i sc -> go n (tag i : ctx) sc t) scc- return $ \x -> asum $ fmap ($ x) alts- go i ctx sc (OneOf tt) = asum $ fmap (go i ctx sc) tt- go i ctx (TTry n sc try) t = do- f <- go i (n : ctx) sc t- return $ \x -> f =<< maybe (failWith ctx (TryFailed n)) pure (try x)+ go n ctx (TOneOf a b _ fromf) t = do+ encoderA <- go n ("L" : ctx) a t+ encoderB <- go n ("R" : ctx) b t+ pure $ \x -> either encoderA encoderB (fromf x)+ go i ctx sc (OneOf tt) = asum $ fmap (go i ctx sc) (tt <> [Empty]) go i ctx (RecordSchema rec) (Record target) = do- let alternatives = runAlt_ extractField (getRecordFields rec)- let targetFields = Set.fromList (Map.keys target)- let complete =- filter ((targetFields ==) . Set.fromList . fmap fst) alternatives- case complete of- [] -> failWith ctx NoMatches- alts -> pure $ \x -> asum $ fmap- (\alt ->- A.Object- . fromList- . (mapMaybe (sequenceOf _2))- <$> traverse (\(fn, f) -> (fn, ) <$> f x) alt- )- alts+ let candidates = runAlt_ extractField (getRecordFields rec)+ case find (\candidate -> Set.fromList (map fst candidate) == targetFields) candidates of+ Nothing -> failWith ctx $+ SchemaMismatch (NE.head $ extractSchema $ RecordSchema rec) (Record target)+ Just solution -> pure $ \x -> do+ fields <- traverse (\(_,f) -> case f x of Nothing -> Nothing ; Just (n,y) -> Just $ (n,) <$> y) solution+ return $ A.object $ catMaybes fields where+ targetFields = Set.fromList (Map.keys target)++ liftGo = (either (const empty) pure . runAttempt)+ extractField :: forall from a . RecordField from a- -> [[(Text, from -> Except E (Maybe Value))]]+ -> [] [(Text, from -> Maybe (Text, Maybe Value))] extractField RequiredAp {..} = case Map.lookup fieldName target of- Nothing -> return []+ Nothing -> pure [] Just targetField -> do- case- runExcept $ go i- (fieldName : ctx)- fieldTypedSchema- (fieldSchema targetField)- of- Left _ -> empty- Right f -> do- let decoder x = Just <$> f x `catchE` \mm ->- failWith ctx (InvalidRecordField fieldName mm)- return [(fieldName, decoder)]+ f <- liftGo $+ go i (fieldName : ctx)+ fieldTypedSchema+ (fieldSchema targetField)+ return $+ let encoder = fmap ((fieldName,) . Just) . f+ in [(fieldName, encoder)] extractField OptionalAp {..} = case Map.lookup fieldName target of- Nothing -> return []+ Nothing -> pure [] Just targetField -> do guard $ not (isRequired targetField)- case- runExcept $ go i- (fieldName : ctx)+ f <- liftGo $ go i (fieldName : ctx) fieldTypedSchema (fieldSchema targetField)- of- Left _ -> empty- Right f -> do- let decoder x = (Just <$> f x) `catchE` \_ -> pure Nothing- return [(fieldName, decoder)]++ return $+ let encoder = Just . (fieldName,) . f+ in [(fieldName, encoder)] go i ctx sc (Array t) = do f <- go i ctx sc t return $ A.Array . fromList . (: []) <.> f- go _ _tx _ Empty = pure $ pure . const emptyValue+ go _ _tx _ Unit = pure $ const (pure emptyValue)+ -- go _ _ other src | pTraceShow ("mismatch", other, src) False = undefined go _ ctx other src = failWith ctx (SchemaMismatch (NE.head $ extractSchema other) src) -- -------------------------------------------------------------------------- -- Decoding -type D = [(Trace, DecodeError)]--type DecodeError = Mismatch- -- | Runs a schema as a function @enc -> dec@. Loops for infinite/circular data-runSchema :: TypedSchemaFlex enc dec -> enc -> Either [DecodeError] dec+runSchema :: TypedSchemaFlex enc dec -> enc -> Either [Mismatch] dec runSchema sc = runExcept . go sc where- go :: forall from a . TypedSchemaFlex from a -> from -> Except [DecodeError] a- go (TEmpty a ) _ = pure a+ go :: forall from a . TypedSchemaFlex from a -> from -> Except [Mismatch] a+ go (TPure x) _ = pure x+ go (TEmpty toF fromF ) x = pure $ toF $ fromF x+ -- TODO handle circular data go (TNamed _ sc tof fromF) a = tof <$> go sc (fromF a)- go (TTry n sc try) from = maybe (throwE [TryFailed n]) (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))@@ -496,43 +547,68 @@ 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 (TOneOf sc sc' toF fF) from = toF <$> bitraverse (go sc) (go sc') (fF from) go (RecordSchema alts ) from = runAlt f (getRecordFields alts) where- f :: RecordField from b -> Except [DecodeError] b+ f :: RecordField from b -> Except [Mismatch] b f RequiredAp {..} = go fieldTypedSchema from f OptionalAp {..} = go fieldTypedSchema from - failWith e = throwE [e]+ failWith e = throwError [e] +-- | Evaluates a schema as a value of type 'dec'. Can only succeed if the schema contains a 'TPure' alternative+evalSchema :: forall enc dec . TypedSchemaFlex enc dec -> Maybe dec+evalSchema (TPure x ) = pure x+evalSchema TEmpty{} = Nothing+-- TODO handle circular data+evalSchema (TNamed _ sc tof _) = tof <$> evalSchema sc+evalSchema (TPrim _ _ _) = empty+evalSchema (TEnum _ _) = empty+evalSchema (TMap _sc _ _) = empty+evalSchema (TArray _sc _ _) = empty+evalSchema (TAllOf scc ) = msum $ evalSchema <$> scc+evalSchema (TOneOf sc sc' toF _) =+ toF <$> ((Left <$> evalSchema sc) <|> (Right <$> evalSchema sc'))+evalSchema (RecordSchema alts ) = runAlt f (getRecordFields alts)+ where+ f :: RecordField from b -> Maybe b+ f RequiredAp {..} = evalSchema fieldTypedSchema+ f OptionalAp {..} = evalSchema fieldTypedSchema+ -- | Given a JSON 'Value' and a typed schema, extract a Haskell value-decodeWith :: TypedSchemaFlex from a -> Value -> Either D a+decodeWith :: TypedSchemaFlex from a -> Value -> Result a decodeWith sc v = decoder >>= ($ v) where decoder = decodeFromWith sc (NE.head $ extractSchema sc) decodeFromWith- :: TypedSchemaFlex from a -> Schema -> Either D (Value -> Either D a)+ :: TypedSchemaFlex from a -> Schema -> Result(Value -> Result a) -- TODO merge runSchema and decodeFromWith ?-decodeFromWith sc source = (runExcept .) <$> runExcept (go [] [] sc (source))+-- TODO expose non-termination as an effect+decodeFromWith sc source = Result $ todoExposeNonTermination $ go [] [] sc source where- failWith ctx e = throwE [(reverse ctx, e)]+ todoExposeNonTermination = lift + failWith ctx e = throwError [(reverse ctx, e)]+ go- :: [(SchemaName, Except D (Value -> Except D Void))]+ :: [(SchemaName, Attempt TracedMismatches (Value -> Result Void))] -> Trace -> TypedSchemaFlex from a -> Schema- -> Except D (Value -> Except D a)- go _nv _tx (TEmpty a) _ = pure $ const $ pure a+ -> Attempt TracedMismatches (Value -> Result a)+ -- go _ _ t s | pTraceShow ("decode", t,s) False = undefined+ go _nv _tx (TPure a) Unit = pure $ \_ -> pure a+ go _ ctx TEmpty{} Empty = pure $ const $ failWith ctx EmptySchema go env ctx (TNamed n sc tof _) (Named n' s) | n == n' = case lookup n env of- Just sol -> do- -- TODO understand why this delay is necessary- return $ unsafeDelay $ (fmap . fmap . fmap) (tof . unsafeCoerce) sol+ Just sol ->+ (fmap . fmap . fmap) (tof . unsafeCoerce) sol Nothing ->- let sol = go ((n, solDyn) : env) ctx sc s- solDyn = (fmap . fmap . fmap) unsafeCoerce sol+ let sol = go ((n, solDynLater) : env) ctx sc s+ solDelayed = (fmap . fmap) delay sol+ solDyn = (fmap . fmap . fmap) unsafeCoerce solDelayed+ solDynLater = pure $ fromMaybe (error "impossible") $ attemptSuccess solDyn in (fmap . fmap . fmap) tof sol- go env ctx (TNamed _ sc tof _) s = (fmap . fmap . fmap) tof $ go env ctx sc s+ -- go env ctx (TNamed _ sc tof _) s = (fmap . fmap . fmap) tof $ go env ctx sc s go _nv ctx (TEnum optsTarget _) s@(Enum optsSource) = case NE.nonEmpty@@ -546,90 +622,75 @@ other -> failWith ctx (ValueMismatch s other) go env ctx (TArray sc tof _) s@(Array src) = do f <- go env ("[]" : ctx) sc src- return $ \case+ pure $ \case A.Array x -> tof <$> traverse f x other -> failWith ctx (ValueMismatch s other) go env ctx (TMap sc tof _) s@(StringMap src) = do f <- go env ("Map" : ctx) sc src- return $ \case+ pure $ \case A.Object x -> tof <$> traverse f x other -> failWith ctx (ValueMismatch s other) go _nv ctx (TPrim n tof _) (Prim src) | n /= src = failWith ctx (PrimMismatch n src)- | otherwise = return $ \x -> case tof x of+ | otherwise = pure $ \x -> case tof x of A.Error e -> failWith ctx (PrimError n (pack e))- A.Success a -> return a- go env ctx (TTry n sc _try) x = go env (n : ctx) sc x+ A.Success a -> pure a go env ctx (TAllOf scc ) src = do- let parsers = map (\sc -> runExcept $ go env ctx sc src) (NE.toList scc)+ let parsers = map (\sc -> runAttempt $ go env ctx sc src) (NE.toList scc) case partitionEithers parsers of (ee, []) -> failWith ctx (AllAlternativesFailed (concat ee))- (_ , pp) -> return $ \x -> asum (map ($ x) pp)- go env ctx (TOneOf scc) src = do- let parsers = map (\sc -> runExcept $ go env ctx sc src) (NE.toList scc)- case partitionEithers parsers of+ (_ , pp) -> do+ pure $ \x -> asum (map ($ x) pp)+ go env ctx (TOneOf sc sc' tof _) src = do+ let parserL = runAttempt $ (Left <.>) <$> go env ctx sc src+ let parserR = runAttempt $ (Right <.>) <$> go env ctx sc' src+ case partitionEithers [parserL, parserR] of (ee, []) -> failWith ctx (AllAlternativesFailed (concat ee))- (_ , pp) -> return $ \x -> asum (map ($ x) pp)- go env ctx (RecordSchema (RecordFields rec)) (Record src) = do- let solutions = coerce $ runAlt f' rec- -- make sure there are no unused fields- sourceFields = Map.keys src- valid = map- (\(tgtFields, f) ->- case Set.difference (fromList sourceFields) (fromList tgtFields) of- [] -> Right f- xx -> Left (Set.toList xx)- )- solutions- case partitionEithers valid of- (ee, [] ) -> throwE [(reverse ctx, UnusedFields ee)]- (_ , alts) -> pure $ \x -> asum $ fmap ($ x) alts+ (_ , pp) -> do+ pure $ \x -> tof <$> asum (map ($ x) pp)+ go env ctx (RecordSchema (RecordFields rec)) (Record src) = unliftGo $ coerce $ runAlt f' rec where- f'- :: RecordField from a- -> ([] `Compose` (,) [Text] `Compose` (->) Value `Compose` (Except D))- a+ sourceFields = Map.keysSet src++ liftGo = either (const empty) pure . runAttempt++ unliftGo = maybe (failWith ctx NoMatches) (pure . snd)+ . find @[] (\(tgtFields,_) -> null $ Set.difference sourceFields (fromList tgtFields))++ f' :: RecordField from a -> ([] `Compose`(,) [Text] `Compose` (->) Value `Compose` Result) a f' x = coerce (f x)- f :: RecordField from a -> [([Text], Value -> Except D a)]++ f :: RecordField from a -> [([Text], Value -> Result a)] f RequiredAp {..} = case Map.lookup fieldName src of Nothing -> empty Just srcField -> do guard $ isRequired srcField- case- runExcept- $ go env (fieldName : ctx) fieldTypedSchema (fieldSchema srcField)- of- Left _ -> empty- Right f -> return- ( [fieldName]- , \case- A.Object o -> case Map.lookup fieldName o of- Nothing ->- failWith (fieldName : ctx) (MissingRecordField fieldName)- Just v -> f v- )+ f <- liftGo $ go env (fieldName : ctx) fieldTypedSchema (fieldSchema srcField)+ pure $+ let decoder v =+ case v of+ A.Object o -> case Map.lookup fieldName o of+ Nothing ->+ failWith (fieldName : ctx) (MissingRecordField fieldName)+ Just v -> f v+ other -> failWith ctx (InvalidRecordValue other)+ in ([fieldName], decoder) f OptionalAp {..} = case Map.lookup fieldName src of- Nothing -> return ([fieldName], const $ return fieldDefValue)+ Nothing -> pure ([], const $ pure fieldDefaultValue) Just srcField -> do- case- runExcept- $ go env (fieldName : ctx) fieldTypedSchema (fieldSchema srcField)- of- Left _ -> empty- Right f -> return- ( [fieldName]- , \case+ f <- liftGo $ go env (fieldName : ctx) fieldTypedSchema (fieldSchema srcField)+ pure $+ let decoder v = case v of A.Object o -> case Map.lookup fieldName o of- Nothing -> return fieldDefValue+ Nothing -> pure fieldDefaultValue Just v -> f v- )+ other -> failWith ctx (InvalidRecordValue other)+ in ([fieldName], decoder) - go env ctx s (OneOf xx ) = asum $ fmap (go env ctx s) xx- go env ctx sc (Named _ s) = go env ctx sc s+ go env ctx s (OneOf xx) = asum $ fmap (go env ctx s) xx go _nv ctx s src = failWith ctx (SchemaMismatch (NE.head $ extractSchema s) src) - -- ---------------------------------------------- -- Utils @@ -641,7 +702,3 @@ f <.> g = fmap f . g infixr 8 <.>---unsafeDelay :: Except a c -> c-unsafeDelay = fromRight (error "internal error") . runExcept
src/Schemas/OpenApi2.hs view
@@ -27,6 +27,7 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Writer import Data.Aeson (Value)+import Data.Function import Data.Functor import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map@@ -44,7 +45,7 @@ -- Failures are omitted, use 'toOpenApi2Document' if you care. encodeAsOpenApi2Document :: OpenApi2Options -> Text -> Schema -> Value encodeAsOpenApi2Document opts n sc =- encode $ toOpenApi2Document opts (Map.fromList [(n, sc)])+ encode & ($ toOpenApi2Document opts (Map.fromList [(n, sc)])) -- | A catalog of definitions data OpenApi2Document = OpenApi2Document@@ -77,7 +78,7 @@ , properties :: Maybe (HashMap Text OpenApi2Schema) , required :: Maybe [Text] }- deriving (Generic, Show)+ deriving (Eq, Generic, Show) deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) instance HasSchema OpenApi2Schema where@@ -136,6 +137,7 @@ :: (Text -> Maybe OpenApi2Schema) -> Schema -> WriterT OpenApi2Document (Except Reason) OpenApi2Schema+toOpenApi2 _rim Empty = lift $ throwE $ Unsupported "empty" toOpenApi2 prim (Array sc) = toOpenApi2 prim sc <&> \sc2 -> (defOpenApi2Schema OpenApi2Array) { items = Just sc2 } toOpenApi2 prim (StringMap sc) = toOpenApi2 prim sc <&> \sc2 ->@@ -159,8 +161,8 @@ } toOpenApi2 prim (Prim p) | Just y <- prim p = pure y toOpenApi2 _rim (Prim p) = lift $ throwE $ Unsupported $ "Unknown prim: " <> p-toOpenApi2 _rim OneOf{} =- lift $ throwE $ Unsupported "undiscriminated unions (OneOf)"+toOpenApi2 _rim s@OneOf{} =+ lift $ throwE $ Unsupported $ "undiscriminated unions (OneOf): " <> Text.pack (show s) -- TODO future work -- fromOpenApi2 :: OpenApi2 -> Schema
src/Schemas/SOP.hs view
@@ -17,8 +17,8 @@ ) where +import Control.Lens (prism') import qualified Data.List.NonEmpty as NE-import Data.Maybe import Data.Profunctor import Data.Text (Text, pack) import Generics.SOP as SOP@@ -38,7 +38,7 @@ fieldSchemaC :: Proxy FieldEncode fieldSchemaC = Proxy -gSchema :: forall a. (HasDatatypeInfo a, All2 FieldEncode (Code a)) => Options -> TypedSchema a+gSchema :: forall a. HasGenericSchema 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@@ -51,24 +51,23 @@ 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))+gSchemaNS opts ci =+ case mkAlts ci of+ [] -> error "empty union"+ other -> union $ NE.fromList other where+ mkAlts = hcollapse . hczipWith3 (Proxy :: Proxy (All FieldEncode)) mk (injections @_ @(NP I)) (ejections @_ @(NP I)) 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) (liftJust $ gSchemaNP opts ci)- )- where cons = pack (constructorTagModifier opts (constructorName ci))+ -> K (Text, UnionAlt (NS (NP I) xss)) xs+ mk (Fn inject) (Fn eject) ci = K (cons, altWith sc (prism' (unK . inject) (unComp . eject . K))) where+ -- sc = dimap (unComp . eject . K) (unK . inject . fromJust) gSchemaNP opts ci)+ sc = gSchemaNP opts ci+ cons = pack (constructorTagModifier opts (constructorName ci)) gSchemaNP :: forall (xs :: [*])
src/Schemas/Untyped.hs view
@@ -28,10 +28,12 @@ import Data.Foldable (asum) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map+import Data.HashSet (HashSet) import Data.List (find, intersperse, intercalate) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Maybe+import Data.Semigroup import Data.Text (Text, pack, unpack) import Data.Typeable import GHC.Exts (IsList (..), IsString(..))@@ -50,7 +52,7 @@ -- | A schema for untyped data, such as JSON or XML. ----- * introduction forms: 'extractSchema', 'theSchema', 'mempty'+-- * introduction forms: 'extractSchema', 'schemaFor', 'mempty' -- * operations: 'isSubtypeOf', 'versions', 'coerce', 'validate' -- * composition: '(<>)' data Schema@@ -61,6 +63,7 @@ | OneOf (NonEmpty Schema) -- ^ Decoding works for all alternatives, encoding only for one | Prim Text -- ^ Carries the name of primitive type | Named SchemaName Schema+ | Empty deriving (Eq, Generic) instance Monoid Schema where mempty = Empty@@ -70,16 +73,18 @@ OneOf aa <> b = OneOf (aa <> [b]) b <> OneOf aa = OneOf ([b] <> aa) a <> b = OneOf [a,b]+ instance Show Schema where showsPrec = go [] where- go seen p (Array sc) = (('[' :) . go seen 5 sc . (']' :))+ go _een p Empty = showParen (p>0) $ ("Empty " ++)+ go seen _ (Array sc) = (('[' :) . go seen 5 sc . (']' :)) go seen p (StringMap sc) = showParen (p > 5) (("Map " ++) . go seen 5 sc) go _een p (Enum opts) = showParen (p > 5) (intercalate "|" (NE.toList $ fmap unpack opts) ++) go seen p (OneOf scc) = showParen (p > 5) $ foldr (.) id $ NE.intersperse (" | " ++) (fmap (go seen 6) scc)- go seen p (Record fields) =+ go seen _ (Record fields) = ('{' :) . foldr (.)@@ -119,15 +124,15 @@ fieldSchemaL :: Applicative f => (Schema -> f Schema) -> Field -> f Field fieldSchemaL f Field{..} = Field <$> f fieldSchema <*> pure isRequired -pattern Empty :: Schema-pattern Empty <- Record [] where Empty = Record []+pattern Unit :: Schema+pattern Unit <- Record [] where Unit = 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+_Unit :: Prism' Schema ()+_Unit = prism' build match where build () = Record [] @@ -155,19 +160,19 @@ = MissingRecordField { name :: Text } | MissingEnumChoices { choices :: NonEmpty Text } | OptionalRecordField { name :: Text }- | InvalidRecordField { name :: Text, mismatches :: [(Trace, Mismatch)] }+ | InvalidRecordField { name :: Text} | InvalidEnumValue { given :: Text, options :: NonEmpty Text}+ | InvalidRecordValue { value :: Value } | InvalidConstructor { name :: Text} | InvalidUnionValue { contents :: Value} | SchemaMismatch {a, b :: Schema} | ValueMismatch {expected :: Schema, got :: Value}- | EmptyAllOf+ | EmptySchema | PrimValidatorMissing { name :: Text } | PrimError {name, primError :: Text} | PrimMismatch {have, want :: Text} | InvalidChoice{choiceNumber :: Int}- | TryFailed { name :: Text }- | UnusedFields [[Text]]+ | UnusedFields (HashSet Text) | AllAlternativesFailed { mismatches :: [(Trace,Mismatch)]} | UnexpectedAllOf | NoMatches@@ -178,7 +183,7 @@ type Validators = HashMap Text ValidatePrim type ValidatePrim = Value -> Maybe Text --- | Structural validation of a JSON value against a schema+-- | 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@@ -245,11 +250,12 @@ Nothing -> let sol = go ((a,sol) : env) ctx sa sb in sol- go _nv _tx Empty _ = pure $ const emptyValue- go _nv _tx (Array _) Empty = pure $ const (A.Array [])- go _nv _tx (Record _) Empty = pure $ const emptyValue- go _nv _tx (StringMap _) Empty = pure $ const emptyValue- go _nv _tx OneOf{} Empty = pure $ const emptyValue+ go _ _ Empty Empty = pure id+ go _nv _tx Unit _ = pure $ const emptyValue+ go _nv _tx (Array _) Unit = pure $ const (A.Array [])+ go _nv _tx (Record _) Unit = pure $ const emptyValue+ go _nv _tx (StringMap _) Unit = pure $ const emptyValue+ go _nv _tx OneOf{} Unit = pure $ const emptyValue go _nv ctx (Prim a) (Prim b ) = do unless (a == b) $ failWith ctx (PrimMismatch b a) pure id
test/Generators.hs view
@@ -49,7 +49,7 @@ constructorNames = ["constructor1", "constructor2"] genSchema :: Int -> Gen Schema-genSchema 0 = elements [Empty, Prim "A", Prim "B"]+genSchema 0 = elements [Unit, Prim "A", Prim "B"] genSchema n = frequency [ (10,) $ Record <$> do nfields <- choose (1,2)
+ test/Looper.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+module Looper where++import Data.Generics.Labels ()+import GHC.Generics+import Schemas++data Looper+ = Number Int+ | Loop Looper+ deriving (Eq, Generic, Show)++instance HasSchema Looper where+ schema = named "Looper" $ oneOf+ [ altWith schema #_Number+ , altWith schema #_Loop+ ]++looper1 = Number 1+looper2 = Loop $ Number 2
test/Schemas/OpenApi2Spec.hs view
@@ -9,16 +9,19 @@ import Person2 import Schemas import Schemas.OpenApi2+import SchemasSpec import Test.Hspec spec :: Spec spec = do+ let personDocument = toOpenApi2Document defaultOptions [("Person", schemaFor @Person)]+ describe "OpenApi2 schema" $+ schemaSpec schema (definitions personDocument Map.! "Person") describe "toOpenApi2Document" $ do it "works for Person" $ do- let document = toOpenApi2Document defaultOptions [("Person", theSchema @Person)]- Map.keys (definitions document) `shouldContain` ["Person"]- Map.keys (failures document) `shouldNotContain` ["Person"]+ Map.keys (definitions personDocument) `shouldContain` ["Person"]+ Map.keys (failures personDocument) `shouldNotContain` ["Person"] it "works for Person2" $ do- let document = toOpenApi2Document defaultOptions [("Person2", theSchema @Person2)]+ let document = toOpenApi2Document defaultOptions [("Person2", schemaFor @Person2)] Map.keys (definitions document) `shouldContain` ["Person2"] Map.keys (failures document) `shouldNotContain` ["Person2"]
test/Schemas/SOPSpec.hs view
@@ -38,17 +38,21 @@ -- NE.toList (extractSchema (schema @a)) `shouldContain` NE.toList genSchemas it "can encode to generic schema" $ do let encoder = encodeTo genSchema- shouldNotLoop $ evaluate encoder+ encoded = (encodeWith genSchemaTyped) ex+ encodedTyped = attemptSuccessOrError encoder ex+ shouldNotDiverge $ evaluate encoder encoder `shouldSatisfy` isRight- fromRight undefined encoder ex `shouldBe` encodeWith genSchemaTyped ex+ shouldNotDiverge $ evaluate encoded+ shouldNotDiverge $ evaluate $ encodedTyped+ encodedTyped `shouldBe` encoded it "can decode from generic schema" $ do let decoder = decodeFrom genSchema encoded = encode ex- decoded = fromRight undefined decoder encoded+ decoded = getSuccessOrError decoder encoded decodedG = decodeWith genSchemaTyped encoded- shouldNotLoop $ evaluate decoder- shouldNotLoop $ evaluate encoded- shouldNotLoop $ evaluate decoded- shouldNotLoop $ evaluate decodedG- decoder `shouldSatisfy` isRight+ shouldNotDiverge $ evaluate decoder+ shouldNotDiverge $ evaluate encoded+ shouldNotDiverge $ evaluate decoded+ shouldNotDiverge $ evaluate decodedG+ decoder `shouldSatisfy` isSuccess decodedG `shouldBe` decoded
test/SchemasSpec.hs view
@@ -1,49 +1,91 @@+{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module SchemasSpec where import Control.Exception-import Control.Monad.Trans.Except+import Control.Lens (_Just, _Nothing, _Empty, _Cons)+import Control.Monad (join)+import Control.Monad.Trans.Except (Except, ExceptT(..)) import qualified Data.Aeson as A-import Data.Coerce+import qualified Data.Coerce import Data.Either import Data.Foldable import Data.Functor.Identity-import qualified Data.List.NonEmpty as NE+import qualified Data.List.NonEmpty as NE import Data.Maybe+import Data.Void import Generators+import Looper import Person import Person2 import Person3 import Person4 import Schemas+import qualified Schemas.Attempt as Attempt+import Schemas.Internal (liftAttempt) import Schemas.Untyped (Validators) import System.Timeout import Test.Hspec-import Test.Hspec.QuickCheck-import Test.Hspec.Runner-import Test.QuickCheck+import Test.Hspec.QuickCheck (prop)+import Test.Hspec.Runner (configQuickCheckMaxSuccess, hspecWith, defaultConfig)+import Test.QuickCheck (sized, forAll, suchThat) import Text.Show.Functions () main :: IO () main = hspecWith defaultConfig{configQuickCheckMaxSuccess = Just 10000} spec +listSchema :: HasSchema a => TypedSchema [a]+listSchema = named "list" $ union+ [ ("Nil", alt _Empty)+ , ( "Cons"+ , altWith+ (record $ (,) <$> field "head" fst <*> fieldWith listSchema "tail" snd)+ _Cons+ )+ ]+ spec :: Spec spec = do describe "encode" $ do+ it "prims" $ do+ let encoder = encode+ shouldNotDiverge $ evaluate encoder+ shouldNotDiverge $ evaluate $ encoder True+ it "unions" $ do+ let encoder = encode+ shouldNotDiverge $ evaluate encoder+ shouldNotDiverge $ evaluate $ encoder (Left ())+ shouldNotDiverge $ evaluate $ encoder (Right ())+ it "recursive schemas" $ do+ let encoder = (encodeWith listSchema)+ shouldNotDiverge $ evaluate encoder+ shouldNotDiverge $ evaluate $ encoder [()] prop "is the inverse of decoding" $ \(sc :: Schema) ->- decode (encode sc) == Right sc+ getSuccess (pure encode >>= decode . ($ sc)) == Just sc describe "encodeTo" $ do- it "laziness delivers" $ do- evaluate (fromRight undefined (encodeToWith (record $ Just <$> field "bottom" fromJust) (Record [makeField "bottom" prim True])) (Nothing :: Maybe Bool))+ it "is lazy" $ do+ evaluate (attemptSuccessOrError (encodeToWith (record $ Just <$> field "bottom" fromJust) (Record [makeField "bottom" prim True])) (Nothing :: Maybe Bool)) `shouldThrow` \(_ :: SomeException) -> True- fromRight undefined (encodeToWith (record $ Just <$> field "bottom" fromJust) (Record [])) (Nothing :: Maybe Bool)- `shouldBe` A.Object []+ let encoded = attemptSuccessOrError (encodeToWith (record $ Just <$> field "bottom" fromJust) (Record [])) (Nothing :: Maybe Bool)+ encoded `shouldBe` A.Object []+ describe "extractSchema" $ do+ it "Named" $+ shouldNotDiverge $ evaluate $ extractSchema $ schema @Schema+ it "Unions" $+ extractSchema (union [("Just", alt (_Just @())), ("Nothing", alt _Nothing)])+ `shouldBe` [Union [("Nothing", Unit) ,("Just", Unit)]]+ describe "canEncode" $ do+ it "Empty to itself" $ do+ mempty @(TypedSchema Void) `shouldBeAbleToEncodeTo` [Empty]+ it "Unions of 1 constructor" $ do+ union [("Just", alt (_Just @()))] `shouldBeAbleToEncodeTo` [Union [("Just", Unit)]] describe "isSubtypeOf" $ do it "is reflexive (in absence of OneOf)" $ forAll (sized genSchema `suchThat` (not . hasOneOf)) $ \sc -> sc `shouldBeSubtypeOf` sc@@ -75,10 +117,10 @@ it "subtypes cannot add enum choices" $ do Enum ["A", "def"] `shouldNotBeSubtypeOf` Enum ["def"] it "subtypes can remove constructors" $ do- Union [constructor' "B" Empty]- `shouldBeSubtypeOf` Union [constructor' "A" Empty, constructor' "B" Empty]+ Union [constructor' "B" Unit]+ `shouldBeSubtypeOf` Union [constructor' "A" Unit, constructor' "B" Unit] it "subtypes cannot add constructors" $ do- Union [constructor' "A" prim, constructor' "B" Empty]+ Union [constructor' "A" prim, constructor' "B" Unit] `shouldNotBeSubtypeOf` Union [constructor' "A" (prim)] it "subtypes can drop an array" $ do prim `shouldBeSubtypeOf` Array prim@@ -86,14 +128,18 @@ Array prim `shouldNotBeSubtypeOf` prim describe "HasSchema" $ do it "Left is a constructor of Either" $ do- shouldBeAbleToDecode @(Either () ()) [Union [constructor' "Left" Empty]]+ shouldBeAbleToDecode @(Either () ()) [Union [constructor' "Left" Unit]]+ -- shouldBeAbleToEncode @(Either () ()) [Union [constructor' "Left" Unit]] it "left is a constructor of Either too" $ do- shouldBeAbleToDecode @(Either () ()) [Union [constructor' "left" Empty]]+ shouldBeAbleToDecode @(Either () ()) [Union [constructor' "left" Unit]]+ -- shouldBeAbleToEncode @(Either () ()) [Union [constructor' "left" Unit]] describe "examples" $ do- let person4_v0 = theSchema @Person4- person2_v0 = theSchema @Person2+ describe "Schema" $+ schemaSpec schema (schemaFor @Person2)+ let person4_v0 = schemaFor @Person4+ person2_v0 = schemaFor @Person2 person2_v2 = extractSchema (schema @Person2) NE.!! 2- person3_v0 = theSchema @Person3+ person3_v0 = schemaFor @Person3 person4_vPerson3 = person3_v0 encoder_p4v0 = encodeTo person4_v0 encoder_p3_to_p4 = encodeTo person4_vPerson3@@ -109,72 +155,93 @@ shouldBeAbleToEncode @Person2 (extractSchema @Person schema) -- shouldBeAbleToDecode @Person (extractSchema @Person2 schema) it "pepe2 `as` Person" $ do- let encoder = encodeTo (theSchema @Person)+ let encoder = encodeTo (schemaFor @Person)+ encoded = attemptSuccessOrError encoder pepe2 encoder `shouldSatisfy` isRight- decode (fromRight undefined encoder pepe2) `shouldBe` Right pepe+ decode (encoded) `shouldBe` Success pepe it "pepe `as` Person2" $ do- let decoder = decodeFrom (theSchema @Person)- decoder `shouldSatisfy` isRight- fromRight undefined decoder (encode pepe) `shouldBe` Right pepe2{Person2.education = [Person.studies pepe]}+ let decoder = decodeFrom (schemaFor @Person)+ decoder `shouldSatisfy` isSuccess+ (pure encode >>= getSuccessOrError decoder . ($ pepe))+ `shouldBe` Success pepe2{Person2.education = [Person.studies pepe]} it "Person < Person2" $ do -- shouldBeAbleToEncode @Person (extractSchema @Person2 schema) shouldBeAbleToDecode @Person2 (extractSchema @Person schema) describe "Person3" $ do+ -- disabled because encode diverges and does not support IterT yet+ -- schemaSpec schema pepe3 it "can show the Person 3 (circular) schema" $- shouldNotLoop $ evaluate $ length $ show $ theSchema @Person3+ shouldNotDiverge $ evaluate $ length $ show $ schemaFor @Person3 it "can compute an encoder for Person3 (circular schema)" $- shouldNotLoop $ evaluate encoder_p3v0+ shouldNotDiverge $ evaluate encoder_p3v0 it "can encode a finite example" $ do- shouldNotLoop $ evaluate $ encode martin- shouldNotLoop $ evaluate $ fromRight undefined encoder_p3v0 martin++ shouldNotDiverge $ evaluate $ encode martin+ shouldNotDiverge $ evaluate $ attemptSuccessOrError encoder_p3v0 martin describe "Person4" $ do schemaSpec schema pepe4- let encoded_pepe4 = fromRight undefined encoder_p4v0 pepe4- encoded_pepe3 = fromRight undefined encoder_p3_to_p4 pepe3{Person3.spouse = Nothing}- encoded_pepe2 = fromRight undefined encoder_p2v0 pepe2+ let encoded_pepe4 = attemptSuccessOrError encoder_p4v0 pepe4+ encoded_pepe3 = attemptSuccessOrError encoder_p3_to_p4 pepe3{Person3.spouse = Nothing}+ encoded_pepe2 = attemptSuccessOrError encoder_p2v0 pepe2 it "can compute an encoder for Person4" $ do- shouldNotLoop $ evaluate encoder_p4v0+ shouldNotDiverge $ evaluate encoder_p4v0 encoder_p4v0 `shouldSatisfy` isRight it "can compute an encoder to Person3 in finite time" $ do- shouldNotLoop $ evaluate encoder_p3_to_p4+ shouldNotDiverge $ evaluate encoder_p3_to_p4 it "can compute an encoder to Person2 in finite time" $ do- shouldNotLoop $ evaluate encoder_p2v0+ shouldNotDiverge $ evaluate encoder_p2v0 it "can encode a Person4" $ do- shouldNotLoop $ evaluate $ A.encode encoded_pepe4+ shouldNotDiverge $ evaluate $ A.encode encoded_pepe4 it "can encode a Person2 as Person4 in finite time" $ do- shouldNotLoop $ evaluate $ A.encode encoded_pepe2+ shouldNotDiverge $ evaluate $ A.encode encoded_pepe2 it "can decode a fully defined record with source schema" $ do- let res = fromRight undefined (decodeFrom person4_v0) encoded_pepe4- shouldNotLoop $ evaluate res- res `shouldBe` Right pepe4+ let res = getSuccessOrError (decodeFrom person4_v0) encoded_pepe4+ shouldNotDiverge $ evaluate res+ res `shouldBe` Success pepe4 it "can decode a fully defined record without source schema" $ do let res = decode encoded_pepe4- shouldNotLoop $ evaluate res- res `shouldBe` Right pepe4+ shouldNotDiverge $ evaluate res+ res `shouldBe` Success pepe4 it "cannot construct a Person2 v0 decoder" $- decoder_p2v0 `shouldSatisfy` isLeft+ decoder_p2v0 `shouldSatisfy` isFailure it "can construct a Person2 v1 decoder" $- decoder_p2v2 `shouldSatisfy` isRight+ decoder_p2v2 `shouldSatisfy` isSuccess it "can decode a Person2 v1" $ do- let res = fromRight undefined decoder_p2v2 encoded_pepe2- holds = res == Right pepe4- shouldNotLoop $ evaluate holds- shouldNotLoop $ evaluate $ length $ show res- res `shouldBe` Right pepe4+ let res = getSuccessOrError decoder_p2v2 encoded_pepe2+ holds = res == Success pepe4+ shouldNotDiverge $ evaluate holds+ shouldNotDiverge $ evaluate $ length $ show res+ res `shouldBe` Success pepe4+ describe "Looper" $ do+ schemaSpec schema looper1 -schemaSpec :: (Eq a, Show a) => TypedSchema a -> a -> Spec+schemaSpec :: forall a. (Eq a, Show a) => TypedSchema a -> a -> Spec schemaSpec sc ex = do- let encoder = encodeToWith sc (NE.head $ extractSchema sc)- decoder = decodeFromWith sc (NE.head $ extractSchema sc)- encodedExample = fromRight undefined encoder ex- it "Can encode itself" $+ let encoder = encodeToWith sc s+ decoder = decodeFromWith sc s+ s = NE.head $ extractSchema sc+ encodedExample = attemptSuccessOrError encoder ex+ it "Can extract untyped schema" $+ shouldNotDiverge $ evaluate s+ it "Can encode itself" $ do+ shouldNotDiverge $ evaluate encoder encoder `shouldSatisfy` isRight- it "Can decode itself" $- decoder `shouldSatisfy` isRight- it "Roundtrips ex" $- fromRight undefined decoder encodedExample `shouldBe` Right ex- it "Roundtrips ex (2)" $- decodeWith sc (encodeWith sc ex) `shouldBe` Right ex+ it "Can decode itself" $ do+ shouldNotDiverge $ evaluate decoder+ decoder `shouldSatisfy` isSuccess+ it "Does not diverge decoding bad input" $ do+ let d = join $ Attempt.attemptSuccess $ runResult 1000 $ decodeFromWith sc (NE.head $ extractSchema sc)+ shouldNotDiverge $ evaluate $ d+ shouldNotDiverge $ evaluate $ join $ join $ Attempt.attemptSuccess $ runResult 1000 $ traverse ($ A.String "Foo") d+ it "Roundtrips ex" $ do+ let res = getSuccessOrError decoder encodedExample+ shouldNotDiverge $ evaluate encodedExample+ shouldNotDiverge $ evaluate res+ runResult 1000 res `shouldBe` Right (Just ex)+ it "Roundtrips ex (2)" $ do+ let res = pure (encodeWith sc) >>= decodeWith sc . ($ ex)+ shouldNotDiverge $ evaluate res+ runResult 1000 res `shouldBe` Right (Just ex) shouldBeSubtypeOf :: HasCallStack => Schema -> Schema -> Expectation shouldBeSubtypeOf a b = case isSubtypeOf primValidators a b of@@ -186,27 +253,28 @@ Right _ -> expectationFailure $ show a <> " should not be a subtype of " <> show b _ -> pure () -shouldLoop :: (Show a, HasCallStack) => IO a -> Expectation-shouldLoop act = do+shouldDiverge :: (HasCallStack, Show a) => IO a -> Expectation+shouldDiverge act = do res <- timeout 1000000 act- res `shouldSatisfy` isNothing+ case res of+ Just{} -> expectationFailure "Did not diverge"+ Nothing -> return () -shouldNotLoop :: (Show a, HasCallStack) => IO a -> Expectation-shouldNotLoop act = do+shouldNotDiverge :: (HasCallStack, Show a) => IO a -> Expectation+shouldNotDiverge act = do res <- timeout 1000000 act- res `shouldSatisfy` isJust+ case res of+ Nothing -> error "Did not terminate after 1s"+ Just {} -> return () -shouldBeAbleToEncode :: forall a . (HasSchema a) => NE.NonEmpty Schema -> Expectation-shouldBeAbleToEncode sc = asumEither (fmap (encodeTo @a) sc) `shouldSatisfy` isRight+shouldBeAbleToEncode :: forall a . HasCallStack => (HasSchema a) => NE.NonEmpty Schema -> Expectation+shouldBeAbleToEncode = shouldBeAbleToEncodeTo (schema @a) -shouldBeAbleToDecode :: forall a . (HasSchema a) => NE.NonEmpty Schema -> Expectation-shouldBeAbleToDecode sc = asumEither (fmap (decodeFrom @a) sc) `shouldSatisfy` isRight+shouldBeAbleToEncodeTo :: forall a . HasCallStack => TypedSchema a -> NE.NonEmpty Schema -> Expectation+shouldBeAbleToEncodeTo tsc sc = asumEither (fmap (encodeToWith tsc) sc) `shouldSatisfy` isRight -asumEither :: forall e a . (Monoid e) => NE.NonEmpty (Either e a) -> Either e a-asumEither = Data.Coerce.coerce asumExcept- where- asumExcept :: NE.NonEmpty (Except e a) -> Except e a- asumExcept = asum+shouldBeAbleToDecode :: forall a . HasCallStack => (HasSchema a) => NE.NonEmpty Schema -> Expectation+shouldBeAbleToDecode sc = asum (fmap (decodeFrom @a) sc) `shouldSatisfy` isSuccess makeField :: a -> Schema -> Bool -> (a, Field) makeField n t isReq = (n, Field t isReq)@@ -219,3 +287,28 @@ primValidators :: Validators primValidators = validatorsFor @(Schema, Double, Int, Bool)++getSuccessOrError :: Result a -> a+getSuccessOrError = either (error . show) (fromMaybe (error "too many delays")) . Attempt.runAttempt . runResult 1000++attemptSuccessOrError :: Show e => Either e a -> a+attemptSuccessOrError = either (error.show) id++pattern Success :: a -> Result a+pattern Success x <- (runResult 1000 -> Attempt.Success (Just x))+ where Success x = liftAttempt $ Attempt.Success x++getSuccess :: Result a -> Maybe a+getSuccess = join . Attempt.attemptSuccess . runResult 1000++isSuccess :: Result a -> Bool+isSuccess = isJust . getSuccess++isFailure :: Result a -> Bool+isFailure = not . isSuccess++asumEither :: forall e a . (Monoid e) => NE.NonEmpty (Either e a) -> Either e a+asumEither = Data.Coerce.coerce asumExcept+ where+ asumExcept :: NE.NonEmpty (Except e a) -> Except e a+ asumExcept = asum