module Hydra.Adapters.UtilsEtc (
  module Hydra.Adapters.UtilsEtc,
  module Hydra.Adapters.Utils,
  module Hydra.Common,
) where

import Hydra.Common
import Hydra.Core
import Hydra.Basics
import Hydra.Module
import Hydra.Monads
import Hydra.Compute
import Hydra.Adapters.Utils
import qualified Hydra.Lib.Strings as Strings
import Hydra.Util.Formatting
import Hydra.Rewriting
import Hydra.Util.Context
import qualified Hydra.Impl.Haskell.Dsl.Terms as Terms

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


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

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 = 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 forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 forall s a. Coder s s a a
idCoder
  else do
    -- Uncomment to debug adapter cycles
    --debugCheckType typ

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

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [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 = forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder s s a b
c1 forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m 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 = forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v2 -> Flow s2 v1
coderDecode Coder s s b c
c2 forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> 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 = forall a. Show a => a -> String
show t
typ
  Set String
types <- forall s. String -> Term Meta -> Flow s (Term Meta)
getAttrWithDefault String
"types" (forall m. Set (Term m) -> Term m
Terms.set forall a. Set a
S.empty) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a m s.
(Ord a, Show m) =>
(Term m -> Flow s a) -> Term m -> Flow s (Set a)
Terms.expectSet forall m s. Show m => Term m -> Flow s String
Terms.expectString
  if forall a. Ord a => a -> Set a -> Bool
S.member String
s Set String
types
    then forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"detected a cycle; type has already been encountered: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
typ
    else forall s. String -> Term Meta -> Flow s ()
putAttr String
"types" forall a b. (a -> b) -> a -> b
$ forall m. Set (Term m) -> Term m
Terms.set forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
S.fromList (forall m. String -> Term m
Terms.string forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
S.insert String
s Set String
types))
  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 = forall a. Show a => a -> String
show t
typ
  Set String
types <- forall s. String -> Term Meta -> Flow s (Term Meta)
getAttrWithDefault String
"types" (forall m. Set (Term m) -> Term m
Terms.set forall a. Set a
S.empty) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a m s.
(Ord a, Show m) =>
(Term m -> Flow s a) -> Term m -> Flow s (Set a)
Terms.expectSet forall m s. Show m => Term m -> Flow s String
Terms.expectString
  let types' :: Set String
types' = forall a. Ord a => a -> Set a -> Set a
S.delete String
s Set String
types
  forall s. String -> Term Meta -> Flow s ()
putAttr String
"types" forall a b. (a -> b) -> a -> b
$ forall m. Set (Term m) -> Term m
Terms.set forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
S.fromList (forall m. String -> Term m
Terms.string forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
S.insert String
s Set String
types'))

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

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

idAdapter :: t -> SymmetricAdapter s t v
idAdapter :: forall t s v. t -> SymmetricAdapter s t v
idAdapter t
t = 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 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 = forall s1 s2 v1 v2.
(v1 -> Flow s1 v2) -> (v2 -> Flow s2 v1) -> Coder s1 s2 v1 v2
Coder forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a. Applicative f => a -> f a
pure

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

literalTypeIsSupported :: LanguageConstraints m -> LiteralType -> Bool
literalTypeIsSupported :: forall m. LanguageConstraints m -> LiteralType -> Bool
literalTypeIsSupported LanguageConstraints m
constraints LiteralType
at = forall a. Ord a => a -> Set a -> Bool
S.member (LiteralType -> LiteralVariant
literalTypeVariant LiteralType
at) (forall m. LanguageConstraints m -> Set LiteralVariant
languageConstraintsLiteralVariants LanguageConstraints m
constraints)
  Bool -> Bool -> Bool
&& case LiteralType
at of
    LiteralTypeFloat FloatType
ft -> forall m. LanguageConstraints m -> FloatType -> Bool
floatTypeIsSupported LanguageConstraints m
constraints FloatType
ft
    LiteralTypeInteger IntegerType
it -> forall m. LanguageConstraints m -> IntegerType -> Bool
integerTypeIsSupported LanguageConstraints m
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 forall a b. (a -> b) -> a -> b
$ String -> Namespace
Namespace forall a b. (a -> b) -> a -> b
$ String
gname forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ String
local
  where
    (Namespace String
gname, String
local) = Name -> (Namespace, String)
toQnameEager Name
name

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

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
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"inbound mapping is unsupported"}