schemas 0.3.0.1 → 0.3.0.2
raw patch · 9 files changed
+139/−16 lines, 9 files
Files
- CHANGELOG.md +2/−0
- example/Person2.hs +16/−5
- example/Person3.hs +4/−0
- example/Person4.hs +9/−3
- schemas.cabal +2/−1
- src/Schemas/SOP.hs +3/−0
- src/Schemas/Untyped.hs +40/−3
- test/Schemas/SOPSpec.hs +54/−0
- test/SchemasSpec.hs +9/−4
CHANGELOG.md view
@@ -1,4 +1,6 @@ # Revision history for schemas+## 0.3.0.2 -- 2019-10-29+* Show circular schemas ## 0.3.0.1 -- 2019-10-25 * Fix a bug that made OpenApi2 generation diverge.
example/Person2.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedLabels #-}@@ -12,6 +15,8 @@ import Data.Maybe import Data.String import GHC.Exts (IsList(..))+import GHC.Generics+import qualified Generics.SOP as SOP import Person import Schemas @@ -24,7 +29,8 @@ , religion :: (Maybe Religion) -- new , education :: NonEmpty Education -- renamed }- deriving (Eq, Show)+ deriving (Generic, Eq, Show)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) data Religion = Catholic | Anglican | Muslim | Hindu deriving (Bounded, Enum, Eq, Show)@@ -39,11 +45,16 @@ schema = record $ Person2- <$> field "name" Person2.name- <*> (optField "age" Person2.age <|> fieldWith (dimap (fromMaybe (-1)) Just schema) "age" Person2.age)+ <$> field "name" Person2.name+ <*> ( optField "age" Person2.age+ <|> fieldWith (dimap (fromMaybe (-1)) Just schema) "age" Person2.age+ ) <*> field "addresses" Person2.addresses- <*> optField "religion" Person2.religion- <*> (field "education" Person2.education <|> (NE.:| []) <$> field "studies" (NE.head . Person2.education))+ <*> optField "religion" Person2.religion+ <*> (field "education" Person2.education <|> (NE.:| []) <$> field+ "studies"+ (NE.head . Person2.education)+ ) pepe2 :: Person2 pepe2 = Person2 "Pepe"
example/Person3.hs view
@@ -51,6 +51,10 @@ , religion = Just Catholic } +martin :: Person3+martin = Person3 "Martin" 10 [] Nothing Nothing []++ -- >>> import qualified Data.ByteString.Lazy.Char8 as B -- >>> import Data.Aeson.Encode.Pretty -- >>> B.putStrLn $ encodePretty $ finiteEncode 4 laura3
example/Person4.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@@ -24,7 +29,8 @@ , d1,d2,d3,d4,d5,d6,d7,d8,d9,d10 :: Bool }- deriving (Eq, Show)+ deriving (Generic, Eq, Show)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo) instance HasSchema Person4 where schema =@@ -34,8 +40,8 @@ <*> field "age" Person4.age <*> field "addresses" Person4.addresses <*> optField "religion" Person4.religion- <*> ( field "studies" Person4.education- <|> field "education" Person4.education+ <*> ( field "education" Person4.education+ <|> field "studies" Person4.education ) <*> grab "a1" a1 <*> grab "a2" a2
schemas.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: schemas-version: 0.3.0.1+version: 0.3.0.2 synopsis: schema guided serialization description: Schemas is a Haskell library for serializing and deserializing data in JSON.@@ -82,6 +82,7 @@ , Person4 , SchemasSpec , Schemas.OpenApi2Spec+ , Schemas.SOPSpec , Generators build-depends: aeson , aeson-pretty
src/Schemas/SOP.hs view
@@ -9,6 +9,7 @@ {-# LANGUAGE UndecidableInstances #-} module Schemas.SOP ( gSchema+ , HasGenericSchema , gRecordFields , Options(..) , defOptions@@ -23,6 +24,8 @@ import Generics.SOP as SOP import Schemas.Class import Schemas.Internal++type HasGenericSchema a = (HasDatatypeInfo a, All2 FieldEncode (Code a)) data Options = Options { fieldLabelModifier :: String -> String
src/Schemas/Untyped.hs view
@@ -28,7 +28,7 @@ import Data.Foldable (asum) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map-import Data.List (find)+import Data.List (find, intersperse, intercalate) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Maybe@@ -44,8 +44,10 @@ -- -------------------------------------------------------------------------------- newtype SchemaName = SchemaName String- deriving newtype (Eq, IsString, Show)+ deriving newtype (Eq, IsString) +instance Show SchemaName where show (SchemaName s) = s+ -- | A schema for untyped data, such as JSON or XML. -- -- * introduction forms: 'extractSchema', 'theSchema', 'mempty'@@ -59,7 +61,7 @@ | OneOf (NonEmpty Schema) -- ^ Decoding works for all alternatives, encoding only for one | Prim Text -- ^ Carries the name of primitive type | Named SchemaName Schema- deriving (Eq, Generic, Show)+ deriving (Eq, Generic) instance Monoid Schema where mempty = Empty instance Semigroup Schema where@@ -68,6 +70,41 @@ 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 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) =+ ('{' :)+ . foldr+ (.)+ id+ (intersperse+ (", " ++)+ (fmap+ (\(r, Field {..}) ->+ (unpack r ++) . ((if isRequired then " :: " else " ?? ") ++) . go seen 0 fieldSchema+ )+ (Map.toList fields)+ )+ )+ . ('}' :)+ go _een _ (Prim t ) = (unpack t ++)+ go seen p (Named n sc) = case n `elem` seen of+ False ->+ ("let " ++)+ . (show n ++)+ . (" = " ++)+ . self+ . (" in " ++)+ . (show n ++)+ True -> (show n ++)+ where self = go (n : seen) p sc data Field = Field { fieldSchema :: Schema
+ test/Schemas/SOPSpec.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Schemas.SOPSpec where++import Control.Exception+import Data.Either+import qualified Data.List.NonEmpty as NE+import Person+import Person2+import Person4+import Schemas+import Schemas.SOP+import SchemasSpec+import Test.Hspec++spec :: Spec+spec = do+ describe "Generics" $ do+ describe "Person" $+ specExample pepe+ describe "Person2" $+ specExample pepe2+ -- Equality across recursive schemas (Person3) is not yet supported+ -- describe "Person3" $+ -- specExample pepe3+ describe "Person4" $+ specExample pepe4++specExample :: forall a . (HasGenericSchema a, HasSchema a, Eq a, Show a) => a -> Spec+specExample ex = do+ let genSchemas = extractSchema genSchemaTyped+ genSchema = NE.head genSchemas+ genSchemaTyped = gSchema defOptions++ it "generic schemas are unitary" $+ length genSchemas `shouldBe` 1+ -- it "generic schema is included in handcrafted one" $+ -- NE.toList (extractSchema (schema @a)) `shouldContain` NE.toList genSchemas+ it "can encode to generic schema" $ do+ let encoder = encodeTo genSchema+ shouldNotLoop $ evaluate encoder+ encoder `shouldSatisfy` isRight+ fromRight undefined encoder ex `shouldBe` encodeWith genSchemaTyped ex+ it "can decode from generic schema" $ do+ let decoder = decodeFrom genSchema+ encoded = encode ex+ decoded = fromRight undefined decoder encoded+ decodedG = decodeWith genSchemaTyped encoded+ shouldNotLoop $ evaluate decoder+ shouldNotLoop $ evaluate encoded+ shouldNotLoop $ evaluate decoded+ shouldNotLoop $ evaluate decodedG+ decoder `shouldSatisfy` isRight+ decodedG `shouldBe` decoded
test/SchemasSpec.hs view
@@ -120,8 +120,13 @@ -- shouldBeAbleToEncode @Person (extractSchema @Person2 schema) shouldBeAbleToDecode @Person2 (extractSchema @Person schema) describe "Person3" $ do+ it "can show the Person 3 (circular) schema" $+ shouldNotLoop $ evaluate $ length $ show $ theSchema @Person3 it "can compute an encoder for Person3 (circular schema)" $ shouldNotLoop $ evaluate encoder_p3v0+ it "can encode a finite example" $ do+ shouldNotLoop $ evaluate $ encode martin+ shouldNotLoop $ evaluate $ fromRight undefined encoder_p3v0 martin describe "Person4" $ do schemaSpec schema pepe4 let encoded_pepe4 = fromRight undefined encoder_p4v0 pepe4@@ -171,22 +176,22 @@ it "Roundtrips ex (2)" $ decodeWith sc (encodeWith sc ex) `shouldBe` Right ex -shouldBeSubtypeOf :: Schema -> Schema -> Expectation+shouldBeSubtypeOf :: HasCallStack => 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 :: HasCallStack => 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) => IO a -> Expectation+shouldLoop :: (Show a, HasCallStack) => IO a -> Expectation shouldLoop act = do res <- timeout 1000000 act res `shouldSatisfy` isNothing -shouldNotLoop :: (Show a) => IO a -> Expectation+shouldNotLoop :: (Show a, HasCallStack) => IO a -> Expectation shouldNotLoop act = do res <- timeout 1000000 act res `shouldSatisfy` isJust