module Data.JSON.Schema.Types
( JSONSchema (..)
, Schema (..)
, Field (..)
, Bound (..)
, LengthBound (..)
, unbounded
, unboundedLength
) where
import Data.Maybe
import Data.Proxy
import Data.String
import Data.Text (Text)
import Data.Time.Clock (UTCTime)
import Data.Vector (Vector)
import Data.Word (Word32)
import qualified Data.Aeson.Types as Aeson
import qualified Data.HashMap.Strict as H
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text.Lazy as L
import qualified Data.Vector as V
data Schema =
Choice [Schema]
| Object [Field]
| Map Schema
| Array LengthBound Bool Schema
| Tuple [Schema]
| Value LengthBound
| Boolean
| Number Bound
| Constant Aeson.Value
| Null
| Any
deriving (Eq, Show)
data Bound = Bound
{ lower :: Maybe Int
, upper :: Maybe Int
} deriving (Eq, Show)
data LengthBound = LengthBound
{ lowerLength :: Maybe Int
, upperLength :: Maybe Int
} deriving (Eq, Show)
unbounded :: Bound
unbounded = Bound Nothing Nothing
unboundedLength :: LengthBound
unboundedLength = LengthBound Nothing Nothing
data Field = Field { key :: Text, required :: Bool, content :: Schema } deriving (Eq, Show)
class JSONSchema a where
schema :: Proxy a -> Schema
instance JSONSchema () where
schema _ = Null
instance JSONSchema Int where
schema _ = Number unbounded
instance JSONSchema Integer where
schema _ = Number unbounded
instance JSONSchema Word32 where
schema _ = Number unbounded
instance JSONSchema Bool where
schema _ = Boolean
instance JSONSchema Text where
schema _ = Value unboundedLength
instance JSONSchema L.Text where
schema _ = Value unboundedLength
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 unboundedLength False . schema . fmap head
instance JSONSchema a => JSONSchema (Vector a) where
schema = Array unboundedLength False . schema . fmap V.head
instance (IsString k, JSONSchema v) => JSONSchema (M.Map k v) where
schema = Map . schema . fmap (head . M.elems)
instance (IsString k, JSONSchema v) => JSONSchema (H.HashMap k v) where
schema = Map . schema . fmap (head . H.elems)
instance JSONSchema UTCTime where
schema _ = Value LengthBound { lowerLength = Just 20, upperLength = Just 24 }
instance JSONSchema a => JSONSchema (S.Set a) where
schema = schema . fmap S.toList
instance (JSONSchema a, JSONSchema b) => JSONSchema (a, b) where
schema s = Tuple
[ schema . fmap fst $ s
, schema . fmap snd $ s
]
instance (JSONSchema a, JSONSchema b, JSONSchema c) => JSONSchema (a, b, c) where
schema s = Tuple
[ schema . fmap (\(a,_,_) -> a) $ s
, schema . fmap (\(_,b,_) -> b) $ s
, schema . fmap (\(_,_,c) -> c) $ s
]
instance (JSONSchema a, JSONSchema b, JSONSchema c, JSONSchema d) => JSONSchema (a, b, c, d) where
schema s = Tuple
[ schema . fmap (\(a,_,_,_) -> a) $ s
, schema . fmap (\(_,b,_,_) -> b) $ s
, schema . fmap (\(_,_,c,_) -> c) $ s
, schema . fmap (\(_,_,_,d) -> d) $ s
]
instance (JSONSchema a, JSONSchema b, JSONSchema c, JSONSchema d, JSONSchema e) => JSONSchema (a, b, c, d, e) where
schema s = Tuple
[ schema . fmap (\(a,_,_,_,_) -> a) $ s
, schema . fmap (\(_,b,_,_,_) -> b) $ s
, schema . fmap (\(_,_,c,_,_) -> c) $ s
, schema . fmap (\(_,_,_,d,_) -> d) $ s
, schema . fmap (\(_,_,_,_,e) -> e) $ s
]
instance (JSONSchema a, JSONSchema b, JSONSchema c, JSONSchema d, JSONSchema e, JSONSchema f) => JSONSchema (a, b, c, d, e, f) where
schema s = Tuple
[ schema . fmap (\(a,_,_,_,_,_) -> a) $ s
, schema . fmap (\(_,b,_,_,_,_) -> b) $ s
, schema . fmap (\(_,_,c,_,_,_) -> c) $ s
, schema . fmap (\(_,_,_,d,_,_) -> d) $ s
, schema . fmap (\(_,_,_,_,e,_) -> e) $ s
, schema . fmap (\(_,_,_,_,_,f) -> f) $ s
]
instance (JSONSchema a, JSONSchema b, JSONSchema c, JSONSchema d, JSONSchema e, JSONSchema f, JSONSchema g) => JSONSchema (a, b, c, d, e, f, g) where
schema s = Tuple
[ schema . fmap (\(a,_,_,_,_,_,_) -> a) $ s
, schema . fmap (\(_,b,_,_,_,_,_) -> b) $ s
, schema . fmap (\(_,_,c,_,_,_,_) -> c) $ s
, schema . fmap (\(_,_,_,d,_,_,_) -> d) $ s
, schema . fmap (\(_,_,_,_,e,_,_) -> e) $ s
, schema . fmap (\(_,_,_,_,_,f,_) -> f) $ s
, schema . fmap (\(_,_,_,_,_,_,g) -> g) $ s
]