hschema-aeson (empty) → 0.0.1.0
raw patch · 13 files changed
+685/−0 lines, 13 filesdep +QuickCheckdep +aesondep +basesetup-changed
Dependencies added: QuickCheck, aeson, base, bytestring, comonad, contravariant, convertible, directory, free, hschema, hschema-aeson, hschema-prettyprinter, hschema-quickcheck, hspec, lens, mtl, natural-transformation, prettyprinter, prettyprinter-ansi-terminal, quickcheck-instances, scientific, text, time, unordered-containers, vector
Files
- ChangeLog.md +3/−0
- LICENSE +165/−0
- README.md +4/−0
- Setup.hs +2/−0
- hschema-aeson.cabal +100/−0
- src/Data/Schema/JSON.hs +26/−0
- src/Data/Schema/JSON/Internal/Serializer.hs +107/−0
- src/Data/Schema/JSON/Internal/Types.hs +91/−0
- src/Data/Schema/JSON/Simple.hs +46/−0
- test/Spec.hs +4/−0
- test/Test/Schema/JSON.hs +45/−0
- test/Test/Schema/Model.hs +75/−0
- test/Test/Schema/Utils.hs +17/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for hexomorph++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,165 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.+++ This version of the GNU Lesser General Public License incorporates+the terms and conditions of version 3 of the GNU General Public+License, supplemented by the additional permissions listed below.++ 0. Additional Definitions.++ As used herein, "this License" refers to version 3 of the GNU Lesser+General Public License, and the "GNU GPL" refers to version 3 of the GNU+General Public License.++ "The Library" refers to a covered work governed by this License,+other than an Application or a Combined Work as defined below.++ An "Application" is any work that makes use of an interface provided+by the Library, but which is not otherwise based on the Library.+Defining a subclass of a class defined by the Library is deemed a mode+of using an interface provided by the Library.++ A "Combined Work" is a work produced by combining or linking an+Application with the Library. The particular version of the Library+with which the Combined Work was made is also called the "Linked+Version".++ The "Minimal Corresponding Source" for a Combined Work means the+Corresponding Source for the Combined Work, excluding any source code+for portions of the Combined Work that, considered in isolation, are+based on the Application, and not on the Linked Version.++ The "Corresponding Application Code" for a Combined Work means the+object code and/or source code for the Application, including any data+and utility programs needed for reproducing the Combined Work from the+Application, but excluding the System Libraries of the Combined Work.++ 1. Exception to Section 3 of the GNU GPL.++ You may convey a covered work under sections 3 and 4 of this License+without being bound by section 3 of the GNU GPL.++ 2. Conveying Modified Versions.++ If you modify a copy of the Library, and, in your modifications, a+facility refers to a function or data to be supplied by an Application+that uses the facility (other than as an argument passed when the+facility is invoked), then you may convey a copy of the modified+version:++ a) under this License, provided that you make a good faith effort to+ ensure that, in the event an Application does not supply the+ function or data, the facility still operates, and performs+ whatever part of its purpose remains meaningful, or++ b) under the GNU GPL, with none of the additional permissions of+ this License applicable to that copy.++ 3. Object Code Incorporating Material from Library Header Files.++ The object code form of an Application may incorporate material from+a header file that is part of the Library. You may convey such object+code under terms of your choice, provided that, if the incorporated+material is not limited to numerical parameters, data structure+layouts and accessors, or small macros, inline functions and templates+(ten or fewer lines in length), you do both of the following:++ a) Give prominent notice with each copy of the object code that the+ Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the object code with a copy of the GNU GPL and this license+ document.++ 4. Combined Works.++ You may convey a Combined Work under terms of your choice that,+taken together, effectively do not restrict modification of the+portions of the Library contained in the Combined Work and reverse+engineering for debugging such modifications, if you also do each of+the following:++ a) Give prominent notice with each copy of the Combined Work that+ the Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the Combined Work with a copy of the GNU GPL and this license+ document.++ c) For a Combined Work that displays copyright notices during+ execution, include the copyright notice for the Library among+ these notices, as well as a reference directing the user to the+ copies of the GNU GPL and this license document.++ d) Do one of the following:++ 0) Convey the Minimal Corresponding Source under the terms of this+ License, and the Corresponding Application Code in a form+ suitable for, and under terms that permit, the user to+ recombine or relink the Application with a modified version of+ the Linked Version to produce a modified Combined Work, in the+ manner specified by section 6 of the GNU GPL for conveying+ Corresponding Source.++ 1) Use a suitable shared library mechanism for linking with the+ Library. A suitable mechanism is one that (a) uses at run time+ a copy of the Library already present on the user's computer+ system, and (b) will operate properly with a modified version+ of the Library that is interface-compatible with the Linked+ Version.++ e) Provide Installation Information, but only if you would otherwise+ be required to provide such information under section 6 of the+ GNU GPL, and only to the extent that such information is+ necessary to install and execute a modified version of the+ Combined Work produced by recombining or relinking the+ Application with a modified version of the Linked Version. (If+ you use option 4d0, the Installation Information must accompany+ the Minimal Corresponding Source and Corresponding Application+ Code. If you use option 4d1, you must provide the Installation+ Information in the manner specified by section 6 of the GNU GPL+ for conveying Corresponding Source.)++ 5. Combined Libraries.++ You may place library facilities that are a work based on the+Library side by side in a single library together with other library+facilities that are not Applications and are not covered by this+License, and convey such a combined library under terms of your+choice, if you do both of the following:++ a) Accompany the combined library with a copy of the same work based+ on the Library, uncombined with any other library facilities,+ conveyed under the terms of this License.++ b) Give prominent notice with the combined library that part of it+ is a work based on the Library, and explaining where to find the+ accompanying uncombined form of the same work.++ 6. Revised Versions of the GNU Lesser General Public License.++ The Free Software Foundation may publish revised and/or new versions+of the GNU Lesser General Public License from time to time. Such new+versions will be similar in spirit to the present version, but may+differ in detail to address new problems or concerns.++ Each version is given a distinguishing version number. If the+Library as you received it specifies that a certain numbered version+of the GNU Lesser General Public License "or any later version"+applies to it, you have the option of following the terms and+conditions either of that published version or of any later version+published by the Free Software Foundation. If the Library as you+received it does not specify a version number of the GNU Lesser+General Public License, you may choose any version of the GNU Lesser+General Public License ever published by the Free Software Foundation.++ If the Library as you received it specifies that a proxy can decide+whether future versions of the GNU Lesser General Public License shall+apply, that proxy's public statement of acceptance of any version is+permanent authorization for you to choose that version for the+Library.
+ README.md view
@@ -0,0 +1,4 @@+# Haskell Schema Aeson++This a companion package for the `hschema` package providing JSON encoder and decoders for your data types.+Find more information on how to use this in the `hschema` package.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hschema-aeson.cabal view
@@ -0,0 +1,100 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 71f8e3ffc184bb6433eed64355bc3b9cf9e12302dadf85d86df8ebf8d4f254f7++name: hschema-aeson+version: 0.0.1.0+synopsis: Describe schemas for your Haskell data types.+description: Please see the README on GitHub at <https://github.com/alonsodomin/haskell-schema#readme>+category: Data,Schema,JSON+homepage: https://github.com/alonsodomin/haskell-schema#readme+bug-reports: https://github.com/alonsodomin/haskell-schema/issues+author: Antonio Alonso Dominguez+maintainer: alonso.domin@gmail.com+copyright: 2018 Antonio Alonso Dominguez+license: LGPL-3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/alonsodomin/haskell-schema++library+ exposed-modules:+ Data.Schema.JSON+ Data.Schema.JSON.Internal.Serializer+ Data.Schema.JSON.Internal.Types+ Data.Schema.JSON.Simple+ other-modules:+ Paths_hschema_aeson+ hs-source-dirs:+ src+ build-depends:+ QuickCheck+ , aeson+ , base >=4.7 && <5+ , comonad >=5.0 && <5.1+ , contravariant+ , free+ , hschema >=0.0.1.0 && <0.0.2.0+ , hschema-prettyprinter >=0.0.1.0 && <0.0.2.0+ , hschema-quickcheck >=0.0.1.0 && <0.0.2.0+ , lens+ , mtl+ , natural-transformation+ , prettyprinter+ , prettyprinter-ansi-terminal+ , quickcheck-instances+ , scientific+ , text+ , time+ , unordered-containers+ , vector+ default-language: Haskell2010++test-suite hschema-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Test.Schema.JSON+ Test.Schema.Model+ Test.Schema.Utils+ Paths_hschema_aeson+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck+ , aeson+ , base >=4.7 && <5+ , bytestring+ , comonad >=5.0 && <5.1+ , contravariant+ , convertible+ , directory+ , free+ , hschema+ , hschema-aeson+ , hschema-prettyprinter >=0.0.1.0 && <0.0.2.0+ , hschema-quickcheck >=0.0.1.0 && <0.0.2.0+ , hspec+ , lens+ , mtl+ , natural-transformation+ , prettyprinter+ , prettyprinter-ansi-terminal+ , quickcheck-instances+ , scientific+ , text+ , time+ , unordered-containers+ , vector+ default-language: Haskell2010
+ src/Data/Schema/JSON.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Schema.JSON+ ( JsonType+ , JsonSchema+ , JsonField+ , JsonSerializer(..)+ , JsonDeserializer(..)+ , ToJsonSerializer(..)+ , ToJsonDeserializer(..)+ , JsonPrimitive(..)+ ) where++import Data.Aeson (FromJSON (parseJSON),+ ToJSON (toJSON))+import Data.Schema+import Data.Schema.JSON.Internal.Serializer+import Data.Schema.JSON.Internal.Types++instance (HasSchema a, ToJsonSerializer (PrimitivesOf a)) => ToJSON a where+ toJSON = runJsonSerializer . toJsonSerializer $ getSchema++instance (HasSchema a, ToJsonDeserializer (PrimitivesOf a)) => FromJSON a where+ parseJSON = runJsonDeserializer . toJsonDeserializer $ getSchema
+ src/Data/Schema/JSON/Internal/Serializer.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Schema.JSON.Internal.Serializer where++import Control.Applicative.Free+import Control.Functor.HigherOrder+import Control.Lens hiding (iso)+import Control.Monad.State (State)+import qualified Control.Monad.State as ST+import Control.Natural+import qualified Data.Aeson.Types as JSON+import Data.Functor.Contravariant+import Data.Functor.Sum+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as Map+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NEL+import Data.Maybe+import Data.Schema.Internal.Types+import Data.Text (Text)++newtype JsonSerializer a = JsonSerializer { runJsonSerializer :: a -> JSON.Value }++instance Contravariant JsonSerializer where+ contramap f (JsonSerializer g) = JsonSerializer $ g . f++newtype JsonDeserializer a = JsonDeserializer { runJsonDeserializer :: JSON.Value -> JSON.Parser a }++instance Functor JsonDeserializer where+ fmap f (JsonDeserializer g) = JsonDeserializer $ \x -> fmap f (g x)++instance Applicative JsonDeserializer where+ pure x = JsonDeserializer $ \_ -> pure x+ (JsonDeserializer l) <*> (JsonDeserializer r) = JsonDeserializer $ \x -> (l x) <*> (r x)++class ToJsonSerializer s where+ toJsonSerializer :: s ~> JsonSerializer++class ToJsonDeserializer s where+ toJsonDeserializer :: s ~> JsonDeserializer++instance (ToJsonSerializer p, ToJsonSerializer q) => ToJsonSerializer (Sum p q) where+ toJsonSerializer (InL l) = toJsonSerializer l+ toJsonSerializer (InR r) = toJsonSerializer r++toJsonSerializerAlg :: ToJsonSerializer p => HAlgebra (SchemaF p) JsonSerializer+toJsonSerializerAlg = wrapNT $ \case+ PrimitiveSchema p -> toJsonSerializer p++ RecordSchema fields -> JsonSerializer $ \obj -> JSON.Object $ ST.execState (runAp (encodeFieldOf obj) (unwrapField fields)) Map.empty+ where encodeFieldOf :: o -> FieldDef o JsonSerializer v -> State (HashMap Text JSON.Value) v+ encodeFieldOf o (RequiredField name (JsonSerializer serialize) getter) = do+ let el = view getter o+ ST.modify $ Map.insert name (serialize el)+ return el+ encodeFieldOf o (OptionalField name (JsonSerializer serialize) getter) = do+ let el = view getter o+ ST.modify $ Map.insert name (maybe JSON.Null serialize el)+ return el++ UnionSchema alts -> JsonSerializer $ \value -> head . catMaybes . NEL.toList $ fmap (encodeAlt value) alts+ where singleAttrObj :: Text -> JSON.Value -> JSON.Value+ singleAttrObj n v = JSON.Object $ Map.insert n v Map.empty++ encodeAlt :: o -> AltDef JsonSerializer o -> Maybe JSON.Value+ encodeAlt o (AltDef name (JsonSerializer serialize) pr) = do+ json <- serialize <$> o ^? pr+ return $ singleAttrObj name json++ AliasSchema (JsonSerializer base) iso -> JsonSerializer $ \value -> base (view (re iso) value)++instance ToJsonSerializer p => ToJsonSerializer (Schema p) where+ toJsonSerializer schema = (cataNT toJsonSerializerAlg) (unwrapSchema schema)++instance (ToJsonDeserializer p, ToJsonDeserializer q) => ToJsonDeserializer (Sum p q) where+ toJsonDeserializer (InL l) = toJsonDeserializer l+ toJsonDeserializer (InR r) = toJsonDeserializer r++toJsonDeserializerAlg :: ToJsonDeserializer p => HAlgebra (SchemaF p) JsonDeserializer+toJsonDeserializerAlg = wrapNT $ \case+ PrimitiveSchema p -> toJsonDeserializer p++ RecordSchema fields -> JsonDeserializer $ \json -> case json of+ JSON.Object obj -> runAp decodeField $ unwrapField fields+ where decodeField :: FieldDef o JsonDeserializer v -> JSON.Parser v+ decodeField (RequiredField name (JsonDeserializer deserial) _) = JSON.explicitParseField deserial obj name+ decodeField (OptionalField name (JsonDeserializer deserial) _) = JSON.explicitParseFieldMaybe deserial obj name+ other -> fail $ "Expected JSON Object but got: " ++ (show other)++ UnionSchema alts -> JsonDeserializer $ \json -> case json of+ JSON.Object obj -> head . catMaybes . NEL.toList $ fmap lookupParser alts+ where lookupParser :: AltDef JsonDeserializer a -> Maybe (JSON.Parser a)+ lookupParser (AltDef name (JsonDeserializer deserial) pr) = do+ altParser <- deserial <$> Map.lookup name obj+ return $ (view $ re pr) <$> altParser+ other -> fail $ "Expected JSON Object but got: " ++ (show other)++ AliasSchema (JsonDeserializer base) iso -> JsonDeserializer $ \json -> (view iso) <$> (base json)++instance ToJsonDeserializer p => ToJsonDeserializer (Schema p) where+ toJsonDeserializer schema = (cataNT toJsonDeserializerAlg) (unwrapSchema schema)
+ src/Data/Schema/JSON/Internal/Types.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Data.Schema.JSON.Internal.Types where++import Control.Applicative (liftA2)+import Control.Functor.HigherOrder+import Data.Aeson (parseJSON)+import qualified Data.Aeson.Types as JSON+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as Map+import Data.Schema.Internal.Types+import Data.Schema.JSON.Internal.Serializer+import Data.Schema.PrettyPrint+import Data.Scientific+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Prettyprint.Doc ((<+>))+import qualified Data.Text.Prettyprint.Doc as PP+import Data.Vector (Vector)+import qualified Data.Vector as Vector+import qualified Test.QuickCheck as QC+import qualified Test.QuickCheck.Gen as QC+import Test.QuickCheck.Instances.Scientific ()+import Test.Schema.QuickCheck.Internal.Gen++data JsonPrimitive (f :: (* -> *)) (a :: *) where+ JsonNumber :: JsonPrimitive f Scientific+ JsonText :: JsonPrimitive f Text+ JsonBool :: JsonPrimitive f Bool+ JsonArray :: f a -> JsonPrimitive f (Vector a)+ JsonMap :: f a -> JsonPrimitive f (HashMap Text a)++type JsonType = HMutu JsonPrimitive Schema++-- | Simple JSON schema type+type JsonSchema = Schema JsonType++-- | Simple JSON field type+type JsonField o a = Field JsonSchema o a++instance ToJsonSerializer JsonType where+ toJsonSerializer jType = JsonSerializer $ case (unmutu jType) of+ JsonNumber -> JSON.Number+ JsonText -> JSON.String+ JsonBool -> JSON.Bool+ JsonArray value -> \x ->+ JSON.Array $ fmap (runJsonSerializer . toJsonSerializer $ value) x+ JsonMap value -> \x ->+ JSON.Object $ Map.map (runJsonSerializer . toJsonSerializer $ value) x++instance ToJsonDeserializer JsonType where+ toJsonDeserializer jType = JsonDeserializer $ case (unmutu jType) of+ JsonNumber -> parseJSON+ JsonText -> parseJSON+ JsonBool -> parseJSON+ JsonArray value -> \case+ JSON.Array arr -> traverse (runJsonDeserializer . toJsonDeserializer $ value) arr+ other -> fail $ "Expected a JSON array but got: " ++ (show other)+ JsonMap value -> \case+ JSON.Object obj -> Map.foldrWithKey Map.insert Map.empty <$> traverse (runJsonDeserializer . toJsonDeserializer $ value) obj+ other -> fail $ "Expected a JSON object but got: " ++ (show other)++instance ToGen JsonType where+ toGen jType = case (unmutu jType) of+ JsonNumber -> QC.arbitrary+ JsonText -> T.pack <$> (QC.listOf QC.chooseAny)+ JsonBool -> QC.arbitrary :: (QC.Gen Bool)+ JsonArray value -> Vector.fromList <$> QC.listOf (toGen value)+ JsonMap value -> Map.fromList <$> (QC.listOf $ liftA2 ((,)) (T.pack <$> (QC.listOf QC.chooseAny)) (toGen value))++instance ToSchemaDoc JsonType where+ toSchemaDoc jType = SchemaDoc $ case (unmutu jType) of+ JsonNumber -> PP.pretty "Number"+ JsonText -> PP.pretty "Text"+ JsonBool -> PP.pretty "Bool"+ JsonArray value -> PP.pretty "[" <> (getDoc . toSchemaDoc $ value) <> PP.pretty "]"+ JsonMap value -> PP.pretty "Map { Text ->" <+> (getDoc . toSchemaDoc $ value) <+> PP.pretty "}"++instance ToSchemaLayout JsonType where+ toSchemaLayout jType = SchemaLayout $ case (unmutu jType) of+ JsonNumber -> PP.unsafeViaShow+ JsonText -> PP.unsafeViaShow+ JsonBool -> PP.unsafeViaShow+ JsonArray value -> \x ->+ PP.vsep $ fmap (\v -> runSchemaLayout (toSchemaLayout value) v) $ Vector.toList x+ JsonMap value -> \x ->+ PP.vsep $ fmap (\(k,v) -> PP.pretty k <+> PP.pretty "->" <+> runSchemaLayout (toSchemaLayout value) v) $ Map.toList x
+ src/Data/Schema/JSON/Simple.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LiberalTypeSynonyms #-}+{-# LANGUAGE RankNTypes #-}++module Data.Schema.JSON.Simple where++import Control.Functor.HigherOrder+import Control.Lens+import Data.HashMap.Strict (HashMap)+import Data.Schema+import Data.Schema.Internal.Types+import Data.Schema.JSON.Internal.Types+import Data.Scientific+import Data.Text (Text)+import qualified Data.Text as T+import Data.Vector (Vector)++-- | Define a text primitive+text :: JsonSchema Text+text = prim $ HMutu JsonText++-- | Define a string primitive+string :: JsonSchema String+string = alias (iso T.unpack T.pack) text++-- | Define a scientific number primitive+number :: JsonSchema Scientific+number = prim $ HMutu JsonNumber++-- | Define an integral primitive+int :: Integral a => JsonSchema a+int = alias (iso (\x -> either truncate id $ floatingOrInteger x) fromIntegral) number++-- | Define a floating point primitive+real :: RealFloat a => JsonSchema a+real = alias (iso (\x -> either id fromIntegral $ floatingOrInteger x) fromFloatDigits) number++array :: JsonSchema a -> JsonSchema (Vector a)+array elemSchema = prim $ HMutu (JsonArray elemSchema)++list :: JsonSchema a -> JsonSchema [a]+list = toList . array++hash :: JsonSchema a -> JsonSchema (HashMap Text a)+hash elemSchema = prim $ HMutu (JsonMap elemSchema)
+ test/Spec.hs view
@@ -0,0 +1,4 @@+import Test.Schema.JSON++main :: IO ()+main = verifyJsonSchema
+ test/Test/Schema/JSON.hs view
@@ -0,0 +1,45 @@+module Test.Schema.JSON+ ( verifyJsonSchema+ ) where++import Data.Aeson+import Data.Aeson.Text+import Data.Convertible+import Data.Schema.JSON+import qualified Data.Text.Lazy as T+import Test.Hspec+import Test.QuickCheck+import Test.Schema.Model+import Test.Schema.Utils++samplePerson :: Person+samplePerson = Person "foo" (Just $ convert (12 :: Int)) [+ mkUserRole+ , mkAdminRole "bar" 4+ ]++samplePersonJSONFileName :: String+samplePersonJSONFileName = "expected-model.json"++samplePersonJSON :: IO String+samplePersonJSON = loadTestFile samplePersonJSONFileName++prop_reverse :: Person -> Bool+prop_reverse person = decode (encode person) == (Just person)++describeJsonSerialization :: IO ()+describeJsonSerialization = hspec $ do+ describe "toJsonSerializer" $ do+ it "should generate valid JSON" $ do+ expectedJSON <- samplePersonJSON+ (T.unpack $ encodeToLazyText samplePerson) `shouldBe` expectedJSON++ it "should parse the given JSON" $ do+ givenJSON <- samplePersonJSON+ decodedPerson <- decodeFileStrict =<< testFilePath samplePersonJSONFileName+ decodedPerson `shouldBe` (Just samplePerson)++verifyJsonSchema :: IO ()+verifyJsonSchema = do+ quickCheck prop_reverse+ describeJsonSerialization
+ test/Test/Schema/Model.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Test.Schema.Model where++import Control.Lens+import Data.Aeson+import Data.Convertible+import Data.Schema (HasSchema (..))+import qualified Data.Schema as S+import Data.Schema.JSON+import qualified Data.Schema.JSON.Simple as JSON+import Data.Time (UTCTime)+import Test.QuickCheck+import Test.Schema.QuickCheck++utcTimeSchema :: JsonSchema UTCTime+utcTimeSchema = S.alias (iso convert convert) (JSON.int :: JsonSchema Integer)++data Role =+ UserRole UserRole+ | AdminRole AdminRole+ deriving (Eq, Show)++data UserRole = UserRole'+ deriving (Eq, Show)++data AdminRole = AdminRole' { department :: String, subordinateCount :: Int }+ deriving (Eq, Show)++mkUserRole :: Role+mkUserRole = UserRole $ UserRole'++mkAdminRole :: String -> Int -> Role+mkAdminRole dpt subs = AdminRole $ AdminRole' dpt subs++_UserRole :: Prism' Role UserRole+_UserRole = prism' UserRole $ \case+ UserRole x -> Just x+ _ -> Nothing++_AdminRole :: Prism' Role AdminRole+_AdminRole = prism' AdminRole $ \case+ AdminRole x -> Just x+ _ -> Nothing++adminRole :: JsonSchema AdminRole+adminRole = S.record+ ( AdminRole'+ <$> S.field "department" JSON.string (to department)+ <*> S.field "subordinateCount" JSON.int (to subordinateCount)+ )++roleSchema :: JsonSchema Role+roleSchema = S.oneOf+ [ S.alt "user" (S.const UserRole') _UserRole+ , S.alt "admin" adminRole _AdminRole+ ]++data Person = Person { personName :: String, birthDate :: Maybe UTCTime, roles :: [Role] }+ deriving (Eq, Show)++personSchema :: JsonSchema Person+personSchema = S.record+ ( Person+ <$> S.field "name" JSON.string (to personName)+ <*> S.optional "birthDate" utcTimeSchema (to birthDate)+ <*> S.field "roles" (JSON.list roleSchema) (to roles)+ )++instance HasSchema Person where+ type PrimitivesOf Person = JsonType++ getSchema = personSchema
+ test/Test/Schema/Utils.hs view
@@ -0,0 +1,17 @@+module Test.Schema.Utils where++import System.Directory+import System.IO++getTestFolder :: IO FilePath+getTestFolder = do+ baseDir <- getCurrentDirectory+ return $ baseDir ++ "/test/"++testFilePath :: String -> IO String+testFilePath f = do+ testDir <- getTestFolder+ return $ testDir ++ f++loadTestFile :: String -> IO String+loadTestFile f = testFilePath f >>= readFile