module Hydra.Langs.Tinkerpop.TermsToElements (
  decodeValueSpec,
  parseValueSpec,
  termToElementsAdapter,
) where

import Hydra.Kernel
import Hydra.Langs.Tinkerpop.Mappings
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.List.Split as LS
import qualified Data.Map as M
import qualified Data.Maybe as Y


type PgAdapter s v = Adapter s s Type [PG.Label] Term [PG.Element v]

termToElementsAdapter :: Schema s t v -> Type -> Flow s (PgAdapter s v)
termToElementsAdapter :: forall s t v. Schema s t v -> Type -> Flow s (PgAdapter s v)
termToElementsAdapter Schema s t v
schema Type
typ = do
    case String -> Type -> Maybe Term
getTypeAnnotation String
"elements" Type
typ of
      Maybe Term
Nothing -> PgAdapter s v -> Flow s (PgAdapter s v)
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PgAdapter s v
forall {s1} {s2} {a} {v1} {a}. Adapter s1 s2 Type [a] v1 [a]
trivialAdapter
      Just Term
term -> do
        [(Label, Term -> Flow s [Element v])]
specs <- (Term -> Flow s ElementSpec) -> Term -> Flow s [ElementSpec]
forall s x. (Term -> Flow s x) -> Term -> Flow s [x]
Expect.list Term -> Flow s ElementSpec
forall s. Term -> Flow s ElementSpec
decodeElementSpec Term
term Flow s [ElementSpec]
-> ([ElementSpec] -> Flow s [(Label, Term -> Flow s [Element v])])
-> Flow s [(Label, Term -> Flow s [Element 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
>>= (ElementSpec -> Flow s (Label, Term -> Flow s [Element v]))
-> [ElementSpec] -> Flow s [(Label, Term -> Flow s [Element 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
-> ElementSpec -> Flow s (Label, Term -> Flow s [Element v])
forall s t v.
Schema s t v
-> ElementSpec -> Flow s (Label, Term -> Flow s [Element v])
parseElementSpec Schema s t v
schema)
        let labels :: [Label]
labels = [Label] -> [Label]
forall a. Eq a => [a] -> [a]
L.nub ((Label, Term -> Flow s [Element v]) -> Label
forall a b. (a, b) -> a
fst ((Label, Term -> Flow s [Element v]) -> Label)
-> [(Label, Term -> Flow s [Element v])] -> [Label]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Label, Term -> Flow s [Element v])]
specs)
        let encoders :: [Term -> Flow s [Element v]]
encoders = (Label, Term -> Flow s [Element v]) -> Term -> Flow s [Element v]
forall a b. (a, b) -> b
snd ((Label, Term -> Flow s [Element v]) -> Term -> Flow s [Element v])
-> [(Label, Term -> Flow s [Element v])]
-> [Term -> Flow s [Element v]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Label, Term -> Flow s [Element v])]
specs
        let encode :: Term -> Flow s [Element v]
encode Term
term = [[Element v]] -> [Element v]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat ([[Element v]] -> [Element v])
-> Flow s [[Element v]] -> Flow s [Element v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Term -> Flow s [Element v]) -> Flow s [Element v])
-> [Term -> Flow s [Element v]] -> Flow s [[Element 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 (\Term -> Flow s [Element v]
e -> Term -> Flow s [Element v]
e Term
term) [Term -> Flow s [Element v]]
encoders
        PgAdapter s v -> Flow s (PgAdapter s v)
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (PgAdapter s v -> Flow s (PgAdapter s v))
-> PgAdapter s v -> Flow s (PgAdapter s v)
forall a b. (a -> b) -> a -> b
$ Bool
-> Type -> [Label] -> Coder s s Term [Element v] -> PgAdapter s 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
typ [Label]
labels (Coder s s Term [Element v] -> PgAdapter s v)
-> Coder s s Term [Element v] -> PgAdapter s v
forall a b. (a -> b) -> a -> b
$ (Term -> Flow s [Element v])
-> ([Element v] -> Flow s Term) -> Coder s s Term [Element v]
forall s1 s2 v1 v2.
(v1 -> Flow s1 v2) -> (v2 -> Flow s2 v1) -> Coder s1 s2 v1 v2
Coder Term -> Flow s [Element v]
encode (\[Element v]
els -> String -> Flow s Term
forall s x. String -> Flow s x
noDecoding String
"element")
  where
    trivialAdapter :: Adapter s1 s2 Type [a] v1 [a]
trivialAdapter = Bool
-> Type
-> [a]
-> Coder s1 s2 v1 [a]
-> Adapter s1 s2 Type [a] v1 [a]
forall s1 s2 t1 t2 v1 v2.
Bool -> t1 -> t2 -> Coder s1 s2 v1 v2 -> Adapter s1 s2 t1 t2 v1 v2
Adapter Bool
False Type
typ [] (Coder s1 s2 v1 [a] -> Adapter s1 s2 Type [a] v1 [a])
-> Coder s1 s2 v1 [a] -> Adapter s1 s2 Type [a] v1 [a]
forall a b. (a -> b) -> a -> b
$ (v1 -> Flow s1 [a]) -> ([a] -> Flow s2 v1) -> Coder s1 s2 v1 [a]
forall s1 s2 v1 v2.
(v1 -> Flow s1 v2) -> (v2 -> Flow s2 v1) -> Coder s1 s2 v1 v2
Coder (\v1
term -> [a] -> Flow s1 [a]
forall a. a -> Flow s1 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (\[a]
el -> String -> Flow s2 v1
forall a. String -> Flow s2 a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no corresponding element type")

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

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"

parseEdgeIdPattern :: Schema s t v -> ValueSpec -> Flow s (Term -> Flow s [v])
parseEdgeIdPattern :: forall s t v.
Schema s t v -> ValueSpec -> Flow s (Term -> Flow s [v])
parseEdgeIdPattern Schema s t v
schema ValueSpec
spec = do
  Term -> Flow s [Term]
fun <- ValueSpec -> Flow s (Term -> Flow s [Term])
forall s. ValueSpec -> Flow s (Term -> Flow s [Term])
parseValueSpec ValueSpec
spec
  (Term -> Flow s [v]) -> Flow s (Term -> Flow s [v])
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Term -> Flow s [v]) -> Flow s (Term -> Flow s [v]))
-> (Term -> Flow s [v]) -> Flow s (Term -> Flow s [v])
forall a b. (a -> b) -> a -> b
$ \Term
term -> Term -> Flow s [Term]
fun Term
term 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
>>= (Term -> Flow s v) -> [Term] -> Flow s [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 (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 -> Term -> Flow s v)
-> Coder s s Term v -> Term -> Flow s v
forall a b. (a -> b) -> a -> b
$ 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)

parseEdgeSpec :: Schema s t v -> EdgeSpec -> Flow s (PG.Label, Term -> Flow s [PG.Element v])
parseEdgeSpec :: forall s t v.
Schema s t v
-> EdgeSpec -> Flow s (Label, Term -> Flow s [Element v])
parseEdgeSpec Schema s t v
schema (EdgeSpec EdgeLabel
label ValueSpec
id ValueSpec
outV ValueSpec
inV [PropertySpec]
props) = do
  Term -> Flow s [v]
getId <- Schema s t v -> ValueSpec -> Flow s (Term -> Flow s [v])
forall s t v.
Schema s t v -> ValueSpec -> Flow s (Term -> Flow s [v])
parseEdgeIdPattern Schema s t v
schema ValueSpec
id
  Term -> Flow s [v]
getOut <- Schema s t v -> ValueSpec -> Flow s (Term -> Flow s [v])
forall s t v.
Schema s t v -> ValueSpec -> Flow s (Term -> Flow s [v])
parseVertexIdPattern Schema s t v
schema ValueSpec
outV
  Term -> Flow s [v]
getIn <- Schema s t v -> ValueSpec -> Flow s (Term -> Flow s [v])
forall s t v.
Schema s t v -> ValueSpec -> Flow s (Term -> Flow s [v])
parseVertexIdPattern Schema s t v
schema ValueSpec
inV
  [Term -> Flow s [(PropertyKey, v)]]
getProps <- (PropertySpec -> Flow s (Term -> Flow s [(PropertyKey, v)]))
-> [PropertySpec] -> Flow s [Term -> Flow s [(PropertyKey, 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
-> PropertySpec -> Flow s (Term -> Flow s [(PropertyKey, v)])
forall s t v.
Schema s t v
-> PropertySpec -> Flow s (Term -> Flow s [(PropertyKey, v)])
parsePropertySpec Schema s t v
schema) [PropertySpec]
props
  let encode :: Term -> Flow s [Element v]
encode Term
term = String -> Flow s [Element v] -> Flow s [Element v]
forall s a. String -> Flow s a -> Flow s a
withTrace String
"encode as edge" (Flow s [Element v] -> Flow s [Element v])
-> Flow s [Element v] -> Flow s [Element v]
forall a b. (a -> b) -> a -> b
$ do
        v
tid <- String -> (Term -> Flow s [v]) -> Term -> Flow s v
forall s x. String -> (Term -> Flow s [x]) -> Term -> Flow s x
requireUnique String
"edge id" Term -> Flow s [v]
getId Term
term
        v
tout <- String -> (Term -> Flow s [v]) -> Term -> Flow s v
forall s x. String -> (Term -> Flow s [x]) -> Term -> Flow s x
requireUnique String
"vertex id" Term -> Flow s [v]
getOut Term
term
        v
tin <- String -> (Term -> Flow s [v]) -> Term -> Flow s v
forall s x. String -> (Term -> Flow s [x]) -> Term -> Flow s x
requireUnique String
"edge id" Term -> Flow s [v]
getIn Term
term
        Map PropertyKey v
tprops <- [(PropertyKey, v)] -> Map PropertyKey v
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(PropertyKey, v)] -> Map PropertyKey v)
-> Flow s [(PropertyKey, v)] -> Flow s (Map PropertyKey v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Term -> Flow s [(PropertyKey, v)]) -> Flow s (PropertyKey, v))
-> [Term -> Flow s [(PropertyKey, v)]] -> Flow s [(PropertyKey, 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 (\Term -> Flow s [(PropertyKey, v)]
g -> String
-> (Term -> Flow s [(PropertyKey, v)])
-> Term
-> Flow s (PropertyKey, v)
forall s x. String -> (Term -> Flow s [x]) -> Term -> Flow s x
requireUnique String
"property key" Term -> Flow s [(PropertyKey, v)]
g Term
term) [Term -> Flow s [(PropertyKey, v)]]
getProps
        [Element v] -> Flow s [Element v]
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return [Edge v -> Element v
forall v. Edge v -> Element v
PG.ElementEdge (Edge v -> Element v) -> Edge v -> Element v
forall a b. (a -> b) -> a -> b
$ 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
tid v
tout v
tin Map PropertyKey v
tprops]
  (Label, Term -> Flow s [Element v])
-> Flow s (Label, Term -> Flow s [Element v])
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (EdgeLabel -> Label
PG.LabelEdge EdgeLabel
label, Term -> Flow s [Element v]
encode)

parseElementSpec :: Schema s t v -> ElementSpec -> Flow s (PG.Label, Term -> Flow s [PG.Element v])
parseElementSpec :: forall s t v.
Schema s t v
-> ElementSpec -> Flow s (Label, Term -> Flow s [Element v])
parseElementSpec Schema s t v
schema ElementSpec
spec = case ElementSpec
spec of
  ElementSpecVertex VertexSpec
vspec -> Schema s t v
-> VertexSpec -> Flow s (Label, Term -> Flow s [Element v])
forall s t v.
Schema s t v
-> VertexSpec -> Flow s (Label, Term -> Flow s [Element v])
parseVertexSpec Schema s t v
schema VertexSpec
vspec
  ElementSpecEdge EdgeSpec
espec -> Schema s t v
-> EdgeSpec -> Flow s (Label, Term -> Flow s [Element v])
forall s t v.
Schema s t v
-> EdgeSpec -> Flow s (Label, Term -> Flow s [Element v])
parseEdgeSpec Schema s t v
schema EdgeSpec
espec

parsePattern :: String -> Flow s (Term -> Flow s [Term])
parsePattern :: forall s. String -> Flow s (Term -> Flow s [Term])
parsePattern String
pat = String
-> Flow s (Term -> Flow s [Term]) -> Flow s (Term -> Flow s [Term])
forall s a. String -> Flow s a -> Flow s a
withTrace String
"parse path pattern" (Flow s (Term -> Flow s [Term]) -> Flow s (Term -> Flow s [Term]))
-> Flow s (Term -> Flow s [Term]) -> Flow s (Term -> Flow s [Term])
forall a b. (a -> b) -> a -> b
$ do
    ([String]
lits, [[String]]
paths) <- [String]
-> [[String]] -> String -> String -> Flow s ([String], [[String]])
forall {f :: * -> *}.
MonadFail f =>
[String]
-> [[String]] -> String -> String -> f ([String], [[String]])
parsePattern [] [] String
"" String
pat
    (Term -> Flow s [Term]) -> Flow s (Term -> Flow s [Term])
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Term -> Flow s [Term]) -> Flow s (Term -> Flow s [Term]))
-> (Term -> Flow s [Term]) -> Flow s (Term -> Flow s [Term])
forall a b. (a -> b) -> a -> b
$ [String] -> [[String]] -> Term -> Flow s [Term]
forall {s}. [String] -> [[String]] -> Term -> Flow s [Term]
traverse [String]
lits [[String]]
paths
  where
    parsePattern :: [String]
-> [[String]] -> String -> String -> f ([String], [[String]])
parsePattern [String]
lits [[String]]
paths String
cur String
s = case String
s of
      [] -> ([String], [[String]]) -> f ([String], [[String]])
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> [String]
forall a. [a] -> [a]
L.reverse (String
nextLitString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
lits), [[String]] -> [[String]]
forall a. [a] -> [a]
L.reverse [[String]]
paths)
      (Char
'$':Char
'{':String
rest) -> [String]
-> [[String]] -> String -> String -> f ([String], [[String]])
parsePath (String
nextLitString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
lits) [[String]]
paths String
"" String
rest
      (Char
c:String
rest) -> [String]
-> [[String]] -> String -> String -> f ([String], [[String]])
parsePattern [String]
lits [[String]]
paths (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cur) String
rest
      where
        nextLit :: String
nextLit = String -> String
forall a. [a] -> [a]
L.reverse String
cur
        parsePath :: [String]
-> [[String]] -> String -> String -> f ([String], [[String]])
parsePath [String]
lits [[String]]
paths String
cur String
s = case String
s of
          [] -> String -> f ([String], [[String]])
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f ([String], [[String]]))
-> String -> f ([String], [[String]])
forall a b. (a -> b) -> a -> b
$ String
"Unfinished path expression: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pat
          (Char
'}':String
rest) -> [String]
-> [[String]] -> String -> String -> f ([String], [[String]])
parsePattern [String]
lits ([String]
path[String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
:[[String]]
paths) String
"" String
rest
            where
              path :: [String]
path = String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
LS.splitOn String
"/" (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
L.reverse String
cur
          (Char
c:String
rest) -> [String]
-> [[String]] -> String -> String -> f ([String], [[String]])
parsePath [String]
lits [[String]]
paths (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cur) String
rest
    traverse :: [String] -> [[String]] -> Term -> Flow s [Term]
traverse [String]
lits [[String]]
paths Term
term = String -> Flow s [Term] -> Flow s [Term]
forall s a. String -> Flow s a -> Flow s a
withTrace (String
"traverse pattern: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pat) (Flow s [Term] -> Flow s [Term]) -> Flow s [Term] -> Flow s [Term]
forall a b. (a -> b) -> a -> b
$ [String] -> Bool -> [String] -> [[String]] -> Flow s [Term]
forall {f :: * -> *}.
MonadFail f =>
[String] -> Bool -> [String] -> [[String]] -> f [Term]
recurse [String
""] Bool
True [String]
lits [[String]]
paths
      where
        recurse :: [String] -> Bool -> [String] -> [[String]] -> f [Term]
recurse [String]
values Bool
lp [String]
lits [[String]]
paths = if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [String]
values
            then [Term] -> f [Term]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            else if Bool
lp
            -- Try to apply a literal
            then case [String]
lits of
              -- All done. The last segment is always a literal.
              [] -> [Term] -> f [Term]
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Term] -> f [Term]) -> [Term] -> f [Term]
forall a b. (a -> b) -> a -> b
$ String -> Term
Terms.string (String -> Term) -> [String] -> [Term]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
values
              -- Append the literal and continue traversing.
              (String
l:[String]
rest) -> [String] -> Bool -> [String] -> [[String]] -> f [Term]
recurse (String -> [String]
append String
l) Bool
False [String]
rest [[String]]
paths
            -- Try to apply a path
            else case [[String]]
paths of
              -- No more paths; continue with literals
              [] -> [String] -> Bool -> [String] -> [[String]] -> f [Term]
recurse [String]
values Bool
True [String]
lits []
              -- Apply the next path
              ([String]
path:[[String]]
rest) -> do
                  [String]
strings <- [String] -> Term -> f [Term]
forall {f :: * -> *}. MonadFail f => [String] -> Term -> f [Term]
evalPath [String]
path Term
term f [Term] -> ([Term] -> f [String]) -> f [String]
forall a b. f a -> (a -> f b) -> f b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Term -> f String) -> [Term] -> f [String]
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 Term -> f String
forall {f :: * -> *}. Applicative f => Term -> f String
toString
                  [String] -> Bool -> [String] -> [[String]] -> f [Term]
recurse ([String] -> [String]
forall {t :: * -> *}.
(Foldable t, Functor t) =>
t String -> [String]
appendAll [String]
strings) Bool
True [String]
lits [[String]]
rest
          where
            append :: String -> [String]
append String
s = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\String
v -> String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s) [String]
values
            appendAll :: t String -> [String]
appendAll t String
strings = t [String] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat (String -> [String]
append (String -> [String]) -> t String -> t [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t String
strings)
    evalPath :: [String] -> Term -> f [Term]
evalPath [String]
path Term
term = case [String]
path of
        [] -> [Term] -> f [Term]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Term
term]
        (String
step:[String]
rest) -> do
          [Term]
results <- String -> Term -> f [Term]
forall {f :: * -> *}. MonadFail f => String -> Term -> f [Term]
evalStep String
step Term
term
          [[Term]] -> [Term]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat ([[Term]] -> [Term]) -> f [[Term]] -> f [Term]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Term -> f [Term]) -> [Term] -> f [[Term]]
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 ([String] -> Term -> f [Term]
evalPath [String]
rest) [Term]
results)
      where
        evalStep :: String -> Term -> f [Term]
evalStep String
step Term
term = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null String
step
          then [Term] -> f [Term]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Term
term]
          else case Term -> Term
stripTerm Term
term of
              TermList [Term]
terms -> [[Term]] -> [Term]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat ([[Term]] -> [Term]) -> f [[Term]] -> f [Term]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term -> f [Term]) -> [Term] -> f [[Term]]
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 (String -> Term -> f [Term]
evalStep String
step) [Term]
terms
              TermOptional Maybe Term
mt -> case Maybe Term
mt of
                Maybe Term
Nothing -> [Term] -> f [Term]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                Just Term
term' -> String -> Term -> f [Term]
evalStep String
step Term
term'
              TermRecord (Record Name
_ [Field]
fields) -> case Name -> Map Name Term -> Maybe Term
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (String -> Name
Name String
step) ([Field] -> Map Name Term
fieldMap [Field]
fields) of
                Maybe Term
Nothing -> String -> f [Term]
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f [Term]) -> String -> f [Term]
forall a b. (a -> b) -> a -> b
$ String
"No such field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
step String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in record: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall a. Show a => a -> String
show Term
term
                Just Term
term' -> [Term] -> f [Term]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Term
term']
              TermUnion (Injection Name
_ Field
field) -> if Name -> String
unName (Field -> Name
fieldName Field
field) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
step
                then String -> Term -> f [Term]
evalStep String
step (Term -> f [Term]) -> Term -> f [Term]
forall a b. (a -> b) -> a -> b
$ Field -> Term
fieldTerm Field
field
                else [Term] -> f [Term]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] -- Note: not checking the step against the union type; assuming it is correct but that it references a field unused by the injection
              TermWrap (WrappedTerm Name
_ Term
term') -> String -> Term -> f [Term]
evalStep String
step Term
term'
              Term
_ -> String -> f [Term]
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f [Term]) -> String -> f [Term]
forall a b. (a -> b) -> a -> b
$ String
"Can't traverse through term for step " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
step String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall a. Show a => a -> String
show Term
term

    -- TODO: replace this with a more standard function
    toString :: Term -> f String
toString Term
term = case Term -> Term
stripTerm Term
term of
      TermLiteral Literal
lit -> String -> f String
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> f String) -> String -> f String
forall a b. (a -> b) -> a -> b
$ case Literal
lit of
        LiteralBinary String
b -> String
b
        LiteralBoolean Bool
b -> Bool -> String
forall a. Show a => a -> String
show Bool
b
        LiteralInteger IntegerValue
i -> case IntegerValue
i of
          IntegerValueBigint Integer
v -> Integer -> String
forall a. Show a => a -> String
show Integer
v
          IntegerValueInt8 Int8
v -> Int8 -> String
forall a. Show a => a -> String
show Int8
v
          IntegerValueInt16 Int16
v -> Int16 -> String
forall a. Show a => a -> String
show Int16
v
          IntegerValueInt32 Int
v -> Int -> String
forall a. Show a => a -> String
show Int
v
          IntegerValueInt64 Int64
v -> Int64 -> String
forall a. Show a => a -> String
show Int64
v
          IntegerValueUint8 Int16
v -> Int16 -> String
forall a. Show a => a -> String
show Int16
v
          IntegerValueUint16 Int
v -> Int -> String
forall a. Show a => a -> String
show Int
v
          IntegerValueUint32 Int64
v -> Int64 -> String
forall a. Show a => a -> String
show Int64
v
          IntegerValueUint64 Integer
v -> Integer -> String
forall a. Show a => a -> String
show Integer
v
        LiteralFloat FloatValue
f -> case FloatValue
f of
          FloatValueBigfloat Double
v -> Double -> String
forall a. Show a => a -> String
show Double
v
          FloatValueFloat32 Float
v -> Float -> String
forall a. Show a => a -> String
show Float
v
          FloatValueFloat64 Double
v -> Double -> String
forall a. Show a => a -> String
show Double
v
        LiteralString String
s -> String
s
      TermOptional Maybe Term
mt -> case Maybe Term
mt of
        Maybe Term
Nothing -> String -> f String
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"nothing"
        Just Term
t -> Term -> f String
toString Term
t
      Term
_ -> String -> f String
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> f String) -> String -> f String
forall a b. (a -> b) -> a -> b
$ Term -> String
forall a. Show a => a -> String
show Term
term

parsePropertySpec :: Schema s t v -> PropertySpec -> Flow s (Term -> Flow s [(PG.PropertyKey, v)])
parsePropertySpec :: forall s t v.
Schema s t v
-> PropertySpec -> Flow s (Term -> Flow s [(PropertyKey, v)])
parsePropertySpec Schema s t v
schema (PropertySpec PropertyKey
key ValueSpec
value) = String
-> Flow s (Term -> Flow s [(PropertyKey, v)])
-> Flow s (Term -> Flow s [(PropertyKey, v)])
forall s a. String -> Flow s a -> Flow s a
withTrace String
"parse property spec" (Flow s (Term -> Flow s [(PropertyKey, v)])
 -> Flow s (Term -> Flow s [(PropertyKey, v)]))
-> Flow s (Term -> Flow s [(PropertyKey, v)])
-> Flow s (Term -> Flow s [(PropertyKey, v)])
forall a b. (a -> b) -> a -> b
$ do
  Term -> Flow s [Term]
fun <- ValueSpec -> Flow s (Term -> Flow s [Term])
forall s. ValueSpec -> Flow s (Term -> Flow s [Term])
parseValueSpec ValueSpec
value
  (Term -> Flow s [(PropertyKey, v)])
-> Flow s (Term -> Flow s [(PropertyKey, v)])
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Term -> Flow s [(PropertyKey, v)])
 -> Flow s (Term -> Flow s [(PropertyKey, v)]))
-> (Term -> Flow s [(PropertyKey, v)])
-> Flow s (Term -> Flow s [(PropertyKey, v)])
forall a b. (a -> b) -> a -> b
$ \Term
term -> String -> Flow s [(PropertyKey, v)] -> Flow s [(PropertyKey, v)]
forall s a. String -> Flow s a -> Flow s a
withTrace (String
"encode property " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PropertyKey -> String
PG.unPropertyKey PropertyKey
key) (Flow s [(PropertyKey, v)] -> Flow s [(PropertyKey, v)])
-> Flow s [(PropertyKey, v)] -> Flow s [(PropertyKey, v)]
forall a b. (a -> b) -> a -> b
$ do
    [Term]
results <- Term -> Flow s [Term]
fun Term
term
    [v]
values <- (Term -> Flow s v) -> [Term] -> Flow s [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 (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 -> Term -> Flow s v)
-> Coder s s Term v -> Term -> Flow s v
forall a b. (a -> b) -> a -> b
$ 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]
results
    [(PropertyKey, v)] -> Flow s [(PropertyKey, v)]
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(PropertyKey, v)] -> Flow s [(PropertyKey, v)])
-> [(PropertyKey, v)] -> Flow s [(PropertyKey, v)]
forall a b. (a -> b) -> a -> b
$ (v -> (PropertyKey, v)) -> [v] -> [(PropertyKey, v)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\v
v -> (PropertyKey
key, v
v)) [v]
values

parseValueSpec :: ValueSpec -> Flow s (Term -> Flow s [Term])
parseValueSpec :: forall s. ValueSpec -> Flow s (Term -> Flow s [Term])
parseValueSpec ValueSpec
spec = case ValueSpec
spec of
  ValueSpec
ValueSpecValue -> (Term -> Flow s [Term]) -> Flow s (Term -> Flow s [Term])
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Term -> Flow s [Term]) -> Flow s (Term -> Flow s [Term]))
-> (Term -> Flow s [Term]) -> Flow s (Term -> Flow s [Term])
forall a b. (a -> b) -> a -> b
$ \Term
term -> [Term] -> Flow s [Term]
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Term
term]
  ValueSpecPattern String
pat -> String -> Flow s (Term -> Flow s [Term])
forall s. String -> Flow s (Term -> Flow s [Term])
parsePattern String
pat

parseVertexIdPattern :: Schema s t v -> ValueSpec -> Flow s (Term -> Flow s [v])
parseVertexIdPattern :: forall s t v.
Schema s t v -> ValueSpec -> Flow s (Term -> Flow s [v])
parseVertexIdPattern Schema s t v
schema ValueSpec
spec = do
  Term -> Flow s [Term]
fun <- ValueSpec -> Flow s (Term -> Flow s [Term])
forall s. ValueSpec -> Flow s (Term -> Flow s [Term])
parseValueSpec ValueSpec
spec
  (Term -> Flow s [v]) -> Flow s (Term -> Flow s [v])
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Term -> Flow s [v]) -> Flow s (Term -> Flow s [v]))
-> (Term -> Flow s [v]) -> Flow s (Term -> Flow s [v])
forall a b. (a -> b) -> a -> b
$ \Term
term -> Term -> Flow s [Term]
fun Term
term 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
>>= (Term -> Flow s v) -> [Term] -> Flow s [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 (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 -> Term -> Flow s v)
-> Coder s s Term v -> Term -> Flow s v
forall a b. (a -> b) -> a -> b
$ 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)

parseVertexSpec :: Schema s t v -> VertexSpec -> Flow s (PG.Label, Term -> Flow s [PG.Element v])
parseVertexSpec :: forall s t v.
Schema s t v
-> VertexSpec -> Flow s (Label, Term -> Flow s [Element v])
parseVertexSpec Schema s t v
schema (VertexSpec VertexLabel
label ValueSpec
id [PropertySpec]
props) = do
  Term -> Flow s [v]
getId <- Schema s t v -> ValueSpec -> Flow s (Term -> Flow s [v])
forall s t v.
Schema s t v -> ValueSpec -> Flow s (Term -> Flow s [v])
parseVertexIdPattern Schema s t v
schema ValueSpec
id
  [Term -> Flow s [(PropertyKey, v)]]
getProps <- (PropertySpec -> Flow s (Term -> Flow s [(PropertyKey, v)]))
-> [PropertySpec] -> Flow s [Term -> Flow s [(PropertyKey, 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
-> PropertySpec -> Flow s (Term -> Flow s [(PropertyKey, v)])
forall s t v.
Schema s t v
-> PropertySpec -> Flow s (Term -> Flow s [(PropertyKey, v)])
parsePropertySpec Schema s t v
schema) [PropertySpec]
props
  let encode :: Term -> Flow s [Element v]
encode Term
term = String -> Flow s [Element v] -> Flow s [Element v]
forall s a. String -> Flow s a -> Flow s a
withTrace String
"encode as vertex" (Flow s [Element v] -> Flow s [Element v])
-> Flow s [Element v] -> Flow s [Element v]
forall a b. (a -> b) -> a -> b
$ do
        v
tid <- String -> (Term -> Flow s [v]) -> Term -> Flow s v
forall s x. String -> (Term -> Flow s [x]) -> Term -> Flow s x
requireUnique String
"vertex id" Term -> Flow s [v]
getId Term
term
        Map PropertyKey v
tprops <- [(PropertyKey, v)] -> Map PropertyKey v
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(PropertyKey, v)] -> Map PropertyKey v)
-> Flow s [(PropertyKey, v)] -> Flow s (Map PropertyKey v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Term -> Flow s [(PropertyKey, v)]) -> Flow s (PropertyKey, v))
-> [Term -> Flow s [(PropertyKey, v)]] -> Flow s [(PropertyKey, 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 (\Term -> Flow s [(PropertyKey, v)]
g -> String
-> (Term -> Flow s [(PropertyKey, v)])
-> Term
-> Flow s (PropertyKey, v)
forall s x. String -> (Term -> Flow s [x]) -> Term -> Flow s x
requireUnique String
"property key" Term -> Flow s [(PropertyKey, v)]
g Term
term) [Term -> Flow s [(PropertyKey, v)]]
getProps
        [Element v] -> Flow s [Element v]
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return [Vertex v -> Element v
forall v. Vertex v -> Element v
PG.ElementVertex (Vertex v -> Element v) -> Vertex v -> Element v
forall a b. (a -> b) -> a -> b
$ VertexLabel -> v -> Map PropertyKey v -> Vertex v
forall v. VertexLabel -> v -> Map PropertyKey v -> Vertex v
PG.Vertex VertexLabel
label v
tid Map PropertyKey v
tprops]
  (Label, Term -> Flow s [Element v])
-> Flow s (Label, Term -> Flow s [Element v])
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return (VertexLabel -> Label
PG.LabelVertex VertexLabel
label, Term -> Flow s [Element v]
encode)

requireUnique :: String -> (Term -> Flow s [x]) -> Term -> Flow s x
requireUnique :: forall s x. String -> (Term -> Flow s [x]) -> Term -> Flow s x
requireUnique String
context Term -> Flow s [x]
fun Term
term = do
  [x]
results <- Term -> Flow s [x]
fun Term
term
  case [x]
results of
    [] -> 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
"No value found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
context
    [x
value] -> x -> Flow s x
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
value
    [x]
_ -> 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
"Multiple values found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
context


-- Element spec decoding. TODO: this should code should really be generated rather than hand-written.

decodeEdgeLabel :: Term -> Flow s PG.EdgeLabel
decodeEdgeLabel :: forall s. Term -> Flow s EdgeLabel
decodeEdgeLabel Term
t = 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
t

decodeEdgeSpec :: Term -> Flow s EdgeSpec
decodeEdgeSpec :: forall s. Term -> Flow s EdgeSpec
decodeEdgeSpec Term
term = String -> Flow s EdgeSpec -> Flow s EdgeSpec
forall s a. String -> Flow s a -> Flow s a
withTrace String
"decode edge spec" (Flow s EdgeSpec -> Flow s EdgeSpec)
-> Flow s EdgeSpec -> Flow s EdgeSpec
forall a b. (a -> b) -> a -> b
$ (Map Name Term -> Flow s EdgeSpec) -> Term -> Flow s EdgeSpec
forall s x. (Map Name Term -> Flow s x) -> Term -> Flow s x
matchRecord (\Map Name Term
fields -> EdgeLabel
-> ValueSpec
-> ValueSpec
-> ValueSpec
-> [PropertySpec]
-> EdgeSpec
EdgeSpec
  (EdgeLabel
 -> ValueSpec
 -> ValueSpec
 -> ValueSpec
 -> [PropertySpec]
 -> EdgeSpec)
-> Flow s EdgeLabel
-> Flow
     s
     (ValueSpec -> ValueSpec -> ValueSpec -> [PropertySpec] -> EdgeSpec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name Term
-> Name -> (Term -> Flow s EdgeLabel) -> Flow s EdgeLabel
forall {m :: * -> *} {t} {a}.
MonadFail m =>
Map Name t -> Name -> (t -> m a) -> m a
readField Map Name Term
fields Name
_EdgeSpec_label Term -> Flow s EdgeLabel
forall s. Term -> Flow s EdgeLabel
decodeEdgeLabel
  Flow
  s
  (ValueSpec -> ValueSpec -> ValueSpec -> [PropertySpec] -> EdgeSpec)
-> Flow s ValueSpec
-> Flow s (ValueSpec -> ValueSpec -> [PropertySpec] -> EdgeSpec)
forall a b. Flow s (a -> b) -> Flow s a -> Flow s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Name Term
-> Name -> (Term -> Flow s ValueSpec) -> Flow s ValueSpec
forall {m :: * -> *} {t} {a}.
MonadFail m =>
Map Name t -> Name -> (t -> m a) -> m a
readField Map Name Term
fields Name
_EdgeSpec_id Term -> Flow s ValueSpec
forall s. Term -> Flow s ValueSpec
decodeValueSpec
  Flow s (ValueSpec -> ValueSpec -> [PropertySpec] -> EdgeSpec)
-> Flow s ValueSpec
-> Flow s (ValueSpec -> [PropertySpec] -> EdgeSpec)
forall a b. Flow s (a -> b) -> Flow s a -> Flow s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Name Term
-> Name -> (Term -> Flow s ValueSpec) -> Flow s ValueSpec
forall {m :: * -> *} {t} {a}.
MonadFail m =>
Map Name t -> Name -> (t -> m a) -> m a
readField Map Name Term
fields Name
_EdgeSpec_out Term -> Flow s ValueSpec
forall s. Term -> Flow s ValueSpec
decodeValueSpec
  Flow s (ValueSpec -> [PropertySpec] -> EdgeSpec)
-> Flow s ValueSpec -> Flow s ([PropertySpec] -> EdgeSpec)
forall a b. Flow s (a -> b) -> Flow s a -> Flow s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Name Term
-> Name -> (Term -> Flow s ValueSpec) -> Flow s ValueSpec
forall {m :: * -> *} {t} {a}.
MonadFail m =>
Map Name t -> Name -> (t -> m a) -> m a
readField Map Name Term
fields Name
_EdgeSpec_in Term -> Flow s ValueSpec
forall s. Term -> Flow s ValueSpec
decodeValueSpec
  Flow s ([PropertySpec] -> EdgeSpec)
-> Flow s [PropertySpec] -> Flow s EdgeSpec
forall a b. Flow s (a -> b) -> Flow s a -> Flow s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Name Term
-> Name -> (Term -> Flow s [PropertySpec]) -> Flow s [PropertySpec]
forall {m :: * -> *} {t} {a}.
MonadFail m =>
Map Name t -> Name -> (t -> m a) -> m a
readField Map Name Term
fields Name
_EdgeSpec_properties ((Term -> Flow s PropertySpec) -> Term -> Flow s [PropertySpec]
forall s x. (Term -> Flow s x) -> Term -> Flow s [x]
Expect.list Term -> Flow s PropertySpec
forall s. Term -> Flow s PropertySpec
decodePropertySpec)) Term
term

decodeElementSpec :: Term -> Flow s ElementSpec
decodeElementSpec :: forall s. Term -> Flow s ElementSpec
decodeElementSpec Term
term = String -> Flow s ElementSpec -> Flow s ElementSpec
forall s a. String -> Flow s a -> Flow s a
withTrace String
"decode element spec" (Flow s ElementSpec -> Flow s ElementSpec)
-> Flow s ElementSpec -> Flow s ElementSpec
forall a b. (a -> b) -> a -> b
$ [(Name, Term -> Flow s ElementSpec)] -> Term -> Flow s ElementSpec
forall s x. [(Name, Term -> Flow s x)] -> Term -> Flow s x
matchInjection [
  (Name
_ElementSpec_vertex, \Term
t -> VertexSpec -> ElementSpec
ElementSpecVertex (VertexSpec -> ElementSpec)
-> Flow s VertexSpec -> Flow s ElementSpec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow s VertexSpec
forall s. Term -> Flow s VertexSpec
decodeVertexSpec Term
t),
  (Name
_ElementSpec_edge, \Term
t -> EdgeSpec -> ElementSpec
ElementSpecEdge (EdgeSpec -> ElementSpec) -> Flow s EdgeSpec -> Flow s ElementSpec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow s EdgeSpec
forall s. Term -> Flow s EdgeSpec
decodeEdgeSpec Term
t)] Term
term

decodePropertyKey :: Term -> Flow s PG.PropertyKey
decodePropertyKey :: forall s. Term -> Flow s PropertyKey
decodePropertyKey Term
t = String -> PropertyKey
PG.PropertyKey (String -> PropertyKey) -> Flow s String -> Flow s PropertyKey
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

decodePropertySpec :: Term -> Flow s PropertySpec
decodePropertySpec :: forall s. Term -> Flow s PropertySpec
decodePropertySpec Term
term = String -> Flow s PropertySpec -> Flow s PropertySpec
forall s a. String -> Flow s a -> Flow s a
withTrace String
"decode property spec" (Flow s PropertySpec -> Flow s PropertySpec)
-> Flow s PropertySpec -> Flow s PropertySpec
forall a b. (a -> b) -> a -> b
$ (Map Name Term -> Flow s PropertySpec)
-> Term -> Flow s PropertySpec
forall s x. (Map Name Term -> Flow s x) -> Term -> Flow s x
matchRecord (\Map Name Term
fields -> PropertyKey -> ValueSpec -> PropertySpec
PropertySpec
  (PropertyKey -> ValueSpec -> PropertySpec)
-> Flow s PropertyKey -> Flow s (ValueSpec -> PropertySpec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name Term
-> Name -> (Term -> Flow s PropertyKey) -> Flow s PropertyKey
forall {m :: * -> *} {t} {a}.
MonadFail m =>
Map Name t -> Name -> (t -> m a) -> m a
readField Map Name Term
fields Name
_PropertySpec_key Term -> Flow s PropertyKey
forall s. Term -> Flow s PropertyKey
decodePropertyKey
  Flow s (ValueSpec -> PropertySpec)
-> Flow s ValueSpec -> Flow s PropertySpec
forall a b. Flow s (a -> b) -> Flow s a -> Flow s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Name Term
-> Name -> (Term -> Flow s ValueSpec) -> Flow s ValueSpec
forall {m :: * -> *} {t} {a}.
MonadFail m =>
Map Name t -> Name -> (t -> m a) -> m a
readField Map Name Term
fields Name
_PropertySpec_value Term -> Flow s ValueSpec
forall s. Term -> Flow s ValueSpec
decodeValueSpec) Term
term

decodeValueSpec :: Term -> Flow s ValueSpec
decodeValueSpec :: forall s. Term -> Flow s ValueSpec
decodeValueSpec Term
term = String -> Flow s ValueSpec -> Flow s ValueSpec
forall s a. String -> Flow s a -> Flow s a
withTrace String
"decode value spec" (Flow s ValueSpec -> Flow s ValueSpec)
-> Flow s ValueSpec -> Flow s ValueSpec
forall a b. (a -> b) -> a -> b
$ case Term -> Term
stripTerm Term
term of
  -- Allow an abbreviated specification consisting of only the pattern string
  TermLiteral (LiteralString String
s) -> ValueSpec -> Flow s ValueSpec
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValueSpec -> Flow s ValueSpec) -> ValueSpec -> Flow s ValueSpec
forall a b. (a -> b) -> a -> b
$ String -> ValueSpec
ValueSpecPattern String
s
  Term
_ -> [(Name, Term -> Flow s ValueSpec)] -> Term -> Flow s ValueSpec
forall s x. [(Name, Term -> Flow s x)] -> Term -> Flow s x
matchInjection [
    (Name
_ValueSpec_value, \Term
t -> ValueSpec -> Flow s ValueSpec
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValueSpec
ValueSpecValue),
    (Name
_ValueSpec_pattern, \Term
t -> String -> ValueSpec
ValueSpecPattern (String -> ValueSpec) -> Flow s String -> Flow s ValueSpec
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)] Term
term

decodeVertexLabel :: Term -> Flow s PG.VertexLabel
decodeVertexLabel :: forall s. Term -> Flow s VertexLabel
decodeVertexLabel Term
t = String -> VertexLabel
PG.VertexLabel (String -> VertexLabel) -> Flow s String -> Flow s VertexLabel
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

decodeVertexSpec :: Term -> Flow s VertexSpec
decodeVertexSpec :: forall s. Term -> Flow s VertexSpec
decodeVertexSpec Term
term = String -> Flow s VertexSpec -> Flow s VertexSpec
forall s a. String -> Flow s a -> Flow s a
withTrace String
"decode vertex spec" (Flow s VertexSpec -> Flow s VertexSpec)
-> Flow s VertexSpec -> Flow s VertexSpec
forall a b. (a -> b) -> a -> b
$ (Map Name Term -> Flow s VertexSpec) -> Term -> Flow s VertexSpec
forall s x. (Map Name Term -> Flow s x) -> Term -> Flow s x
matchRecord (\Map Name Term
fields -> VertexLabel -> ValueSpec -> [PropertySpec] -> VertexSpec
VertexSpec
  (VertexLabel -> ValueSpec -> [PropertySpec] -> VertexSpec)
-> Flow s VertexLabel
-> Flow s (ValueSpec -> [PropertySpec] -> VertexSpec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name Term
-> Name -> (Term -> Flow s VertexLabel) -> Flow s VertexLabel
forall {m :: * -> *} {t} {a}.
MonadFail m =>
Map Name t -> Name -> (t -> m a) -> m a
readField Map Name Term
fields Name
_VertexSpec_label Term -> Flow s VertexLabel
forall s. Term -> Flow s VertexLabel
decodeVertexLabel
  Flow s (ValueSpec -> [PropertySpec] -> VertexSpec)
-> Flow s ValueSpec -> Flow s ([PropertySpec] -> VertexSpec)
forall a b. Flow s (a -> b) -> Flow s a -> Flow s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Name Term
-> Name -> (Term -> Flow s ValueSpec) -> Flow s ValueSpec
forall {m :: * -> *} {t} {a}.
MonadFail m =>
Map Name t -> Name -> (t -> m a) -> m a
readField Map Name Term
fields Name
_VertexSpec_id Term -> Flow s ValueSpec
forall s. Term -> Flow s ValueSpec
decodeValueSpec
  Flow s ([PropertySpec] -> VertexSpec)
-> Flow s [PropertySpec] -> Flow s VertexSpec
forall a b. Flow s (a -> b) -> Flow s a -> Flow s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Name Term
-> Name -> (Term -> Flow s [PropertySpec]) -> Flow s [PropertySpec]
forall {m :: * -> *} {t} {a}.
MonadFail m =>
Map Name t -> Name -> (t -> m a) -> m a
readField Map Name Term
fields Name
_VertexSpec_properties ((Term -> Flow s PropertySpec) -> Term -> Flow s [PropertySpec]
forall s x. (Term -> Flow s x) -> Term -> Flow s [x]
Expect.list Term -> Flow s PropertySpec
forall s. Term -> Flow s PropertySpec
decodePropertySpec)) Term
term


-- General-purpose code for decoding

matchInjection :: [(Name, Term -> Flow s x)] -> Term -> Flow s x
matchInjection :: forall s x. [(Name, Term -> Flow s x)] -> Term -> Flow s x
matchInjection [(Name, Term -> Flow s x)]
cases Term
encoded = do
  Map Name Term
mp <- (Term -> Flow s Name)
-> (Term -> Flow s Term) -> Term -> Flow s (Map Name Term)
forall k s v.
Ord k =>
(Term -> Flow s k)
-> (Term -> Flow s v) -> Term -> Flow s (Map k v)
Expect.map (\Term
k -> String -> Name
Name (String -> Name) -> Flow s String -> Flow s Name
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
k) Term -> Flow s Term
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
encoded
  Field
f <- case Map Name Term -> [(Name, Term)]
forall k a. Map k a -> [(k, a)]
M.toList Map Name Term
mp of
    [] -> String -> Flow s Field
forall a. String -> Flow s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty injection"
    [(Name
k, Term
v)] -> Field -> Flow s Field
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Field -> Flow s Field) -> Field -> Flow s Field
forall a b. (a -> b) -> a -> b
$ Name -> Term -> Field
Field Name
k Term
v
    [(Name, Term)]
_ -> String -> Flow s Field
forall a. String -> Flow s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Flow s Field) -> String -> Flow s Field
forall a b. (a -> b) -> a -> b
$ String
"invalid injection: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Map Name Term -> String
forall a. Show a => a -> String
show Map Name Term
mp
  case (Name, Term -> Flow s x) -> Term -> Flow s x
forall a b. (a, b) -> b
snd ((Name, Term -> Flow s x) -> Term -> Flow s x)
-> [(Name, Term -> Flow s x)] -> [Term -> Flow s x]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((Name, Term -> Flow s x) -> Bool)
-> [(Name, Term -> Flow s x)] -> [(Name, Term -> Flow s x)]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (\(Name, Term -> Flow s x)
c -> (Name, Term -> Flow s x) -> Name
forall a b. (a, b) -> a
fst (Name, Term -> Flow s x)
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Field -> Name
fieldName Field
f) [(Name, Term -> Flow s x)]
cases) of
    [] -> 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
"unexpected field: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
unName (Field -> Name
fieldName Field
f)
    [Term -> Flow s x
fun] -> Term -> Flow s x
fun (Field -> Term
fieldTerm Field
f)
    [Term -> Flow s x]
_ -> String -> Flow s x
forall a. String -> Flow s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"duplicate field name in cases"

matchRecord :: (M.Map Name Term -> Flow s x) -> Term -> Flow s x
matchRecord :: forall s x. (Map Name Term -> Flow s x) -> Term -> Flow s x
matchRecord Map Name Term -> Flow s x
cons Term
term = (Term -> Flow s Name)
-> (Term -> Flow s Term) -> Term -> Flow s (Map Name Term)
forall k s v.
Ord k =>
(Term -> Flow s k)
-> (Term -> Flow s v) -> Term -> Flow s (Map k v)
Expect.map (\Term
k -> String -> Name
Name (String -> Name) -> Flow s String -> Flow s Name
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
k) Term -> Flow s Term
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
term Flow s (Map Name Term) -> (Map Name Term -> Flow s x) -> Flow s x
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
>>= Map Name Term -> Flow s x
cons

readField :: Map Name t -> Name -> (t -> m a) -> m a
readField Map Name t
fields Name
fname t -> m a
fun = case Name -> Map Name t -> Maybe t
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
fname Map Name t
fields of
  Maybe t
Nothing -> String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"no such field: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
fname
  Just t
t -> t -> m a
fun t
t