{-# language DataKinds #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language GADTs #-}
{-# language PolyKinds #-}
{-# language QuantifiedConstraints #-}
{-# language RankNTypes #-}
{-# language ScopedTypeVariables #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language TypeOperators #-}
{-# language UndecidableInstances #-}
module Mu.Schema.Interpretation (
Term(..), Field(..), FieldValue(..)
, NS(..), NP(..), Proxy(..)
) where
import Data.Map
import Data.Proxy
import Data.SOP
import Mu.Schema.Definition
data Term (sch :: Schema typeName fieldName) (t :: TypeDef typeName fieldName) where
TRecord :: NP (Field sch) args -> Term sch ('DRecord name args)
TEnum :: NS Proxy choices -> Term sch ('DEnum name choices)
TSimple :: FieldValue sch t -> Term sch ('DSimple t)
data Field (sch :: Schema typeName fieldName) (f :: FieldDef typeName fieldName) where
Field :: FieldValue sch t -> Field sch ('FieldDef name t)
data FieldValue (sch :: Schema typeName fieldName) (t :: FieldType typeName) where
FNull :: FieldValue sch 'TNull
FPrimitive :: t -> FieldValue sch ('TPrimitive t)
FSchematic :: Term sch (sch :/: t)
-> FieldValue sch ('TSchematic t)
FOption :: Maybe (FieldValue sch t)
-> FieldValue sch ('TOption t)
FList :: [FieldValue sch t]
-> FieldValue sch ('TList t)
FMap :: Ord (FieldValue sch k)
=> Map (FieldValue sch k) (FieldValue sch v)
-> FieldValue sch ('TMap k v)
FUnion :: NS (FieldValue sch) choices
-> FieldValue sch ('TUnion choices)
instance All (Eq `Compose` Field sch) args
=> Eq (Term sch ('DRecord name args)) where
TRecord xs :: NP (Field sch) args
xs == :: Term sch ('DRecord name args)
-> Term sch ('DRecord name args) -> Bool
== TRecord ys :: 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 xs :: NP (Field sch) args
xs) = "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 -> 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]
++ " }"
where printFields :: forall fs. All (Show `Compose` Field sch) fs
=> NP (Field sch) fs -> String
printFields :: NP (Field sch) fs -> String
printFields Nil = ""
printFields (x :: Field sch x
x :* Nil) = Field sch x -> String
forall a. Show a => a -> String
show Field sch x
x
printFields (x :: Field sch x
x :* rest :: 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 -> 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 x :: NS Proxy choices
x == :: Term sch ('DEnum name choices)
-> Term sch ('DEnum name choices) -> Bool
== TEnum y :: 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 choice :: NS Proxy choices
choice) = "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 -> 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]
++ " }"
where printChoice :: forall cs. All KnownName cs => NS Proxy cs -> String
printChoice :: NS Proxy cs -> String
printChoice (Z p :: Proxy x
p) = Proxy x -> String
forall k (a :: k) (proxy :: k -> *).
KnownName a =>
proxy a -> String
nameVal Proxy x
p
printChoice (S n :: 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 x :: FieldValue sch t
x == :: Term sch ('DSimple t) -> Term sch ('DSimple t) -> Bool
== TSimple y :: 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 x :: 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 x :: FieldValue sch t
x == :: Field sch ('FieldDef name t)
-> Field sch ('FieldDef name t) -> Bool
== Field y :: 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 x :: 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 -> 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 -> Bool
== _ = Bool
True
instance Eq t => Eq (FieldValue sch ('TPrimitive t)) where
FPrimitive x :: t
x == :: FieldValue sch ('TPrimitive t)
-> FieldValue sch ('TPrimitive t) -> Bool
== FPrimitive y :: 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 x :: Term sch (sch :/: t)
x == :: FieldValue sch ('TSchematic t)
-> FieldValue sch ('TSchematic t) -> Bool
== FSchematic y :: 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 x :: Maybe (FieldValue sch t)
x == :: FieldValue sch ('TOption t) -> FieldValue sch ('TOption t) -> Bool
== FOption y :: 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 x :: [FieldValue sch t]
x == :: FieldValue sch ('TList t) -> FieldValue sch ('TList t) -> Bool
== FList y :: [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 x :: Map (FieldValue sch k) (FieldValue sch v)
x == :: FieldValue sch ('TMap k v) -> FieldValue sch ('TMap k v) -> Bool
== FMap y :: 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 x :: NS (FieldValue sch) choices
x == :: FieldValue sch ('TUnion choices)
-> FieldValue sch ('TUnion choices) -> Bool
== FUnion y :: 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 _ _ = Ordering
EQ
instance Ord t => Ord (FieldValue sch ('TPrimitive t)) where
compare :: FieldValue sch ('TPrimitive t)
-> FieldValue sch ('TPrimitive t) -> Ordering
compare (FPrimitive x :: t
x) (FPrimitive y :: 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 x :: Term sch (sch :/: t)
x) (FSchematic y :: 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 x :: Maybe (FieldValue sch t)
x) (FOption y :: 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 x :: [FieldValue sch t]
x) (FList y :: [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 x :: Map (FieldValue sch k) (FieldValue sch v)
x) (FMap y :: 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 x :: NS (FieldValue sch) choices
x) (FUnion y :: 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 _ = "null"
instance Show t => Show (FieldValue sch ('TPrimitive t)) where
show :: FieldValue sch ('TPrimitive t) -> String
show (FPrimitive x :: 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 x :: 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 Nothing) = "none"
show (FOption (Just x :: FieldValue sch t
x)) = "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]
++ ")"
instance Show (FieldValue sch t) => Show (FieldValue sch ('TList t)) where
show :: FieldValue sch ('TList t) -> String
show (FList xs :: [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 x :: 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 x :: NS (FieldValue sch) choices
x) = NS (FieldValue sch) choices -> String
forall a. Show a => a -> String
show NS (FieldValue sch) choices
x