module Hydra.Langs.Tinkerpop.Coder (
  elementCoder,
) where

import Hydra.Kernel
import Hydra.Langs.Tinkerpop.Mappings
import Hydra.Langs.Tinkerpop.TermsToElements
import qualified Hydra.Langs.Tinkerpop.PropertyGraph as PG
import qualified Hydra.Dsl.Expect as Expect
import qualified Hydra.Dsl.Terms as Terms

import qualified Control.Monad as CM
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Maybe as Y


type ElementAdapter s t v = Adapter s s (Type) (PG.ElementTypeTree t) (Term) (PG.ElementTree v)

type PropertyAdapter s t v = Adapter s s (FieldType) (PG.PropertyType t) (Field) (PG.Property v)

type IdAdapter s t v = (Name, Adapter s s (Type) t (Term) v)

data AdjacentEdgeAdapter s a t v = AdjacentEdgeAdapter {
  forall s a t v. AdjacentEdgeAdapter s a t v -> Direction
adjacentEdgeAdapterDirection :: PG.Direction,
  forall s a t v. AdjacentEdgeAdapter s a t v -> FieldType
adjacentEdgeAdapterField :: FieldType,
  forall s a t v. AdjacentEdgeAdapter s a t v -> EdgeLabel
adjacentEdgeAdapterLabel :: PG.EdgeLabel,
  forall s a t v. AdjacentEdgeAdapter s a t v -> ElementAdapter s t v
adjacentEdgeAdapterAdapter :: ElementAdapter s t v}

data ProjectionSpec a = ProjectionSpec {
  forall a. ProjectionSpec a -> FieldType
projectionSpecField :: FieldType,
  forall a. ProjectionSpec a -> ValueSpec
projectionSpecValues :: ValueSpec,
  forall a. ProjectionSpec a -> Maybe String
projectionSpecAlias :: Maybe String}

check :: Bool -> Flow s () -> Flow s ()
check :: forall s. Bool -> Flow s () -> Flow s ()
check Bool
b Flow s ()
err = if Bool
b then () -> Flow s ()
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else Flow s ()
err

checkRecordName :: Name -> Name -> Flow s ()
checkRecordName Name
expected Name
actual = Bool -> Flow s () -> Flow s ()
forall s. Bool -> Flow s () -> Flow s ()
check (Name
actual Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
expected) (Flow s () -> Flow s ()) -> Flow s () -> Flow s ()
forall a b. (a -> b) -> a -> b
$
  String -> String -> Flow s ()
forall s x. String -> String -> Flow s x
unexpected (String
"record of type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
expected) (String
"record of type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
actual)

edgeCoder :: PG.Direction -> Schema s t v
  -> Type
  -> t
  -> Name
  -> PG.EdgeLabel -> PG.VertexLabel -> PG.VertexLabel
  -> Maybe (IdAdapter s t v) -> Maybe (IdAdapter s t v) -> Maybe (IdAdapter s t v) -> [PropertyAdapter s t v]
  -> ElementAdapter s t v
edgeCoder :: forall s t v.
Direction
-> Schema s t v
-> Type
-> t
-> Name
-> EdgeLabel
-> VertexLabel
-> VertexLabel
-> Maybe (IdAdapter s t v)
-> Maybe (IdAdapter s t v)
-> Maybe (IdAdapter s t v)
-> [PropertyAdapter s t v]
-> ElementAdapter s t v
edgeCoder Direction
dir Schema s t v
schema Type
source t
eidType Name
tname EdgeLabel
label VertexLabel
outLabel VertexLabel
inLabel Maybe (IdAdapter s t v)
mIdAdapter Maybe (IdAdapter s t v)
outAdapter Maybe (IdAdapter s t v)
inAdapter [PropertyAdapter s t v]
propAdapters
    = Bool
-> Type
-> ElementTypeTree t
-> Coder s s Term (ElementTree v)
-> Adapter s s Type (ElementTypeTree t) Term (ElementTree v)
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter Bool
lossy Type
source (EdgeType t -> [ElementTypeTree t] -> ElementTypeTree t
forall t. EdgeType t -> [ElementTypeTree t] -> ElementTypeTree t
elementTypeTreeEdge EdgeType t
et []) Coder s s Term (ElementTree v)
forall {s2}. Coder s s2 Term (ElementTree v)
coder
  where
    et :: EdgeType t
et = EdgeLabel
-> t
-> VertexLabel
-> VertexLabel
-> [PropertyType t]
-> EdgeType t
forall t.
EdgeLabel
-> t
-> VertexLabel
-> VertexLabel
-> [PropertyType t]
-> EdgeType t
PG.EdgeType EdgeLabel
label t
eidType VertexLabel
outLabel VertexLabel
inLabel ([PropertyType t] -> EdgeType t) -> [PropertyType t] -> EdgeType t
forall a b. (a -> b) -> a -> b
$ [PropertyAdapter s t v] -> [PropertyType t]
forall {f :: * -> *} {s1} {s2} {t1} {t} {v1} {v2}.
Functor f =>
f (Adapter s1 s2 t1 (PropertyType t) v1 v2) -> f (PropertyType t)
propertyTypes [PropertyAdapter s t v]
propAdapters
    coder :: Coder s s2 Term (ElementTree v)
coder = (Term -> Flow s (ElementTree v))
-> (ElementTree v -> Flow s2 Term)
-> Coder s s2 Term (ElementTree v)
forall s1 s2 v1 v2.
(v1 -> Flow s1 v2) -> (v2 -> Flow s2 v1) -> Coder s1 s2 v1 v2
Coder Term -> Flow s (ElementTree v)
encode ElementTree v -> Flow s2 Term
forall {p} {s} {x}. p -> Flow s x
decode
      where
        encode :: Term -> Flow s (ElementTree v)
encode Term
term = case Term -> Term
stripTerm Term
term of
          TermOptional (Just Term
ot) -> Term -> Flow s (ElementTree v)
encode Term
ot
          TermRecord (Record Name
tname' [Field]
fields) -> do
            Name -> Name -> Flow s ()
forall {s}. Name -> Name -> Flow s ()
checkRecordName Name
tname Name
tname'
            let fieldsm :: Map Name Term
fieldsm = [Field] -> Map Name Term
fieldMap [Field]
fields
            v
id <- case Maybe (IdAdapter s t v)
mIdAdapter of
              Maybe (IdAdapter s t v)
Nothing -> v -> Flow s v
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (v -> Flow s v) -> v -> Flow s v
forall a b. (a -> b) -> a -> b
$ Schema s t v -> v
forall s t v. Schema s t v -> v
schemaDefaultEdgeId Schema s t v
schema
              Just IdAdapter s t v
ad -> Map Name Term -> IdAdapter s t v -> Flow s v
forall {v1} {s1} {s2} {t1} {t2} {a}.
Map Name v1 -> (Name, Adapter s1 s2 t1 t2 v1 a) -> Flow s1 a
selectEdgeId Map Name Term
fieldsm IdAdapter s t v
ad
            Map PropertyKey v
props <- Map Name Term
-> [PropertyAdapter s t v] -> Flow s (Map PropertyKey v)
forall s t v.
Map Name Term
-> [PropertyAdapter s t v] -> Flow s (Map PropertyKey v)
encodeProperties Map Name Term
fieldsm [PropertyAdapter s t v]
propAdapters
            v
outId <- Direction -> Map Name Term -> Maybe (IdAdapter s t v) -> Flow s v
forall {s} {t}.
Direction -> Map Name Term -> Maybe (IdAdapter s t v) -> Flow s v
getVertexId Direction
PG.DirectionOut Map Name Term
fieldsm Maybe (IdAdapter s t v)
outAdapter
            v
inId <- Direction -> Map Name Term -> Maybe (IdAdapter s t v) -> Flow s v
forall {s} {t}.
Direction -> Map Name Term -> Maybe (IdAdapter s t v) -> Flow s v
getVertexId Direction
PG.DirectionIn Map Name Term
fieldsm Maybe (IdAdapter s t v)
inAdapter
            ElementTree v -> Flow s (ElementTree v)
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (ElementTree v -> Flow s (ElementTree v))
-> ElementTree v -> Flow s (ElementTree v)
forall a b. (a -> b) -> a -> b
$ Edge v -> [ElementTree v] -> ElementTree v
forall v. Edge v -> [ElementTree v] -> ElementTree v
elementTreeEdge (EdgeLabel -> v -> v -> v -> Map PropertyKey v -> Edge v
forall v. EdgeLabel -> v -> v -> v -> Map PropertyKey v -> Edge v
PG.Edge EdgeLabel
label v
id v
outId v
inId Map PropertyKey v
props) []
          Term
_ -> String -> String -> Flow s (ElementTree v)
forall s x. String -> String -> Flow s x
unexpected String
"record (1)" (String -> Flow s (ElementTree v))
-> String -> Flow s (ElementTree v)
forall a b. (a -> b) -> a -> b
$ Term -> String
forall a. Show a => a -> String
show Term
term
        decode :: p -> Flow s x
decode p
el = String -> Flow s x
forall s x. String -> Flow s x
noDecoding String
"edge"
        getVertexId :: Direction -> Map Name Term -> Maybe (IdAdapter s t v) -> Flow s v
getVertexId Direction
dir1 Map Name Term
fieldsm Maybe (IdAdapter s t v)
adapter = if Direction
dir1 Direction -> Direction -> Bool
forall a. Eq a => a -> a -> Bool
== Direction
dir
          then v -> Flow s v
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (v -> Flow s v) -> v -> Flow s v
forall a b. (a -> b) -> a -> b
$ Schema s t v -> v
forall s t v. Schema s t v -> v
schemaDefaultVertexId Schema s t v
schema
          else case Maybe (IdAdapter s t v)
adapter of
            Maybe (IdAdapter s t v)
Nothing -> String -> Flow s v
forall a. String -> Flow s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Flow s v) -> String -> Flow s v
forall a b. (a -> b) -> a -> b
$ String
"no adapter for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Direction -> String
forall a. Show a => a -> String
show Direction
dir1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Direction -> String
forall a. Show a => a -> String
show Direction
dir
            Just IdAdapter s t v
ad -> Map Name Term -> IdAdapter s t v -> Flow s v
forall s t v. Map Name Term -> IdAdapter s t v -> Flow s v
selectVertexId Map Name Term
fieldsm IdAdapter s t v
ad

elementCoder :: (Show t, Show v) => Y.Maybe (PG.Direction, PG.VertexLabel)
  -> Schema s t v
  -> Type
  -> t -> t
  -> Flow s (ElementAdapter s t v)
elementCoder :: forall t v s.
(Show t, Show v) =>
Maybe (Direction, VertexLabel)
-> Schema s t v -> Type -> t -> t -> Flow s (ElementAdapter s t v)
elementCoder Maybe (Direction, VertexLabel)
mparent Schema s t v
schema Type
source t
vidType t
eidType = case Type -> Type
stripType Type
source of
    TypeOptional Type
ot -> Maybe (Direction, VertexLabel)
-> Schema s t v -> Type -> t -> t -> Flow s (ElementAdapter s t v)
forall t v s.
(Show t, Show v) =>
Maybe (Direction, VertexLabel)
-> Schema s t v -> Type -> t -> t -> Flow s (ElementAdapter s t v)
elementCoder Maybe (Direction, VertexLabel)
mparent Schema s t v
schema Type
ot t
vidType t
eidType
    TypeRecord (RowType Name
name Maybe Name
_ [FieldType]
fields) -> String
-> Flow s (ElementAdapter s t v) -> Flow s (ElementAdapter s t v)
forall s a. String -> Flow s a -> Flow s a
withTrace (String
"adapter for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
name) (Flow s (ElementAdapter s t v) -> Flow s (ElementAdapter s t v))
-> Flow s (ElementAdapter s t v) -> Flow s (ElementAdapter s t v)
forall a b. (a -> b) -> a -> b
$ do
      Maybe (ProjectionSpec Any)
mOutSpec <- Name
-> String
-> String
-> [FieldType]
-> Flow s (Maybe (ProjectionSpec Any))
forall {s} {a}.
Name
-> String
-> String
-> [FieldType]
-> Flow s (Maybe (ProjectionSpec a))
findProjectionSpec Name
name String
outVertexKey String
outVertexLabelKey [FieldType]
fields
      Maybe (ProjectionSpec Any)
mInSpec <- Name
-> String
-> String
-> [FieldType]
-> Flow s (Maybe (ProjectionSpec Any))
forall {s} {a}.
Name
-> String
-> String
-> [FieldType]
-> Flow s (Maybe (ProjectionSpec a))
findProjectionSpec Name
name String
inVertexKey String
inVertexLabelKey [FieldType]
fields

      -- TODO: deprecate "kind"
      ElementKind
kind <- case String -> Type -> Maybe Term
getTypeAnnotation String
"kind" Type
source of
        Maybe Term
Nothing -> ElementKind -> Flow s ElementKind
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ElementKind -> Flow s ElementKind)
-> ElementKind -> Flow s ElementKind
forall a b. (a -> b) -> a -> b
$ if Maybe (ProjectionSpec Any) -> Maybe (ProjectionSpec Any) -> Bool
forall {a} {a}. Maybe a -> Maybe a -> Bool
hasVertexAdapters Maybe (ProjectionSpec Any)
mOutSpec Maybe (ProjectionSpec Any)
mInSpec
          then ElementKind
PG.ElementKindEdge
          else ElementKind
PG.ElementKindVertex
        Just Term
kindTerm -> do
          String
s <- Term -> Flow s String
forall s. Term -> Flow s String
Expect.string Term
kindTerm
          case String
s of
            String
"vertex" -> ElementKind -> Flow s ElementKind
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return ElementKind
PG.ElementKindVertex
            String
"edge" -> if Maybe (ProjectionSpec Any) -> Bool
forall a. Maybe a -> Bool
Y.isNothing Maybe (ProjectionSpec Any)
mOutSpec Bool -> Bool -> Bool
|| Maybe (ProjectionSpec Any) -> Bool
forall a. Maybe a -> Bool
Y.isNothing Maybe (ProjectionSpec Any)
mInSpec
              then String -> Flow s ElementKind
forall a. String -> Flow s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Flow s ElementKind) -> String -> Flow s ElementKind
forall a b. (a -> b) -> a -> b
$ String
"Record type marked as an edge type, but missing 'out' and/or 'in' fields: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
name
              else ElementKind -> Flow s ElementKind
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return ElementKind
PG.ElementKindEdge

      [ProjectionSpec Any]
propSpecs <- ElementKind -> [FieldType] -> Flow s [ProjectionSpec Any]
forall {s} {a}.
ElementKind -> [FieldType] -> Flow s [ProjectionSpec a]
findPropertySpecs ElementKind
kind [FieldType]
fields
      [PropertyAdapter s t v]
propAdapters <- (ProjectionSpec Any -> Flow s (PropertyAdapter s t v))
-> [ProjectionSpec Any] -> Flow s [PropertyAdapter s t v]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM (Schema s t v
-> ProjectionSpec Any -> Flow s (PropertyAdapter s t v)
forall s t v a.
Schema s t v -> ProjectionSpec a -> Flow s (PropertyAdapter s t v)
propertyAdapter Schema s t v
schema) [ProjectionSpec Any]
propSpecs

      case ElementKind
kind of
        ElementKind
PG.ElementKindVertex -> do
          VertexLabel
label <- String -> VertexLabel
PG.VertexLabel (String -> VertexLabel) -> Flow s String -> Flow s VertexLabel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> String -> Flow s String
forall {s}. Name -> String -> Flow s String
findLabelString Name
name String
vertexLabelKey
          IdAdapter s t v
idAdapter <- Name -> String -> [FieldType] -> Flow s (IdAdapter s t v)
vertexIdAdapter Name
name String
vertexIdKey [FieldType]
fields
          [AdjacentEdgeAdapter s Any t v]
outEdgeAdapters <- VertexLabel
-> Direction
-> [FieldType]
-> Flow s [AdjacentEdgeAdapter s Any t v]
forall {a}.
VertexLabel
-> Direction -> [FieldType] -> Flow s [AdjacentEdgeAdapter s a t v]
edgeAdapters VertexLabel
label Direction
PG.DirectionOut [FieldType]
fields
          [AdjacentEdgeAdapter s Any t v]
inEdgeAdapters <- VertexLabel
-> Direction
-> [FieldType]
-> Flow s [AdjacentEdgeAdapter s Any t v]
forall {a}.
VertexLabel
-> Direction -> [FieldType] -> Flow s [AdjacentEdgeAdapter s a t v]
edgeAdapters VertexLabel
label Direction
PG.DirectionIn [FieldType]
fields
          ElementAdapter s t v -> Flow s (ElementAdapter s t v)
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (ElementAdapter s t v -> Flow s (ElementAdapter s t v))
-> ElementAdapter s t v -> Flow s (ElementAdapter s t v)
forall a b. (a -> b) -> a -> b
$ Schema s t v
-> Type
-> t
-> Name
-> VertexLabel
-> IdAdapter s t v
-> [PropertyAdapter s t v]
-> [AdjacentEdgeAdapter s Any t v]
-> ElementAdapter s t v
forall t v s a.
(Show t, Show v) =>
Schema s t v
-> Type
-> t
-> Name
-> VertexLabel
-> IdAdapter s t v
-> [PropertyAdapter s t v]
-> [AdjacentEdgeAdapter s a t v]
-> ElementAdapter s t v
vertexCoder Schema s t v
schema Type
source t
vidType Name
name VertexLabel
label IdAdapter s t v
idAdapter [PropertyAdapter s t v]
propAdapters ([AdjacentEdgeAdapter s Any t v]
outEdgeAdapters [AdjacentEdgeAdapter s Any t v]
-> [AdjacentEdgeAdapter s Any t v]
-> [AdjacentEdgeAdapter s Any t v]
forall a. [a] -> [a] -> [a]
++ [AdjacentEdgeAdapter s Any t v]
inEdgeAdapters)
        ElementKind
PG.ElementKindEdge -> do
          EdgeLabel
label <- String -> EdgeLabel
PG.EdgeLabel (String -> EdgeLabel) -> Flow s String -> Flow s EdgeLabel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> String -> Flow s String
forall {s}. Name -> String -> Flow s String
findLabelString Name
name String
edgeLabelKey
          Maybe (IdAdapter s t v)
idAdapter <- Name -> String -> [FieldType] -> Flow s (Maybe (IdAdapter s t v))
edgeIdAdapter Name
name String
edgeIdKey [FieldType]
fields
          Maybe (IdAdapter s t v)
outAdapter <- Flow s (Maybe (IdAdapter s t v))
-> (ProjectionSpec Any -> Flow s (Maybe (IdAdapter s t v)))
-> Maybe (ProjectionSpec Any)
-> Flow s (Maybe (IdAdapter s t v))
forall b a. b -> (a -> b) -> Maybe a -> b
Y.maybe (Maybe (IdAdapter s t v) -> Flow s (Maybe (IdAdapter s t v))
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (IdAdapter s t v)
forall a. Maybe a
Nothing) (\ProjectionSpec Any
s -> IdAdapter s t v -> Maybe (IdAdapter s t v)
forall a. a -> Maybe a
Just (IdAdapter s t v -> Maybe (IdAdapter s t v))
-> Flow s (IdAdapter s t v) -> Flow s (Maybe (IdAdapter s t v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t
-> Coder s s Term v
-> ProjectionSpec Any
-> String
-> Flow s (IdAdapter s t v)
forall t s v a.
t
-> Coder s s Term v
-> ProjectionSpec a
-> String
-> Flow s (IdAdapter s t v)
projectionAdapter t
vidType (Schema s t v -> Coder s s Term v
forall s t v. Schema s t v -> Coder s s Term v
schemaVertexIds Schema s t v
schema) ProjectionSpec Any
s String
"out") Maybe (ProjectionSpec Any)
mOutSpec
          Maybe (IdAdapter s t v)
inAdapter <- Flow s (Maybe (IdAdapter s t v))
-> (ProjectionSpec Any -> Flow s (Maybe (IdAdapter s t v)))
-> Maybe (ProjectionSpec Any)
-> Flow s (Maybe (IdAdapter s t v))
forall b a. b -> (a -> b) -> Maybe a -> b
Y.maybe (Maybe (IdAdapter s t v) -> Flow s (Maybe (IdAdapter s t v))
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (IdAdapter s t v)
forall a. Maybe a
Nothing) (\ProjectionSpec Any
s -> IdAdapter s t v -> Maybe (IdAdapter s t v)
forall a. a -> Maybe a
Just (IdAdapter s t v -> Maybe (IdAdapter s t v))
-> Flow s (IdAdapter s t v) -> Flow s (Maybe (IdAdapter s t v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t
-> Coder s s Term v
-> ProjectionSpec Any
-> String
-> Flow s (IdAdapter s t v)
forall t s v a.
t
-> Coder s s Term v
-> ProjectionSpec a
-> String
-> Flow s (IdAdapter s t v)
projectionAdapter t
vidType (Schema s t v -> Coder s s Term v
forall s t v. Schema s t v -> Coder s s Term v
schemaVertexIds Schema s t v
schema) ProjectionSpec Any
s String
"in") Maybe (ProjectionSpec Any)
mInSpec
          VertexLabel
outLabel <- case Maybe (ProjectionSpec Any)
mOutSpec of
            Maybe (ProjectionSpec Any)
Nothing -> VertexLabel -> Flow s VertexLabel
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VertexLabel
parentLabel
            Just ProjectionSpec Any
spec -> Flow s VertexLabel
-> (String -> Flow s VertexLabel)
-> Maybe String
-> Flow s VertexLabel
forall b a. b -> (a -> b) -> Maybe a -> b
Y.maybe (String -> Flow s VertexLabel
forall a. String -> Flow s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no out-vertex label") (VertexLabel -> Flow s VertexLabel
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VertexLabel -> Flow s VertexLabel)
-> (String -> VertexLabel) -> String -> Flow s VertexLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> VertexLabel
PG.VertexLabel) (Maybe String -> Flow s VertexLabel)
-> Maybe String -> Flow s VertexLabel
forall a b. (a -> b) -> a -> b
$ ProjectionSpec Any -> Maybe String
forall a. ProjectionSpec a -> Maybe String
projectionSpecAlias ProjectionSpec Any
spec
          VertexLabel
inLabel <- case Maybe (ProjectionSpec Any)
mInSpec of
            Maybe (ProjectionSpec Any)
Nothing -> VertexLabel -> Flow s VertexLabel
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VertexLabel
parentLabel
            Just ProjectionSpec Any
spec -> Flow s VertexLabel
-> (String -> Flow s VertexLabel)
-> Maybe String
-> Flow s VertexLabel
forall b a. b -> (a -> b) -> Maybe a -> b
Y.maybe (String -> Flow s VertexLabel
forall a. String -> Flow s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no in-vertex label") (VertexLabel -> Flow s VertexLabel
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VertexLabel -> Flow s VertexLabel)
-> (String -> VertexLabel) -> String -> Flow s VertexLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> VertexLabel
PG.VertexLabel) (Maybe String -> Flow s VertexLabel)
-> Maybe String -> Flow s VertexLabel
forall a b. (a -> b) -> a -> b
$ ProjectionSpec Any -> Maybe String
forall a. ProjectionSpec a -> Maybe String
projectionSpecAlias ProjectionSpec Any
spec
          ElementAdapter s t v -> Flow s (ElementAdapter s t v)
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (ElementAdapter s t v -> Flow s (ElementAdapter s t v))
-> ElementAdapter s t v -> Flow s (ElementAdapter s t v)
forall a b. (a -> b) -> a -> b
$ Direction
-> Schema s t v
-> Type
-> t
-> Name
-> EdgeLabel
-> VertexLabel
-> VertexLabel
-> Maybe (IdAdapter s t v)
-> Maybe (IdAdapter s t v)
-> Maybe (IdAdapter s t v)
-> [PropertyAdapter s t v]
-> ElementAdapter s t v
forall s t v.
Direction
-> Schema s t v
-> Type
-> t
-> Name
-> EdgeLabel
-> VertexLabel
-> VertexLabel
-> Maybe (IdAdapter s t v)
-> Maybe (IdAdapter s t v)
-> Maybe (IdAdapter s t v)
-> [PropertyAdapter s t v]
-> ElementAdapter s t v
edgeCoder Direction
dir Schema s t v
schema Type
source t
eidType Name
name EdgeLabel
label VertexLabel
outLabel VertexLabel
inLabel Maybe (IdAdapter s t v)
idAdapter Maybe (IdAdapter s t v)
outAdapter Maybe (IdAdapter s t v)
inAdapter [PropertyAdapter s t v]
propAdapters

    Type
_ -> String -> String -> Flow s (ElementAdapter s t v)
forall s x. String -> String -> Flow s x
unexpected String
"record type" (String -> Flow s (ElementAdapter s t v))
-> String -> Flow s (ElementAdapter s t v)
forall a b. (a -> b) -> a -> b
$ Type -> String
forall a. Show a => a -> String
show Type
source
  where
    dir :: Direction
dir = Direction
-> ((Direction, VertexLabel) -> Direction)
-> Maybe (Direction, VertexLabel)
-> Direction
forall b a. b -> (a -> b) -> Maybe a -> b
Y.maybe Direction
PG.DirectionBoth (Direction, VertexLabel) -> Direction
forall a b. (a, b) -> a
fst Maybe (Direction, VertexLabel)
mparent
    parentLabel :: VertexLabel
parentLabel = VertexLabel
-> ((Direction, VertexLabel) -> VertexLabel)
-> Maybe (Direction, VertexLabel)
-> VertexLabel
forall b a. b -> (a -> b) -> Maybe a -> b
Y.maybe (String -> VertexLabel
PG.VertexLabel String
"NOLABEL") (Direction, VertexLabel) -> VertexLabel
forall a b. (a, b) -> b
snd Maybe (Direction, VertexLabel)
mparent

    vertexIdAdapter :: Name -> String -> [FieldType] -> Flow s (IdAdapter s t v)
vertexIdAdapter Name
name String
idKey [FieldType]
fields = do
      ProjectionSpec Any
idSpec <- Maybe (ProjectionSpec Any) -> ProjectionSpec Any
forall a. HasCallStack => Maybe a -> a
Y.fromJust (Maybe (ProjectionSpec Any) -> ProjectionSpec Any)
-> Flow s (Maybe (ProjectionSpec Any))
-> Flow s (ProjectionSpec Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> Name
-> String
-> [FieldType]
-> Flow s (Maybe (ProjectionSpec Any))
forall {s} {a}.
Bool
-> Name
-> String
-> [FieldType]
-> Flow s (Maybe (ProjectionSpec a))
findId Bool
True Name
name String
idKey [FieldType]
fields
      IdAdapter s t v
idAdapter <- t
-> Coder s s Term v
-> ProjectionSpec Any
-> String
-> Flow s (IdAdapter s t v)
forall t s v a.
t
-> Coder s s Term v
-> ProjectionSpec a
-> String
-> Flow s (IdAdapter s t v)
projectionAdapter t
vidType (Schema s t v -> Coder s s Term v
forall s t v. Schema s t v -> Coder s s Term v
schemaVertexIds Schema s t v
schema) ProjectionSpec Any
idSpec String
"id"
      IdAdapter s t v -> Flow s (IdAdapter s t v)
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return IdAdapter s t v
idAdapter

    edgeIdAdapter :: Name -> String -> [FieldType] -> Flow s (Maybe (IdAdapter s t v))
edgeIdAdapter Name
name String
idKey [FieldType]
fields = do
      Maybe (ProjectionSpec Any)
mIdSpec <- Bool
-> Name
-> String
-> [FieldType]
-> Flow s (Maybe (ProjectionSpec Any))
forall {s} {a}.
Bool
-> Name
-> String
-> [FieldType]
-> Flow s (Maybe (ProjectionSpec a))
findId Bool
False Name
name String
idKey [FieldType]
fields
      case Maybe (ProjectionSpec Any)
mIdSpec of
        Maybe (ProjectionSpec Any)
Nothing -> Maybe (IdAdapter s t v) -> Flow s (Maybe (IdAdapter s t v))
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (IdAdapter s t v)
forall a. Maybe a
Nothing
        Just ProjectionSpec Any
idSpec -> IdAdapter s t v -> Maybe (IdAdapter s t v)
forall a. a -> Maybe a
Just (IdAdapter s t v -> Maybe (IdAdapter s t v))
-> Flow s (IdAdapter s t v) -> Flow s (Maybe (IdAdapter s t v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t
-> Coder s s Term v
-> ProjectionSpec Any
-> String
-> Flow s (IdAdapter s t v)
forall t s v a.
t
-> Coder s s Term v
-> ProjectionSpec a
-> String
-> Flow s (IdAdapter s t v)
projectionAdapter t
eidType (Schema s t v -> Coder s s Term v
forall s t v. Schema s t v -> Coder s s Term v
schemaEdgeIds Schema s t v
schema) ProjectionSpec Any
idSpec String
"id"

    hasVertexAdapters :: Maybe a -> Maybe a -> Bool
hasVertexAdapters Maybe a
mOutSpec Maybe a
mInSpec = case Direction
dir of
      Direction
PG.DirectionOut -> Maybe a -> Bool
forall a. Maybe a -> Bool
Y.isJust Maybe a
mInSpec
      Direction
PG.DirectionIn -> Maybe a -> Bool
forall a. Maybe a -> Bool
Y.isJust Maybe a
mOutSpec
      Direction
PG.DirectionBoth -> Maybe a -> Bool
forall a. Maybe a -> Bool
Y.isJust Maybe a
mOutSpec Bool -> Bool -> Bool
&& Maybe a -> Bool
forall a. Maybe a -> Bool
Y.isJust Maybe a
mInSpec

    vertexLabelKey :: String
vertexLabelKey = AnnotationSchema -> String
annotationSchemaVertexLabel (AnnotationSchema -> String) -> AnnotationSchema -> String
forall a b. (a -> b) -> a -> b
$ Schema s t v -> AnnotationSchema
forall s t v. Schema s t v -> AnnotationSchema
schemaAnnotations Schema s t v
schema
    edgeLabelKey :: String
edgeLabelKey = AnnotationSchema -> String
annotationSchemaEdgeLabel (AnnotationSchema -> String) -> AnnotationSchema -> String
forall a b. (a -> b) -> a -> b
$ Schema s t v -> AnnotationSchema
forall s t v. Schema s t v -> AnnotationSchema
schemaAnnotations Schema s t v
schema
    vertexIdKey :: String
vertexIdKey = AnnotationSchema -> String
annotationSchemaVertexId (AnnotationSchema -> String) -> AnnotationSchema -> String
forall a b. (a -> b) -> a -> b
$ Schema s t v -> AnnotationSchema
forall s t v. Schema s t v -> AnnotationSchema
schemaAnnotations Schema s t v
schema
    edgeIdKey :: String
edgeIdKey = AnnotationSchema -> String
annotationSchemaEdgeId (AnnotationSchema -> String) -> AnnotationSchema -> String
forall a b. (a -> b) -> a -> b
$ Schema s t v -> AnnotationSchema
forall s t v. Schema s t v -> AnnotationSchema
schemaAnnotations Schema s t v
schema
    propertyKeyKey :: String
propertyKeyKey = AnnotationSchema -> String
annotationSchemaPropertyKey (AnnotationSchema -> String) -> AnnotationSchema -> String
forall a b. (a -> b) -> a -> b
$ Schema s t v -> AnnotationSchema
forall s t v. Schema s t v -> AnnotationSchema
schemaAnnotations Schema s t v
schema
    propertyValueKey :: String
propertyValueKey = AnnotationSchema -> String
annotationSchemaPropertyValue (AnnotationSchema -> String) -> AnnotationSchema -> String
forall a b. (a -> b) -> a -> b
$ Schema s t v -> AnnotationSchema
forall s t v. Schema s t v -> AnnotationSchema
schemaAnnotations Schema s t v
schema
    outVertexKey :: String
outVertexKey = AnnotationSchema -> String
annotationSchemaOutVertex (AnnotationSchema -> String) -> AnnotationSchema -> String
forall a b. (a -> b) -> a -> b
$ Schema s t v -> AnnotationSchema
forall s t v. Schema s t v -> AnnotationSchema
schemaAnnotations Schema s t v
schema
    outVertexLabelKey :: String
outVertexLabelKey = AnnotationSchema -> String
annotationSchemaOutVertexLabel (AnnotationSchema -> String) -> AnnotationSchema -> String
forall a b. (a -> b) -> a -> b
$ Schema s t v -> AnnotationSchema
forall s t v. Schema s t v -> AnnotationSchema
schemaAnnotations Schema s t v
schema
    inVertexKey :: String
inVertexKey = AnnotationSchema -> String
annotationSchemaInVertex (AnnotationSchema -> String) -> AnnotationSchema -> String
forall a b. (a -> b) -> a -> b
$ Schema s t v -> AnnotationSchema
forall s t v. Schema s t v -> AnnotationSchema
schemaAnnotations Schema s t v
schema
    inVertexLabelKey :: String
inVertexLabelKey = AnnotationSchema -> String
annotationSchemaInVertexLabel (AnnotationSchema -> String) -> AnnotationSchema -> String
forall a b. (a -> b) -> a -> b
$ Schema s t v -> AnnotationSchema
forall s t v. Schema s t v -> AnnotationSchema
schemaAnnotations Schema s t v
schema
    outEdgeLabelKey :: String
outEdgeLabelKey = AnnotationSchema -> String
annotationSchemaOutEdgeLabel (AnnotationSchema -> String) -> AnnotationSchema -> String
forall a b. (a -> b) -> a -> b
$ Schema s t v -> AnnotationSchema
forall s t v. Schema s t v -> AnnotationSchema
schemaAnnotations Schema s t v
schema
    inEdgeLabelKey :: String
inEdgeLabelKey = AnnotationSchema -> String
annotationSchemaInEdgeLabel (AnnotationSchema -> String) -> AnnotationSchema -> String
forall a b. (a -> b) -> a -> b
$ Schema s t v -> AnnotationSchema
forall s t v. Schema s t v -> AnnotationSchema
schemaAnnotations Schema s t v
schema
    ignoreKey :: String
ignoreKey = AnnotationSchema -> String
annotationSchemaIgnore (AnnotationSchema -> String) -> AnnotationSchema -> String
forall a b. (a -> b) -> a -> b
$ Schema s t v -> AnnotationSchema
forall s t v. Schema s t v -> AnnotationSchema
schemaAnnotations Schema s t v
schema

    findLabelString :: Name -> String -> Flow s String
findLabelString Name
tname String
labelKey = case String -> Type -> Maybe Term
getTypeAnnotation String
labelKey Type
source of
      Maybe Term
Nothing -> String -> Flow s String
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Flow s String) -> String -> Flow s String
forall a b. (a -> b) -> a -> b
$ Name -> String
unName Name
tname
      Just Term
labelTerm -> Term -> Flow s String
forall s. Term -> Flow s String
Expect.string Term
labelTerm

    findId :: Bool
-> Name
-> String
-> [FieldType]
-> Flow s (Maybe (ProjectionSpec a))
findId Bool
required Name
tname String
idKey [FieldType]
fields = String
-> Flow s (Maybe (ProjectionSpec a))
-> Flow s (Maybe (ProjectionSpec a))
forall s a. String -> Flow s a -> Flow s a
withTrace String
"find id field" (Flow s (Maybe (ProjectionSpec a))
 -> Flow s (Maybe (ProjectionSpec a)))
-> Flow s (Maybe (ProjectionSpec a))
-> Flow s (Maybe (ProjectionSpec a))
forall a b. (a -> b) -> a -> b
$ do
      Maybe FieldType
mid <- Name -> String -> [FieldType] -> Flow s (Maybe FieldType)
forall {s}.
Name -> String -> [FieldType] -> Flow s (Maybe FieldType)
findField Name
tname String
idKey [FieldType]
fields
      case Maybe FieldType
mid of
        Maybe FieldType
Nothing -> if Bool
required
          then String -> Flow s (Maybe (ProjectionSpec a))
forall a. String -> Flow s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Flow s (Maybe (ProjectionSpec a)))
-> String -> Flow s (Maybe (ProjectionSpec a))
forall a b. (a -> b) -> a -> b
$ String
"no " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
idKey String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" field"
          else Maybe (ProjectionSpec a) -> Flow s (Maybe (ProjectionSpec a))
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ProjectionSpec a)
forall a. Maybe a
Nothing
        Just FieldType
mi -> do
          ValueSpec
spec <- case String -> Type -> Maybe Term
getTypeAnnotation String
idKey (FieldType -> Type
fieldTypeType FieldType
mi) of
            Maybe Term
Nothing -> ValueSpec -> Flow s ValueSpec
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValueSpec
ValueSpecValue
            Just Term
t -> Term -> Flow s ValueSpec
forall s. Term -> Flow s ValueSpec
decodeValueSpec Term
t
          Maybe (ProjectionSpec a) -> Flow s (Maybe (ProjectionSpec a))
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ProjectionSpec a) -> Flow s (Maybe (ProjectionSpec a)))
-> Maybe (ProjectionSpec a) -> Flow s (Maybe (ProjectionSpec a))
forall a b. (a -> b) -> a -> b
$ ProjectionSpec a -> Maybe (ProjectionSpec a)
forall a. a -> Maybe a
Just (ProjectionSpec a -> Maybe (ProjectionSpec a))
-> ProjectionSpec a -> Maybe (ProjectionSpec a)
forall a b. (a -> b) -> a -> b
$ FieldType -> ValueSpec -> Maybe String -> ProjectionSpec a
forall a.
FieldType -> ValueSpec -> Maybe String -> ProjectionSpec a
ProjectionSpec FieldType
mi ValueSpec
spec Maybe String
forall a. Maybe a
Nothing

    findProjectionSpec :: Name
-> String
-> String
-> [FieldType]
-> Flow s (Maybe (ProjectionSpec a))
findProjectionSpec Name
tname String
key String
aliasKey [FieldType]
fields = String
-> Flow s (Maybe (ProjectionSpec a))
-> Flow s (Maybe (ProjectionSpec a))
forall s a. String -> Flow s a -> Flow s a
withTrace (String
"find " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" projection") (Flow s (Maybe (ProjectionSpec a))
 -> Flow s (Maybe (ProjectionSpec a)))
-> Flow s (Maybe (ProjectionSpec a))
-> Flow s (Maybe (ProjectionSpec a))
forall a b. (a -> b) -> a -> b
$ do
      Maybe FieldType
mfield <- Name -> String -> [FieldType] -> Flow s (Maybe FieldType)
forall {s}.
Name -> String -> [FieldType] -> Flow s (Maybe FieldType)
findField Name
tname String
key [FieldType]
fields
      case Maybe FieldType
mfield of
        Maybe FieldType
Nothing -> Maybe (ProjectionSpec a) -> Flow s (Maybe (ProjectionSpec a))
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ProjectionSpec a)
forall a. Maybe a
Nothing
        Just FieldType
field -> do
          ValueSpec
spec <- Term -> Flow s ValueSpec
forall s. Term -> Flow s ValueSpec
decodeValueSpec (Term -> Flow s ValueSpec) -> Term -> Flow s ValueSpec
forall a b. (a -> b) -> a -> b
$ Maybe Term -> Term
forall a. HasCallStack => Maybe a -> a
Y.fromJust (Maybe Term -> Term) -> Maybe Term -> Term
forall a b. (a -> b) -> a -> b
$ String -> Type -> Maybe Term
getTypeAnnotation String
key (Type -> Maybe Term) -> Type -> Maybe Term
forall a b. (a -> b) -> a -> b
$ FieldType -> Type
fieldTypeType FieldType
field
          Maybe String
alias <- case String -> Type -> Maybe Term
getTypeAnnotation String
aliasKey (Type -> Maybe Term) -> Type -> Maybe Term
forall a b. (a -> b) -> a -> b
$ FieldType -> Type
fieldTypeType FieldType
field of
            Maybe Term
Nothing -> Maybe String -> Flow s (Maybe String)
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
            Just Term
t -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> Flow s String -> Flow s (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow s String
forall s. Term -> Flow s String
Expect.string Term
t
          Maybe (ProjectionSpec a) -> Flow s (Maybe (ProjectionSpec a))
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ProjectionSpec a) -> Flow s (Maybe (ProjectionSpec a)))
-> Maybe (ProjectionSpec a) -> Flow s (Maybe (ProjectionSpec a))
forall a b. (a -> b) -> a -> b
$ ProjectionSpec a -> Maybe (ProjectionSpec a)
forall a. a -> Maybe a
Just (ProjectionSpec a -> Maybe (ProjectionSpec a))
-> ProjectionSpec a -> Maybe (ProjectionSpec a)
forall a b. (a -> b) -> a -> b
$ FieldType -> ValueSpec -> Maybe String -> ProjectionSpec a
forall a.
FieldType -> ValueSpec -> Maybe String -> ProjectionSpec a
ProjectionSpec FieldType
field ValueSpec
spec Maybe String
alias

    findField :: Name -> String -> [FieldType] -> Flow s (Maybe FieldType)
findField Name
tname String
key [FieldType]
fields = String -> Flow s (Maybe FieldType) -> Flow s (Maybe FieldType)
forall s a. String -> Flow s a -> Flow s a
withTrace (String
"find " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" field") (Flow s (Maybe FieldType) -> Flow s (Maybe FieldType))
-> Flow s (Maybe FieldType) -> Flow s (Maybe FieldType)
forall a b. (a -> b) -> a -> b
$ do
      let matches :: [FieldType]
matches = (FieldType -> Bool) -> [FieldType] -> [FieldType]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (\FieldType
f -> Maybe Term -> Bool
forall a. Maybe a -> Bool
Y.isJust (Maybe Term -> Bool) -> Maybe Term -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Type -> Maybe Term
getTypeAnnotation String
key (Type -> Maybe Term) -> Type -> Maybe Term
forall a b. (a -> b) -> a -> b
$ FieldType -> Type
fieldTypeType FieldType
f) [FieldType]
fields
      if [FieldType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [FieldType]
matches Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
        then String -> Flow s (Maybe FieldType)
forall a. String -> Flow s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Flow s (Maybe FieldType))
-> String -> Flow s (Maybe FieldType)
forall a b. (a -> b) -> a -> b
$ String
"Multiple fields marked as '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' in record type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
tname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
", " (Name -> String
unName (Name -> String) -> (FieldType -> Name) -> FieldType -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldType -> Name
fieldTypeName (FieldType -> String) -> [FieldType] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldType]
matches))
        else Maybe FieldType -> Flow s (Maybe FieldType)
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FieldType -> Flow s (Maybe FieldType))
-> Maybe FieldType -> Flow s (Maybe FieldType)
forall a b. (a -> b) -> a -> b
$ if [FieldType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [FieldType]
matches then Maybe FieldType
forall a. Maybe a
Nothing else FieldType -> Maybe FieldType
forall a. a -> Maybe a
Just (FieldType -> Maybe FieldType) -> FieldType -> Maybe FieldType
forall a b. (a -> b) -> a -> b
$ [FieldType] -> FieldType
forall a. HasCallStack => [a] -> a
L.head [FieldType]
matches

    findPropertySpecs :: ElementKind -> [FieldType] -> Flow s [ProjectionSpec a]
findPropertySpecs ElementKind
kind [FieldType]
fields = (FieldType -> Flow s (ProjectionSpec a))
-> [FieldType] -> Flow s [ProjectionSpec a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM FieldType -> Flow s (ProjectionSpec a)
forall {s} {a}. FieldType -> Flow s (ProjectionSpec a)
toSpec ([FieldType] -> Flow s [ProjectionSpec a])
-> [FieldType] -> Flow s [ProjectionSpec a]
forall a b. (a -> b) -> a -> b
$ (FieldType -> Bool) -> [FieldType] -> [FieldType]
forall a. (a -> Bool) -> [a] -> [a]
L.filter FieldType -> Bool
isPropField [FieldType]
fields
      where
        isPropField :: FieldType -> Bool
isPropField FieldType
field = Bool -> Bool
not (Bool
hasSpecialAnnotation Bool -> Bool -> Bool
|| Bool
hasSpecialFieldName)
          where
            hasSpecialAnnotation :: Bool
hasSpecialAnnotation = (Bool -> String -> Bool) -> Bool -> [String] -> Bool
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (\Bool
b String
k -> Bool
b Bool -> Bool -> Bool
|| String -> Bool
hasAnnotation String
k) Bool
False (String
ignoreKeyString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
specialKeys)
            hasSpecialFieldName :: Bool
hasSpecialFieldName = (Bool -> String -> Bool) -> Bool -> [String] -> Bool
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (\Bool
b String
n -> Bool
b Bool -> Bool -> Bool
|| String -> Bool
hasName String
n) Bool
False [String]
specialKeys
            specialKeys :: [String]
specialKeys = case ElementKind
kind of
              ElementKind
PG.ElementKindVertex -> [String
vertexIdKey, String
outEdgeLabelKey, String
inEdgeLabelKey]
              ElementKind
PG.ElementKindEdge -> [String
edgeIdKey, String
outVertexKey, String
inVertexKey]
            hasAnnotation :: String -> Bool
hasAnnotation String
key = Maybe Term -> Bool
forall a. Maybe a -> Bool
Y.isJust (Maybe Term -> Bool) -> Maybe Term -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Type -> Maybe Term
getTypeAnnotation String
key (Type -> Maybe Term) -> Type -> Maybe Term
forall a b. (a -> b) -> a -> b
$ FieldType -> Type
fieldTypeType FieldType
field
            hasName :: String -> Bool
hasName String
fname = FieldType -> Name
fieldTypeName FieldType
field Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
Name String
fname
        toSpec :: FieldType -> Flow s (ProjectionSpec a)
toSpec FieldType
field = do
          Maybe String
alias <- case (String -> Type -> Maybe Term
getTypeAnnotation String
propertyKeyKey (Type -> Maybe Term) -> Type -> Maybe Term
forall a b. (a -> b) -> a -> b
$ FieldType -> Type
fieldTypeType FieldType
field) of
            Maybe Term
Nothing -> Maybe String -> Flow s (Maybe String)
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
            Just Term
a -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> Flow s String -> Flow s (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow s String
forall s. Term -> Flow s String
Expect.string Term
a
          ValueSpec
values <- case (String -> Type -> Maybe Term
getTypeAnnotation String
propertyValueKey (Type -> Maybe Term) -> Type -> Maybe Term
forall a b. (a -> b) -> a -> b
$ FieldType -> Type
fieldTypeType FieldType
field) of
            Maybe Term
Nothing -> ValueSpec -> Flow s ValueSpec
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValueSpec
ValueSpecValue
            Just Term
sp -> Term -> Flow s ValueSpec
forall s. Term -> Flow s ValueSpec
decodeValueSpec Term
sp
          ProjectionSpec a -> Flow s (ProjectionSpec a)
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectionSpec a -> Flow s (ProjectionSpec a))
-> ProjectionSpec a -> Flow s (ProjectionSpec a)
forall a b. (a -> b) -> a -> b
$ FieldType -> ValueSpec -> Maybe String -> ProjectionSpec a
forall a.
FieldType -> ValueSpec -> Maybe String -> ProjectionSpec a
ProjectionSpec FieldType
field ValueSpec
values Maybe String
alias

    edgeAdapters :: VertexLabel
-> Direction -> [FieldType] -> Flow s [AdjacentEdgeAdapter s a t v]
edgeAdapters VertexLabel
vlabel Direction
dir [FieldType]
fields = [Maybe (AdjacentEdgeAdapter s a t v)]
-> [AdjacentEdgeAdapter s a t v]
forall a. [Maybe a] -> [a]
Y.catMaybes ([Maybe (AdjacentEdgeAdapter s a t v)]
 -> [AdjacentEdgeAdapter s a t v])
-> Flow s [Maybe (AdjacentEdgeAdapter s a t v)]
-> Flow s [AdjacentEdgeAdapter s a t v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldType -> Flow s (Maybe (AdjacentEdgeAdapter s a t v)))
-> [FieldType] -> Flow s [Maybe (AdjacentEdgeAdapter s a t v)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM FieldType -> Flow s (Maybe (AdjacentEdgeAdapter s a t v))
forall {a}.
FieldType -> Flow s (Maybe (AdjacentEdgeAdapter s a t v))
toSpec [FieldType]
fields
      where
        toSpec :: FieldType -> Flow s (Maybe (AdjacentEdgeAdapter s a t v))
toSpec FieldType
field = case String -> Type -> Maybe Term
getTypeAnnotation String
key (FieldType -> Type
fieldTypeType FieldType
field) of
          Maybe Term
Nothing -> Maybe (AdjacentEdgeAdapter s a t v)
-> Flow s (Maybe (AdjacentEdgeAdapter s a t v))
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (AdjacentEdgeAdapter s a t v)
forall a. Maybe a
Nothing
          Just Term
a -> do
            EdgeLabel
label <- String -> EdgeLabel
PG.EdgeLabel (String -> EdgeLabel) -> Flow s String -> Flow s EdgeLabel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow s String
forall s. Term -> Flow s String
Expect.string Term
a
            ElementAdapter s t v
elad <- Maybe (Direction, VertexLabel)
-> Schema s t v -> Type -> t -> t -> Flow s (ElementAdapter s t v)
forall t v s.
(Show t, Show v) =>
Maybe (Direction, VertexLabel)
-> Schema s t v -> Type -> t -> t -> Flow s (ElementAdapter s t v)
elementCoder ((Direction, VertexLabel) -> Maybe (Direction, VertexLabel)
forall a. a -> Maybe a
Just (Direction
dir, VertexLabel
vlabel)) Schema s t v
schema (FieldType -> Type
fieldTypeType FieldType
field) t
vidType t
eidType 
            Maybe (AdjacentEdgeAdapter s a t v)
-> Flow s (Maybe (AdjacentEdgeAdapter s a t v))
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (AdjacentEdgeAdapter s a t v)
 -> Flow s (Maybe (AdjacentEdgeAdapter s a t v)))
-> Maybe (AdjacentEdgeAdapter s a t v)
-> Flow s (Maybe (AdjacentEdgeAdapter s a t v))
forall a b. (a -> b) -> a -> b
$ AdjacentEdgeAdapter s a t v -> Maybe (AdjacentEdgeAdapter s a t v)
forall a. a -> Maybe a
Just (AdjacentEdgeAdapter s a t v
 -> Maybe (AdjacentEdgeAdapter s a t v))
-> AdjacentEdgeAdapter s a t v
-> Maybe (AdjacentEdgeAdapter s a t v)
forall a b. (a -> b) -> a -> b
$ Direction
-> FieldType
-> EdgeLabel
-> ElementAdapter s t v
-> AdjacentEdgeAdapter s a t v
forall s a t v.
Direction
-> FieldType
-> EdgeLabel
-> ElementAdapter s t v
-> AdjacentEdgeAdapter s a t v
AdjacentEdgeAdapter Direction
dir FieldType
field EdgeLabel
label ElementAdapter s t v
elad
        key :: String
key = case Direction
dir of
          Direction
PG.DirectionOut -> String
outEdgeLabelKey
          Direction
PG.DirectionIn -> String
inEdgeLabelKey

elementTreeEdge :: PG.Edge v -> [PG.ElementTree v] -> PG.ElementTree v
elementTreeEdge :: forall v. Edge v -> [ElementTree v] -> ElementTree v
elementTreeEdge Edge v
edge = Element v -> [ElementTree v] -> ElementTree v
forall v. Element v -> [ElementTree v] -> ElementTree v
PG.ElementTree (Edge v -> Element v
forall v. Edge v -> Element v
PG.ElementEdge Edge v
edge)

elementTreeVertex :: PG.Vertex v -> [PG.ElementTree v] -> PG.ElementTree v
elementTreeVertex :: forall v. Vertex v -> [ElementTree v] -> ElementTree v
elementTreeVertex Vertex v
vertex = Element v -> [ElementTree v] -> ElementTree v
forall v. Element v -> [ElementTree v] -> ElementTree v
PG.ElementTree (Vertex v -> Element v
forall v. Vertex v -> Element v
PG.ElementVertex Vertex v
vertex)

elementTypeTreeEdge :: PG.EdgeType t -> [PG.ElementTypeTree t] -> PG.ElementTypeTree t
elementTypeTreeEdge :: forall t. EdgeType t -> [ElementTypeTree t] -> ElementTypeTree t
elementTypeTreeEdge EdgeType t
etype = ElementType t -> [ElementTypeTree t] -> ElementTypeTree t
forall t. ElementType t -> [ElementTypeTree t] -> ElementTypeTree t
PG.ElementTypeTree (EdgeType t -> ElementType t
forall t. EdgeType t -> ElementType t
PG.ElementTypeEdge EdgeType t
etype)

elementTypeTreeVertex :: PG.VertexType t -> [PG.ElementTypeTree t] -> PG.ElementTypeTree t
elementTypeTreeVertex :: forall t. VertexType t -> [ElementTypeTree t] -> ElementTypeTree t
elementTypeTreeVertex VertexType t
vtype = ElementType t -> [ElementTypeTree t] -> ElementTypeTree t
forall t. ElementType t -> [ElementTypeTree t] -> ElementTypeTree t
PG.ElementTypeTree (VertexType t -> ElementType t
forall t. VertexType t -> ElementType t
PG.ElementTypeVertex VertexType t
vtype)

encodeProperties :: M.Map Name (Term) -> [PropertyAdapter s t v] -> Flow s (M.Map PG.PropertyKey v)
encodeProperties :: forall s t v.
Map Name Term
-> [PropertyAdapter s t v] -> Flow s (Map PropertyKey v)
encodeProperties Map Name Term
fields [PropertyAdapter s t v]
adapters = do
  [Property v]
props <- [Maybe (Property v)] -> [Property v]
forall a. [Maybe a] -> [a]
Y.catMaybes ([Maybe (Property v)] -> [Property v])
-> Flow s [Maybe (Property v)] -> Flow s [Property v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PropertyAdapter s t v -> Flow s (Maybe (Property v)))
-> [PropertyAdapter s t v] -> Flow s [Maybe (Property v)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM (Map Name Term
-> PropertyAdapter s t v -> Flow s (Maybe (Property v))
forall s t v.
Map Name Term
-> PropertyAdapter s t v -> Flow s (Maybe (Property v))
encodeProperty Map Name Term
fields) [PropertyAdapter s t v]
adapters
  Map PropertyKey v -> Flow s (Map PropertyKey v)
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map PropertyKey v -> Flow s (Map PropertyKey v))
-> Map PropertyKey v -> Flow s (Map PropertyKey v)
forall a b. (a -> b) -> a -> b
$ [(PropertyKey, v)] -> Map PropertyKey v
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(PropertyKey, v)] -> Map PropertyKey v)
-> [(PropertyKey, v)] -> Map PropertyKey v
forall a b. (a -> b) -> a -> b
$ (Property v -> (PropertyKey, v))
-> [Property v] -> [(PropertyKey, v)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(PG.Property PropertyKey
key v
val) -> (PropertyKey
key, v
val)) [Property v]
props

encodeProperty :: M.Map Name (Term) -> PropertyAdapter s t v -> Flow s (Maybe (PG.Property v))
encodeProperty :: forall s t v.
Map Name Term
-> PropertyAdapter s t v -> Flow s (Maybe (Property v))
encodeProperty Map Name Term
fields PropertyAdapter s t v
adapter = do
  case Name -> Map Name Term -> Maybe Term
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
fname Map Name Term
fields of
    Maybe Term
Nothing -> case Type
ftyp of
      TypeOptional Type
_ -> Maybe (Property v) -> Flow s (Maybe (Property v))
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Property v)
forall a. Maybe a
Nothing
      Type
_ -> String -> Flow s (Maybe (Property v))
forall a. String -> Flow s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Flow s (Maybe (Property v)))
-> String -> Flow s (Maybe (Property v))
forall a b. (a -> b) -> a -> b
$ String
"expected field not found in record: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
fname
    Just Term
value -> case Type
ftyp of
      TypeOptional Type
_ -> case Term -> Term
stripTerm Term
value of
        TermOptional Maybe Term
ov -> case Maybe Term
ov of
          Maybe Term
Nothing -> Maybe (Property v) -> Flow s (Maybe (Property v))
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Property v)
forall a. Maybe a
Nothing
          Just Term
v -> Property v -> Maybe (Property v)
forall a. a -> Maybe a
Just (Property v -> Maybe (Property v))
-> Flow s (Property v) -> Flow s (Maybe (Property v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow s (Property v)
encodeValue Term
v
        Term
_ -> String -> String -> Flow s (Maybe (Property v))
forall s x. String -> String -> Flow s x
unexpected String
"optional term" (String -> Flow s (Maybe (Property v)))
-> String -> Flow s (Maybe (Property v))
forall a b. (a -> b) -> a -> b
$ Term -> String
forall a. Show a => a -> String
show Term
value
      Type
_ -> Property v -> Maybe (Property v)
forall a. a -> Maybe a
Just (Property v -> Maybe (Property v))
-> Flow s (Property v) -> Flow s (Maybe (Property v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow s (Property v)
encodeValue Term
value
  where
    fname :: Name
fname = FieldType -> Name
fieldTypeName (FieldType -> Name) -> FieldType -> Name
forall a b. (a -> b) -> a -> b
$ PropertyAdapter s t v -> FieldType
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t1
adapterSource PropertyAdapter s t v
adapter
    ftyp :: Type
ftyp = Type -> Type
stripType (FieldType -> Type
fieldTypeType (FieldType -> Type) -> FieldType -> Type
forall a b. (a -> b) -> a -> b
$ PropertyAdapter s t v -> FieldType
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t1
adapterSource PropertyAdapter s t v
adapter)
    encodeValue :: Term -> Flow s (Property v)
encodeValue Term
v = Coder s s Field (Property v) -> Field -> Flow s (Property v)
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode (PropertyAdapter s t v -> Coder s s Field (Property v)
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder PropertyAdapter s t v
adapter) (Name -> Term -> Field
Field Name
fname Term
v)

-- TODO; infer lossiness
lossy :: Bool
lossy = Bool
True

noDecoding :: String -> Flow s x
noDecoding :: forall s x. String -> Flow s x
noDecoding String
cat = String -> Flow s x
forall a. String -> Flow s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Flow s x) -> String -> Flow s x
forall a b. (a -> b) -> a -> b
$ String
cat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" decoding is not yet supported"

projectionAdapter :: t
  -> Coder s s (Term) v
  -> ProjectionSpec a
  -> String
  -> Flow s (IdAdapter s t v)
projectionAdapter :: forall t s v a.
t
-> Coder s s Term v
-> ProjectionSpec a
-> String
-> Flow s (IdAdapter s t v)
projectionAdapter t
idtype Coder s s Term v
coder ProjectionSpec a
spec String
key = do
    Term -> Flow s [Term]
traversal <- ValueSpec -> Flow s (Term -> Flow s [Term])
forall s. ValueSpec -> Flow s (Term -> Flow s [Term])
parseValueSpec (ValueSpec -> Flow s (Term -> Flow s [Term]))
-> ValueSpec -> Flow s (Term -> Flow s [Term])
forall a b. (a -> b) -> a -> b
$ ProjectionSpec a -> ValueSpec
forall a. ProjectionSpec a -> ValueSpec
projectionSpecValues ProjectionSpec a
spec
    let field :: FieldType
field = ProjectionSpec a -> FieldType
forall a. ProjectionSpec a -> FieldType
projectionSpecField ProjectionSpec a
spec
    let encode :: Term -> Flow s v
encode = \Term
typ -> String -> (Term -> Flow s [Term]) -> Term -> Flow s Term
forall s. String -> (Term -> Flow s [Term]) -> Term -> Flow s Term
traverseToSingleTerm (String
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-projection") Term -> Flow s [Term]
traversal Term
typ Flow s Term -> (Term -> Flow s v) -> Flow s v
forall a b. Flow s a -> (a -> Flow s b) -> Flow s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Coder s s Term v -> Term -> Flow s v
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder s s Term v
coder
    IdAdapter s t v -> Flow s (IdAdapter s t v)
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldType -> Name
fieldTypeName FieldType
field, Bool -> Type -> t -> Coder s s Term v -> Adapter s s Type t Term v
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter Bool
lossy (FieldType -> Type
fieldTypeType FieldType
field) t
idtype (Coder s s Term v -> Adapter s s Type t Term v)
-> Coder s s Term v -> Adapter s s Type t Term v
forall a b. (a -> b) -> a -> b
$ (Term -> Flow s v) -> (v -> Flow s Term) -> Coder s s Term v
forall s1 s2 v1 v2.
(v1 -> Flow s1 v2) -> (v2 -> Flow s2 v1) -> Coder s1 s2 v1 v2
Coder Term -> Flow s v
encode v -> Flow s Term
forall {p} {s} {x}. p -> Flow s x
decode)
  where
    decode :: p -> Flow s x
decode p
_ = String -> Flow s x
forall s x. String -> Flow s x
noDecoding (String -> Flow s x) -> String -> Flow s x
forall a b. (a -> b) -> a -> b
$ String
"edge '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"

propertyAdapter :: Schema s t v -> ProjectionSpec a -> Flow s (PropertyAdapter s t v)
propertyAdapter :: forall s t v a.
Schema s t v -> ProjectionSpec a -> Flow s (PropertyAdapter s t v)
propertyAdapter Schema s t v
schema (ProjectionSpec FieldType
tfield ValueSpec
values Maybe String
alias) = do
  let key :: PropertyKey
key = String -> PropertyKey
PG.PropertyKey (String -> PropertyKey) -> String -> PropertyKey
forall a b. (a -> b) -> a -> b
$ case Maybe String
alias of
        Maybe String
Nothing -> Name -> String
unName (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ FieldType -> Name
fieldTypeName FieldType
tfield
        Just String
k -> String
k
  t
pt <- Coder s s Type t -> Type -> Flow s t
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode (Schema s t v -> Coder s s Type t
forall s t v. Schema s t v -> Coder s s Type t
schemaPropertyTypes Schema s t v
schema) (Type -> Flow s t) -> Type -> Flow s t
forall a b. (a -> b) -> a -> b
$ FieldType -> Type
fieldTypeType FieldType
tfield
  Term -> Flow s [Term]
traversal <- ValueSpec -> Flow s (Term -> Flow s [Term])
forall s. ValueSpec -> Flow s (Term -> Flow s [Term])
parseValueSpec ValueSpec
values
  let coder :: Coder s s2 Field (Property v)
coder = (Field -> Flow s (Property v))
-> (Property v -> Flow s2 Field) -> Coder s s2 Field (Property v)
forall s1 s2 v1 v2.
(v1 -> Flow s1 v2) -> (v2 -> Flow s2 v1) -> Coder s1 s2 v1 v2
Coder Field -> Flow s (Property v)
encode Property v -> Flow s2 Field
forall {p} {s} {x}. p -> Flow s x
decode
        where
          encode :: Field -> Flow s (Property v)
encode Field
dfield = String -> Flow s (Property v) -> Flow s (Property v)
forall s a. String -> Flow s a -> Flow s a
withTrace (String
"encode property field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (Name -> String
unName (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ FieldType -> Name
fieldTypeName FieldType
tfield)) (Flow s (Property v) -> Flow s (Property v))
-> Flow s (Property v) -> Flow s (Property v)
forall a b. (a -> b) -> a -> b
$ do
            if Field -> Name
fieldName Field
dfield Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= FieldType -> Name
fieldTypeName FieldType
tfield
              then String -> String -> Flow s (Property v)
forall s x. String -> String -> Flow s x
unexpected (String
"field '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
unName (FieldType -> Name
fieldTypeName FieldType
tfield) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'") (String -> Flow s (Property v)) -> String -> Flow s (Property v)
forall a b. (a -> b) -> a -> b
$ Field -> String
forall a. Show a => a -> String
show Field
dfield
              else do
                Term
result <- String -> (Term -> Flow s [Term]) -> Term -> Flow s Term
forall s. String -> (Term -> Flow s [Term]) -> Term -> Flow s Term
traverseToSingleTerm String
"property traversal" Term -> Flow s [Term]
traversal (Term -> Flow s Term) -> Term -> Flow s Term
forall a b. (a -> b) -> a -> b
$ Field -> Term
fieldTerm Field
dfield
                v
value <- Coder s s Term v -> Term -> Flow s v
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode (Schema s t v -> Coder s s Term v
forall s t v. Schema s t v -> Coder s s Term v
schemaPropertyValues Schema s t v
schema) Term
result
                Property v -> Flow s (Property v)
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property v -> Flow s (Property v))
-> Property v -> Flow s (Property v)
forall a b. (a -> b) -> a -> b
$ PropertyKey -> v -> Property v
forall v. PropertyKey -> v -> Property v
PG.Property PropertyKey
key v
value
          decode :: p -> Flow s x
decode p
_ = String -> Flow s x
forall s x. String -> Flow s x
noDecoding String
"property"
  PropertyAdapter s t v -> Flow s (PropertyAdapter s t v)
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (PropertyAdapter s t v -> Flow s (PropertyAdapter s t v))
-> PropertyAdapter s t v -> Flow s (PropertyAdapter s t v)
forall a b. (a -> b) -> a -> b
$ Bool
-> FieldType
-> PropertyType t
-> Coder s s Field (Property v)
-> PropertyAdapter s t v
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter Bool
lossy FieldType
tfield (PropertyKey -> t -> Bool -> PropertyType t
forall t. PropertyKey -> t -> Bool -> PropertyType t
PG.PropertyType PropertyKey
key t
pt Bool
True) Coder s s Field (Property v)
forall {s2}. Coder s s2 Field (Property v)
coder

propertyTypes :: f (Adapter s1 s2 t1 (PropertyType t) v1 v2) -> f (PropertyType t)
propertyTypes f (Adapter s1 s2 t1 (PropertyType t) v1 v2)
propAdapters = Adapter s1 s2 t1 (PropertyType t) v1 v2 -> PropertyType t
forall {s1} {s2} {t1} {t} {v1} {v2}.
Adapter s1 s2 t1 (PropertyType t) v1 v2 -> PropertyType t
toPropertyType (Adapter s1 s2 t1 (PropertyType t) v1 v2 -> PropertyType t)
-> f (Adapter s1 s2 t1 (PropertyType t) v1 v2)
-> f (PropertyType t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Adapter s1 s2 t1 (PropertyType t) v1 v2)
propAdapters
  where
    toPropertyType :: Adapter s1 s2 t1 (PropertyType t) v1 v2 -> PropertyType t
toPropertyType Adapter s1 s2 t1 (PropertyType t) v1 v2
a = PropertyKey -> t -> Bool -> PropertyType t
forall t. PropertyKey -> t -> Bool -> PropertyType t
PG.PropertyType (PropertyType t -> PropertyKey
forall t. PropertyType t -> PropertyKey
PG.propertyTypeKey (PropertyType t -> PropertyKey) -> PropertyType t -> PropertyKey
forall a b. (a -> b) -> a -> b
$ Adapter s1 s2 t1 (PropertyType t) v1 v2 -> PropertyType t
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget Adapter s1 s2 t1 (PropertyType t) v1 v2
a) (PropertyType t -> t
forall t. PropertyType t -> t
PG.propertyTypeValue (PropertyType t -> t) -> PropertyType t -> t
forall a b. (a -> b) -> a -> b
$ Adapter s1 s2 t1 (PropertyType t) v1 v2 -> PropertyType t
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget Adapter s1 s2 t1 (PropertyType t) v1 v2
a) Bool
True

selectEdgeId :: Map Name v1 -> (Name, Adapter s1 s2 t1 t2 v1 a) -> Flow s1 a
selectEdgeId Map Name v1
fields (Name
fname, Adapter s1 s2 t1 t2 v1 a
ad) = case Name -> Map Name v1 -> Maybe v1
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
fname Map Name v1
fields of
  Maybe v1
Nothing -> String -> Flow s1 a
forall a. String -> Flow s1 a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Flow s1 a) -> String -> Flow s1 a
forall a b. (a -> b) -> a -> b
$ String
"no " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
fname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in record"
  Just v1
t -> Coder s1 s2 v1 a -> v1 -> Flow s1 a
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode (Adapter s1 s2 t1 t2 v1 a -> Coder s1 s2 v1 a
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder Adapter s1 s2 t1 t2 v1 a
ad) v1
t

selectVertexId :: M.Map Name (Term) -> IdAdapter s t v -> Flow s v
selectVertexId :: forall s t v. Map Name Term -> IdAdapter s t v -> Flow s v
selectVertexId  Map Name Term
fields (Name
fname, Adapter s s Type t Term v
ad) = case Name -> Map Name Term -> Maybe Term
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
fname Map Name Term
fields of
  Maybe Term
Nothing -> String -> Flow s v
forall a. String -> Flow s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Flow s v) -> String -> Flow s v
forall a b. (a -> b) -> a -> b
$ String
"no " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
fname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in record"
  Just Term
t -> Coder s s Term v -> Term -> Flow s v
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode (Adapter s s Type t Term v -> Coder s s Term v
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder Adapter s s Type t Term v
ad) Term
t

traverseToSingleTerm :: String -> (Term -> Flow s [Term]) -> Term -> Flow s (Term)
traverseToSingleTerm :: forall s. String -> (Term -> Flow s [Term]) -> Term -> Flow s Term
traverseToSingleTerm String
desc Term -> Flow s [Term]
traversal Term
term = do
  [Term]
terms <- Term -> Flow s [Term]
traversal Term
term
  case [Term]
terms of
    [] -> String -> Flow s Term
forall a. String -> Flow s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Flow s Term) -> String -> Flow s Term
forall a b. (a -> b) -> a -> b
$ String
desc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" did not resolve to a term"
    [Term
t] -> Term -> Flow s Term
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
t
    [Term]
_ -> String -> Flow s Term
forall a. String -> Flow s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Flow s Term) -> String -> Flow s Term
forall a b. (a -> b) -> a -> b
$ String
desc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" resolved to multiple terms"

vertexCoder :: (Show t, Show v)
  => Schema s t v
  -> Type
  -> t
   -> Name
  -> PG.VertexLabel -> IdAdapter s t v -> [PropertyAdapter s t v]
  -> [AdjacentEdgeAdapter s a t v]
  -> ElementAdapter s t v
vertexCoder :: forall t v s a.
(Show t, Show v) =>
Schema s t v
-> Type
-> t
-> Name
-> VertexLabel
-> IdAdapter s t v
-> [PropertyAdapter s t v]
-> [AdjacentEdgeAdapter s a t v]
-> ElementAdapter s t v
vertexCoder Schema s t v
schema Type
source t
vidType Name
tname VertexLabel
label IdAdapter s t v
idAdapter [PropertyAdapter s t v]
propAdapters [AdjacentEdgeAdapter s a t v]
edgeAdapters = Bool
-> Type
-> ElementTypeTree t
-> Coder s s Term (ElementTree v)
-> Adapter s s Type (ElementTypeTree t) Term (ElementTree v)
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter Bool
lossy Type
source ElementTypeTree t
target Coder s s Term (ElementTree v)
forall {s2}. Coder s s2 Term (ElementTree v)
coder
  where
    target :: ElementTypeTree t
target = VertexType t -> [ElementTypeTree t] -> ElementTypeTree t
forall t. VertexType t -> [ElementTypeTree t] -> ElementTypeTree t
elementTypeTreeVertex VertexType t
vtype [ElementTypeTree t]
depTypes
    vtype :: VertexType t
vtype = VertexLabel -> t -> [PropertyType t] -> VertexType t
forall t. VertexLabel -> t -> [PropertyType t] -> VertexType t
PG.VertexType VertexLabel
label t
vidType ([PropertyType t] -> VertexType t)
-> [PropertyType t] -> VertexType t
forall a b. (a -> b) -> a -> b
$ [PropertyAdapter s t v] -> [PropertyType t]
forall {f :: * -> *} {s1} {s2} {t1} {t} {v1} {v2}.
Functor f =>
f (Adapter s1 s2 t1 (PropertyType t) v1 v2) -> f (PropertyType t)
propertyTypes [PropertyAdapter s t v]
propAdapters
    depTypes :: [ElementTypeTree t]
depTypes = Adapter s s Type (ElementTypeTree t) Term (ElementTree v)
-> ElementTypeTree t
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget (Adapter s s Type (ElementTypeTree t) Term (ElementTree v)
 -> ElementTypeTree t)
-> (AdjacentEdgeAdapter s a t v
    -> Adapter s s Type (ElementTypeTree t) Term (ElementTree v))
-> AdjacentEdgeAdapter s a t v
-> ElementTypeTree t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacentEdgeAdapter s a t v
-> Adapter s s Type (ElementTypeTree t) Term (ElementTree v)
forall s a t v. AdjacentEdgeAdapter s a t v -> ElementAdapter s t v
adjacentEdgeAdapterAdapter (AdjacentEdgeAdapter s a t v -> ElementTypeTree t)
-> [AdjacentEdgeAdapter s a t v] -> [ElementTypeTree t]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AdjacentEdgeAdapter s a t v]
edgeAdapters
    coder :: Coder s s2 Term (ElementTree v)
coder = (Term -> Flow s (ElementTree v))
-> (ElementTree v -> Flow s2 Term)
-> Coder s s2 Term (ElementTree v)
forall s1 s2 v1 v2.
(v1 -> Flow s1 v2) -> (v2 -> Flow s2 v1) -> Coder s1 s2 v1 v2
Coder Term -> Flow s (ElementTree v)
encode ElementTree v -> Flow s2 Term
forall {p} {s} {x}. p -> Flow s x
decode
      where
        encode :: Term -> Flow s (ElementTree v)
encode Term
term = case Term -> Term
stripTerm Term
term of
            TermOptional (Just Term
ot) -> Term -> Flow s (ElementTree v)
encode Term
ot
            TermRecord (Record Name
tname' [Field]
fields) -> do
              Name -> Name -> Flow s ()
forall {s}. Name -> Name -> Flow s ()
checkRecordName Name
tname Name
tname'
              let fieldsm :: Map Name Term
fieldsm = [Field] -> Map Name Term
fieldMap [Field]
fields
              v
vid <- Map Name Term -> IdAdapter s t v -> Flow s v
forall s t v. Map Name Term -> IdAdapter s t v -> Flow s v
selectVertexId Map Name Term
fieldsm IdAdapter s t v
idAdapter
              Map PropertyKey v
props <- Map Name Term
-> [PropertyAdapter s t v] -> Flow s (Map PropertyKey v)
forall s t v.
Map Name Term
-> [PropertyAdapter s t v] -> Flow s (Map PropertyKey v)
encodeProperties ([Field] -> Map Name Term
fieldMap [Field]
fields) [PropertyAdapter s t v]
propAdapters
              [ElementTree v]
deps <- [Maybe (ElementTree v)] -> [ElementTree v]
forall a. [Maybe a] -> [a]
Y.catMaybes ([Maybe (ElementTree v)] -> [ElementTree v])
-> Flow s [Maybe (ElementTree v)] -> Flow s [ElementTree v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AdjacentEdgeAdapter s a t v -> Flow s (Maybe (ElementTree v)))
-> [AdjacentEdgeAdapter s a t v] -> Flow s [Maybe (ElementTree v)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM (v
-> Map Name Term
-> AdjacentEdgeAdapter s a t v
-> Flow s (Maybe (ElementTree v))
forall {v} {s2} {a} {t}.
Show v =>
v
-> Map Name Term
-> AdjacentEdgeAdapter s2 a t v
-> Flow s2 (Maybe (ElementTree v))
findDeps v
vid Map Name Term
fieldsm) [AdjacentEdgeAdapter s a t v]
edgeAdapters
              ElementTree v -> Flow s (ElementTree v)
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (ElementTree v -> Flow s (ElementTree v))
-> ElementTree v -> Flow s (ElementTree v)
forall a b. (a -> b) -> a -> b
$ Vertex v -> [ElementTree v] -> ElementTree v
forall v. Vertex v -> [ElementTree v] -> ElementTree v
elementTreeVertex (VertexLabel -> v -> Map PropertyKey v -> Vertex v
forall v. VertexLabel -> v -> Map PropertyKey v -> Vertex v
PG.Vertex VertexLabel
label v
vid Map PropertyKey v
props) [ElementTree v]
deps
            Term
_ -> String -> String -> Flow s (ElementTree v)
forall s x. String -> String -> Flow s x
unexpected String
"record (2)" (String -> Flow s (ElementTree v))
-> String -> Flow s (ElementTree v)
forall a b. (a -> b) -> a -> b
$ Term -> String
forall a. Show a => a -> String
show Term
term
          where
            findDeps :: v
-> Map Name Term
-> AdjacentEdgeAdapter s2 a t v
-> Flow s2 (Maybe (ElementTree v))
findDeps v
vid Map Name Term
fieldsm (AdjacentEdgeAdapter Direction
dir FieldType
field EdgeLabel
label ElementAdapter s2 t v
ad) = do
                case Name -> Map Name Term -> Maybe Term
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (FieldType -> Name
fieldTypeName FieldType
field) Map Name Term
fieldsm of
                  Maybe Term
Nothing -> Maybe (ElementTree v) -> Flow s2 (Maybe (ElementTree v))
forall a. a -> Flow s2 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ElementTree v)
forall a. Maybe a
Nothing
                  Just Term
fterm -> ElementTree v -> Maybe (ElementTree v)
forall a. a -> Maybe a
Just (ElementTree v -> Maybe (ElementTree v))
-> Flow s2 (ElementTree v) -> Flow s2 (Maybe (ElementTree v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Coder s2 s2 Term (ElementTree v) -> Term -> Flow s2 (ElementTree v)
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode (ElementAdapter s2 t v -> Coder s2 s2 Term (ElementTree v)
forall s1 s2 t1 t2 v1 v2.
Adapter s1 s2 t1 t2 v1 v2 -> Coder s1 s2 v1 v2
adapterCoder ElementAdapter s2 t v
ad) Term
fterm Flow s2 (ElementTree v)
-> (ElementTree v -> Flow s2 (ElementTree v))
-> Flow s2 (ElementTree v)
forall a b. Flow s2 a -> (a -> Flow s2 b) -> Flow s2 b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ElementTree v -> Flow s2 (ElementTree v)
forall {s}. ElementTree v -> Flow s (ElementTree v)
fixTree)
              where
                fixTree :: ElementTree v -> Flow s (ElementTree v)
fixTree ElementTree v
tree = case ElementTree v -> Element v
forall v. ElementTree v -> Element v
PG.elementTreeSelf ElementTree v
tree of
                  PG.ElementEdge Edge v
e -> ElementTree v -> Flow s (ElementTree v)
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ElementTree v -> Flow s (ElementTree v))
-> ElementTree v -> Flow s (ElementTree v)
forall a b. (a -> b) -> a -> b
$ ElementTree v
tree {PG.elementTreeSelf = PG.ElementEdge $ fixEdge e}
                  Element v
_ -> String -> String -> Flow s (ElementTree v)
forall s x. String -> String -> Flow s x
unexpected String
"edge tree" (String -> Flow s (ElementTree v))
-> String -> Flow s (ElementTree v)
forall a b. (a -> b) -> a -> b
$ ElementTree v -> String
forall a. Show a => a -> String
show ElementTree v
tree
                fixEdge :: Edge v -> Edge v
fixEdge Edge v
e = case Direction
dir of
                  Direction
PG.DirectionOut -> Edge v
e {PG.edgeOut = vid}
                  Direction
PG.DirectionIn -> Edge v
e {PG.edgeIn = vid}
        decode :: p -> Flow s x
decode p
el = String -> Flow s x
forall s x. String -> Flow s x
noDecoding String
"vertex"