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 Hydra.Impl.Haskell.Dsl.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

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"

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
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
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
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