{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
module Typson.JsonTree
(
ObjectSYM(..)
, FieldSYM(..)
, UnionSYM(..)
, JsonSchema
, key
, ObjectEncoder(..)
, ObjectDecoder(..)
, ObjectTree(..)
, TreeBuilder
, (<<$>)
, (<<*>)
, runAp
, runAp_
, type Tree(..)
, type Edge(..)
, type Aggregator(..)
, type Multiplicity(..)
, NoDuplicateKeys
) where
import Control.Monad ((<=<))
import Data.Aeson ((.:), (.:?), (.=), FromJSON, ToJSON, FromJSONKey, ToJSONKey)
import qualified Data.Aeson.Types as Aeson
import Data.Functor.Identity (Identity(..))
import qualified Data.HashMap.Strict as HM
import Data.Kind (Constraint, Type)
import qualified Data.Map.Strict as M
import Data.Proxy (Proxy(..))
import qualified Data.Set as S
import Data.String (IsString)
import qualified Data.Text as T
import qualified Data.Vector as V
import GHC.TypeLits (ErrorMessage(..), KnownSymbol, Nat, Symbol, TypeError, symbolVal)
data Tree = Node Aggregator [Edge]
| IndexedNode Type Tree
| Leaf
data Edge
= Edge
Symbol
Multiplicity
Type
Tree
data Aggregator
= Product
| Sum
data Multiplicity
= Singleton
| Nullable
class FieldSYM repr => ObjectSYM (repr :: Tree -> Type -> Type) where
object :: ( tree ~ 'Node 'Product edges
, NoDuplicateKeys o edges
)
=> String
-> TreeBuilder (Field repr o) tree o
-> repr tree o
prim :: ( FromJSON v
, ToJSON v
)
=> repr 'Leaf v
list :: repr tree o
-> repr ('IndexedNode Nat tree) [o]
textMap :: (FromJSONKey k, ToJSONKey k, IsString k, Ord k)
=> repr tree o
-> repr ('IndexedNode Symbol tree) (M.Map k o)
set :: Ord o
=> repr tree o
-> repr ('IndexedNode Nat tree) (S.Set o)
vector :: repr tree o
-> repr ('IndexedNode Nat tree) (V.Vector o)
class FieldSYM repr where
data Field repr :: Type -> Tree -> Type -> Type
field :: ( KnownSymbol key
, edge ~ 'Edge key 'Singleton field subTree
, tree ~ 'Node 'Product '[edge]
)
=> proxy key
-> (obj -> field)
-> repr subTree field
-> Field repr obj tree field
optField :: ( KnownSymbol key
, edge ~ 'Edge key 'Nullable field subTree
, tree ~ 'Node 'Product '[edge]
)
=> proxy key
-> (obj -> Maybe field)
-> repr subTree field
-> Field repr obj tree (Maybe field)
optFieldDef :: ( KnownSymbol key
, edge ~ 'Edge key 'Singleton field subTree
, tree ~ 'Node 'Product '[edge]
)
=> proxy key
-> (obj -> field)
-> field
-> repr subTree field
-> Field repr obj tree field
optFieldDef p :: proxy key
p getter :: obj -> field
getter _ sub :: repr subTree field
sub = proxy key
-> (obj -> field)
-> repr subTree field
-> Field repr obj tree field
forall (repr :: Tree -> * -> *) (key :: Symbol) (edge :: Edge)
field (subTree :: Tree) (tree :: Tree) (proxy :: Symbol -> *) obj.
(FieldSYM repr, KnownSymbol key,
edge ~ 'Edge key 'Singleton field subTree,
tree ~ 'Node 'Product '[edge]) =>
proxy key
-> (obj -> field)
-> repr subTree field
-> Field repr obj tree field
field proxy key
p obj -> field
getter repr subTree field
sub
class UnionSYM (repr :: Tree -> Type -> Type) where
type Result repr union :: Type
data Tag repr :: Type -> Tree -> Type -> Type
union :: ( tree ~ 'Node 'Sum edges
, NoDuplicateKeys union edges
)
=> String
-> TreeBuilder (Tag repr union) tree (union -> Result repr union)
-> repr tree union
tag :: ( KnownSymbol name
, edge ~ 'Edge name 'Nullable v subTree
, tree ~ 'Node 'Sum '[edge]
)
=> proxy name
-> (v -> union)
-> repr subTree v
-> Tag repr union tree (v -> Result repr union)
type JsonSchema t a = forall repr. (ObjectSYM repr, UnionSYM repr) => repr t a
key :: Proxy (key :: Symbol)
key :: Proxy key
key = Proxy key
forall k (t :: k). Proxy t
Proxy
data TreeProxy (t :: Tree) o = TreeProxy
newtype ObjectTree (t :: Tree) o =
ObjectTree { ObjectTree t o -> TreeProxy t o
getObjectTree :: TreeProxy t o }
instance ObjectSYM ObjectTree where
object :: String
-> TreeBuilder (Field ObjectTree o) tree o -> ObjectTree tree o
object _ _ = TreeProxy tree o -> ObjectTree tree o
forall (t :: Tree) o. TreeProxy t o -> ObjectTree t o
ObjectTree TreeProxy tree o
forall (t :: Tree) o. TreeProxy t o
TreeProxy
list :: ObjectTree tree o -> ObjectTree ('IndexedNode Nat tree) [o]
list _ = TreeProxy ('IndexedNode Nat tree) [o]
-> ObjectTree ('IndexedNode Nat tree) [o]
forall (t :: Tree) o. TreeProxy t o -> ObjectTree t o
ObjectTree TreeProxy ('IndexedNode Nat tree) [o]
forall (t :: Tree) o. TreeProxy t o
TreeProxy
textMap :: ObjectTree tree o
-> ObjectTree ('IndexedNode Symbol tree) (Map k o)
textMap _ = TreeProxy ('IndexedNode Symbol tree) (Map k o)
-> ObjectTree ('IndexedNode Symbol tree) (Map k o)
forall (t :: Tree) o. TreeProxy t o -> ObjectTree t o
ObjectTree TreeProxy ('IndexedNode Symbol tree) (Map k o)
forall (t :: Tree) o. TreeProxy t o
TreeProxy
set :: ObjectTree tree o -> ObjectTree ('IndexedNode Nat tree) (Set o)
set _ = TreeProxy ('IndexedNode Nat tree) (Set o)
-> ObjectTree ('IndexedNode Nat tree) (Set o)
forall (t :: Tree) o. TreeProxy t o -> ObjectTree t o
ObjectTree TreeProxy ('IndexedNode Nat tree) (Set o)
forall (t :: Tree) o. TreeProxy t o
TreeProxy
vector :: ObjectTree tree o -> ObjectTree ('IndexedNode Nat tree) (Vector o)
vector _ = TreeProxy ('IndexedNode Nat tree) (Vector o)
-> ObjectTree ('IndexedNode Nat tree) (Vector o)
forall (t :: Tree) o. TreeProxy t o -> ObjectTree t o
ObjectTree TreeProxy ('IndexedNode Nat tree) (Vector o)
forall (t :: Tree) o. TreeProxy t o
TreeProxy
prim :: ObjectTree 'Leaf v
prim = TreeProxy 'Leaf v -> ObjectTree 'Leaf v
forall (t :: Tree) o. TreeProxy t o -> ObjectTree t o
ObjectTree TreeProxy 'Leaf v
forall (t :: Tree) o. TreeProxy t o
TreeProxy
instance FieldSYM ObjectTree where
data Field ObjectTree o t a = FieldProxy
field :: proxy key
-> (obj -> field)
-> ObjectTree subTree field
-> Field ObjectTree obj tree field
field _ _ _ = Field ObjectTree obj tree field
forall o (t :: Tree) a. Field ObjectTree o t a
FieldProxy
optField :: proxy key
-> (obj -> Maybe field)
-> ObjectTree subTree field
-> Field ObjectTree obj tree (Maybe field)
optField _ _ _ = Field ObjectTree obj tree (Maybe field)
forall o (t :: Tree) a. Field ObjectTree o t a
FieldProxy
instance UnionSYM ObjectTree where
data Tag ObjectTree u t a = TagProxy
type Result ObjectTree u = ()
union :: String
-> TreeBuilder
(Tag ObjectTree union) tree (union -> Result ObjectTree union)
-> ObjectTree tree union
union _ _ = TreeProxy tree union -> ObjectTree tree union
forall (t :: Tree) o. TreeProxy t o -> ObjectTree t o
ObjectTree TreeProxy tree union
forall (t :: Tree) o. TreeProxy t o
TreeProxy
tag :: proxy name
-> (v -> union)
-> ObjectTree subTree v
-> Tag ObjectTree union tree (v -> Result ObjectTree union)
tag _ _ _ = Tag ObjectTree union tree (v -> Result ObjectTree union)
forall u (t :: Tree) a. Tag ObjectTree u t a
TagProxy
newtype ObjectEncoder (t :: Tree) o =
ObjectEncoder
{
ObjectEncoder t o -> o -> Value
encodeObject :: o -> Aeson.Value
}
instance ObjectSYM ObjectEncoder where
object :: String
-> TreeBuilder (Field ObjectEncoder o) tree o
-> ObjectEncoder tree o
object _ fields :: TreeBuilder (Field ObjectEncoder o) tree o
fields = (o -> Value) -> ObjectEncoder tree o
forall (t :: Tree) o. (o -> Value) -> ObjectEncoder t o
ObjectEncoder ((o -> Value) -> ObjectEncoder tree o)
-> (o -> Value) -> ObjectEncoder tree o
forall a b. (a -> b) -> a -> b
$ \o :: o
o ->
Object -> Value
Aeson.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ (forall a' (t' :: Tree). Field ObjectEncoder o t' a' -> Object)
-> TreeBuilder (Field ObjectEncoder o) tree o -> Object
forall m (f :: Tree -> * -> *) (t :: Tree) a.
Monoid m =>
(forall a' (t' :: Tree). f t' a' -> m) -> TreeBuilder f t a -> m
runAp_ (Field ObjectEncoder o t' a' -> o -> Object
forall o (t :: Tree) a. Field ObjectEncoder o t a -> o -> Object
`unFieldEncoder` o
o) TreeBuilder (Field ObjectEncoder o) tree o
fields
list :: ObjectEncoder tree o -> ObjectEncoder ('IndexedNode Nat tree) [o]
list (ObjectEncoder e :: o -> Value
e) = ([o] -> Value) -> ObjectEncoder ('IndexedNode Nat tree) [o]
forall (t :: Tree) o. (o -> Value) -> ObjectEncoder t o
ObjectEncoder (([o] -> Value) -> ObjectEncoder ('IndexedNode Nat tree) [o])
-> ([o] -> Value) -> ObjectEncoder ('IndexedNode Nat tree) [o]
forall a b. (a -> b) -> a -> b
$ [Value] -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON ([Value] -> Value) -> ([o] -> [Value]) -> [o] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (o -> Value) -> [o] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map o -> Value
e
textMap :: ObjectEncoder tree o
-> ObjectEncoder ('IndexedNode Symbol tree) (Map k o)
textMap (ObjectEncoder e :: o -> Value
e) = (Map k o -> Value)
-> ObjectEncoder ('IndexedNode Symbol tree) (Map k o)
forall (t :: Tree) o. (o -> Value) -> ObjectEncoder t o
ObjectEncoder ((Map k o -> Value)
-> ObjectEncoder ('IndexedNode Symbol tree) (Map k o))
-> (Map k o -> Value)
-> ObjectEncoder ('IndexedNode Symbol tree) (Map k o)
forall a b. (a -> b) -> a -> b
$ Map k Value -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (Map k Value -> Value)
-> (Map k o -> Map k Value) -> Map k o -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (o -> Value) -> Map k o -> Map k Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap o -> Value
e
set :: ObjectEncoder tree o
-> ObjectEncoder ('IndexedNode Nat tree) (Set o)
set (ObjectEncoder e :: o -> Value
e) = (Set o -> Value) -> ObjectEncoder ('IndexedNode Nat tree) (Set o)
forall (t :: Tree) o. (o -> Value) -> ObjectEncoder t o
ObjectEncoder ((Set o -> Value) -> ObjectEncoder ('IndexedNode Nat tree) (Set o))
-> (Set o -> Value)
-> ObjectEncoder ('IndexedNode Nat tree) (Set o)
forall a b. (a -> b) -> a -> b
$ [Value] -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON ([Value] -> Value) -> (Set o -> [Value]) -> Set o -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (o -> Value) -> [o] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map o -> Value
e ([o] -> [Value]) -> (Set o -> [o]) -> Set o -> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set o -> [o]
forall a. Set a -> [a]
S.toList
vector :: ObjectEncoder tree o
-> ObjectEncoder ('IndexedNode Nat tree) (Vector o)
vector (ObjectEncoder e :: o -> Value
e) = (Vector o -> Value)
-> ObjectEncoder ('IndexedNode Nat tree) (Vector o)
forall (t :: Tree) o. (o -> Value) -> ObjectEncoder t o
ObjectEncoder ((Vector o -> Value)
-> ObjectEncoder ('IndexedNode Nat tree) (Vector o))
-> (Vector o -> Value)
-> ObjectEncoder ('IndexedNode Nat tree) (Vector o)
forall a b. (a -> b) -> a -> b
$ Vector Value -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (Vector Value -> Value)
-> (Vector o -> Vector Value) -> Vector o -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (o -> Value) -> Vector o -> Vector Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap o -> Value
e
prim :: ObjectEncoder 'Leaf v
prim = (v -> Value) -> ObjectEncoder 'Leaf v
forall (t :: Tree) o. (o -> Value) -> ObjectEncoder t o
ObjectEncoder v -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON
instance FieldSYM ObjectEncoder where
newtype Field ObjectEncoder o t a =
FieldEncoder { Field ObjectEncoder o t a -> o -> Object
unFieldEncoder :: o -> Aeson.Object }
field :: proxy key
-> (obj -> field)
-> ObjectEncoder subTree field
-> Field ObjectEncoder obj tree field
field ky :: proxy key
ky acc :: obj -> field
acc (ObjectEncoder so :: field -> Value
so) =
(obj -> Object) -> Field ObjectEncoder obj tree field
forall o (t :: Tree) a. (o -> Object) -> Field ObjectEncoder o t a
FieldEncoder ((obj -> Object) -> Field ObjectEncoder obj tree field)
-> (obj -> Object) -> Field ObjectEncoder obj tree field
forall a b. (a -> b) -> a -> b
$ \o :: obj
o -> String -> Text
T.pack (proxy key -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal proxy key
ky) Text -> Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= field -> Value
so (obj -> field
acc obj
o)
optField :: proxy key
-> (obj -> Maybe field)
-> ObjectEncoder subTree field
-> Field ObjectEncoder obj tree (Maybe field)
optField ky :: proxy key
ky acc :: obj -> Maybe field
acc (ObjectEncoder so :: field -> Value
so) =
(obj -> Object) -> Field ObjectEncoder obj tree (Maybe field)
forall o (t :: Tree) a. (o -> Object) -> Field ObjectEncoder o t a
FieldEncoder ((obj -> Object) -> Field ObjectEncoder obj tree (Maybe field))
-> (obj -> Object) -> Field ObjectEncoder obj tree (Maybe field)
forall a b. (a -> b) -> a -> b
$ \o :: obj
o -> String -> Text
T.pack (proxy key -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal proxy key
ky) Text -> Maybe Value -> Object
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (field -> Value
so (field -> Value) -> Maybe field -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> obj -> Maybe field
acc obj
o)
instance UnionSYM ObjectEncoder where
newtype Tag ObjectEncoder u t a =
TagEncoder { Tag ObjectEncoder u t a -> a
unTagEncoder :: a }
type Result ObjectEncoder u = Aeson.Value
union :: String
-> TreeBuilder
(Tag ObjectEncoder union)
tree
(union -> Result ObjectEncoder union)
-> ObjectEncoder tree union
union _ tags :: TreeBuilder
(Tag ObjectEncoder union)
tree
(union -> Result ObjectEncoder union)
tags = (union -> Value) -> ObjectEncoder tree union
forall (t :: Tree) o. (o -> Value) -> ObjectEncoder t o
ObjectEncoder ((union -> Value) -> ObjectEncoder tree union)
-> (union -> Value) -> ObjectEncoder tree union
forall a b. (a -> b) -> a -> b
$
Identity (union -> Value) -> union -> Value
forall a. Identity a -> a
runIdentity ((forall a' (t' :: Tree).
Tag ObjectEncoder union t' a' -> Identity a')
-> TreeBuilder (Tag ObjectEncoder union) tree (union -> Value)
-> Identity (union -> Value)
forall (g :: * -> *) (f :: Tree -> * -> *) (t :: Tree) a.
Applicative g =>
(forall a' (t' :: Tree). f t' a' -> g a')
-> TreeBuilder f t a -> g a
runAp (a' -> Identity a'
forall a. a -> Identity a
Identity (a' -> Identity a')
-> (Tag ObjectEncoder union t' a' -> a')
-> Tag ObjectEncoder union t' a'
-> Identity a'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag ObjectEncoder union t' a' -> a'
forall u (t :: Tree) a. Tag ObjectEncoder u t a -> a
unTagEncoder) TreeBuilder (Tag ObjectEncoder union) tree (union -> Value)
TreeBuilder
(Tag ObjectEncoder union)
tree
(union -> Result ObjectEncoder union)
tags)
tag :: proxy name
-> (v -> union)
-> ObjectEncoder subTree v
-> Tag ObjectEncoder union tree (v -> Result ObjectEncoder union)
tag name :: proxy name
name _ valueEncoder :: ObjectEncoder subTree v
valueEncoder =
(v -> Value)
-> Tag ObjectEncoder union tree (v -> Result ObjectEncoder union)
forall u (t :: Tree) a. a -> Tag ObjectEncoder u t a
TagEncoder ((v -> Value)
-> Tag ObjectEncoder union tree (v -> Result ObjectEncoder union))
-> (v -> Value)
-> Tag ObjectEncoder union tree (v -> Result ObjectEncoder union)
forall a b. (a -> b) -> a -> b
$ \v :: v
v ->
[Pair] -> Value
Aeson.object
[ String -> Text
T.pack (proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal proxy name
name) Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ObjectEncoder subTree v -> v -> Value
forall (t :: Tree) o. ObjectEncoder t o -> o -> Value
encodeObject ObjectEncoder subTree v
valueEncoder v
v ]
newtype ObjectDecoder (t :: Tree) o =
ObjectDecoder
{
ObjectDecoder t o -> Value -> Parser o
decodeObject :: Aeson.Value -> Aeson.Parser o
}
instance ObjectSYM ObjectDecoder where
object :: String
-> TreeBuilder (Field ObjectDecoder o) tree o
-> ObjectDecoder tree o
object name :: String
name fields :: TreeBuilder (Field ObjectDecoder o) tree o
fields = (Value -> Parser o) -> ObjectDecoder tree o
forall (t :: Tree) o. (Value -> Parser o) -> ObjectDecoder t o
ObjectDecoder ((Value -> Parser o) -> ObjectDecoder tree o)
-> ((Object -> Parser o) -> Value -> Parser o)
-> (Object -> Parser o)
-> ObjectDecoder tree o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (Object -> Parser o) -> Value -> Parser o
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
name ((Object -> Parser o) -> ObjectDecoder tree o)
-> (Object -> Parser o) -> ObjectDecoder tree o
forall a b. (a -> b) -> a -> b
$ \obj :: Object
obj ->
(forall a' (t' :: Tree). Field ObjectDecoder o t' a' -> Parser a')
-> TreeBuilder (Field ObjectDecoder o) tree o -> Parser o
forall (g :: * -> *) (f :: Tree -> * -> *) (t :: Tree) a.
Applicative g =>
(forall a' (t' :: Tree). f t' a' -> g a')
-> TreeBuilder f t a -> g a
runAp (Field ObjectDecoder o t' a' -> Object -> Parser a'
forall o (t :: Tree) a.
Field ObjectDecoder o t a -> Object -> Parser a
`unFieldDecoder` Object
obj) TreeBuilder (Field ObjectDecoder o) tree o
fields
list :: ObjectDecoder tree o -> ObjectDecoder ('IndexedNode Nat tree) [o]
list (ObjectDecoder d :: Value -> Parser o
d) = (Value -> Parser [o]) -> ObjectDecoder ('IndexedNode Nat tree) [o]
forall (t :: Tree) o. (Value -> Parser o) -> ObjectDecoder t o
ObjectDecoder ((Value -> Parser [o])
-> ObjectDecoder ('IndexedNode Nat tree) [o])
-> (Value -> Parser [o])
-> ObjectDecoder ('IndexedNode Nat tree) [o]
forall a b. (a -> b) -> a -> b
$ (Value -> Parser o) -> [Value] -> Parser [o]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Parser o
d ([Value] -> Parser [o])
-> (Value -> Parser [Value]) -> Value -> Parser [o]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Value -> Parser [Value]
forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON
textMap :: ObjectDecoder tree o
-> ObjectDecoder ('IndexedNode Symbol tree) (Map k o)
textMap (ObjectDecoder d :: Value -> Parser o
d) = (Value -> Parser (Map k o))
-> ObjectDecoder ('IndexedNode Symbol tree) (Map k o)
forall (t :: Tree) o. (Value -> Parser o) -> ObjectDecoder t o
ObjectDecoder ((Value -> Parser (Map k o))
-> ObjectDecoder ('IndexedNode Symbol tree) (Map k o))
-> (Value -> Parser (Map k o))
-> ObjectDecoder ('IndexedNode Symbol tree) (Map k o)
forall a b. (a -> b) -> a -> b
$ (Value -> Parser o) -> Map k Value -> Parser (Map k o)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Parser o
d (Map k Value -> Parser (Map k o))
-> (Value -> Parser (Map k Value)) -> Value -> Parser (Map k o)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Value -> Parser (Map k Value)
forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON
set :: ObjectDecoder tree o
-> ObjectDecoder ('IndexedNode Nat tree) (Set o)
set (ObjectDecoder d :: Value -> Parser o
d) = (Value -> Parser (Set o))
-> ObjectDecoder ('IndexedNode Nat tree) (Set o)
forall (t :: Tree) o. (Value -> Parser o) -> ObjectDecoder t o
ObjectDecoder ((Value -> Parser (Set o))
-> ObjectDecoder ('IndexedNode Nat tree) (Set o))
-> (Value -> Parser (Set o))
-> ObjectDecoder ('IndexedNode Nat tree) (Set o)
forall a b. (a -> b) -> a -> b
$ ([o] -> Set o) -> Parser [o] -> Parser (Set o)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [o] -> Set o
forall a. Ord a => [a] -> Set a
S.fromList
(Parser [o] -> Parser (Set o))
-> ([Value] -> Parser [o]) -> [Value] -> Parser (Set o)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Parser o) -> [Value] -> Parser [o]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Parser o
d ([Value] -> Parser (Set o))
-> (Value -> Parser [Value]) -> Value -> Parser (Set o)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Value -> Parser [Value]
forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON
vector :: ObjectDecoder tree o
-> ObjectDecoder ('IndexedNode Nat tree) (Vector o)
vector (ObjectDecoder d :: Value -> Parser o
d) = (Value -> Parser (Vector o))
-> ObjectDecoder ('IndexedNode Nat tree) (Vector o)
forall (t :: Tree) o. (Value -> Parser o) -> ObjectDecoder t o
ObjectDecoder ((Value -> Parser (Vector o))
-> ObjectDecoder ('IndexedNode Nat tree) (Vector o))
-> (Value -> Parser (Vector o))
-> ObjectDecoder ('IndexedNode Nat tree) (Vector o)
forall a b. (a -> b) -> a -> b
$ (Value -> Parser o) -> Vector Value -> Parser (Vector o)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Parser o
d (Vector Value -> Parser (Vector o))
-> (Value -> Parser (Vector Value)) -> Value -> Parser (Vector o)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Value -> Parser (Vector Value)
forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON
prim :: ObjectDecoder 'Leaf v
prim = (Value -> Parser v) -> ObjectDecoder 'Leaf v
forall (t :: Tree) o. (Value -> Parser o) -> ObjectDecoder t o
ObjectDecoder Value -> Parser v
forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON
instance FieldSYM ObjectDecoder where
newtype Field ObjectDecoder o t a =
FieldDecoder { Field ObjectDecoder o t a -> Object -> Parser a
unFieldDecoder :: Aeson.Object -> Aeson.Parser a }
field :: proxy key
-> (obj -> field)
-> ObjectDecoder subTree field
-> Field ObjectDecoder obj tree field
field ky :: proxy key
ky _ (ObjectDecoder d :: Value -> Parser field
d) = (Object -> Parser field) -> Field ObjectDecoder obj tree field
forall o (t :: Tree) a.
(Object -> Parser a) -> Field ObjectDecoder o t a
FieldDecoder ((Object -> Parser field) -> Field ObjectDecoder obj tree field)
-> (Object -> Parser field) -> Field ObjectDecoder obj tree field
forall a b. (a -> b) -> a -> b
$ \obj :: Object
obj -> do
Value
so <- Object
obj Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: String -> Text
T.pack (proxy key -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal proxy key
ky)
Value -> Parser field
d Value
so
optField :: proxy key
-> (obj -> Maybe field)
-> ObjectDecoder subTree field
-> Field ObjectDecoder obj tree (Maybe field)
optField ky :: proxy key
ky _ (ObjectDecoder d :: Value -> Parser field
d) = (Object -> Parser (Maybe field))
-> Field ObjectDecoder obj tree (Maybe field)
forall o (t :: Tree) a.
(Object -> Parser a) -> Field ObjectDecoder o t a
FieldDecoder ((Object -> Parser (Maybe field))
-> Field ObjectDecoder obj tree (Maybe field))
-> (Object -> Parser (Maybe field))
-> Field ObjectDecoder obj tree (Maybe field)
forall a b. (a -> b) -> a -> b
$ \obj :: Object
obj -> do
Maybe Value
mbSo <- Object
obj Object -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? String -> Text
T.pack (proxy key -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal proxy key
ky)
(Value -> Parser field) -> Maybe Value -> Parser (Maybe field)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Parser field
d Maybe Value
mbSo
optFieldDef :: proxy key
-> (obj -> field)
-> field
-> ObjectDecoder subTree field
-> Field ObjectDecoder obj tree field
optFieldDef ky :: proxy key
ky _ def :: field
def (ObjectDecoder d :: Value -> Parser field
d) = (Object -> Parser field) -> Field ObjectDecoder obj tree field
forall o (t :: Tree) a.
(Object -> Parser a) -> Field ObjectDecoder o t a
FieldDecoder ((Object -> Parser field) -> Field ObjectDecoder obj tree field)
-> (Object -> Parser field) -> Field ObjectDecoder obj tree field
forall a b. (a -> b) -> a -> b
$ \obj :: Object
obj -> do
Maybe Value
mbSo <- Object
obj Object -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? String -> Text
T.pack (proxy key -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal proxy key
ky)
Parser field
-> (Value -> Parser field) -> Maybe Value -> Parser field
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (field -> Parser field
forall (f :: * -> *) a. Applicative f => a -> f a
pure field
def) Value -> Parser field
d Maybe Value
mbSo
instance UnionSYM ObjectDecoder where
newtype Tag ObjectDecoder u t a =
TagDecoder { Tag ObjectDecoder u t a -> HashMap Text (Value -> Parser u)
unTagDecoder :: HM.HashMap T.Text (Aeson.Value -> Aeson.Parser u) }
type Result ObjectDecoder u = ()
union :: String
-> TreeBuilder
(Tag ObjectDecoder union)
tree
(union -> Result ObjectDecoder union)
-> ObjectDecoder tree union
union name :: String
name tags :: TreeBuilder
(Tag ObjectDecoder union)
tree
(union -> Result ObjectDecoder union)
tags = (Value -> Parser union) -> ObjectDecoder tree union
forall (t :: Tree) o. (Value -> Parser o) -> ObjectDecoder t o
ObjectDecoder ((Value -> Parser union) -> ObjectDecoder tree union)
-> ((Object -> Parser union) -> Value -> Parser union)
-> (Object -> Parser union)
-> ObjectDecoder tree union
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> (Object -> Parser union) -> Value -> Parser union
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
name ((Object -> Parser union) -> ObjectDecoder tree union)
-> (Object -> Parser union) -> ObjectDecoder tree union
forall a b. (a -> b) -> a -> b
$ \obj :: Object
obj -> do
let decoderMap :: HashMap Text (Value -> Parser union)
decoderMap = (forall a' (t' :: Tree).
Tag ObjectDecoder union t' a'
-> HashMap Text (Value -> Parser union))
-> TreeBuilder (Tag ObjectDecoder union) tree (union -> ())
-> HashMap Text (Value -> Parser union)
forall m (f :: Tree -> * -> *) (t :: Tree) a.
Monoid m =>
(forall a' (t' :: Tree). f t' a' -> m) -> TreeBuilder f t a -> m
runAp_ forall a' (t' :: Tree).
Tag ObjectDecoder union t' a'
-> HashMap Text (Value -> Parser union)
forall u (t :: Tree) a.
Tag ObjectDecoder u t a -> HashMap Text (Value -> Parser u)
unTagDecoder TreeBuilder (Tag ObjectDecoder union) tree (union -> ())
TreeBuilder
(Tag ObjectDecoder union)
tree
(union -> Result ObjectDecoder union)
tags
decodeVal :: Text -> Value -> Parser union -> Parser union
decodeVal k :: Text
k v :: Value
v nxt :: Parser union
nxt =
case Text
-> HashMap Text (Value -> Parser union)
-> Maybe (Value -> Parser union)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
k HashMap Text (Value -> Parser union)
decoderMap of
Nothing -> Parser union
nxt
Just tagDecoder :: Value -> Parser union
tagDecoder ->
Value -> Parser union
tagDecoder Value
v
(Text -> Value -> Parser union -> Parser union)
-> Parser union -> Object -> Parser union
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HM.foldrWithKey Text -> Value -> Parser union -> Parser union
decodeVal (String -> Parser union
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Unable to find a matching tag") Object
obj
tag :: proxy name
-> (v -> union)
-> ObjectDecoder subTree v
-> Tag ObjectDecoder union tree (v -> Result ObjectDecoder union)
tag name :: proxy name
name constr :: v -> union
constr valueDecoder :: ObjectDecoder subTree v
valueDecoder =
HashMap Text (Value -> Parser union)
-> Tag ObjectDecoder union tree (v -> ())
forall u (t :: Tree) a.
HashMap Text (Value -> Parser u) -> Tag ObjectDecoder u t a
TagDecoder (HashMap Text (Value -> Parser union)
-> Tag ObjectDecoder union tree (v -> ()))
-> ((Value -> Parser union)
-> HashMap Text (Value -> Parser union))
-> (Value -> Parser union)
-> Tag ObjectDecoder union tree (v -> ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> (Value -> Parser union) -> HashMap Text (Value -> Parser union)
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal proxy name
name)
((Value -> Parser union)
-> Tag ObjectDecoder union tree (v -> Result ObjectDecoder union))
-> (Value -> Parser union)
-> Tag ObjectDecoder union tree (v -> Result ObjectDecoder union)
forall a b. (a -> b) -> a -> b
$ (v -> union) -> Parser v -> Parser union
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> union
constr (Parser v -> Parser union)
-> (Value -> Parser v) -> Value -> Parser union
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectDecoder subTree v -> Value -> Parser v
forall (t :: Tree) o. ObjectDecoder t o -> Value -> Parser o
decodeObject ObjectDecoder subTree v
valueDecoder
type family NoDuplicateKeys (obj :: Type) (edges :: [Edge]) :: Constraint where
NoDuplicateKeys obj ('Edge key q ty subTree ': rest)
= (KeyNotPresent key obj rest, NoDuplicateKeys obj rest)
NoDuplicateKeys obj '[] = ()
type family KeyNotPresent (key :: Symbol) (obj :: Type) (edges :: [Edge]) :: Constraint where
KeyNotPresent key obj ('Edge key q ty subTree ': rest)
= TypeError ('Text "Duplicate JSON key \""
':<>: 'Text key
':<>: 'Text "\" in object "
':<>: 'ShowType obj
)
KeyNotPresent key obj ('Edge notKey q ty subTree ': rest)
= KeyNotPresent key obj rest
KeyNotPresent key obj '[] = ()
data TreeBuilder (f :: Tree -> Type -> Type) (t :: Tree) (a :: Type) where
Pure :: a -> TreeBuilder f ('Node aggr '[]) a
Ap :: TreeBuilder f ('Node aggr edges) (a -> b)
-> f ('Node aggr '[edge]) a
-> TreeBuilder f ('Node aggr (edge ': edges)) b
(<<$>) :: (a -> b)
-> f ('Node aggr '[edge]) a
-> TreeBuilder f ('Node aggr '[edge]) b
f :: a -> b
f <<$> :: (a -> b)
-> f ('Node aggr '[edge]) a -> TreeBuilder f ('Node aggr '[edge]) b
<<$> i :: f ('Node aggr '[edge]) a
i = (a -> b) -> TreeBuilder f ('Node aggr '[]) (a -> b)
forall a (f :: Tree -> * -> *) (aggr :: Aggregator).
a -> TreeBuilder f ('Node aggr '[]) a
Pure a -> b
f TreeBuilder f ('Node aggr '[]) (a -> b)
-> f ('Node aggr '[edge]) a -> TreeBuilder f ('Node aggr '[edge]) b
forall (f :: Tree -> * -> *) (aggr :: Aggregator) (edges :: [Edge])
a b (edge :: Edge).
TreeBuilder f ('Node aggr edges) (a -> b)
-> f ('Node aggr '[edge]) a
-> TreeBuilder f ('Node aggr (edge : edges)) b
`Ap` f ('Node aggr '[edge]) a
i
infixl 4 <<$>
(<<*>) :: TreeBuilder f ('Node aggr edges) (a -> b)
-> f ('Node aggr '[edge]) a
-> TreeBuilder f ('Node aggr (edge ': edges)) b
<<*> :: TreeBuilder f ('Node aggr edges) (a -> b)
-> f ('Node aggr '[edge]) a
-> TreeBuilder f ('Node aggr (edge : edges)) b
(<<*>) = TreeBuilder f ('Node aggr edges) (a -> b)
-> f ('Node aggr '[edge]) a
-> TreeBuilder f ('Node aggr (edge : edges)) b
forall (f :: Tree -> * -> *) (aggr :: Aggregator) (edges :: [Edge])
a b (edge :: Edge).
TreeBuilder f ('Node aggr edges) (a -> b)
-> f ('Node aggr '[edge]) a
-> TreeBuilder f ('Node aggr (edge : edges)) b
Ap
infixl 4 <<*>
runAp_ :: Monoid m => (forall a' t'. f t' a' -> m) -> TreeBuilder f t a -> m
runAp_ :: (forall a' (t' :: Tree). f t' a' -> m) -> TreeBuilder f t a -> m
runAp_ _ (Pure _) = m
forall a. Monoid a => a
mempty
runAp_ f :: forall a' (t' :: Tree). f t' a' -> m
f (Ap p :: TreeBuilder f ('Node aggr edges) (a -> a)
p c :: f ('Node aggr '[edge]) a
c) = (forall a' (t' :: Tree). f t' a' -> m)
-> TreeBuilder f ('Node aggr edges) (a -> a) -> m
forall m (f :: Tree -> * -> *) (t :: Tree) a.
Monoid m =>
(forall a' (t' :: Tree). f t' a' -> m) -> TreeBuilder f t a -> m
runAp_ forall a' (t' :: Tree). f t' a' -> m
f TreeBuilder f ('Node aggr edges) (a -> a)
p m -> m -> m
forall a. Semigroup a => a -> a -> a
<> f ('Node aggr '[edge]) a -> m
forall a' (t' :: Tree). f t' a' -> m
f f ('Node aggr '[edge]) a
c
runAp :: Applicative g => (forall a' t'. f t' a' -> g a') -> TreeBuilder f t a -> g a
runAp :: (forall a' (t' :: Tree). f t' a' -> g a')
-> TreeBuilder f t a -> g a
runAp _ (Pure a :: a
a) = a -> g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
runAp f :: forall a' (t' :: Tree). f t' a' -> g a'
f (Ap p :: TreeBuilder f ('Node aggr edges) (a -> a)
p c :: f ('Node aggr '[edge]) a
c) = (forall a' (t' :: Tree). f t' a' -> g a')
-> TreeBuilder f ('Node aggr edges) (a -> a) -> g (a -> a)
forall (g :: * -> *) (f :: Tree -> * -> *) (t :: Tree) a.
Applicative g =>
(forall a' (t' :: Tree). f t' a' -> g a')
-> TreeBuilder f t a -> g a
runAp forall a' (t' :: Tree). f t' a' -> g a'
f TreeBuilder f ('Node aggr edges) (a -> a)
p g (a -> a) -> g a -> g a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f ('Node aggr '[edge]) a -> g a
forall a' (t' :: Tree). f t' a' -> g a'
f f ('Node aggr '[edge]) a
c