-- | Additional adapter utilities, above and beyond the generated ones

module Hydra.AdapterUtils (
  module Hydra.AdapterUtils,
  module Hydra.Printing,
) where

import Hydra.Coders
import Hydra.Compute
import Hydra.Core
import Hydra.Basics
import Hydra.Module
import Hydra.Printing
import Hydra.Mantle
import Hydra.Strip
import Hydra.Annotations
import qualified Hydra.Lib.Strings as Strings
import qualified Hydra.Dsl.Expect as Expect
import qualified Hydra.Dsl.Terms as Terms

import qualified Data.List as L
import qualified Data.Set as S
import qualified Data.Maybe as Y
import Control.Monad


type SymmetricAdapter s t v = Adapter s s t t v v

type TypeAdapter = Type -> Flow AdapterContext (SymmetricAdapter AdapterContext Type Term)

key_types :: Name
key_types = String -> Name
Name String
"types"

bidirectional :: (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional :: forall b s. (CoderDirection -> b -> Flow s b) -> Coder s s b b
bidirectional CoderDirection -> b -> Flow s b
f = (b -> Flow s b) -> (b -> Flow s b) -> Coder s s b b
forall s1 s2 v1 v2.
(v1 -> Flow s1 v2) -> (v2 -> Flow s2 v1) -> Coder s1 s2 v1 v2
Coder (CoderDirection -> b -> Flow s b
f CoderDirection
CoderDirectionEncode) (CoderDirection -> b -> Flow s b
f CoderDirection
CoderDirectionDecode)

chooseAdapter :: (Eq t, Ord t, Show t) =>
    (t -> [Flow so (SymmetricAdapter si t v)])
 -> (t -> Bool)
 -> (t -> String)
 -> t
 -> Flow so (SymmetricAdapter si t v)
chooseAdapter :: forall t so si v.
(Eq t, Ord t, Show t) =>
(t -> [Flow so (SymmetricAdapter si t v)])
-> (t -> Bool)
-> (t -> String)
-> t
-> Flow so (SymmetricAdapter si t v)
chooseAdapter t -> [Flow so (SymmetricAdapter si t v)]
alts t -> Bool
supported t -> String
describe t
typ = if t -> Bool
supported t
typ
  then SymmetricAdapter si t v -> Flow so (SymmetricAdapter si t v)
forall a. a -> Flow so a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SymmetricAdapter si t v -> Flow so (SymmetricAdapter si t v))
-> SymmetricAdapter si t v -> Flow so (SymmetricAdapter si t v)
forall a b. (a -> b) -> a -> b
$ Bool -> t -> t -> Coder si si v v -> SymmetricAdapter si 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
False t
typ t
typ Coder si si v v
forall s a. Coder s s a a
idCoder
  else do
    -- Uncomment to debug adapter cycles
    -- debugCheckType typ

    [SymmetricAdapter si t v]
raw <- [Flow so (SymmetricAdapter si t v)]
-> Flow so [SymmetricAdapter si t v]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence (t -> [Flow so (SymmetricAdapter si t v)]
alts t
typ)
    let candidates :: [SymmetricAdapter si t v]
candidates = (SymmetricAdapter si t v -> Bool)
-> [SymmetricAdapter si t v] -> [SymmetricAdapter si t v]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (t -> Bool
supported (t -> Bool)
-> (SymmetricAdapter si t v -> t)
-> SymmetricAdapter si t v
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymmetricAdapter si t v -> t
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget) [SymmetricAdapter si t v]
raw
    if [SymmetricAdapter si t v] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [SymmetricAdapter si t v]
candidates
      then String -> Flow so (SymmetricAdapter si t v)
forall a. String -> Flow so a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Flow so (SymmetricAdapter si t v))
-> String -> Flow so (SymmetricAdapter si t v)
forall a b. (a -> b) -> a -> b
$ String
"no adapters found for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
describe t
typ
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if [SymmetricAdapter si t v] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [SymmetricAdapter si t v]
raw
           then String
""
           else String
" (discarded " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([SymmetricAdapter si t v] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [SymmetricAdapter si t v]
raw) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" unsupported candidate types: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [t] -> String
forall a. Show a => a -> String
show (SymmetricAdapter si t v -> t
forall s1 s2 t1 t2 v1 v2. Adapter s1 s2 t1 t2 v1 v2 -> t2
adapterTarget (SymmetricAdapter si t v -> t) -> [SymmetricAdapter si t v] -> [t]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SymmetricAdapter si t v]
raw) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". Original type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
typ
      else do
        -- Uncomment to debug adapter cycles
        -- debugRemoveType typ

        SymmetricAdapter si t v -> Flow so (SymmetricAdapter si t v)
forall a. a -> Flow so a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymmetricAdapter si t v -> Flow so (SymmetricAdapter si t v))
-> SymmetricAdapter si t v -> Flow so (SymmetricAdapter si t v)
forall a b. (a -> b) -> a -> b
$ [SymmetricAdapter si t v] -> SymmetricAdapter si t v
forall a. HasCallStack => [a] -> a
L.head [SymmetricAdapter si t v]
candidates

composeCoders :: Coder s s a b -> Coder s s b c -> Coder s s a c
composeCoders :: forall s a b c. Coder s s a b -> Coder s s b c -> Coder s s a c
composeCoders Coder s s a b
c1 Coder s s b c
c2 = Coder {
  coderEncode :: a -> Flow s c
coderEncode = Coder s s a b -> a -> Flow s b
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder s s a b
c1 (a -> Flow s b) -> (b -> Flow s c) -> a -> Flow s c
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Coder s s b c -> b -> Flow s c
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder s s b c
c2,
  coderDecode :: c -> Flow s a
coderDecode = Coder s s b c -> c -> Flow s b
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode Coder s s b c
c2 (c -> Flow s b) -> (b -> Flow s a) -> c -> Flow s a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Coder s s a b -> b -> Flow s a
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode Coder s s a b
c1}

debugCheckType :: (Eq t, Ord t, Show t) => t -> Flow s ()
debugCheckType :: forall t s. (Eq t, Ord t, Show t) => t -> Flow s ()
debugCheckType t
typ = do
  let s :: String
s = t -> String
forall a. Show a => a -> String
show t
typ
  Set String
types <- Name -> Term -> Flow s Term
forall s. Name -> Term -> Flow s Term
getAttrWithDefault Name
key_types (Set Term -> Term
Terms.set Set Term
forall a. Set a
S.empty) Flow s Term -> (Term -> Flow s (Set String)) -> Flow s (Set String)
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 String) -> Term -> Flow s (Set String)
forall x s. Ord x => (Term -> Flow s x) -> Term -> Flow s (Set x)
Expect.set Term -> Flow s String
forall s. Term -> Flow s String
Expect.string
  if String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member String
s Set String
types
    then String -> Flow s ()
forall a. String -> Flow s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Flow s ()) -> String -> Flow s ()
forall a b. (a -> b) -> a -> b
$ String
"detected a cycle; type has already been encountered: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
typ
    else Name -> Term -> Flow s ()
forall s. Name -> Term -> Flow s ()
putAttr Name
key_types (Term -> Flow s ()) -> Term -> Flow s ()
forall a b. (a -> b) -> a -> b
$ Set Term -> Term
Terms.set (Set Term -> Term) -> Set Term -> Term
forall a b. (a -> b) -> a -> b
$ [Term] -> Set Term
forall a. Ord a => [a] -> Set a
S.fromList (String -> Term
Terms.string (String -> Term) -> [String] -> [Term]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Set String -> [String]
forall a. Set a -> [a]
S.toList (Set String -> [String]) -> Set String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
S.insert String
s Set String
types))
  () -> Flow s ()
forall a. a -> Flow s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

debugRemoveType :: (Eq t, Ord t, Show t) => t -> Flow s ()
debugRemoveType :: forall t s. (Eq t, Ord t, Show t) => t -> Flow s ()
debugRemoveType t
typ = do
  let s :: String
s = t -> String
forall a. Show a => a -> String
show t
typ
  Set String
types <- Name -> Term -> Flow s Term
forall s. Name -> Term -> Flow s Term
getAttrWithDefault Name
key_types (Set Term -> Term
Terms.set Set Term
forall a. Set a
S.empty) Flow s Term -> (Term -> Flow s (Set String)) -> Flow s (Set String)
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 String) -> Term -> Flow s (Set String)
forall x s. Ord x => (Term -> Flow s x) -> Term -> Flow s (Set x)
Expect.set Term -> Flow s String
forall s. Term -> Flow s String
Expect.string
  let types' :: Set String
types' = String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
S.delete String
s Set String
types
  Name -> Term -> Flow s ()
forall s. Name -> Term -> Flow s ()
putAttr Name
key_types (Term -> Flow s ()) -> Term -> Flow s ()
forall a b. (a -> b) -> a -> b
$ Set Term -> Term
Terms.set (Set Term -> Term) -> Set Term -> Term
forall a b. (a -> b) -> a -> b
$ [Term] -> Set Term
forall a. Ord a => [a] -> Set a
S.fromList (String -> Term
Terms.string (String -> Term) -> [String] -> [Term]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Set String -> [String]
forall a. Set a -> [a]
S.toList (Set String -> [String]) -> Set String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
S.insert String
s Set String
types'))

encodeDecode :: CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode :: forall s x. CoderDirection -> Coder s s x x -> x -> Flow s x
encodeDecode CoderDirection
dir = case CoderDirection
dir of
  CoderDirection
CoderDirectionEncode -> Coder s s x x -> x -> Flow s x
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode
  CoderDirection
CoderDirectionDecode -> Coder s s x x -> x -> Flow s x
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode

floatTypeIsSupported :: LanguageConstraints -> FloatType -> Bool
floatTypeIsSupported :: LanguageConstraints -> FloatType -> Bool
floatTypeIsSupported LanguageConstraints
constraints FloatType
ft = FloatType -> Set FloatType -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member FloatType
ft (Set FloatType -> Bool) -> Set FloatType -> Bool
forall a b. (a -> b) -> a -> b
$ LanguageConstraints -> Set FloatType
languageConstraintsFloatTypes LanguageConstraints
constraints

idAdapter :: t -> SymmetricAdapter s t v
idAdapter :: forall t s v. t -> SymmetricAdapter s t v
idAdapter t
t = Bool -> t -> t -> Coder s s v v -> Adapter s s t t v 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
False t
t t
t Coder s s v v
forall s a. Coder s s a a
idCoder

idCoder :: Coder s s a a
idCoder :: forall s a. Coder s s a a
idCoder = (a -> Flow s a) -> (a -> Flow s a) -> Coder s s a a
forall s1 s2 v1 v2.
(v1 -> Flow s1 v2) -> (v2 -> Flow s2 v1) -> Coder s1 s2 v1 v2
Coder a -> Flow s a
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> Flow s a
forall a. a -> Flow s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

integerTypeIsSupported :: LanguageConstraints -> IntegerType -> Bool
integerTypeIsSupported :: LanguageConstraints -> IntegerType -> Bool
integerTypeIsSupported LanguageConstraints
constraints IntegerType
it = IntegerType -> Set IntegerType -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member IntegerType
it (Set IntegerType -> Bool) -> Set IntegerType -> Bool
forall a b. (a -> b) -> a -> b
$ LanguageConstraints -> Set IntegerType
languageConstraintsIntegerTypes LanguageConstraints
constraints

literalTypeIsSupported :: LanguageConstraints -> LiteralType -> Bool
literalTypeIsSupported :: LanguageConstraints -> LiteralType -> Bool
literalTypeIsSupported LanguageConstraints
constraints LiteralType
at = LiteralVariant -> Set LiteralVariant -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member (LiteralType -> LiteralVariant
literalTypeVariant LiteralType
at) (LanguageConstraints -> Set LiteralVariant
languageConstraintsLiteralVariants LanguageConstraints
constraints)
  Bool -> Bool -> Bool
&& case LiteralType
at of
    LiteralTypeFloat FloatType
ft -> LanguageConstraints -> FloatType -> Bool
floatTypeIsSupported LanguageConstraints
constraints FloatType
ft
    LiteralTypeInteger IntegerType
it -> LanguageConstraints -> IntegerType -> Bool
integerTypeIsSupported LanguageConstraints
constraints IntegerType
it
    LiteralType
_ -> Bool
True

nameToFilePath :: Bool -> FileExtension -> Name -> FilePath
nameToFilePath :: Bool -> FileExtension -> Name -> String
nameToFilePath Bool
caps FileExtension
ext Name
name = Bool -> FileExtension -> Namespace -> String
namespaceToFilePath Bool
caps FileExtension
ext (Namespace -> String) -> Namespace -> String
forall a b. (a -> b) -> a -> b
$ String -> Namespace
Namespace (String -> Namespace) -> String -> Namespace
forall a b. (a -> b) -> a -> b
$ String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
local
  where
    QualifiedName Maybe Namespace
ns String
local = Name -> QualifiedName
qualifyNameEager Name
name
    prefix :: String
prefix = String -> (Namespace -> String) -> Maybe Namespace -> String
forall b a. b -> (a -> b) -> Maybe a -> b
Y.maybe String
"" (\(Namespace String
gname) -> String
gname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/") Maybe Namespace
ns

typeIsSupported :: LanguageConstraints -> Type -> Bool
typeIsSupported :: LanguageConstraints -> Type -> Bool
typeIsSupported LanguageConstraints
constraints Type
t = LanguageConstraints -> Type -> Bool
languageConstraintsTypes LanguageConstraints
constraints Type
base -- these are *additional* type constraints
  Bool -> Bool -> Bool
&& TypeVariant -> Bool
isSupportedVariant (Type -> TypeVariant
typeVariant Type
base)
  Bool -> Bool -> Bool
&& case Type
base of
    TypeLiteral LiteralType
at -> LanguageConstraints -> LiteralType -> Bool
literalTypeIsSupported LanguageConstraints
constraints LiteralType
at
    TypeFunction (FunctionType Type
dom Type
cod) -> LanguageConstraints -> Type -> Bool
typeIsSupported LanguageConstraints
constraints Type
dom Bool -> Bool -> Bool
&& LanguageConstraints -> Type -> Bool
typeIsSupported LanguageConstraints
constraints Type
cod
    TypeList Type
lt -> LanguageConstraints -> Type -> Bool
typeIsSupported LanguageConstraints
constraints Type
lt
    TypeMap (MapType Type
kt Type
vt) -> LanguageConstraints -> Type -> Bool
typeIsSupported LanguageConstraints
constraints Type
kt Bool -> Bool -> Bool
&& LanguageConstraints -> Type -> Bool
typeIsSupported LanguageConstraints
constraints Type
vt
    TypeWrap WrappedType
_ -> Bool
True -- TODO: dereference the type
    TypeOptional Type
t -> LanguageConstraints -> Type -> Bool
typeIsSupported LanguageConstraints
constraints Type
t
    TypeRecord RowType
rt -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ LanguageConstraints -> Type -> Bool
typeIsSupported LanguageConstraints
constraints (Type -> Bool) -> (FieldType -> Type) -> FieldType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldType -> Type
fieldTypeType (FieldType -> Bool) -> [FieldType] -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowType -> [FieldType]
rowTypeFields RowType
rt
    TypeSet Type
st -> LanguageConstraints -> Type -> Bool
typeIsSupported LanguageConstraints
constraints Type
st
    TypeUnion RowType
rt -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ LanguageConstraints -> Type -> Bool
typeIsSupported LanguageConstraints
constraints (Type -> Bool) -> (FieldType -> Type) -> FieldType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldType -> Type
fieldTypeType (FieldType -> Bool) -> [FieldType] -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowType -> [FieldType]
rowTypeFields RowType
rt
    Type
_ -> Bool
True
  where
    isSupportedVariant :: TypeVariant -> Bool
isSupportedVariant TypeVariant
v = TypeVariant
v TypeVariant -> TypeVariant -> Bool
forall a. Eq a => a -> a -> Bool
== TypeVariant
TypeVariantVariable Bool -> Bool -> Bool
|| TypeVariant -> Set TypeVariant -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member TypeVariant
v (LanguageConstraints -> Set TypeVariant
languageConstraintsTypeVariants LanguageConstraints
constraints)
    base :: Type
base = Type -> Type
stripType Type
t

unidirectionalCoder :: (a -> Flow s b) -> Coder s s a b
unidirectionalCoder :: forall a s b. (a -> Flow s b) -> Coder s s a b
unidirectionalCoder a -> Flow s b
m = Coder {
  coderEncode :: a -> Flow s b
coderEncode = a -> Flow s b
m,
  coderDecode :: b -> Flow s a
coderDecode = \b
_ -> String -> Flow s a
forall a. String -> Flow s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"inbound mapping is unsupported"}