json-schema (empty) → 0.4

raw patch · 7 files changed

+284/−0 lines, 7 filesdep +aesondep +basedep +containerssetup-changed

Dependencies added: aeson, base, containers, generic-aeson, generic-deriving, tagged, text

Files

LICENSE +30/−0
Setup.hs +2/−0
json-schema.cabal +31/−0
src/Data/JSON/Schema.hs +9/−0
src/Data/JSON/Schema/Combinators.hs +58/−0
src/Data/JSON/Schema/Generic.hs +92/−0
src/Data/JSON/Schema/Types.hs +62/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2014, Silk++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Silk nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ json-schema.cabal view

@@ -0,0 +1,31 @@+Name:                json-schema+Version:             0.4+Synopsis:            Types and type classes for defining JSON schemas.+Description:         Types and type classes for defining JSON schemas.+License:             BSD3+License-file:        LICENSE+Author:              Silk+Maintainer:          code@silk.co+Category:            Data+Build-type:          Simple+Cabal-version:       >=1.6++Library+  Hs-Source-Dirs:    src+  Exposed-Modules:   Data.JSON.Schema+                   , Data.JSON.Schema.Combinators+                   , Data.JSON.Schema.Generic+                   , Data.JSON.Schema.Types+  Build-Depends:     base == 4.*+                   , aeson >= 0.6 && < 0.8+                   , containers >= 0.3 && < 0.6+                   , generic-aeson == 0.1.*+                   , generic-deriving == 1.6.*+                   , tagged >= 0.2 && < 0.8+                   -- No bounds, since we only use the Text type.+                   , text+  Ghc-Options:       -Wall++Source-repository head+  Type:              Git+  Location:          https://github.com/silkapp/json-schema.git

+ src/Data/JSON/Schema.hs view

@@ -0,0 +1,9 @@+module Data.JSON.Schema+  ( module Data.JSON.Schema.Generic+  , module Data.JSON.Schema.Types+  , Proxy (..)+  ) where++import Data.JSON.Schema.Generic+import Data.JSON.Schema.Types+import Data.Proxy

+ src/Data/JSON/Schema/Combinators.hs view

@@ -0,0 +1,58 @@+-- | Combinators for creating JSON schemas.+module Data.JSON.Schema.Combinators where++import Data.JSON.Schema.Types++-- | A schema combinator.+type SchemaC = Schema -> Schema++-- | Optionality operator for schemas.+infixl 3 <|>+(<|>) :: Schema -> Schema -> Schema+(Choice s1) <|> (Choice s2) = Choice $ s1 ++ s2+(Choice s1) <|> v           = Choice $ s1 ++ [v]+v           <|> (Choice s2) = Choice $ v : s2+v1          <|> v2          = Choice $ [v1, v2]++-- | Tupling.+infixl 4 <+>+(<+>) :: Schema -> Schema -> Schema+(Tuple t1) <+> (Tuple t2) = Tuple $ t1 ++ t2+(Tuple t1) <+> v          = Tuple $ t1 ++ [v]+v          <+> (Tuple t2) = Tuple $ v : t2+v1         <+> v2         = Tuple $ [v1, v2]++-- | If passed two objects, merges the fields. Otherwise creates a+-- tuple.+merge :: Schema -> Schema -> Schema+merge (Object f1) (Object f2) = Object $ f1 ++ f2+merge v1          v2          = v1 <+> v2++-- | Create an object with a single field.+field :: String -> Bool -> Schema -> Schema+field k r v = Object [Field k r v]++-- | An unbounded string.+value :: Schema+value = Value 0 (-1)++-- | An unbounded number.+number :: Schema+number = Number 0 (-1)++-- | An unbounded array with non-unique values.+array :: Schema -> Schema+array = Array 0 (-1) False++-- | Add a field to an object, or tuple if passed a non-object.+addField :: String -> Bool -> Schema -> SchemaC+addField k r v = merge $ field k r v++-- | Add multiple fields to an object, or tuple if passed a+-- non-object.+addFields :: [(String, Bool, Schema)] -> SchemaC+addFields = flip $ foldr (\(k, r, v) -> addField k r v)++-- | An empty object.+empty :: Schema+empty = Object []

+ src/Data/JSON/Schema/Generic.hs view

@@ -0,0 +1,92 @@+{-# LANGUAGE TypeOperators+           , TupleSections+           , ScopedTypeVariables+           , FlexibleContexts+           , FlexibleInstances+           , OverlappingInstances+           , TypeFamilies+           #-}+-- | Generic derivation of schemas. The schemas generated match the+-- JSON generated by type 'generic-aeson' package. See that package+-- for documentation on the format and examples of it.+module Data.JSON.Schema.Generic (gSchema) where++import Control.Applicative hiding (empty, (<|>))+import Data.Char+import Data.JSON.Schema.Combinators+import Data.JSON.Schema.Types+import Data.Maybe+import Data.Proxy+import GHC.Generics+import Generics.Deriving.ConNames+import Generics.Generic.IsEnum++class GJSONSCHEMA f where+  gSchema' :: Bool -> Bool -> Proxy (f a) -> Schema++-- Recursive positions disabled for now, it causes infintite data structures. This is a problem to be solved!+{-+instance GJSONSCHEMA I where+  gSchema' _ f = f . fmap unI+-}++instance JSONSchema c => GJSONSCHEMA (K1 i c) where+  gSchema' _ _ = schema . fmap unK1++instance GJSONSCHEMA (K1 i String) where+  gSchema' _ _ _ = Value 0 (-1)++instance GJSONSCHEMA U1 where+  gSchema' _ _ _ = empty++instance (GJSONSCHEMA f, GJSONSCHEMA g) => GJSONSCHEMA (f :+: g) where+  gSchema' mc enm p =+        gSchema' mc enm (gL <$> p)+    <|> gSchema' mc enm (gR <$> p)+    where+      gL :: (f :+: g) r -> f r+      gL _ = undefined+      gR :: (f :+: g) r -> g r+      gR _ = undefined++gFst :: (f :*: g) r -> f r+gFst (f :*: _) = f++gSnd :: (f :*: g) r -> g r+gSnd (_ :*: g) = g++instance (GJSONSCHEMA f, GJSONSCHEMA g) => GJSONSCHEMA (f :*: g) where+  gSchema' mc enm p = gSchema' mc enm (gFst <$> p) `merge` gSchema' mc enm (gSnd <$> p)++instance (Constructor c, GJSONSCHEMA f) => GJSONSCHEMA (M1 C c f) where+  gSchema' _  True = const $ Value 0 (-1)+  gSchema' mc enm = wrap . gSchema' mc enm . fmap unM1+    where+      wrap = if mc+             then field (firstLetterToLower $ conName (undefined :: M1 C c f p)) True+             else id++instance GJSONSCHEMA f => GJSONSCHEMA (M1 D c f) where+  gSchema' mc enm = gSchema' mc enm . fmap unM1++firstLetterToLower :: String -> String+firstLetterToLower ""     = ""+firstLetterToLower (l:ls) = toLower l : ls++instance (Selector c, JSONSchema a) => GJSONSCHEMA (M1 S c (K1 i (Maybe a))) where+  gSchema' _ _ = field (selName (undefined :: M1 S c f p)) False . schema . fmap (fromJust . unK1 . unM1)++instance Selector c => GJSONSCHEMA (M1 S c (K1 i (Maybe String))) where+  gSchema' _ _ _ = field (selName (undefined :: M1 S c f p)) False $ Value 0 (-1)++instance (Selector c, GJSONSCHEMA f) => GJSONSCHEMA (M1 S c f) where+  gSchema' mc enm = field (selName (undefined :: M1 S c f p)) True . gSchema' mc enm . fmap unM1++multipleConstructors :: (Generic a, ConNames (Rep a)) => Proxy a -> Bool+multipleConstructors = (> 1) . length . conNames . pv+  where pv :: Proxy a -> a+        pv _ = undefined++-- | Derive a JSON schema for types with an instance of 'Generic'.+gSchema :: (Generic a, GJSONSCHEMA (Rep a), ConNames (Rep a), GIsEnum (Rep a)) => Proxy a -> Schema+gSchema p = gSchema' (multipleConstructors p) (isEnum p) (fmap from p)

+ src/Data/JSON/Schema/Types.hs view

@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+-- | Types for defining JSON schemas.+module Data.JSON.Schema.Types where++import Data.Maybe+import Data.Proxy+import Data.Text (Text)+import Data.Word (Word32)++-- | A schema is any JSON value.+type Schema = Value++-- | A schema for a JSON value.+data Value =+    Choice [Value] -- ^ A choice of multiple values, e.g. for sum types.+  | Object [Field] -- ^ A JSON object.+  | Array Int Int Bool Value -- ^ An array. The integers represent the+                             -- lower and upper bound of the array+                             -- size. The value -1 indicates no bound.+                             -- The boolean denotes whether items have+                             -- to unique.+  | Tuple [Value]   -- ^ A fixed-length tuple of different values.+  | Value Int Int   -- ^ A string. The integers denote the lower and+                    -- upper bound of the length of the string. The+                    -- value -1 indicates no bound.+  | Boolean+  | Number Int Int  -- ^ A number. The integers denote the lower and+                    -- upper bound on the value. The value -1+                    -- indicates no bound.+  | Null+  deriving (Eq, Show)++-- | A field in an object.+data Field = Field { key :: String, required :: Bool, content :: Schema } deriving (Eq, Show)++-- | Class representing JSON schemas+class JSONSchema a where+  schema :: Proxy a -> Schema++instance JSONSchema () where+  schema _ = Null++instance JSONSchema Int where+  schema _ = Number 0 (-1)++instance JSONSchema Integer where+  schema _ = Number 0 (-1)++instance JSONSchema Word32 where+  schema _ = Number 0 4294967295++instance JSONSchema Bool where+  schema _ = Boolean++instance JSONSchema Text where+  schema _ = Value 0 (-1)++instance JSONSchema a => JSONSchema (Maybe a) where+  schema p = Choice [Object [Field "Just" True $ schema $ fmap fromJust p], Object [Field "Nothing" True Null]]++instance JSONSchema a => JSONSchema [a] where+  schema = Array 0 (-1) False . schema . fmap head