-- | Functions for working with Meta, the default annotation type in Hydra

module Hydra.Meta where

import Hydra.Core
import Hydra.Compute
import Hydra.CoreDecoding
import Hydra.CoreEncoding
import Hydra.Common
import Hydra.Monads
import Hydra.Mantle
import qualified Hydra.Impl.Haskell.Dsl.Terms as Terms

import qualified Data.Map as M
import qualified Data.Maybe as Y


aggregateAnnotations :: (a -> Maybe (Annotated a Meta)) -> a -> Meta
aggregateAnnotations :: forall a. (a -> Maybe (Annotated a Meta)) -> a -> Meta
aggregateAnnotations a -> Maybe (Annotated a Meta)
getAnn a
t = Map String (Term Meta) -> Meta
Meta forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ [(String, Term Meta)] -> a -> [(String, Term Meta)]
addMeta [] a
t
  where
    addMeta :: [(String, Term Meta)] -> a -> [(String, Term Meta)]
addMeta [(String, Term Meta)]
m a
t = case a -> Maybe (Annotated a Meta)
getAnn a
t of
      Maybe (Annotated a Meta)
Nothing -> [(String, Term Meta)]
m
      Just (Annotated a
t' (Meta Map String (Term Meta)
other)) -> [(String, Term Meta)] -> a -> [(String, Term Meta)]
addMeta ([(String, Term Meta)]
m forall a. [a] -> [a] -> [a]
++ forall k a. Map k a -> [(k, a)]
M.toList Map String (Term Meta)
other) a
t'

getAnnotation :: String -> Meta -> Maybe (Term Meta)
getAnnotation :: String -> Meta -> Maybe (Term Meta)
getAnnotation String
key (Meta Map String (Term Meta)
m) = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
key Map String (Term Meta)
m

getAttr :: String -> Flow s (Maybe (Term Meta))
getAttr :: forall s. String -> Flow s (Maybe (Term Meta))
getAttr String
key = forall s a. (s -> Trace -> FlowState s a) -> Flow s a
Flow forall {s}. s -> Trace -> FlowState s (Maybe (Term Meta))
q
  where
    q :: s -> Trace -> FlowState s (Maybe (Term Meta))
q s
s0 Trace
t0 = forall s a. Maybe a -> s -> Trace -> FlowState s a
FlowState (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
key forall a b. (a -> b) -> a -> b
$ Trace -> Map String (Term Meta)
traceOther Trace
t0) s
s0 Trace
t0

getAttrWithDefault :: String -> Term Meta -> Flow s (Term Meta)
getAttrWithDefault :: forall s. String -> Term Meta -> Flow s (Term Meta)
getAttrWithDefault String
key Term Meta
def = forall a. a -> Maybe a -> a
Y.fromMaybe Term Meta
def forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. String -> Flow s (Maybe (Term Meta))
getAttr String
key

getDescription :: Meta -> GraphFlow Meta (Y.Maybe String)
getDescription :: Meta -> GraphFlow Meta (Maybe String)
getDescription Meta
meta = case String -> Meta -> Maybe (Term Meta)
getAnnotation String
metaDescription Meta
meta of
  Maybe (Term Meta)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  Just Term Meta
term -> case Term Meta
term of
    TermLiteral (LiteralString String
s) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just String
s
    Term Meta
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"unexpected value for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
metaDescription forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Term Meta
term

getTermAnnotation :: Context Meta -> String -> Term Meta -> Y.Maybe (Term Meta)
getTermAnnotation :: Context Meta -> String -> Term Meta -> Maybe (Term Meta)
getTermAnnotation Context Meta
cx String
key = String -> Meta -> Maybe (Term Meta)
getAnnotation String
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term Meta -> Meta
termMetaInternal

getTermDescription :: Term Meta -> GraphFlow Meta (Y.Maybe String)
getTermDescription :: Term Meta -> GraphFlow Meta (Maybe String)
getTermDescription = Meta -> GraphFlow Meta (Maybe String)
getDescription forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term Meta -> Meta
termMetaInternal

getType :: Meta -> GraphFlow Meta (Y.Maybe (Type Meta))
getType :: Meta -> GraphFlow Meta (Maybe (Type Meta))
getType Meta
meta = case String -> Meta -> Maybe (Term Meta)
getAnnotation String
metaType Meta
meta of
  Maybe (Term Meta)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  Just Term Meta
dat -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall m. Show m => Term m -> GraphFlow m (Type m)
decodeType Term Meta
dat

getTypeDescription :: Type Meta -> GraphFlow Meta (Y.Maybe String)
getTypeDescription :: Type Meta -> GraphFlow Meta (Maybe String)
getTypeDescription = Meta -> GraphFlow Meta (Maybe String)
getDescription forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type Meta -> Meta
typeMetaInternal

metaAnnotationClass :: AnnotationClass Meta
metaAnnotationClass :: AnnotationClass Meta
metaAnnotationClass = AnnotationClass {
    annotationClassDefault :: Meta
annotationClassDefault = Map String (Term Meta) -> Meta
Meta forall k a. Map k a
M.empty,
    annotationClassEqual :: Meta -> Meta -> Bool
annotationClassEqual = forall a. Eq a => a -> a -> Bool
(==),
    annotationClassCompare :: Meta -> Meta -> Comparison
annotationClassCompare = \Meta
m1 Meta
m2 -> Ordering -> Comparison
toComparison forall a b. (a -> b) -> a -> b
$ Meta
m1 forall a. Ord a => a -> a -> Ordering
`compare` Meta
m2,
    annotationClassShow :: Meta -> String
annotationClassShow = forall a. Show a => a -> String
show,
    annotationClassRead :: String -> Maybe Meta
annotationClassRead = forall a. Read a => String -> a
read,

    -- TODO: simplify
    annotationClassTermMeta :: Term Meta -> Meta
annotationClassTermMeta = Term Meta -> Meta
termMetaInternal,
    annotationClassTypeMeta :: Type Meta -> Meta
annotationClassTypeMeta = Type Meta -> Meta
typeMetaInternal,
    annotationClassTermDescription :: Term Meta -> GraphFlow Meta (Maybe String)
annotationClassTermDescription = Term Meta -> GraphFlow Meta (Maybe String)
getTermDescription,
    annotationClassTypeDescription :: Type Meta -> GraphFlow Meta (Maybe String)
annotationClassTypeDescription = Type Meta -> GraphFlow Meta (Maybe String)
getTypeDescription,
    annotationClassTermType :: Term Meta -> GraphFlow Meta (Maybe (Type Meta))
annotationClassTermType = Meta -> GraphFlow Meta (Maybe (Type Meta))
getType forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term Meta -> Meta
termMetaInternal,
    annotationClassSetTermDescription :: Context Meta -> Maybe String -> Term Meta -> Term Meta
annotationClassSetTermDescription = Context Meta -> Maybe String -> Term Meta -> Term Meta
setTermDescription,
    annotationClassSetTermType :: Context Meta -> Maybe (Type Meta) -> Term Meta -> Term Meta
annotationClassSetTermType = Context Meta -> Maybe (Type Meta) -> Term Meta -> Term Meta
setTermType,
    annotationClassTypeOf :: Meta -> GraphFlow Meta (Maybe (Type Meta))
annotationClassTypeOf = Meta -> GraphFlow Meta (Maybe (Type Meta))
getType,
    annotationClassSetTypeOf :: Maybe (Type Meta) -> Meta -> Meta
annotationClassSetTypeOf = Maybe (Type Meta) -> Meta -> Meta
setType}
  where
    toComparison :: Ordering -> Comparison
toComparison Ordering
c = case Ordering
c of
      Ordering
LT -> Comparison
ComparisonLessThan
      Ordering
EQ -> Comparison
ComparisonEqualTo
      Ordering
GT -> Comparison
ComparisonGreaterThan

metaDescription :: String
metaDescription :: String
metaDescription = String
"description"

metaType :: String
metaType :: String
metaType = String
"type"

nextCount :: String -> Flow s Int
nextCount :: forall s. String -> Flow s Int
nextCount String
attrName = do
  Int
count <- forall s. String -> Term Meta -> Flow s (Term Meta)
getAttrWithDefault String
attrName (forall m. Int -> Term m
Terms.int32 Int
0) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall m s. Show m => Term m -> Flow s Int
Terms.expectInt32
  forall s. String -> Term Meta -> Flow s ()
putAttr String
attrName (forall m. Int -> Term m
Terms.int32 forall a b. (a -> b) -> a -> b
$ Int
count forall a. Num a => a -> a -> a
+ Int
1)
  forall (m :: * -> *) a. Monad m => a -> m a
return Int
count

putAttr :: String -> Term Meta -> Flow s ()
putAttr :: forall s. String -> Term Meta -> Flow s ()
putAttr String
key Term Meta
val = forall s a. (s -> Trace -> FlowState s a) -> Flow s a
Flow forall {s}. s -> Trace -> FlowState s ()
q
  where
    q :: s -> Trace -> FlowState s ()
q s
s0 Trace
t0 = forall s a. Maybe a -> s -> Trace -> FlowState s a
FlowState (forall a. a -> Maybe a
Just ()) s
s0 (Trace
t0 {traceOther :: Map String (Term Meta)
traceOther = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
key Term Meta
val forall a b. (a -> b) -> a -> b
$ Trace -> Map String (Term Meta)
traceOther Trace
t0})

setAnnotation :: String -> Y.Maybe (Term Meta) -> Meta -> Meta
setAnnotation :: String -> Maybe (Term Meta) -> Meta -> Meta
setAnnotation String
key Maybe (Term Meta)
val (Meta Map String (Term Meta)
m) = Map String (Term Meta) -> Meta
Meta forall a b. (a -> b) -> a -> b
$ forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (forall a b. a -> b -> a
const Maybe (Term Meta)
val) String
key Map String (Term Meta)
m

setDescription :: Y.Maybe String -> Meta -> Meta
setDescription :: Maybe String -> Meta -> Meta
setDescription Maybe String
d = String -> Maybe (Term Meta) -> Meta -> Meta
setAnnotation String
metaDescription (forall m. String -> Term m
Terms.string forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
d)

setTermAnnotation :: Context Meta -> String -> Y.Maybe (Term Meta) -> Term Meta -> Term Meta
setTermAnnotation :: Context Meta
-> String -> Maybe (Term Meta) -> Term Meta -> Term Meta
setTermAnnotation Context Meta
cx String
key Maybe (Term Meta)
val Term Meta
term = if Meta
meta forall a. Eq a => a -> a -> Bool
== forall m. AnnotationClass m -> m
annotationClassDefault (forall m. Context m -> AnnotationClass m
contextAnnotations Context Meta
cx)
    then Term Meta
term'
    else forall m. Annotated (Term m) m -> Term m
TermAnnotated forall a b. (a -> b) -> a -> b
$ forall a m. a -> m -> Annotated a m
Annotated Term Meta
term' Meta
meta
  where
    term' :: Term Meta
term' = forall m. Term m -> Term m
stripTerm Term Meta
term
    meta :: Meta
meta = String -> Maybe (Term Meta) -> Meta -> Meta
setAnnotation String
key Maybe (Term Meta)
val forall a b. (a -> b) -> a -> b
$ Term Meta -> Meta
termMetaInternal Term Meta
term

setTermDescription :: Context Meta -> Y.Maybe String -> Term Meta -> Term Meta
setTermDescription :: Context Meta -> Maybe String -> Term Meta -> Term Meta
setTermDescription Context Meta
cx Maybe String
d = Context Meta
-> String -> Maybe (Term Meta) -> Term Meta -> Term Meta
setTermAnnotation Context Meta
cx String
metaDescription (forall m. String -> Term m
Terms.string forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
d)

setTermType :: Context Meta -> Y.Maybe (Type Meta) -> Term Meta -> Term Meta
setTermType :: Context Meta -> Maybe (Type Meta) -> Term Meta -> Term Meta
setTermType Context Meta
cx Maybe (Type Meta)
d = Context Meta
-> String -> Maybe (Term Meta) -> Term Meta -> Term Meta
setTermAnnotation Context Meta
cx String
metaType (forall m. Type m -> Term m
encodeType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Type Meta)
d)

setType :: Y.Maybe (Type Meta) -> Meta -> Meta
setType :: Maybe (Type Meta) -> Meta -> Meta
setType Maybe (Type Meta)
mt = String -> Maybe (Term Meta) -> Meta -> Meta
setAnnotation String
metaType (forall m. Type m -> Term m
encodeType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Type Meta)
mt)

setTypeAnnotation :: Context Meta -> String -> Y.Maybe (Term Meta) -> Type Meta -> Type Meta
setTypeAnnotation :: Context Meta
-> String -> Maybe (Term Meta) -> Type Meta -> Type Meta
setTypeAnnotation Context Meta
cx String
key Maybe (Term Meta)
val Type Meta
typ = if Meta
meta forall a. Eq a => a -> a -> Bool
== forall m. AnnotationClass m -> m
annotationClassDefault (forall m. Context m -> AnnotationClass m
contextAnnotations Context Meta
cx)
    then Type Meta
typ'
    else forall m. Annotated (Type m) m -> Type m
TypeAnnotated forall a b. (a -> b) -> a -> b
$ forall a m. a -> m -> Annotated a m
Annotated Type Meta
typ' Meta
meta
  where
    typ' :: Type Meta
typ' = forall m. Type m -> Type m
stripType Type Meta
typ
    meta :: Meta
meta = String -> Maybe (Term Meta) -> Meta -> Meta
setAnnotation String
key Maybe (Term Meta)
val forall a b. (a -> b) -> a -> b
$ Type Meta -> Meta
typeMetaInternal Type Meta
typ

setTypeDescription :: Context Meta -> Y.Maybe String -> Type Meta -> Type Meta
setTypeDescription :: Context Meta -> Maybe String -> Type Meta -> Type Meta
setTypeDescription Context Meta
cx Maybe String
d = Context Meta
-> String -> Maybe (Term Meta) -> Type Meta -> Type Meta
setTypeAnnotation Context Meta
cx String
metaDescription (forall m. String -> Term m
Terms.string forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
d)

termMetaInternal :: Term Meta -> Meta
termMetaInternal :: Term Meta -> Meta
termMetaInternal = forall a. (a -> Maybe (Annotated a Meta)) -> a -> Meta
aggregateAnnotations forall a b. (a -> b) -> a -> b
$ \Term Meta
t -> case Term Meta
t of
  TermAnnotated Annotated (Term Meta) Meta
a -> forall a. a -> Maybe a
Just Annotated (Term Meta) Meta
a
  Term Meta
_ -> forall a. Maybe a
Nothing

typeMetaInternal :: Type Meta -> Meta
typeMetaInternal :: Type Meta -> Meta
typeMetaInternal = forall a. (a -> Maybe (Annotated a Meta)) -> a -> Meta
aggregateAnnotations forall a b. (a -> b) -> a -> b
$ \Type Meta
t -> case Type Meta
t of
  TypeAnnotated Annotated (Type Meta) Meta
a -> forall a. a -> Maybe a
Just Annotated (Type Meta) Meta
a
  Type Meta
_ -> forall a. Maybe a
Nothing