module Data.OpenApi.Compare.Validate.Schema.TypedJson
  ( JsonType (..),
    describeJSONType,
    TypedValue (..),
    untypeValue,
    ForeachType (..),
    foldType,
    forType_,
  )
where

import Algebra.Lattice
import qualified Data.Aeson as A
import Data.Kind
import Data.Monoid
import Data.Scientific
import Data.String
import Data.Text (Text)
import Data.Typeable

-- | Type of a JSON value
data JsonType
  = Null
  | Boolean
  | Number
  | String
  | Array
  | Object
  deriving stock (JsonType -> JsonType -> Bool
(JsonType -> JsonType -> Bool)
-> (JsonType -> JsonType -> Bool) -> Eq JsonType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JsonType -> JsonType -> Bool
$c/= :: JsonType -> JsonType -> Bool
== :: JsonType -> JsonType -> Bool
$c== :: JsonType -> JsonType -> Bool
Eq, Eq JsonType
Eq JsonType
-> (JsonType -> JsonType -> Ordering)
-> (JsonType -> JsonType -> Bool)
-> (JsonType -> JsonType -> Bool)
-> (JsonType -> JsonType -> Bool)
-> (JsonType -> JsonType -> Bool)
-> (JsonType -> JsonType -> JsonType)
-> (JsonType -> JsonType -> JsonType)
-> Ord JsonType
JsonType -> JsonType -> Bool
JsonType -> JsonType -> Ordering
JsonType -> JsonType -> JsonType
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 :: JsonType -> JsonType -> JsonType
$cmin :: JsonType -> JsonType -> JsonType
max :: JsonType -> JsonType -> JsonType
$cmax :: JsonType -> JsonType -> JsonType
>= :: JsonType -> JsonType -> Bool
$c>= :: JsonType -> JsonType -> Bool
> :: JsonType -> JsonType -> Bool
$c> :: JsonType -> JsonType -> Bool
<= :: JsonType -> JsonType -> Bool
$c<= :: JsonType -> JsonType -> Bool
< :: JsonType -> JsonType -> Bool
$c< :: JsonType -> JsonType -> Bool
compare :: JsonType -> JsonType -> Ordering
$ccompare :: JsonType -> JsonType -> Ordering
$cp1Ord :: Eq JsonType
Ord, Int -> JsonType -> ShowS
[JsonType] -> ShowS
JsonType -> String
(Int -> JsonType -> ShowS)
-> (JsonType -> String) -> ([JsonType] -> ShowS) -> Show JsonType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JsonType] -> ShowS
$cshowList :: [JsonType] -> ShowS
show :: JsonType -> String
$cshow :: JsonType -> String
showsPrec :: Int -> JsonType -> ShowS
$cshowsPrec :: Int -> JsonType -> ShowS
Show)

describeJSONType :: IsString s => JsonType -> s
describeJSONType :: JsonType -> s
describeJSONType = \case
  JsonType
Null -> s
"Null"
  JsonType
Boolean -> s
"Boolean"
  JsonType
Number -> s
"Number"
  JsonType
String -> s
"String"
  JsonType
Array -> s
"Array"
  JsonType
Object -> s
"Object"

-- | A 'A.Value' whose type we know
data TypedValue :: JsonType -> Type where
  TNull :: TypedValue 'Null
  TBool :: !Bool -> TypedValue 'Boolean
  TNumber :: !Scientific -> TypedValue 'Number
  TString :: !Text -> TypedValue 'String
  TArray :: !A.Array -> TypedValue 'Array
  TObject :: !A.Object -> TypedValue 'Object

deriving stock instance Eq (TypedValue t)

deriving stock instance Ord (TypedValue t)

deriving stock instance Show (TypedValue t)

untypeValue :: TypedValue t -> A.Value
untypeValue :: TypedValue t -> Value
untypeValue TypedValue t
TNull = Value
A.Null
untypeValue (TBool Bool
b) = Bool -> Value
A.Bool Bool
b
untypeValue (TNumber Scientific
n) = Scientific -> Value
A.Number Scientific
n
untypeValue (TString Text
s) = Text -> Value
A.String Text
s
untypeValue (TArray Array
a) = Array -> Value
A.Array Array
a
untypeValue (TObject Object
o) = Object -> Value
A.Object Object
o

data ForeachType (f :: JsonType -> Type) = ForeachType
  { ForeachType f -> f 'Null
forNull :: f 'Null
  , ForeachType f -> f 'Boolean
forBoolean :: f 'Boolean
  , ForeachType f -> f 'Number
forNumber :: f 'Number
  , ForeachType f -> f 'String
forString :: f 'String
  , ForeachType f -> f 'Array
forArray :: f 'Array
  , ForeachType f -> f 'Object
forObject :: f 'Object
  }

deriving stock instance (forall x. Typeable x => Eq (f x)) => Eq (ForeachType f)

deriving stock instance (forall x. Typeable x => Ord (f x)) => Ord (ForeachType f)

deriving stock instance (forall x. Typeable x => Show (f x)) => Show (ForeachType f)

foldType :: Monoid m => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m) -> m
foldType :: (forall (x :: JsonType).
 Typeable x =>
 JsonType -> (ForeachType f -> f x) -> m)
-> m
foldType forall (x :: JsonType).
Typeable x =>
JsonType -> (ForeachType f -> f x) -> m
k =
  JsonType -> (ForeachType f -> f 'Null) -> m
forall (x :: JsonType).
Typeable x =>
JsonType -> (ForeachType f -> f x) -> m
k JsonType
Null ForeachType f -> f 'Null
forall (f :: JsonType -> *). ForeachType f -> f 'Null
forNull
    m -> m -> m
forall a. Semigroup a => a -> a -> a
<> JsonType -> (ForeachType f -> f 'Boolean) -> m
forall (x :: JsonType).
Typeable x =>
JsonType -> (ForeachType f -> f x) -> m
k JsonType
Boolean ForeachType f -> f 'Boolean
forall (f :: JsonType -> *). ForeachType f -> f 'Boolean
forBoolean
    m -> m -> m
forall a. Semigroup a => a -> a -> a
<> JsonType -> (ForeachType f -> f 'Number) -> m
forall (x :: JsonType).
Typeable x =>
JsonType -> (ForeachType f -> f x) -> m
k JsonType
Number ForeachType f -> f 'Number
forall (f :: JsonType -> *). ForeachType f -> f 'Number
forNumber
    m -> m -> m
forall a. Semigroup a => a -> a -> a
<> JsonType -> (ForeachType f -> f 'String) -> m
forall (x :: JsonType).
Typeable x =>
JsonType -> (ForeachType f -> f x) -> m
k JsonType
String ForeachType f -> f 'String
forall (f :: JsonType -> *). ForeachType f -> f 'String
forString
    m -> m -> m
forall a. Semigroup a => a -> a -> a
<> JsonType -> (ForeachType f -> f 'Array) -> m
forall (x :: JsonType).
Typeable x =>
JsonType -> (ForeachType f -> f x) -> m
k JsonType
Array ForeachType f -> f 'Array
forall (f :: JsonType -> *). ForeachType f -> f 'Array
forArray
    m -> m -> m
forall a. Semigroup a => a -> a -> a
<> JsonType -> (ForeachType f -> f 'Object) -> m
forall (x :: JsonType).
Typeable x =>
JsonType -> (ForeachType f -> f x) -> m
k JsonType
Object ForeachType f -> f 'Object
forall (f :: JsonType -> *). ForeachType f -> f 'Object
forObject

forType_ :: Applicative m => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m ()) -> m ()
forType_ :: (forall (x :: JsonType).
 Typeable x =>
 JsonType -> (ForeachType f -> f x) -> m ())
-> m ()
forType_ forall (x :: JsonType).
Typeable x =>
JsonType -> (ForeachType f -> f x) -> m ()
k = Ap m () -> m ()
forall k (f :: k -> *) (a :: k). Ap f a -> f a
getAp (Ap m () -> m ()) -> Ap m () -> m ()
forall a b. (a -> b) -> a -> b
$ (forall (x :: JsonType).
 Typeable x =>
 JsonType -> (ForeachType f -> f x) -> Ap m ())
-> Ap m ()
forall m (f :: JsonType -> *).
Monoid m =>
(forall (x :: JsonType).
 Typeable x =>
 JsonType -> (ForeachType f -> f x) -> m)
-> m
foldType (\JsonType
ty ForeachType f -> f x
proj -> m () -> Ap m ()
forall k (f :: k -> *) (a :: k). f a -> Ap f a
Ap (m () -> Ap m ()) -> m () -> Ap m ()
forall a b. (a -> b) -> a -> b
$ JsonType -> (ForeachType f -> f x) -> m ()
forall (x :: JsonType).
Typeable x =>
JsonType -> (ForeachType f -> f x) -> m ()
k JsonType
ty ForeachType f -> f x
proj)

broadcastType :: (forall x. Typeable x => f x) -> ForeachType f
broadcastType :: (forall (x :: JsonType). Typeable x => f x) -> ForeachType f
broadcastType forall (x :: JsonType). Typeable x => f x
k =
  ForeachType :: forall (f :: JsonType -> *).
f 'Null
-> f 'Boolean
-> f 'Number
-> f 'String
-> f 'Array
-> f 'Object
-> ForeachType f
ForeachType
    { $sel:forNull:ForeachType :: f 'Null
forNull = f 'Null
forall (x :: JsonType). Typeable x => f x
k
    , $sel:forBoolean:ForeachType :: f 'Boolean
forBoolean = f 'Boolean
forall (x :: JsonType). Typeable x => f x
k
    , $sel:forNumber:ForeachType :: f 'Number
forNumber = f 'Number
forall (x :: JsonType). Typeable x => f x
k
    , $sel:forString:ForeachType :: f 'String
forString = f 'String
forall (x :: JsonType). Typeable x => f x
k
    , $sel:forArray:ForeachType :: f 'Array
forArray = f 'Array
forall (x :: JsonType). Typeable x => f x
k
    , $sel:forObject:ForeachType :: f 'Object
forObject = f 'Object
forall (x :: JsonType). Typeable x => f x
k
    }

zipType :: (forall x. Typeable x => f x -> g x -> h x) -> ForeachType f -> ForeachType g -> ForeachType h
zipType :: (forall (x :: JsonType). Typeable x => f x -> g x -> h x)
-> ForeachType f -> ForeachType g -> ForeachType h
zipType forall (x :: JsonType). Typeable x => f x -> g x -> h x
k ForeachType f
f1 ForeachType g
f2 =
  ForeachType :: forall (f :: JsonType -> *).
f 'Null
-> f 'Boolean
-> f 'Number
-> f 'String
-> f 'Array
-> f 'Object
-> ForeachType f
ForeachType
    { $sel:forNull:ForeachType :: h 'Null
forNull = f 'Null -> g 'Null -> h 'Null
forall (x :: JsonType). Typeable x => f x -> g x -> h x
k (ForeachType f -> f 'Null
forall (f :: JsonType -> *). ForeachType f -> f 'Null
forNull ForeachType f
f1) (ForeachType g -> g 'Null
forall (f :: JsonType -> *). ForeachType f -> f 'Null
forNull ForeachType g
f2)
    , $sel:forBoolean:ForeachType :: h 'Boolean
forBoolean = f 'Boolean -> g 'Boolean -> h 'Boolean
forall (x :: JsonType). Typeable x => f x -> g x -> h x
k (ForeachType f -> f 'Boolean
forall (f :: JsonType -> *). ForeachType f -> f 'Boolean
forBoolean ForeachType f
f1) (ForeachType g -> g 'Boolean
forall (f :: JsonType -> *). ForeachType f -> f 'Boolean
forBoolean ForeachType g
f2)
    , $sel:forNumber:ForeachType :: h 'Number
forNumber = f 'Number -> g 'Number -> h 'Number
forall (x :: JsonType). Typeable x => f x -> g x -> h x
k (ForeachType f -> f 'Number
forall (f :: JsonType -> *). ForeachType f -> f 'Number
forNumber ForeachType f
f1) (ForeachType g -> g 'Number
forall (f :: JsonType -> *). ForeachType f -> f 'Number
forNumber ForeachType g
f2)
    , $sel:forString:ForeachType :: h 'String
forString = f 'String -> g 'String -> h 'String
forall (x :: JsonType). Typeable x => f x -> g x -> h x
k (ForeachType f -> f 'String
forall (f :: JsonType -> *). ForeachType f -> f 'String
forString ForeachType f
f1) (ForeachType g -> g 'String
forall (f :: JsonType -> *). ForeachType f -> f 'String
forString ForeachType g
f2)
    , $sel:forArray:ForeachType :: h 'Array
forArray = f 'Array -> g 'Array -> h 'Array
forall (x :: JsonType). Typeable x => f x -> g x -> h x
k (ForeachType f -> f 'Array
forall (f :: JsonType -> *). ForeachType f -> f 'Array
forArray ForeachType f
f1) (ForeachType g -> g 'Array
forall (f :: JsonType -> *). ForeachType f -> f 'Array
forArray ForeachType g
f2)
    , $sel:forObject:ForeachType :: h 'Object
forObject = f 'Object -> g 'Object -> h 'Object
forall (x :: JsonType). Typeable x => f x -> g x -> h x
k (ForeachType f -> f 'Object
forall (f :: JsonType -> *). ForeachType f -> f 'Object
forObject ForeachType f
f1) (ForeachType g -> g 'Object
forall (f :: JsonType -> *). ForeachType f -> f 'Object
forObject ForeachType g
f2)
    }

instance (forall x. Lattice (f x)) => Lattice (ForeachType f) where
  \/ :: ForeachType f -> ForeachType f -> ForeachType f
(\/) = (forall (x :: JsonType). Typeable x => f x -> f x -> f x)
-> ForeachType f -> ForeachType f -> ForeachType f
forall (f :: JsonType -> *) (g :: JsonType -> *)
       (h :: JsonType -> *).
(forall (x :: JsonType). Typeable x => f x -> g x -> h x)
-> ForeachType f -> ForeachType g -> ForeachType h
zipType forall a. Lattice a => a -> a -> a
forall (x :: JsonType). Typeable x => f x -> f x -> f x
(\/)
  /\ :: ForeachType f -> ForeachType f -> ForeachType f
(/\) = (forall (x :: JsonType). Typeable x => f x -> f x -> f x)
-> ForeachType f -> ForeachType f -> ForeachType f
forall (f :: JsonType -> *) (g :: JsonType -> *)
       (h :: JsonType -> *).
(forall (x :: JsonType). Typeable x => f x -> g x -> h x)
-> ForeachType f -> ForeachType g -> ForeachType h
zipType forall a. Lattice a => a -> a -> a
forall (x :: JsonType). Typeable x => f x -> f x -> f x
(/\)

instance (forall x. BoundedJoinSemiLattice (f x)) => BoundedJoinSemiLattice (ForeachType f) where
  bottom :: ForeachType f
bottom = (forall (x :: JsonType). Typeable x => f x) -> ForeachType f
forall (f :: JsonType -> *).
(forall (x :: JsonType). Typeable x => f x) -> ForeachType f
broadcastType forall a. BoundedJoinSemiLattice a => a
forall (x :: JsonType). Typeable x => f x
bottom

instance (forall x. BoundedMeetSemiLattice (f x)) => BoundedMeetSemiLattice (ForeachType f) where
  top :: ForeachType f
top = (forall (x :: JsonType). Typeable x => f x) -> ForeachType f
forall (f :: JsonType -> *).
(forall (x :: JsonType). Typeable x => f x) -> ForeachType f
broadcastType forall a. BoundedMeetSemiLattice a => a
forall (x :: JsonType). Typeable x => f x
top