{-# language AllowAmbiguousTypes   #-}
{-# language DataKinds             #-}
{-# language FlexibleContexts      #-}
{-# language FlexibleInstances     #-}
{-# language GADTs                 #-}
{-# language MultiParamTypeClasses #-}
{-# language PolyKinds             #-}
{-# language ScopedTypeVariables   #-}
{-# language StandaloneDeriving    #-}
{-# language TypeApplications      #-}
{-# language TypeOperators         #-}
{-# language UndecidableInstances  #-}
{-|
Description : Terms without an associated schema

In the edges of your application it's useful to
consider terms for which a type-level schema has
not yet been applied. Think of receiving a JSON
document: you can parse it but checking the schema
is an additional step.
-}
module Mu.Schema.Interpretation.Schemaless (
  -- * Terms without an associated schema
  Term(..), Field(..), FieldValue(..)
  -- * Checking and conversion against a schema
, checkSchema, fromSchemalessTerm
  -- * For deserialization to schemaless terms
, ToSchemalessTerm(..), ToSchemalessValue(..)
  -- * For implementors
, CheckSchema
) where

import           Control.Applicative      ((<|>))
import           Data.List                (find)
import qualified Data.Map                 as M
import           Data.Proxy
import           Data.SOP
import qualified Data.Text                as T
import           Data.Typeable

import           Mu.Schema.Class
import           Mu.Schema.Definition
import qualified Mu.Schema.Interpretation as S

-- | Interpretation of a type in a schema.
data Term (w :: * -> *) where
  -- | A record given by the value of its fields.
  TRecord :: [Field w]    -> Term w
  -- | An enumeration given by one choice.
  TEnum   :: Int          -> Term w
  -- | A primitive value.
  TSimple :: FieldValue w -> Term w

deriving instance Eq   (w (FieldValue w)) => Eq   (Term w)
deriving instance Ord  (w (FieldValue w)) => Ord  (Term w)
deriving instance Show (w (FieldValue w)) => Show (Term w)

-- | Interpretation of a field.
data Field (w :: * -> *) where
  -- | A single field given by its name and its value.
  --   Note that the contents are wrapped in a @w@ type constructor.
  Field :: T.Text -> w (FieldValue w) -> Field w

deriving instance Eq   (w (FieldValue w)) => Eq   (Field w)
deriving instance Ord  (w (FieldValue w)) => Ord  (Field w)
deriving instance Show (w (FieldValue w)) => Show (Field w)

-- | Interpretation of a field type, by giving a value of that type.
data FieldValue (w :: * -> *) where
  FNull      :: FieldValue w
  FPrimitive :: (Typeable t, Eq t, Ord t, Show t) => t -> FieldValue w
  FSchematic :: Term w -> FieldValue w
  FOption    :: Maybe (FieldValue w) -> FieldValue w
  FList      :: [FieldValue w] -> FieldValue w
  FMap       :: M.Map (FieldValue w) (FieldValue w) -> FieldValue w

-- | Checks that a schemaless 'Term' obbeys the
--   restrictions for tyoe @t@ of schema @s@.
--   If successful, returns a 'S.Term' indexed
--   by the corresponding schema and type.
--
--   Use this function to check a schemaless terms
--   at the "borders" of your application.
checkSchema
  :: forall (s :: Schema tn fn) (t :: tn) (w :: * -> *).
     (Traversable w, CheckSchema s (s :/: t))
  => Proxy t -> Term w -> Maybe (S.Term w s (s :/: t))
checkSchema :: Proxy t -> Term w -> Maybe (Term w s (s :/: t))
checkSchema _ = Term w -> Maybe (Term w s (s :/: t))
forall tn fn (s :: Schema tn fn) (t :: TypeDef tn fn)
       (w :: * -> *).
(CheckSchema s t, Traversable w) =>
Term w -> Maybe (Term w s t)
checkSchema'

-- | Converts a schemaless term to a Haskell type
--   by going through the corresponding schema type.
fromSchemalessTerm
  :: forall sch w t sty.
     (Traversable w, FromSchema w sch sty t, CheckSchema sch (sch :/: sty))
  => Term w -> Maybe t
fromSchemalessTerm :: Term w -> Maybe t
fromSchemalessTerm t :: Term w
t = forall (sty :: t) t.
FromSchema w sch sty t =>
Term w sch (sch :/: sty) -> t
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName) (sty :: typeName) t.
FromSchema w sch sty t =>
Term w sch (sch :/: sty) -> t
fromSchema @_ @_ @w @sch (Term w sch (sch :/: sty) -> t)
-> Maybe (Term w sch (sch :/: sty)) -> Maybe t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy sty -> Term w -> Maybe (Term w sch (sch :/: sty))
forall tn fn (s :: Schema tn fn) (t :: tn) (w :: * -> *).
(Traversable w, CheckSchema s (s :/: t)) =>
Proxy t -> Term w -> Maybe (Term w s (s :/: t))
checkSchema (Proxy sty
forall k (t :: k). Proxy t
Proxy @sty) Term w
t

-- | Deserialization to schemaless terms.
class ToSchemalessTerm t w where
  -- | Turns a document (such as JSON) into a schemaless term.
  --   This function should handle the "compound" types in that format,
  --   such as records and enumerations.
  toSchemalessTerm  :: t -> Term w
-- | Deserialization to schemaless values.
class ToSchemalessValue t w where
  -- | Turns a document (such as JSON) into a schemaless term.
  --   This function should handle the "primitive" types in that format.
  toSchemalessValue :: t -> FieldValue w

-- | Type class used to define the generic 'checkSchema'.
--
--   Exposed for usage in other modules,
--   in particular 'Mu.Schema.Registry'.
class CheckSchema (s :: Schema tn fn) (t :: TypeDef tn fn) where
  checkSchema' :: Traversable w => Term w -> Maybe (S.Term w s t)
class CheckSchemaFields (s :: Schema tn fn) (fields :: [FieldDef tn fn]) where
  checkSchemaFields :: Traversable w => [Field w] -> Maybe (NP (S.Field w s) fields)
class CheckSchemaEnum (choices :: [ChoiceDef fn]) where
  checkSchemaEnumInt  :: Int -> Maybe (NS Proxy choices)
  checkSchemaEnumText :: T.Text -> Maybe (NS Proxy choices)
class CheckSchemaValue (s :: Schema tn fn) (field :: FieldType tn) where
  checkSchemaValue :: Traversable w => FieldValue w -> Maybe (S.FieldValue w s field)
class CheckSchemaUnion (s :: Schema tn fn) (ts :: [FieldType tn]) where
  checkSchemaUnion :: Traversable w => FieldValue w -> Maybe (NS (S.FieldValue w s) ts)

instance CheckSchemaFields s fields => CheckSchema s ('DRecord nm fields) where
  checkSchema' :: Term w -> Maybe (Term w s ('DRecord nm fields))
checkSchema' (TRecord fields :: [Field w]
fields) = NP (Field w s) fields -> Term w s ('DRecord nm fields)
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName)
       (args :: [FieldDef typeName fieldName]) (choices :: typeName).
NP (Field w sch) args -> Term w sch ('DRecord choices args)
S.TRecord (NP (Field w s) fields -> Term w s ('DRecord nm fields))
-> Maybe (NP (Field w s) fields)
-> Maybe (Term w s ('DRecord nm fields))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Field w] -> Maybe (NP (Field w s) fields)
forall tn fn (s :: Schema tn fn) (fields :: [FieldDef tn fn])
       (w :: * -> *).
(CheckSchemaFields s fields, Traversable w) =>
[Field w] -> Maybe (NP (Field w s) fields)
checkSchemaFields [Field w]
fields
  checkSchema' _                = Maybe (Term w s ('DRecord nm fields))
forall a. Maybe a
Nothing
instance CheckSchemaFields s '[] where
  checkSchemaFields :: [Field w] -> Maybe (NP (Field w s) '[])
checkSchemaFields _ = NP (Field w s) '[] -> Maybe (NP (Field w s) '[])
forall (f :: * -> *) a. Applicative f => a -> f a
pure NP (Field w s) '[]
forall k (a :: k -> *). NP a '[]
Nil
instance (KnownName nm, CheckSchemaValue s ty, CheckSchemaFields s rest)
         => CheckSchemaFields s ('FieldDef nm ty ': rest) where
  checkSchemaFields :: [Field w] -> Maybe (NP (Field w s) ('FieldDef nm ty : rest))
checkSchemaFields fs :: [Field w]
fs
    = do let name :: Text
name = String -> Text
T.pack (Proxy nm -> String
forall k (a :: k) (proxy :: k -> *).
KnownName a =>
proxy a -> String
nameVal (Proxy nm
forall k (t :: k). Proxy t
Proxy @nm))
         Field _ v :: w (FieldValue w)
v <- (Field w -> Bool) -> [Field w] -> Maybe (Field w)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Field fieldName :: Text
fieldName _) -> Text
fieldName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name) [Field w]
fs
         w (FieldValue w s ty)
v' <- (FieldValue w -> Maybe (FieldValue w s ty))
-> w (FieldValue w) -> Maybe (w (FieldValue w s ty))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FieldValue w -> Maybe (FieldValue w s ty)
forall tn fn (s :: Schema tn fn) (field :: FieldType tn)
       (w :: * -> *).
(CheckSchemaValue s field, Traversable w) =>
FieldValue w -> Maybe (FieldValue w s field)
checkSchemaValue w (FieldValue w)
v
         NP (Field w s) rest
r' <- [Field w] -> Maybe (NP (Field w s) rest)
forall tn fn (s :: Schema tn fn) (fields :: [FieldDef tn fn])
       (w :: * -> *).
(CheckSchemaFields s fields, Traversable w) =>
[Field w] -> Maybe (NP (Field w s) fields)
checkSchemaFields @_ @_ @s @rest [Field w]
fs
         NP (Field w s) ('FieldDef nm ty : rest)
-> Maybe (NP (Field w s) ('FieldDef nm ty : rest))
forall (m :: * -> *) a. Monad m => a -> m a
return (w (FieldValue w s ty) -> Field w s ('FieldDef nm ty)
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName) (t :: FieldType typeName)
       (name :: fieldName).
w (FieldValue w sch t) -> Field w sch ('FieldDef name t)
S.Field w (FieldValue w s ty)
v' Field w s ('FieldDef nm ty)
-> NP (Field w s) rest -> NP (Field w s) ('FieldDef nm ty : rest)
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP (Field w s) rest
r')

instance CheckSchemaEnum choices => CheckSchema s ('DEnum nm choices) where
  checkSchema' :: Term w -> Maybe (Term w s ('DEnum nm choices))
checkSchema' (TEnum n :: Int
n) = NS Proxy choices -> Term w s ('DEnum nm choices)
forall fieldName typeName (choices :: [ChoiceDef fieldName])
       (w :: * -> *) (sch :: Schema typeName fieldName)
       (name :: typeName).
NS Proxy choices -> Term w sch ('DEnum name choices)
S.TEnum (NS Proxy choices -> Term w s ('DEnum nm choices))
-> Maybe (NS Proxy choices) -> Maybe (Term w s ('DEnum nm choices))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Maybe (NS Proxy choices)
forall fn (choices :: [ChoiceDef fn]).
CheckSchemaEnum choices =>
Int -> Maybe (NS Proxy choices)
checkSchemaEnumInt Int
n
  checkSchema' (TSimple (FPrimitive (t
n :: a)))
    = case ((Typeable t, Typeable Int) => Maybe (t :~: Int)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @a @Int, (Typeable t, Typeable Text) => Maybe (t :~: Text)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @a @T.Text, (Typeable t, Typeable String) => Maybe (t :~: String)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @a @String) of
        (Just Refl, _, _) -> NS Proxy choices -> Term w s ('DEnum nm choices)
forall fieldName typeName (choices :: [ChoiceDef fieldName])
       (w :: * -> *) (sch :: Schema typeName fieldName)
       (name :: typeName).
NS Proxy choices -> Term w sch ('DEnum name choices)
S.TEnum (NS Proxy choices -> Term w s ('DEnum nm choices))
-> Maybe (NS Proxy choices) -> Maybe (Term w s ('DEnum nm choices))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Maybe (NS Proxy choices)
forall fn (choices :: [ChoiceDef fn]).
CheckSchemaEnum choices =>
Int -> Maybe (NS Proxy choices)
checkSchemaEnumInt t
Int
n
        (_, Just Refl, _) -> NS Proxy choices -> Term w s ('DEnum nm choices)
forall fieldName typeName (choices :: [ChoiceDef fieldName])
       (w :: * -> *) (sch :: Schema typeName fieldName)
       (name :: typeName).
NS Proxy choices -> Term w sch ('DEnum name choices)
S.TEnum (NS Proxy choices -> Term w s ('DEnum nm choices))
-> Maybe (NS Proxy choices) -> Maybe (Term w s ('DEnum nm choices))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe (NS Proxy choices)
forall fn (choices :: [ChoiceDef fn]).
CheckSchemaEnum choices =>
Text -> Maybe (NS Proxy choices)
checkSchemaEnumText t
Text
n
        (_, _, Just Refl) -> NS Proxy choices -> Term w s ('DEnum nm choices)
forall fieldName typeName (choices :: [ChoiceDef fieldName])
       (w :: * -> *) (sch :: Schema typeName fieldName)
       (name :: typeName).
NS Proxy choices -> Term w sch ('DEnum name choices)
S.TEnum (NS Proxy choices -> Term w s ('DEnum nm choices))
-> Maybe (NS Proxy choices) -> Maybe (Term w s ('DEnum nm choices))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe (NS Proxy choices)
forall fn (choices :: [ChoiceDef fn]).
CheckSchemaEnum choices =>
Text -> Maybe (NS Proxy choices)
checkSchemaEnumText (String -> Text
T.pack t
String
n)
        _                 -> Maybe (Term w s ('DEnum nm choices))
forall a. Maybe a
Nothing
  checkSchema' _ = Maybe (Term w s ('DEnum nm choices))
forall a. Maybe a
Nothing
instance CheckSchemaEnum '[] where
  checkSchemaEnumInt :: Int -> Maybe (NS Proxy '[])
checkSchemaEnumInt  _ = Maybe (NS Proxy '[])
forall a. Maybe a
Nothing
  checkSchemaEnumText :: Text -> Maybe (NS Proxy '[])
checkSchemaEnumText _ = Maybe (NS Proxy '[])
forall a. Maybe a
Nothing
instance (KnownName c, CheckSchemaEnum cs)
         => CheckSchemaEnum ('ChoiceDef c ': cs) where
  checkSchemaEnumInt :: Int -> Maybe (NS Proxy ('ChoiceDef c : cs))
checkSchemaEnumInt 0 = NS Proxy ('ChoiceDef c : cs)
-> Maybe (NS Proxy ('ChoiceDef c : cs))
forall a. a -> Maybe a
Just (Proxy ('ChoiceDef c) -> NS Proxy ('ChoiceDef c : cs)
forall k (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z Proxy ('ChoiceDef c)
forall k (t :: k). Proxy t
Proxy)
  checkSchemaEnumInt n :: Int
n = NS Proxy cs -> NS Proxy ('ChoiceDef c : cs)
forall k (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (NS Proxy cs -> NS Proxy ('ChoiceDef c : cs))
-> Maybe (NS Proxy cs) -> Maybe (NS Proxy ('ChoiceDef c : cs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Maybe (NS Proxy cs)
forall fn (choices :: [ChoiceDef fn]).
CheckSchemaEnum choices =>
Int -> Maybe (NS Proxy choices)
checkSchemaEnumInt (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)
  checkSchemaEnumText :: Text -> Maybe (NS Proxy ('ChoiceDef c : cs))
checkSchemaEnumText t :: Text
t
    | Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
T.pack (Proxy c -> String
forall k (a :: k) (proxy :: k -> *).
KnownName a =>
proxy a -> String
nameVal (Proxy c
forall k (t :: k). Proxy t
Proxy @c)) = NS Proxy ('ChoiceDef c : cs)
-> Maybe (NS Proxy ('ChoiceDef c : cs))
forall a. a -> Maybe a
Just (Proxy ('ChoiceDef c) -> NS Proxy ('ChoiceDef c : cs)
forall k (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z Proxy ('ChoiceDef c)
forall k (t :: k). Proxy t
Proxy)
    | Bool
otherwise                        = NS Proxy cs -> NS Proxy ('ChoiceDef c : cs)
forall k (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (NS Proxy cs -> NS Proxy ('ChoiceDef c : cs))
-> Maybe (NS Proxy cs) -> Maybe (NS Proxy ('ChoiceDef c : cs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe (NS Proxy cs)
forall fn (choices :: [ChoiceDef fn]).
CheckSchemaEnum choices =>
Text -> Maybe (NS Proxy choices)
checkSchemaEnumText Text
t

instance CheckSchemaValue s f => CheckSchema s ('DSimple f) where
  checkSchema' :: Term w -> Maybe (Term w s ('DSimple f))
checkSchema' (TSimple t :: FieldValue w
t) = FieldValue w s f -> Term w s ('DSimple f)
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName) (t :: FieldType typeName).
FieldValue w sch t -> Term w sch ('DSimple t)
S.TSimple (FieldValue w s f -> Term w s ('DSimple f))
-> Maybe (FieldValue w s f) -> Maybe (Term w s ('DSimple f))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldValue w -> Maybe (FieldValue w s f)
forall tn fn (s :: Schema tn fn) (field :: FieldType tn)
       (w :: * -> *).
(CheckSchemaValue s field, Traversable w) =>
FieldValue w -> Maybe (FieldValue w s field)
checkSchemaValue FieldValue w
t
  checkSchema' _           = Maybe (Term w s ('DSimple f))
forall a. Maybe a
Nothing
instance CheckSchemaValue s 'TNull where
  checkSchemaValue :: FieldValue w -> Maybe (FieldValue w s 'TNull)
checkSchemaValue FNull = FieldValue w s 'TNull -> Maybe (FieldValue w s 'TNull)
forall a. a -> Maybe a
Just FieldValue w s 'TNull
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName).
FieldValue w sch 'TNull
S.FNull
  checkSchemaValue _     = Maybe (FieldValue w s 'TNull)
forall a. Maybe a
Nothing
instance Typeable t => CheckSchemaValue s ('TPrimitive t) where
  checkSchemaValue :: FieldValue w -> Maybe (FieldValue w s ('TPrimitive t))
checkSchemaValue (FPrimitive (t
t :: a))
    = case (Typeable t, Typeable t) => Maybe (t :~: t)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @a @t of
        Just Refl -> FieldValue w s ('TPrimitive t)
-> Maybe (FieldValue w s ('TPrimitive t))
forall a. a -> Maybe a
Just (t -> FieldValue w s ('TPrimitive t)
forall typeName fieldName t (w :: * -> *)
       (sch :: Schema typeName fieldName).
t -> FieldValue w sch ('TPrimitive t)
S.FPrimitive t
t)
        Nothing   -> Maybe (FieldValue w s ('TPrimitive t))
forall a. Maybe a
Nothing
  checkSchemaValue _              = Maybe (FieldValue w s ('TPrimitive t))
forall a. Maybe a
Nothing
-- TODO: handle enums better by an if with typedef
instance (CheckSchema s (s :/: t))
         => CheckSchemaValue s ('TSchematic t) where
  checkSchemaValue :: FieldValue w -> Maybe (FieldValue w s ('TSchematic t))
checkSchemaValue (FSchematic t :: Term w
t) = Term w s (s :/: t) -> FieldValue w s ('TSchematic t)
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName) (t :: typeName).
Term w sch (sch :/: t) -> FieldValue w sch ('TSchematic t)
S.FSchematic (Term w s (s :/: t) -> FieldValue w s ('TSchematic t))
-> Maybe (Term w s (s :/: t))
-> Maybe (FieldValue w s ('TSchematic t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term w -> Maybe (Term w s (s :/: t))
forall tn fn (s :: Schema tn fn) (t :: TypeDef tn fn)
       (w :: * -> *).
(CheckSchema s t, Traversable w) =>
Term w -> Maybe (Term w s t)
checkSchema' Term w
t
  checkSchemaValue _              = Maybe (FieldValue w s ('TSchematic t))
forall a. Maybe a
Nothing
instance CheckSchemaValue s t => CheckSchemaValue s ('TOption t) where
  checkSchemaValue :: FieldValue w -> Maybe (FieldValue w s ('TOption t))
checkSchemaValue (FOption x :: Maybe (FieldValue w)
x) = Maybe (FieldValue w s t) -> FieldValue w s ('TOption t)
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName) (t :: FieldType typeName).
Maybe (FieldValue w sch t) -> FieldValue w sch ('TOption t)
S.FOption (Maybe (FieldValue w s t) -> FieldValue w s ('TOption t))
-> Maybe (Maybe (FieldValue w s t))
-> Maybe (FieldValue w s ('TOption t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldValue w -> Maybe (FieldValue w s t))
-> Maybe (FieldValue w) -> Maybe (Maybe (FieldValue w s t))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FieldValue w -> Maybe (FieldValue w s t)
forall tn fn (s :: Schema tn fn) (field :: FieldType tn)
       (w :: * -> *).
(CheckSchemaValue s field, Traversable w) =>
FieldValue w -> Maybe (FieldValue w s field)
checkSchemaValue Maybe (FieldValue w)
x
  checkSchemaValue _           = Maybe (FieldValue w s ('TOption t))
forall a. Maybe a
Nothing
instance CheckSchemaValue s t => CheckSchemaValue s ('TList t) where
  checkSchemaValue :: FieldValue w -> Maybe (FieldValue w s ('TList t))
checkSchemaValue (FList xs :: [FieldValue w]
xs) = [FieldValue w s t] -> FieldValue w s ('TList t)
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName) (t :: FieldType typeName).
[FieldValue w sch t] -> FieldValue w sch ('TList t)
S.FList ([FieldValue w s t] -> FieldValue w s ('TList t))
-> Maybe [FieldValue w s t] -> Maybe (FieldValue w s ('TList t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldValue w -> Maybe (FieldValue w s t))
-> [FieldValue w] -> Maybe [FieldValue w s t]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FieldValue w -> Maybe (FieldValue w s t)
forall tn fn (s :: Schema tn fn) (field :: FieldType tn)
       (w :: * -> *).
(CheckSchemaValue s field, Traversable w) =>
FieldValue w -> Maybe (FieldValue w s field)
checkSchemaValue [FieldValue w]
xs
  checkSchemaValue _          = Maybe (FieldValue w s ('TList t))
forall a. Maybe a
Nothing
-- TODO: how to deal with maps??
instance CheckSchemaUnion s ts => CheckSchemaValue s ('TUnion ts) where
  checkSchemaValue :: FieldValue w -> Maybe (FieldValue w s ('TUnion ts))
checkSchemaValue x :: FieldValue w
x = NS (FieldValue w s) ts -> FieldValue w s ('TUnion ts)
forall typeName fieldName (w :: * -> *)
       (sch :: Schema typeName fieldName)
       (choices :: [FieldType typeName]).
NS (FieldValue w sch) choices -> FieldValue w sch ('TUnion choices)
S.FUnion (NS (FieldValue w s) ts -> FieldValue w s ('TUnion ts))
-> Maybe (NS (FieldValue w s) ts)
-> Maybe (FieldValue w s ('TUnion ts))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldValue w -> Maybe (NS (FieldValue w s) ts)
forall tn fn (s :: Schema tn fn) (ts :: [FieldType tn])
       (w :: * -> *).
(CheckSchemaUnion s ts, Traversable w) =>
FieldValue w -> Maybe (NS (FieldValue w s) ts)
checkSchemaUnion FieldValue w
x

instance CheckSchemaUnion s '[] where
  checkSchemaUnion :: FieldValue w -> Maybe (NS (FieldValue w s) '[])
checkSchemaUnion _ = Maybe (NS (FieldValue w s) '[])
forall a. Maybe a
Nothing
instance (CheckSchemaValue s t, CheckSchemaUnion s ts)
         => CheckSchemaUnion s (t ': ts) where
  checkSchemaUnion :: FieldValue w -> Maybe (NS (FieldValue w s) (t : ts))
checkSchemaUnion x :: FieldValue w
x = FieldValue w s t -> NS (FieldValue w s) (t : ts)
forall k (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (FieldValue w s t -> NS (FieldValue w s) (t : ts))
-> Maybe (FieldValue w s t) -> Maybe (NS (FieldValue w s) (t : ts))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldValue w -> Maybe (FieldValue w s t)
forall tn fn (s :: Schema tn fn) (field :: FieldType tn)
       (w :: * -> *).
(CheckSchemaValue s field, Traversable w) =>
FieldValue w -> Maybe (FieldValue w s field)
checkSchemaValue @_ @_ @s @t FieldValue w
x Maybe (NS (FieldValue w s) (t : ts))
-> Maybe (NS (FieldValue w s) (t : ts))
-> Maybe (NS (FieldValue w s) (t : ts))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> NS (FieldValue w s) ts -> NS (FieldValue w s) (t : ts)
forall k (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (NS (FieldValue w s) ts -> NS (FieldValue w s) (t : ts))
-> Maybe (NS (FieldValue w s) ts)
-> Maybe (NS (FieldValue w s) (t : ts))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldValue w -> Maybe (NS (FieldValue w s) ts)
forall tn fn (s :: Schema tn fn) (ts :: [FieldType tn])
       (w :: * -> *).
(CheckSchemaUnion s ts, Traversable w) =>
FieldValue w -> Maybe (NS (FieldValue w s) ts)
checkSchemaUnion FieldValue w
x

-- Boring instances
deriving instance (Show (w (FieldValue w))) => Show (FieldValue w)
instance (Eq (w (FieldValue w))) => Eq (FieldValue w) where
  FNull == :: FieldValue w -> FieldValue w -> Bool
== FNull = Bool
True
  FPrimitive (t
x :: a) == FPrimitive (t
y :: b)
    = case (Typeable t, Typeable t) => Maybe (t :~: t)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @a @b of
        Nothing   -> Bool
False
        Just Refl -> t
x t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
t
y
  FSchematic x :: Term w
x == FSchematic y :: Term w
y = Term w
x Term w -> Term w -> Bool
forall a. Eq a => a -> a -> Bool
== Term w
y
  FOption    x :: Maybe (FieldValue w)
x == FOption    y :: Maybe (FieldValue w)
y = Maybe (FieldValue w)
x Maybe (FieldValue w) -> Maybe (FieldValue w) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe (FieldValue w)
y
  FList      x :: [FieldValue w]
x == FList      y :: [FieldValue w]
y = [FieldValue w]
x [FieldValue w] -> [FieldValue w] -> Bool
forall a. Eq a => a -> a -> Bool
== [FieldValue w]
y
  FMap       x :: Map (FieldValue w) (FieldValue w)
x == FMap       y :: Map (FieldValue w) (FieldValue w)
y = Map (FieldValue w) (FieldValue w)
x Map (FieldValue w) (FieldValue w)
-> Map (FieldValue w) (FieldValue w) -> Bool
forall a. Eq a => a -> a -> Bool
== Map (FieldValue w) (FieldValue w)
y
  _            == _            = Bool
False
instance (Ord (w (FieldValue w))) => Ord (FieldValue w) where
  FNull <= :: FieldValue w -> FieldValue w -> Bool
<= _ = Bool
True
  FPrimitive _ <= FNull = Bool
False
  FPrimitive (t
x :: a) <= FPrimitive (t
y :: b)
    = case (Typeable t, Typeable t) => Maybe (t :~: t)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @a @b of
        Nothing   -> t -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf t
x TypeRep -> TypeRep -> Bool
forall a. Ord a => a -> a -> Bool
<= t -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf t
y
        Just Refl -> t
x t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
t
y
  FPrimitive _ <= _            = Bool
True
  FSchematic _ <= FNull        = Bool
False
  FSchematic _ <= FPrimitive _ = Bool
False
  FSchematic x :: Term w
x <= FSchematic y :: Term w
y = Term w
x Term w -> Term w -> Bool
forall a. Ord a => a -> a -> Bool
<= Term w
y
  FSchematic _ <= _            = Bool
True
  FOption    _ <= FNull        = Bool
False
  FOption    _ <= FPrimitive _ = Bool
False
  FOption    _ <= FSchematic _ = Bool
False
  FOption    x :: Maybe (FieldValue w)
x <= FOption    y :: Maybe (FieldValue w)
y = Maybe (FieldValue w)
x Maybe (FieldValue w) -> Maybe (FieldValue w) -> Bool
forall a. Ord a => a -> a -> Bool
<= Maybe (FieldValue w)
y
  FOption    _ <= _            = Bool
True
  FList      _ <= FNull        = Bool
False
  FList      _ <= FPrimitive _ = Bool
False
  FList      _ <= FSchematic _ = Bool
False
  FList      _ <= FOption    _ = Bool
False
  FList      x :: [FieldValue w]
x <= FList      y :: [FieldValue w]
y = [FieldValue w]
x [FieldValue w] -> [FieldValue w] -> Bool
forall a. Ord a => a -> a -> Bool
<= [FieldValue w]
y
  FList      _ <= _            = Bool
True
  FMap       _ <= FNull        = Bool
False
  FMap       _ <= FPrimitive _ = Bool
False
  FMap       _ <= FSchematic _ = Bool
False
  FMap       _ <= FOption    _ = Bool
False
  FMap       _ <= FList      _ = Bool
False
  FMap       x :: Map (FieldValue w) (FieldValue w)
x <= FMap       y :: Map (FieldValue w) (FieldValue w)
y = Map (FieldValue w) (FieldValue w)
x Map (FieldValue w) (FieldValue w)
-> Map (FieldValue w) (FieldValue w) -> Bool
forall a. Ord a => a -> a -> Bool
<= Map (FieldValue w) (FieldValue w)
y
  -- FMap       _ <= _            = True