{-# language DataKinds             #-}
{-# language FlexibleContexts      #-}
{-# language FlexibleInstances     #-}
{-# language GADTs                 #-}
{-# language PolyKinds             #-}
{-# language QuantifiedConstraints #-}
{-# language RankNTypes            #-}
{-# language ScopedTypeVariables   #-}
{-# language TypeApplications      #-}
{-# language TypeFamilies          #-}
{-# language TypeOperators         #-}
{-# language UndecidableInstances  #-}
{-|
Description : Interpretation of schemas

This module defines 'Term's which comply with
a given 'Schema'. These 'Term's are the main
form of values used internally by @mu-haskell@.

In this module we make use of 'NP' and 'NS'
as defined by <https://hackage.haskell.org/package/sop-core sop-core>.
These are the n-ary versions of a pair and
'Either', respectively. In other words, 'NP'
puts together a bunch of values of different
types, 'NS' allows you to choose from a bunch
of types.
-}
module Mu.Schema.Interpretation (
  -- * Interpretation
  Term(..), Field(..), FieldValue(..)
, NS(..), NP(..), Proxy(..)
) where

import           Data.Map
import           Data.Proxy
import           Data.SOP

import           Mu.Schema.Definition

-- | Interpretation of a type in a schema.
data Term (sch :: Schema typeName fieldName) (t :: TypeDef typeName fieldName) where
  -- | A record given by the value of its fields.
  TRecord :: NP (Field sch) args -> Term sch ('DRecord name args)
  -- | An enumeration given by one choice.
  TEnum   :: NS Proxy choices    -> Term sch ('DEnum name choices)
  -- | A primitive value.
  TSimple :: FieldValue sch t    -> Term sch ('DSimple t)

-- | Interpretation of a field.
data Field (sch :: Schema typeName fieldName) (f :: FieldDef typeName fieldName) where
  -- | A single field. Note that the contents are wrapped in a @w@ type constructor.
  Field :: FieldValue sch t -> Field sch ('FieldDef name t)

-- | Interpretation of a field type, by giving a value of that type.
data FieldValue (sch :: Schema typeName fieldName) (t :: FieldType typeName) where
  -- | Null value, as found in Avro and JSON.
  FNull      :: FieldValue sch 'TNull
  -- | Value of a primitive type.
  FPrimitive :: t -> FieldValue sch ('TPrimitive t)
  -- | Term of another type in the schema.
  FSchematic :: Term sch (sch :/: t)
             -> FieldValue sch ('TSchematic t)
  -- | Optional value.
  FOption    :: Maybe (FieldValue sch t)
             -> FieldValue sch ('TOption t)
  -- | List of values.
  FList      :: [FieldValue sch t]
             -> FieldValue sch ('TList   t)
  -- | Dictionary (key-value map) of values.
  FMap       :: Ord (FieldValue sch k)
             => Map (FieldValue sch k) (FieldValue sch v)
             -> FieldValue sch ('TMap k v)
  -- | One single value of one of the specified types.
  FUnion     :: NS (FieldValue sch) choices
             -> FieldValue sch ('TUnion choices)

-- ===========================
-- CRAZY EQ AND SHOW INSTANCES
-- ===========================

instance All (Eq `Compose` Field sch) args
         => Eq (Term sch ('DRecord name args)) where
  TRecord NP (Field sch) args
xs == :: Term sch ('DRecord name args)
-> Term sch ('DRecord name args) -> Bool
== TRecord NP (Field sch) args
ys = NP (Field sch) args
xs NP (Field sch) args -> NP (Field sch) args -> Bool
forall a. Eq a => a -> a -> Bool
== NP (Field sch) args
NP (Field sch) args
ys
instance (KnownName name, All (Show `Compose` Field sch) args)
         => Show (Term sch ('DRecord name args)) where
  show :: Term sch ('DRecord name args) -> String
show (TRecord NP (Field sch) args
xs) = String
"record " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Proxy name -> String
forall k (a :: k) (proxy :: k -> *).
KnownName a =>
proxy a -> String
nameVal (Proxy name
forall k (t :: k). Proxy t
Proxy @name) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" { " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NP (Field sch) args -> String
forall (fs :: [FieldDef typeName fieldName]).
All (Compose Show (Field sch)) fs =>
NP (Field sch) fs -> String
printFields NP (Field sch) args
xs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" }"
    where printFields :: forall fs. All (Show `Compose` Field sch) fs
                      => NP (Field sch) fs -> String
          printFields :: NP (Field sch) fs -> String
printFields NP (Field sch) fs
Nil         = String
""
          printFields (Field sch x
x :* NP (Field sch) xs
Nil)  = Field sch x -> String
forall a. Show a => a -> String
show Field sch x
x
          printFields (Field sch x
x :* NP (Field sch) xs
rest) = Field sch x -> String
forall a. Show a => a -> String
show Field sch x
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NP (Field sch) xs -> String
forall (fs :: [FieldDef typeName fieldName]).
All (Compose Show (Field sch)) fs =>
NP (Field sch) fs -> String
printFields NP (Field sch) xs
rest
instance All (Eq `Compose` Proxy) choices => Eq (Term sch ('DEnum name choices)) where
  TEnum NS Proxy choices
x == :: Term sch ('DEnum name choices)
-> Term sch ('DEnum name choices) -> Bool
== TEnum NS Proxy choices
y = NS Proxy choices
x NS Proxy choices -> NS Proxy choices -> Bool
forall a. Eq a => a -> a -> Bool
== NS Proxy choices
NS Proxy choices
y
instance (KnownName name, All KnownName choices, All (Show `Compose` Proxy) choices)
         => Show (Term sch ('DEnum name choices)) where
  show :: Term sch ('DEnum name choices) -> String
show (TEnum NS Proxy choices
choice) = String
"enum " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Proxy name -> String
forall k (a :: k) (proxy :: k -> *).
KnownName a =>
proxy a -> String
nameVal (Proxy name
forall k (t :: k). Proxy t
Proxy @name) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" { " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NS Proxy choices -> String
forall k (cs :: [k]). All KnownName cs => NS Proxy cs -> String
printChoice NS Proxy choices
choice String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" }"
    where printChoice :: forall cs. All KnownName cs => NS Proxy cs -> String
          printChoice :: NS Proxy cs -> String
printChoice (Z Proxy x
p) = Proxy x -> String
forall k (a :: k) (proxy :: k -> *).
KnownName a =>
proxy a -> String
nameVal Proxy x
p
          printChoice (S NS Proxy xs
n) = NS Proxy xs -> String
forall k (cs :: [k]). All KnownName cs => NS Proxy cs -> String
printChoice NS Proxy xs
n
instance Eq (FieldValue sch t) => Eq (Term sch ('DSimple t)) where
  TSimple FieldValue sch t
x == :: Term sch ('DSimple t) -> Term sch ('DSimple t) -> Bool
== TSimple FieldValue sch t
y = FieldValue sch t
x FieldValue sch t -> FieldValue sch t -> Bool
forall a. Eq a => a -> a -> Bool
== FieldValue sch t
FieldValue sch t
y
instance Show (FieldValue sch t) => Show (Term sch ('DSimple t)) where
  show :: Term sch ('DSimple t) -> String
show (TSimple FieldValue sch t
x) = FieldValue sch t -> String
forall a. Show a => a -> String
show FieldValue sch t
x

instance (Eq (FieldValue sch t)) => Eq (Field sch ('FieldDef name t)) where
  Field FieldValue sch t
x == :: Field sch ('FieldDef name t)
-> Field sch ('FieldDef name t) -> Bool
== Field FieldValue sch t
y = FieldValue sch t
x FieldValue sch t -> FieldValue sch t -> Bool
forall a. Eq a => a -> a -> Bool
== FieldValue sch t
FieldValue sch t
y
instance (KnownName name, Show (FieldValue sch t))
         => Show (Field sch ('FieldDef name t)) where
  show :: Field sch ('FieldDef name t) -> String
show (Field FieldValue sch t
x) = Proxy name -> String
forall k (a :: k) (proxy :: k -> *).
KnownName a =>
proxy a -> String
nameVal (Proxy name
forall k (t :: k). Proxy t
Proxy @name) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldValue sch t -> String
forall a. Show a => a -> String
show FieldValue sch t
x

instance Eq (FieldValue sch 'TNull) where
  FieldValue sch 'TNull
_ == :: FieldValue sch 'TNull -> FieldValue sch 'TNull -> Bool
== FieldValue sch 'TNull
_ = Bool
True
instance Eq t => Eq (FieldValue sch ('TPrimitive t)) where
  FPrimitive t
x == :: FieldValue sch ('TPrimitive t)
-> FieldValue sch ('TPrimitive t) -> Bool
== FPrimitive t
y = t
x t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
t
y
instance Eq (Term sch (sch :/: t)) => Eq (FieldValue sch ('TSchematic t)) where
  FSchematic Term sch (sch :/: t)
x == :: FieldValue sch ('TSchematic t)
-> FieldValue sch ('TSchematic t) -> Bool
== FSchematic Term sch (sch :/: t)
y = Term sch (sch :/: t)
Term sch (sch :/: t)
x Term sch (sch :/: t) -> Term sch (sch :/: t) -> Bool
forall a. Eq a => a -> a -> Bool
== Term sch (sch :/: t)
Term sch (sch :/: t)
y
instance Eq (FieldValue sch t) => Eq (FieldValue sch ('TOption t)) where
  FOption Maybe (FieldValue sch t)
x == :: FieldValue sch ('TOption t) -> FieldValue sch ('TOption t) -> Bool
== FOption Maybe (FieldValue sch t)
y = Maybe (FieldValue sch t)
x Maybe (FieldValue sch t) -> Maybe (FieldValue sch t) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe (FieldValue sch t)
Maybe (FieldValue sch t)
y
instance Eq (FieldValue sch t) => Eq (FieldValue sch ('TList t)) where
  FList [FieldValue sch t]
x == :: FieldValue sch ('TList t) -> FieldValue sch ('TList t) -> Bool
== FList [FieldValue sch t]
y = [FieldValue sch t]
x [FieldValue sch t] -> [FieldValue sch t] -> Bool
forall a. Eq a => a -> a -> Bool
== [FieldValue sch t]
[FieldValue sch t]
y
instance (Eq (FieldValue sch k), Eq (FieldValue sch v))
         => Eq (FieldValue sch ('TMap k v)) where
  FMap Map (FieldValue sch k) (FieldValue sch v)
x == :: FieldValue sch ('TMap k v) -> FieldValue sch ('TMap k v) -> Bool
== FMap Map (FieldValue sch k) (FieldValue sch v)
y = Map (FieldValue sch k) (FieldValue sch v)
x Map (FieldValue sch k) (FieldValue sch v)
-> Map (FieldValue sch k) (FieldValue sch v) -> Bool
forall a. Eq a => a -> a -> Bool
== Map (FieldValue sch k) (FieldValue sch v)
Map (FieldValue sch k) (FieldValue sch v)
y
instance All (Eq `Compose` FieldValue sch) choices
         => Eq (FieldValue sch ('TUnion choices)) where
  FUnion NS (FieldValue sch) choices
x == :: FieldValue sch ('TUnion choices)
-> FieldValue sch ('TUnion choices) -> Bool
== FUnion NS (FieldValue sch) choices
y = NS (FieldValue sch) choices
x NS (FieldValue sch) choices -> NS (FieldValue sch) choices -> Bool
forall a. Eq a => a -> a -> Bool
== NS (FieldValue sch) choices
NS (FieldValue sch) choices
y

instance Ord (FieldValue sch 'TNull) where
  compare :: FieldValue sch 'TNull -> FieldValue sch 'TNull -> Ordering
compare FieldValue sch 'TNull
_ FieldValue sch 'TNull
_ = Ordering
EQ
instance Ord t => Ord (FieldValue sch ('TPrimitive t)) where
  compare :: FieldValue sch ('TPrimitive t)
-> FieldValue sch ('TPrimitive t) -> Ordering
compare (FPrimitive t
x) (FPrimitive t
y) = t -> t -> Ordering
forall a. Ord a => a -> a -> Ordering
compare t
x t
t
y
instance Ord (Term sch (sch :/: t)) => Ord (FieldValue sch ('TSchematic t)) where
  compare :: FieldValue sch ('TSchematic t)
-> FieldValue sch ('TSchematic t) -> Ordering
compare (FSchematic Term sch (sch :/: t)
x) (FSchematic Term sch (sch :/: t)
y) = Term sch (sch :/: t) -> Term sch (sch :/: t) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Term sch (sch :/: t)
Term sch (sch :/: t)
x Term sch (sch :/: t)
Term sch (sch :/: t)
y
instance Ord (FieldValue sch t) => Ord (FieldValue sch ('TOption t)) where
  compare :: FieldValue sch ('TOption t)
-> FieldValue sch ('TOption t) -> Ordering
compare (FOption Maybe (FieldValue sch t)
x) (FOption Maybe (FieldValue sch t)
y) = Maybe (FieldValue sch t) -> Maybe (FieldValue sch t) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Maybe (FieldValue sch t)
x Maybe (FieldValue sch t)
Maybe (FieldValue sch t)
y
instance Ord (FieldValue sch t) => Ord (FieldValue sch ('TList t)) where
  compare :: FieldValue sch ('TList t) -> FieldValue sch ('TList t) -> Ordering
compare (FList [FieldValue sch t]
x) (FList [FieldValue sch t]
y) = [FieldValue sch t] -> [FieldValue sch t] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [FieldValue sch t]
x [FieldValue sch t]
[FieldValue sch t]
y
instance (Ord (FieldValue sch k), Ord (FieldValue sch v))
         => Ord (FieldValue sch ('TMap k v)) where
  compare :: FieldValue sch ('TMap k v)
-> FieldValue sch ('TMap k v) -> Ordering
compare (FMap Map (FieldValue sch k) (FieldValue sch v)
x) (FMap Map (FieldValue sch k) (FieldValue sch v)
y) = Map (FieldValue sch k) (FieldValue sch v)
-> Map (FieldValue sch k) (FieldValue sch v) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Map (FieldValue sch k) (FieldValue sch v)
x Map (FieldValue sch k) (FieldValue sch v)
Map (FieldValue sch k) (FieldValue sch v)
y
instance ( All (Ord `Compose` FieldValue sch) choices
         , All (Eq  `Compose` FieldValue sch) choices )
         => Ord (FieldValue sch ('TUnion choices)) where
  compare :: FieldValue sch ('TUnion choices)
-> FieldValue sch ('TUnion choices) -> Ordering
compare (FUnion NS (FieldValue sch) choices
x) (FUnion NS (FieldValue sch) choices
y) = NS (FieldValue sch) choices
-> NS (FieldValue sch) choices -> Ordering
forall a. Ord a => a -> a -> Ordering
compare NS (FieldValue sch) choices
x NS (FieldValue sch) choices
NS (FieldValue sch) choices
y

instance Show (FieldValue sch 'TNull) where
  show :: FieldValue sch 'TNull -> String
show FieldValue sch 'TNull
_ = String
"null"
instance Show t => Show (FieldValue sch ('TPrimitive t)) where
  show :: FieldValue sch ('TPrimitive t) -> String
show (FPrimitive t
x) = t -> String
forall a. Show a => a -> String
show t
x
instance Show (Term sch (sch :/: t)) => Show (FieldValue sch ('TSchematic t)) where
  show :: FieldValue sch ('TSchematic t) -> String
show (FSchematic Term sch (sch :/: t)
x) = Term sch (sch :/: t) -> String
forall a. Show a => a -> String
show Term sch (sch :/: t)
Term sch (sch :/: t)
x
instance Show (FieldValue sch t) => Show (FieldValue sch ('TOption t)) where
  show :: FieldValue sch ('TOption t) -> String
show (FOption Maybe (FieldValue sch t)
Nothing)  = String
"none"
  show (FOption (Just FieldValue sch t
x)) = String
"some(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ FieldValue sch t -> String
forall a. Show a => a -> String
show FieldValue sch t
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
instance Show (FieldValue sch t) => Show (FieldValue sch ('TList t)) where
  show :: FieldValue sch ('TList t) -> String
show (FList [FieldValue sch t]
xs) = [FieldValue sch t] -> String
forall a. Show a => a -> String
show [FieldValue sch t]
xs
instance (Show (FieldValue sch k), Show (FieldValue sch v))
         => Show (FieldValue sch ('TMap k v)) where
  show :: FieldValue sch ('TMap k v) -> String
show (FMap Map (FieldValue sch k) (FieldValue sch v)
x) = Map (FieldValue sch k) (FieldValue sch v) -> String
forall a. Show a => a -> String
show Map (FieldValue sch k) (FieldValue sch v)
x
instance All (Show `Compose` FieldValue sch) choices
         => Show (FieldValue sch ('TUnion choices)) where
  show :: FieldValue sch ('TUnion choices) -> String
show (FUnion NS (FieldValue sch) choices
x) = NS (FieldValue sch) choices -> String
forall a. Show a => a -> String
show NS (FieldValue sch) choices
x