module Data.OpenApi.Compare.Validate.Schema.JsonFormula
  ( Bound (..),
    showBound,
    Property (..),
    Condition (..),
    showCondition,
    satisfiesTyped,
    checkStringFormat,
    checkNumberFormat,
    SomeCondition (..),
    JsonFormula (..),
    satisfiesFormula,
    satisfies,
    showJSONValue,
    showJSONValueInline,
  )
where

import Algebra.Lattice
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Foldable as F
import Data.Functor
import qualified Data.HashMap.Strict as HM
import Data.Int
import Data.Kind
import qualified Data.Map as M
import Data.Maybe
import Data.OpenApi
import Data.OpenApi.Compare.Orphans ()
import Data.OpenApi.Compare.Subtree
import Data.OpenApi.Compare.Validate.Schema.DNF
import Data.OpenApi.Compare.Validate.Schema.TypedJson
import Data.Ord
import Data.Ratio
import Data.Scientific
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Typeable
import Text.Pandoc.Builder hiding (Format, Null)
import Text.Regex.Pcre2

data Bound a = Exclusive !a | Inclusive !a
  deriving stock (Bound a -> Bound a -> Bool
(Bound a -> Bound a -> Bool)
-> (Bound a -> Bound a -> Bool) -> Eq (Bound a)
forall a. Eq a => Bound a -> Bound a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bound a -> Bound a -> Bool
$c/= :: forall a. Eq a => Bound a -> Bound a -> Bool
== :: Bound a -> Bound a -> Bool
$c== :: forall a. Eq a => Bound a -> Bound a -> Bool
Eq, Int -> Bound a -> ShowS
[Bound a] -> ShowS
Bound a -> String
(Int -> Bound a -> ShowS)
-> (Bound a -> String) -> ([Bound a] -> ShowS) -> Show (Bound a)
forall a. Show a => Int -> Bound a -> ShowS
forall a. Show a => [Bound a] -> ShowS
forall a. Show a => Bound a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bound a] -> ShowS
$cshowList :: forall a. Show a => [Bound a] -> ShowS
show :: Bound a -> String
$cshow :: forall a. Show a => Bound a -> String
showsPrec :: Int -> Bound a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Bound a -> ShowS
Show, a -> Bound b -> Bound a
(a -> b) -> Bound a -> Bound b
(forall a b. (a -> b) -> Bound a -> Bound b)
-> (forall a b. a -> Bound b -> Bound a) -> Functor Bound
forall a b. a -> Bound b -> Bound a
forall a b. (a -> b) -> Bound a -> Bound b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Bound b -> Bound a
$c<$ :: forall a b. a -> Bound b -> Bound a
fmap :: (a -> b) -> Bound a -> Bound b
$cfmap :: forall a b. (a -> b) -> Bound a -> Bound b
Functor)

-- | The order is lexicographical on @a * Bool@.
instance Ord a => Ord (Bound a) where
  Exclusive a
a compare :: Bound a -> Bound a -> Ordering
`compare` Exclusive a
b = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b
  Exclusive a
a `compare` Inclusive a
b = if a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
b then Ordering
LT else Ordering
GT
  Inclusive a
a `compare` Exclusive a
b = if a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
b then Ordering
LT else Ordering
GT
  Inclusive a
a `compare` Inclusive a
b = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b

showBound :: Show a => Bound a -> Inlines
showBound :: Bound a -> Inlines
showBound (Inclusive a
x) = a -> Inlines
forall x. Show x => x -> Inlines
show' a
x Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
" inclusive"
showBound (Exclusive a
x) = a -> Inlines
forall x. Show x => x -> Inlines
show' a
x Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
" exclusive"

data Property = Property
  { Property -> Bool
propRequired :: Bool
  , Property -> ForeachType JsonFormula
propFormula :: ForeachType JsonFormula
  , Property -> Traced (Referenced Schema)
propRefSchema :: Traced (Referenced Schema)
  }
  deriving stock (Property -> Property -> Bool
(Property -> Property -> Bool)
-> (Property -> Property -> Bool) -> Eq Property
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Property -> Property -> Bool
$c/= :: Property -> Property -> Bool
== :: Property -> Property -> Bool
$c== :: Property -> Property -> Bool
Eq, Eq Property
Eq Property
-> (Property -> Property -> Ordering)
-> (Property -> Property -> Bool)
-> (Property -> Property -> Bool)
-> (Property -> Property -> Bool)
-> (Property -> Property -> Bool)
-> (Property -> Property -> Property)
-> (Property -> Property -> Property)
-> Ord Property
Property -> Property -> Bool
Property -> Property -> Ordering
Property -> Property -> Property
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Property -> Property -> Property
$cmin :: Property -> Property -> Property
max :: Property -> Property -> Property
$cmax :: Property -> Property -> Property
>= :: Property -> Property -> Bool
$c>= :: Property -> Property -> Bool
> :: Property -> Property -> Bool
$c> :: Property -> Property -> Bool
<= :: Property -> Property -> Bool
$c<= :: Property -> Property -> Bool
< :: Property -> Property -> Bool
$c< :: Property -> Property -> Bool
compare :: Property -> Property -> Ordering
$ccompare :: Property -> Property -> Ordering
$cp1Ord :: Eq Property
Ord, Int -> Property -> ShowS
[Property] -> ShowS
Property -> String
(Int -> Property -> ShowS)
-> (Property -> String) -> ([Property] -> ShowS) -> Show Property
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Property] -> ShowS
$cshowList :: [Property] -> ShowS
show :: Property -> String
$cshow :: Property -> String
showsPrec :: Int -> Property -> ShowS
$cshowsPrec :: Int -> Property -> ShowS
Show)

-- | A primitive structural condition for the "top level" of a JSON value (of a specific type)
data Condition :: JsonType -> Type where
  Exactly :: TypedValue t -> Condition t
  Maximum :: !(Bound Scientific) -> Condition 'Number
  Minimum ::
    !(Down (Bound (Down Scientific))) ->
    -- | this has the right Ord
    Condition 'Number
  MultipleOf :: !Scientific -> Condition 'Number
  NumberFormat :: !Format -> Condition 'Number
  MaxLength :: !Integer -> Condition 'String
  MinLength :: !Integer -> Condition 'String
  Pattern :: !Pattern -> Condition 'String
  StringFormat :: !Format -> Condition 'String
  Items ::
    !(ForeachType JsonFormula) ->
    !(Traced (Referenced Schema)) ->
    Condition 'Array
  TupleItems ::
    ![(ForeachType JsonFormula, Traced (Referenced Schema))] ->
    Condition 'Array
  MaxItems :: !Integer -> Condition 'Array
  MinItems :: !Integer -> Condition 'Array
  UniqueItems :: Condition 'Array
  Properties ::
    !(M.Map Text Property) ->
    -- | formula for additional properties
    !(ForeachType JsonFormula) ->
    -- | schema for additional properties, Nothing means bottom
    !(Maybe (Traced (Referenced Schema))) ->
    Condition 'Object
  MaxProperties :: !Integer -> Condition 'Object
  MinProperties :: !Integer -> Condition 'Object

deriving stock instance Eq (Condition t)

deriving stock instance Ord (Condition t)

deriving stock instance Show (Condition t)

showCondition :: Condition a -> Blocks
showCondition :: Condition a -> Blocks
showCondition = \case
  (Exactly TypedValue a
v) -> Inlines -> Blocks
para Inlines
"The value should be:" Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Value -> Blocks
showJSONValue (TypedValue a -> Value
forall (t :: JsonType). TypedValue t -> Value
untypeValue TypedValue a
v)
  (Maximum Bound Scientific
b) -> Inlines -> Blocks
para (Inlines -> Blocks) -> Inlines -> Blocks
forall a b. (a -> b) -> a -> b
$ Inlines
"The value should be less than " Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Bound Scientific -> Inlines
forall a. Show a => Bound a -> Inlines
showBound Bound Scientific
b Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
"."
  (Minimum (Down Bound (Down Scientific)
b)) -> Inlines -> Blocks
para (Inlines -> Blocks) -> Inlines -> Blocks
forall a b. (a -> b) -> a -> b
$ Inlines
"The value should be more than " Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Bound Scientific -> Inlines
forall a. Show a => Bound a -> Inlines
showBound (Down Scientific -> Scientific
forall a. Down a -> a
getDown (Down Scientific -> Scientific)
-> Bound (Down Scientific) -> Bound Scientific
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bound (Down Scientific)
b) Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
"."
  (MultipleOf Scientific
n) -> Inlines -> Blocks
para (Inlines -> Blocks) -> Inlines -> Blocks
forall a b. (a -> b) -> a -> b
$ Inlines
"The value should be a multiple of " Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Scientific -> Inlines
forall x. Show x => x -> Inlines
show' Scientific
n Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
"."
  (NumberFormat Format
p) -> Inlines -> Blocks
para (Inlines -> Blocks) -> Inlines -> Blocks
forall a b. (a -> b) -> a -> b
$ Inlines
"The number should have the following format:" Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Format -> Inlines
code Format
p Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
"."
  (Pattern Format
p) -> Inlines -> Blocks
para Inlines
"The value should satisfy the following pattern (regular expression):" Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Format -> Blocks
codeBlock Format
p
  (StringFormat Format
p) -> Inlines -> Blocks
para (Inlines -> Blocks) -> Inlines -> Blocks
forall a b. (a -> b) -> a -> b
$ Inlines
"The string should have the following format:" Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Format -> Inlines
code Format
p Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
"."
  (MaxLength Integer
p) -> Inlines -> Blocks
para (Inlines -> Blocks) -> Inlines -> Blocks
forall a b. (a -> b) -> a -> b
$ Inlines
"The length of the string should be less than or equal to " Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Integer -> Inlines
forall x. Show x => x -> Inlines
show' Integer
p Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
"."
  (MinLength Integer
p) -> Inlines -> Blocks
para (Inlines -> Blocks) -> Inlines -> Blocks
forall a b. (a -> b) -> a -> b
$ Inlines
"The length of the string should be more than or equal to " Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Integer -> Inlines
forall x. Show x => x -> Inlines
show' Integer
p Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
"."
  (Items ForeachType JsonFormula
i Traced (Referenced Schema)
_) -> Inlines -> Blocks
para Inlines
"The items of the array should satisfy:" Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> ForeachType JsonFormula -> Blocks
showForEachJsonFormula ForeachType JsonFormula
i
  (TupleItems [(ForeachType JsonFormula, Traced (Referenced Schema))]
is) -> Inlines -> Blocks
para (Inlines
"There should be " Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Int -> Inlines
forall x. Show x => x -> Inlines
show' ([(ForeachType JsonFormula, Traced (Referenced Schema))] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ForeachType JsonFormula, Traced (Referenced Schema))]
is) Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
" items in the array:") Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> [Blocks] -> Blocks
bulletList (ForeachType JsonFormula -> Blocks
showForEachJsonFormula (ForeachType JsonFormula -> Blocks)
-> ((ForeachType JsonFormula, Traced (Referenced Schema))
    -> ForeachType JsonFormula)
-> (ForeachType JsonFormula, Traced (Referenced Schema))
-> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ForeachType JsonFormula, Traced (Referenced Schema))
-> ForeachType JsonFormula
forall a b. (a, b) -> a
fst ((ForeachType JsonFormula, Traced (Referenced Schema)) -> Blocks)
-> [(ForeachType JsonFormula, Traced (Referenced Schema))]
-> [Blocks]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ForeachType JsonFormula, Traced (Referenced Schema))]
is)
  (MaxItems Integer
n) -> Inlines -> Blocks
para (Inlines -> Blocks) -> Inlines -> Blocks
forall a b. (a -> b) -> a -> b
$ Inlines
"The length of the array should be less than or equal to " Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Integer -> Inlines
forall x. Show x => x -> Inlines
show' Integer
n Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
"."
  (MinItems Integer
n) -> Inlines -> Blocks
para (Inlines -> Blocks) -> Inlines -> Blocks
forall a b. (a -> b) -> a -> b
$ Inlines
"The length of the array should be more than or equal to " Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Integer -> Inlines
forall x. Show x => x -> Inlines
show' Integer
n Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
"."
  Condition a
UniqueItems -> Inlines -> Blocks
para Inlines
"The elements in the array should be unique."
  (Properties Map Format Property
props ForeachType JsonFormula
additional Maybe (Traced (Referenced Schema))
_) ->
    [Blocks] -> Blocks
bulletList ([Blocks] -> Blocks) -> [Blocks] -> Blocks
forall a b. (a -> b) -> a -> b
$
      ( Map Format Property -> [(Format, Property)]
forall k a. Map k a -> [(k, a)]
M.toList Map Format Property
props
          [(Format, Property)] -> ((Format, Property) -> Blocks) -> [Blocks]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ( \(Format
k, Property
p) ->
                  Inlines -> Blocks
para (Format -> Inlines
code Format
k)
                    Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Inlines -> Blocks
para (Inlines -> Inlines
strong (Inlines -> Inlines) -> Inlines -> Inlines
forall a b. (a -> b) -> a -> b
$ if Property -> Bool
propRequired Property
p then Inlines
"Required" else Inlines
"Optional")
                    Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> ForeachType JsonFormula -> Blocks
showForEachJsonFormula (Property -> ForeachType JsonFormula
propFormula Property
p)
              )
      )
        [Blocks] -> [Blocks] -> [Blocks]
forall a. Semigroup a => a -> a -> a
<> [ Inlines -> Blocks
para (Inlines -> Inlines
emph Inlines
"Additional properties")
              Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> ForeachType JsonFormula -> Blocks
showForEachJsonFormula ForeachType JsonFormula
additional
           ]
  (MaxProperties Integer
n) -> Inlines -> Blocks
para (Inlines -> Blocks) -> Inlines -> Blocks
forall a b. (a -> b) -> a -> b
$ Inlines
"The maximum number of fields should be " Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Integer -> Inlines
forall x. Show x => x -> Inlines
show' Integer
n Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
"."
  (MinProperties Integer
n) -> Inlines -> Blocks
para (Inlines -> Blocks) -> Inlines -> Blocks
forall a b. (a -> b) -> a -> b
$ Inlines
"The minimum number of fields should be " Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Integer -> Inlines
forall x. Show x => x -> Inlines
show' Integer
n Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
"."
  where
    showForEachJsonFormula :: ForeachType JsonFormula -> Blocks
    showForEachJsonFormula :: ForeachType JsonFormula -> Blocks
showForEachJsonFormula ForeachType JsonFormula
i =
      [Blocks] -> Blocks
bulletList ([Blocks] -> Blocks) -> [Blocks] -> Blocks
forall a b. (a -> b) -> a -> b
$
        (forall (x :: JsonType).
 Typeable x =>
 JsonType -> (ForeachType JsonFormula -> JsonFormula x) -> [Blocks])
-> [Blocks]
forall m (f :: JsonType -> *).
Monoid m =>
(forall (x :: JsonType).
 Typeable x =>
 JsonType -> (ForeachType f -> f x) -> m)
-> m
foldType
          ( \JsonType
t ForeachType JsonFormula -> JsonFormula x
f -> case JsonFormula x -> DNF (Condition x)
forall (t :: JsonType). JsonFormula t -> DNF (Condition t)
getJsonFormula (JsonFormula x -> DNF (Condition x))
-> JsonFormula x -> DNF (Condition x)
forall a b. (a -> b) -> a -> b
$ ForeachType JsonFormula -> JsonFormula x
f ForeachType JsonFormula
i of
              DNF (Condition x)
BottomDNF -> [Blocks]
forall a. Monoid a => a
mempty
              (DNF Set (Disjunct (Condition x))
conds) ->
                [ Inlines -> Blocks
para (JsonType -> Inlines
forall s. IsString s => JsonType -> s
describeJSONType JsonType
t)
                    Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> [Blocks] -> Blocks
bulletList
                      ( Set (Disjunct (Condition x)) -> [Disjunct (Condition x)]
forall a. Set a -> [a]
S.toList Set (Disjunct (Condition x))
conds [Disjunct (Condition x)]
-> (Disjunct (Condition x) -> Blocks) -> [Blocks]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                          Disjunct (Set (Condition x) -> [Condition x]
forall a. Set a -> [a]
S.toList -> []) -> Inlines -> Blocks
para Inlines
"Empty"
                          Disjunct (Set (Condition x) -> [Condition x]
forall a. Set a -> [a]
S.toList -> [Condition x]
cond) -> [Blocks] -> Blocks
bulletList (Condition x -> Blocks
forall (a :: JsonType). Condition a -> Blocks
showCondition (Condition x -> Blocks) -> [Condition x] -> [Blocks]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Condition x]
cond)
                      )
                ]
          )

showJSONValue :: A.Value -> Blocks
showJSONValue :: Value -> Blocks
showJSONValue Value
v = Attr -> Format -> Blocks
codeBlockWith (Format
"", [Format
"json"], [(Format, Format)]
forall a. Monoid a => a
mempty) (ByteString -> Format
T.decodeUtf8 (ByteString -> Format) -> (Value -> ByteString) -> Value -> Format
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString)
-> (Value -> ByteString) -> Value -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (Value -> Format) -> Value -> Format
forall a b. (a -> b) -> a -> b
$ Value
v)

showJSONValueInline :: A.Value -> Inlines
showJSONValueInline :: Value -> Inlines
showJSONValueInline Value
v = Format -> Inlines
code (ByteString -> Format
T.decodeUtf8 (ByteString -> Format) -> (Value -> ByteString) -> Value -> Format
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString)
-> (Value -> ByteString) -> Value -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (Value -> Format) -> Value -> Format
forall a b. (a -> b) -> a -> b
$ Value
v)

show' :: Show x => x -> Inlines
show' :: x -> Inlines
show' = Format -> Inlines
str (Format -> Inlines) -> (x -> Format) -> x -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Format
T.pack (String -> Format) -> (x -> String) -> x -> Format
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> String
forall a. Show a => a -> String
show

satisfiesTyped :: TypedValue t -> Condition t -> Bool
satisfiesTyped :: TypedValue t -> Condition t -> Bool
satisfiesTyped TypedValue t
e (Exactly TypedValue t
e') = TypedValue t
e TypedValue t -> TypedValue t -> Bool
forall a. Eq a => a -> a -> Bool
== TypedValue t
e'
satisfiesTyped (TNumber Scientific
n) (Maximum (Exclusive Scientific
m)) = Scientific
n Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
< Scientific
m
satisfiesTyped (TNumber Scientific
n) (Maximum (Inclusive Scientific
m)) = Scientific
n Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
<= Scientific
m
satisfiesTyped (TNumber Scientific
n) (Minimum (Down (Exclusive (Down Scientific
m)))) = Scientific
n Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
> Scientific
m
satisfiesTyped (TNumber Scientific
n) (Minimum (Down (Inclusive (Down Scientific
m)))) = Scientific
n Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
>= Scientific
m
satisfiesTyped (TNumber Scientific
n) (MultipleOf Scientific
m) = Ratio Integer -> Integer
forall a. Ratio a -> a
denominator (Scientific -> Ratio Integer
forall a. Real a => a -> Ratio Integer
toRational Scientific
n Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Fractional a => a -> a -> a
/ Scientific -> Ratio Integer
forall a. Real a => a -> Ratio Integer
toRational Scientific
m) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 -- TODO: could be better #36
satisfiesTyped (TNumber Scientific
n) (NumberFormat Format
f) = Format -> Scientific -> Bool
checkNumberFormat Format
f Scientific
n
satisfiesTyped (TString Format
s) (MaxLength Integer
m) = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Format -> Int
T.length Format
s) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
m
satisfiesTyped (TString Format
s) (MinLength Integer
m) = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Format -> Int
T.length Format
s) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
m
satisfiesTyped (TString Format
s) (Pattern Format
p) = Maybe Format -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Format -> Bool) -> Maybe Format -> Bool
forall a b. (a -> b) -> a -> b
$ Format -> Format -> Maybe Format
forall (f :: * -> *). Alternative f => Format -> Format -> f Format
match Format
p Format
s -- TODO: regex stuff #32
satisfiesTyped (TString Format
s) (StringFormat Format
f) = Format -> Format -> Bool
checkStringFormat Format
f Format
s
satisfiesTyped (TArray Array
a) (Items ForeachType JsonFormula
f Traced (Referenced Schema)
_) = (Value -> Bool) -> Array -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Value -> ForeachType JsonFormula -> Bool
`satisfies` ForeachType JsonFormula
f) Array
a
satisfiesTyped (TArray Array
a) (TupleItems [(ForeachType JsonFormula, Traced (Referenced Schema))]
fs) = [(ForeachType JsonFormula, Traced (Referenced Schema))] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ForeachType JsonFormula, Traced (Referenced Schema))]
fs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Array -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
F.length Array
a Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Value -> ForeachType JsonFormula -> Bool)
-> [Value] -> [ForeachType JsonFormula] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Value -> ForeachType JsonFormula -> Bool
satisfies (Array -> [Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Array
a) ((ForeachType JsonFormula, Traced (Referenced Schema))
-> ForeachType JsonFormula
forall a b. (a, b) -> a
fst ((ForeachType JsonFormula, Traced (Referenced Schema))
 -> ForeachType JsonFormula)
-> [(ForeachType JsonFormula, Traced (Referenced Schema))]
-> [ForeachType JsonFormula]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ForeachType JsonFormula, Traced (Referenced Schema))]
fs))
satisfiesTyped (TArray Array
a) (MaxItems Integer
m) = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Array -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
F.length Array
a) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
m
satisfiesTyped (TArray Array
a) (MinItems Integer
m) = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Array -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
F.length Array
a) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
m
satisfiesTyped (TArray Array
a) Condition t
UniqueItems = Set Value -> Int
forall a. Set a -> Int
S.size ([Value] -> Set Value
forall a. Ord a => [a] -> Set a
S.fromList ([Value] -> Set Value) -> [Value] -> Set Value
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Array
a) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Array -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
F.length Array
a -- TODO: could be better #36
satisfiesTyped (TObject Object
o) (Properties Map Format Property
props ForeachType JsonFormula
additional Maybe (Traced (Referenced Schema))
_) =
  (Format -> Bool) -> [Format] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Format -> Object -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`HM.member` Object
o) (Map Format Property -> [Format]
forall k a. Map k a -> [k]
M.keys ((Property -> Bool) -> Map Format Property -> Map Format Property
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter Property -> Bool
propRequired Map Format Property
props))
    Bool -> Bool -> Bool
&& ((Format, Value) -> Bool) -> [(Format, Value)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Format
k, Value
v) -> Value -> ForeachType JsonFormula -> Bool
satisfies Value
v (ForeachType JsonFormula -> Bool)
-> ForeachType JsonFormula -> Bool
forall a b. (a -> b) -> a -> b
$ ForeachType JsonFormula
-> (Property -> ForeachType JsonFormula)
-> Maybe Property
-> ForeachType JsonFormula
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ForeachType JsonFormula
additional Property -> ForeachType JsonFormula
propFormula (Maybe Property -> ForeachType JsonFormula)
-> Maybe Property -> ForeachType JsonFormula
forall a b. (a -> b) -> a -> b
$ Format -> Map Format Property -> Maybe Property
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Format
k Map Format Property
props) (Object -> [(Format, Value)]
forall k v. HashMap k v -> [(k, v)]
HM.toList Object
o)
satisfiesTyped (TObject Object
o) (MaxProperties Integer
m) = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Object -> Int
forall k v. HashMap k v -> Int
HM.size Object
o) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
m
satisfiesTyped (TObject Object
o) (MinProperties Integer
m) = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Object -> Int
forall k v. HashMap k v -> Int
HM.size Object
o) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
m

checkNumberFormat :: Format -> Scientific -> Bool
checkNumberFormat :: Format -> Scientific -> Bool
checkNumberFormat Format
"int32" (Scientific -> Ratio Integer
forall a. Real a => a -> Ratio Integer
toRational -> Ratio Integer
n) =
  Ratio Integer -> Integer
forall a. Ratio a -> a
denominator Ratio Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1
    Bool -> Bool -> Bool
&& Ratio Integer
n Ratio Integer -> Ratio Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Int32 -> Ratio Integer
forall a. Real a => a -> Ratio Integer
toRational (Int32
forall a. Bounded a => a
minBound :: Int32)
    Bool -> Bool -> Bool
&& Ratio Integer
n Ratio Integer -> Ratio Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int32 -> Ratio Integer
forall a. Real a => a -> Ratio Integer
toRational (Int32
forall a. Bounded a => a
maxBound :: Int32)
checkNumberFormat Format
"int64" (Scientific -> Ratio Integer
forall a. Real a => a -> Ratio Integer
toRational -> Ratio Integer
n) =
  Ratio Integer -> Integer
forall a. Ratio a -> a
denominator Ratio Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1
    Bool -> Bool -> Bool
&& Ratio Integer
n Ratio Integer -> Ratio Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64 -> Ratio Integer
forall a. Real a => a -> Ratio Integer
toRational (Int64
forall a. Bounded a => a
minBound :: Int64)
    Bool -> Bool -> Bool
&& Ratio Integer
n Ratio Integer -> Ratio Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64 -> Ratio Integer
forall a. Real a => a -> Ratio Integer
toRational (Int64
forall a. Bounded a => a
maxBound :: Int64)
checkNumberFormat Format
"float" Scientific
_n = Bool
True
checkNumberFormat Format
"double" Scientific
_n = Bool
True
checkNumberFormat Format
f Scientific
_n = String -> Bool
forall a. HasCallStack => String -> a
error (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
"Invalid number format: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Format -> String
T.unpack Format
f

checkStringFormat :: Format -> Text -> Bool
checkStringFormat :: Format -> Format -> Bool
checkStringFormat Format
"byte" Format
_s = Bool
True -- TODO: regex stuff #32
checkStringFormat Format
"binary" Format
_s = Bool
True
checkStringFormat Format
"date" Format
_s = Bool
True
checkStringFormat Format
"date-time" Format
_s = Bool
True
checkStringFormat Format
"password" Format
_s = Bool
True
checkStringFormat Format
"uuid" Format
_s = Bool
True
checkStringFormat Format
f Format
_s = String -> Bool
forall a. HasCallStack => String -> a
error (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
"Invalid string format: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Format -> String
T.unpack Format
f

data SomeCondition where
  SomeCondition :: Typeable t => Condition t -> SomeCondition

instance Eq SomeCondition where
  SomeCondition Condition t
x == :: SomeCondition -> SomeCondition -> Bool
== SomeCondition Condition t
y = case Condition t -> Maybe (Condition t)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Condition t
x of
    Just Condition t
x' -> Condition t
x' Condition t -> Condition t -> Bool
forall a. Eq a => a -> a -> Bool
== Condition t
y
    Maybe (Condition t)
Nothing -> Bool
False

instance Ord SomeCondition where
  compare :: SomeCondition -> SomeCondition -> Ordering
compare (SomeCondition Condition t
x) (SomeCondition Condition t
y) = case Condition t -> Maybe (Condition t)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Condition t
x of
    Just Condition t
x' -> Condition t -> Condition t -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Condition t
x' Condition t
y
    Maybe (Condition t)
Nothing -> TypeRep -> TypeRep -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Condition t -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Condition t
x) (Condition t -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Condition t
y)

deriving stock instance Show SomeCondition

newtype JsonFormula t = JsonFormula {JsonFormula t -> DNF (Condition t)
getJsonFormula :: DNF (Condition t)}
  deriving stock (JsonFormula t -> JsonFormula t -> Bool
(JsonFormula t -> JsonFormula t -> Bool)
-> (JsonFormula t -> JsonFormula t -> Bool) -> Eq (JsonFormula t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (t :: JsonType). JsonFormula t -> JsonFormula t -> Bool
/= :: JsonFormula t -> JsonFormula t -> Bool
$c/= :: forall (t :: JsonType). JsonFormula t -> JsonFormula t -> Bool
== :: JsonFormula t -> JsonFormula t -> Bool
$c== :: forall (t :: JsonType). JsonFormula t -> JsonFormula t -> Bool
Eq, Eq (JsonFormula t)
Eq (JsonFormula t)
-> (JsonFormula t -> JsonFormula t -> Ordering)
-> (JsonFormula t -> JsonFormula t -> Bool)
-> (JsonFormula t -> JsonFormula t -> Bool)
-> (JsonFormula t -> JsonFormula t -> Bool)
-> (JsonFormula t -> JsonFormula t -> Bool)
-> (JsonFormula t -> JsonFormula t -> JsonFormula t)
-> (JsonFormula t -> JsonFormula t -> JsonFormula t)
-> Ord (JsonFormula t)
JsonFormula t -> JsonFormula t -> Bool
JsonFormula t -> JsonFormula t -> Ordering
JsonFormula t -> JsonFormula t -> JsonFormula t
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall (t :: JsonType). Eq (JsonFormula t)
forall (t :: JsonType). JsonFormula t -> JsonFormula t -> Bool
forall (t :: JsonType). JsonFormula t -> JsonFormula t -> Ordering
forall (t :: JsonType).
JsonFormula t -> JsonFormula t -> JsonFormula t
min :: JsonFormula t -> JsonFormula t -> JsonFormula t
$cmin :: forall (t :: JsonType).
JsonFormula t -> JsonFormula t -> JsonFormula t
max :: JsonFormula t -> JsonFormula t -> JsonFormula t
$cmax :: forall (t :: JsonType).
JsonFormula t -> JsonFormula t -> JsonFormula t
>= :: JsonFormula t -> JsonFormula t -> Bool
$c>= :: forall (t :: JsonType). JsonFormula t -> JsonFormula t -> Bool
> :: JsonFormula t -> JsonFormula t -> Bool
$c> :: forall (t :: JsonType). JsonFormula t -> JsonFormula t -> Bool
<= :: JsonFormula t -> JsonFormula t -> Bool
$c<= :: forall (t :: JsonType). JsonFormula t -> JsonFormula t -> Bool
< :: JsonFormula t -> JsonFormula t -> Bool
$c< :: forall (t :: JsonType). JsonFormula t -> JsonFormula t -> Bool
compare :: JsonFormula t -> JsonFormula t -> Ordering
$ccompare :: forall (t :: JsonType). JsonFormula t -> JsonFormula t -> Ordering
$cp1Ord :: forall (t :: JsonType). Eq (JsonFormula t)
Ord, Int -> JsonFormula t -> ShowS
[JsonFormula t] -> ShowS
JsonFormula t -> String
(Int -> JsonFormula t -> ShowS)
-> (JsonFormula t -> String)
-> ([JsonFormula t] -> ShowS)
-> Show (JsonFormula t)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (t :: JsonType). Int -> JsonFormula t -> ShowS
forall (t :: JsonType). [JsonFormula t] -> ShowS
forall (t :: JsonType). JsonFormula t -> String
showList :: [JsonFormula t] -> ShowS
$cshowList :: forall (t :: JsonType). [JsonFormula t] -> ShowS
show :: JsonFormula t -> String
$cshow :: forall (t :: JsonType). JsonFormula t -> String
showsPrec :: Int -> JsonFormula t -> ShowS
$cshowsPrec :: forall (t :: JsonType). Int -> JsonFormula t -> ShowS
Show)
  deriving newtype (JsonFormula t -> JsonFormula t -> JsonFormula t
(JsonFormula t -> JsonFormula t -> JsonFormula t)
-> (JsonFormula t -> JsonFormula t -> JsonFormula t)
-> Lattice (JsonFormula t)
forall a. (a -> a -> a) -> (a -> a -> a) -> Lattice a
forall (t :: JsonType).
JsonFormula t -> JsonFormula t -> JsonFormula t
/\ :: JsonFormula t -> JsonFormula t -> JsonFormula t
$c/\ :: forall (t :: JsonType).
JsonFormula t -> JsonFormula t -> JsonFormula t
\/ :: JsonFormula t -> JsonFormula t -> JsonFormula t
$c\/ :: forall (t :: JsonType).
JsonFormula t -> JsonFormula t -> JsonFormula t
Lattice, Lattice (JsonFormula t)
JsonFormula t
Lattice (JsonFormula t)
-> JsonFormula t -> BoundedJoinSemiLattice (JsonFormula t)
forall a. Lattice a -> a -> BoundedJoinSemiLattice a
forall (t :: JsonType). Lattice (JsonFormula t)
forall (t :: JsonType). JsonFormula t
bottom :: JsonFormula t
$cbottom :: forall (t :: JsonType). JsonFormula t
$cp1BoundedJoinSemiLattice :: forall (t :: JsonType). Lattice (JsonFormula t)
BoundedJoinSemiLattice, Lattice (JsonFormula t)
JsonFormula t
Lattice (JsonFormula t)
-> JsonFormula t -> BoundedMeetSemiLattice (JsonFormula t)
forall a. Lattice a -> a -> BoundedMeetSemiLattice a
forall (t :: JsonType). Lattice (JsonFormula t)
forall (t :: JsonType). JsonFormula t
top :: JsonFormula t
$ctop :: forall (t :: JsonType). JsonFormula t
$cp1BoundedMeetSemiLattice :: forall (t :: JsonType). Lattice (JsonFormula t)
BoundedMeetSemiLattice)

satisfiesFormula :: TypedValue t -> JsonFormula t -> Bool
satisfiesFormula :: TypedValue t -> JsonFormula t -> Bool
satisfiesFormula TypedValue t
val = (Condition t -> Bool) -> DNF (Condition t) -> Bool
forall l a. BoundedLattice l => (a -> l) -> DNF a -> l
foldDNF (TypedValue t -> Condition t -> Bool
forall (t :: JsonType). TypedValue t -> Condition t -> Bool
satisfiesTyped TypedValue t
val) (DNF (Condition t) -> Bool)
-> (JsonFormula t -> DNF (Condition t)) -> JsonFormula t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonFormula t -> DNF (Condition t)
forall (t :: JsonType). JsonFormula t -> DNF (Condition t)
getJsonFormula

satisfies :: A.Value -> ForeachType JsonFormula -> Bool
satisfies :: Value -> ForeachType JsonFormula -> Bool
satisfies Value
val ForeachType JsonFormula
p = case Value
val of
  Value
A.Null -> TypedValue 'Null -> JsonFormula 'Null -> Bool
forall (t :: JsonType). TypedValue t -> JsonFormula t -> Bool
satisfiesFormula TypedValue 'Null
TNull (JsonFormula 'Null -> Bool) -> JsonFormula 'Null -> Bool
forall a b. (a -> b) -> a -> b
$ ForeachType JsonFormula -> JsonFormula 'Null
forall (f :: JsonType -> *). ForeachType f -> f 'Null
forNull ForeachType JsonFormula
p
  A.Bool Bool
b -> TypedValue 'Boolean -> JsonFormula 'Boolean -> Bool
forall (t :: JsonType). TypedValue t -> JsonFormula t -> Bool
satisfiesFormula (Bool -> TypedValue 'Boolean
TBool Bool
b) (JsonFormula 'Boolean -> Bool) -> JsonFormula 'Boolean -> Bool
forall a b. (a -> b) -> a -> b
$ ForeachType JsonFormula -> JsonFormula 'Boolean
forall (f :: JsonType -> *). ForeachType f -> f 'Boolean
forBoolean ForeachType JsonFormula
p
  A.Number Scientific
n -> TypedValue 'Number -> JsonFormula 'Number -> Bool
forall (t :: JsonType). TypedValue t -> JsonFormula t -> Bool
satisfiesFormula (Scientific -> TypedValue 'Number
TNumber Scientific
n) (JsonFormula 'Number -> Bool) -> JsonFormula 'Number -> Bool
forall a b. (a -> b) -> a -> b
$ ForeachType JsonFormula -> JsonFormula 'Number
forall (f :: JsonType -> *). ForeachType f -> f 'Number
forNumber ForeachType JsonFormula
p
  A.String Format
s -> TypedValue 'String -> JsonFormula 'String -> Bool
forall (t :: JsonType). TypedValue t -> JsonFormula t -> Bool
satisfiesFormula (Format -> TypedValue 'String
TString Format
s) (JsonFormula 'String -> Bool) -> JsonFormula 'String -> Bool
forall a b. (a -> b) -> a -> b
$ ForeachType JsonFormula -> JsonFormula 'String
forall (f :: JsonType -> *). ForeachType f -> f 'String
forString ForeachType JsonFormula
p
  A.Array Array
a -> TypedValue 'Array -> JsonFormula 'Array -> Bool
forall (t :: JsonType). TypedValue t -> JsonFormula t -> Bool
satisfiesFormula (Array -> TypedValue 'Array
TArray Array
a) (JsonFormula 'Array -> Bool) -> JsonFormula 'Array -> Bool
forall a b. (a -> b) -> a -> b
$ ForeachType JsonFormula -> JsonFormula 'Array
forall (f :: JsonType -> *). ForeachType f -> f 'Array
forArray ForeachType JsonFormula
p
  A.Object Object
o -> TypedValue 'Object -> JsonFormula 'Object -> Bool
forall (t :: JsonType). TypedValue t -> JsonFormula t -> Bool
satisfiesFormula (Object -> TypedValue 'Object
TObject Object
o) (JsonFormula 'Object -> Bool) -> JsonFormula 'Object -> Bool
forall a b. (a -> b) -> a -> b
$ ForeachType JsonFormula -> JsonFormula 'Object
forall (f :: JsonType -> *). ForeachType f -> f 'Object
forObject ForeachType JsonFormula
p