diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/example/Person2.hs b/example/Person2.hs --- a/example/Person2.hs +++ b/example/Person2.hs @@ -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" diff --git a/example/Person3.hs b/example/Person3.hs --- a/example/Person3.hs +++ b/example/Person3.hs @@ -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 diff --git a/example/Person4.hs b/example/Person4.hs --- a/example/Person4.hs +++ b/example/Person4.hs @@ -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 diff --git a/schemas.cabal b/schemas.cabal --- a/schemas.cabal +++ b/schemas.cabal @@ -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 diff --git a/src/Schemas/SOP.hs b/src/Schemas/SOP.hs --- a/src/Schemas/SOP.hs +++ b/src/Schemas/SOP.hs @@ -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 diff --git a/src/Schemas/Untyped.hs b/src/Schemas/Untyped.hs --- a/src/Schemas/Untyped.hs +++ b/src/Schemas/Untyped.hs @@ -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 diff --git a/test/Schemas/SOPSpec.hs b/test/Schemas/SOPSpec.hs new file mode 100644 --- /dev/null +++ b/test/Schemas/SOPSpec.hs @@ -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 diff --git a/test/SchemasSpec.hs b/test/SchemasSpec.hs --- a/test/SchemasSpec.hs +++ b/test/SchemasSpec.hs @@ -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