{-# OPTIONS_GHC -fplugin=IfSat.Plugin #-}

module Temporal.Codec.Optimal (
  defaultCodec,
  Composite (..),
  module Data.Constraint.If,
) where

import Data.Constraint.If
import Data.Kind
import qualified Data.Map.Strict as Map
import Data.Proxy
import GHC.TypeLits
import Temporal.Payload


{- | The 'Composite' codec allows you to combine multiple codecs into one.

The codecs are tried in order, and the first one that succeeds is used.
If none of the codecs succeed, the compile-time error message will indicate
the type that didn't satisfy any of the specified codecs.

This Codec is useful when you want to support multiple serialization formats
and choose the best / most performant one for each type.

Note that this Codec relies upon the 'if-instance' package, which supplies
a compiler plugin that allows us to use this. You must add the following
pragma to the module that registers your workflow code:

> {\-# OPTIONS_GHC -fplugin=IfSat.Plugin #-\}
> -- ^ Put this at the top of the module that registers your workflow code.
>
> let testFn :: Int -> Text -> Bool -> W.Workflow () () (Int, Text, Bool)
>     testFn a b c = pure (a, b, c)
>     wf = W.provideWorkflow defaultCodec "test" () testFn
>     conf = configure () () $ do
>       addWorkflow wf

If you forget to add this pragma, your code will fail to compile with
a message like:

> hs-temporal/test/IntegrationSpec.hs:66:16: error:
>    • No instance for (Codec Null ()
>                       Data.Constraint.If.|| Codec
>                                               (Temporal.Payload.Composite
>                                                  '[Binary, Protobuf, JSON])
>                                               ())
>        arising from a use of ‘W.provideWorkflow’
>    • In the expression:
>        W.provideWorkflow defaultCodec "test" () testFn
>      In an equation for ‘wf’:
>          wf = W.provideWorkflow defaultCodec "test" () testFn
>      In the expression:
>        do taskQueue <- W.TaskQueue <$> uuidText
>           let testFn :: W.Workflow () () ()
>               testFn = pure ()
>               ....
>           withWorker conf
>             $ do wfId <- uuidText
>                  let ...
>                  ....
>   |
>66 |           wf = W.provideWorkflow defaultCodec "test" () testFn
>   |                ^^^^^^^^^^^^^^^^^
-}
data Composite (codecs :: [Type]) where
  CompositeNil :: Composite '[]
  CompositeCons :: codec -> Composite codecs -> Composite (codec ': codecs)


instance TypeError ('ShowType a ':<>: 'Text " is not supported by any of the provided codecs") => Codec (Composite '[]) a where
  messageType :: Composite '[] -> a -> ByteString
messageType = String -> Composite '[] -> a -> ByteString
forall a. HasCallStack => String -> a
error String
"unreachable"
  encoding :: Composite '[] -> Proxy a -> ByteString
encoding = String -> Composite '[] -> Proxy a -> ByteString
forall a. HasCallStack => String -> a
error String
"unreachable"
  encode :: Composite '[] -> a -> IO Payload
encode = String -> Composite '[] -> a -> IO Payload
forall a. HasCallStack => String -> a
error String
"unreachable"
  decode :: Composite '[] -> Payload -> IO (Either String a)
decode Composite '[]
_ Payload
_ = Either String a -> IO (Either String a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String a -> IO (Either String a))
-> Either String a -> IO (Either String a)
forall a b. (a -> b) -> a -> b
$ String -> Either String a
forall a b. a -> Either a b
Left String
"No recognized codec for this type"


instance (Codec fmt a || Codec (Composite codecs) a) => Codec (Composite (fmt ': codecs)) a where
  encoding :: Composite (fmt : codecs) -> Proxy a -> ByteString
encoding Composite (fmt : codecs)
fmt =
    forall (c :: Constraint) (d :: Constraint) r.
(c || d) =>
((IsSat c ~ 'True, c) => r)
-> ((IsSat c ~ 'False, IsSat d ~ 'True, d) => r) -> r
dispatch @(Codec fmt a) @(Codec (Composite codecs) a)
      (case Composite (fmt : codecs)
fmt of CompositeCons codec
codec Composite codecs
_ -> codec -> Proxy a -> ByteString
forall fmt a. Codec fmt a => fmt -> Proxy a -> ByteString
encoding codec
codec)
      (case Composite (fmt : codecs)
fmt of CompositeCons codec
_ Composite codecs
codecs -> Composite codecs -> Proxy a -> ByteString
forall fmt a. Codec fmt a => fmt -> Proxy a -> ByteString
encoding Composite codecs
codecs)
  messageType :: Composite (fmt : codecs) -> a -> ByteString
messageType Composite (fmt : codecs)
fmt =
    forall (c :: Constraint) (d :: Constraint) r.
(c || d) =>
((IsSat c ~ 'True, c) => r)
-> ((IsSat c ~ 'False, IsSat d ~ 'True, d) => r) -> r
dispatch @(Codec fmt a) @(Codec (Composite codecs) a)
      (case Composite (fmt : codecs)
fmt of CompositeCons codec
codec Composite codecs
_ -> codec -> a -> ByteString
forall fmt a. Codec fmt a => fmt -> a -> ByteString
messageType codec
codec)
      (case Composite (fmt : codecs)
fmt of CompositeCons codec
_ Composite codecs
codecs -> Composite codecs -> a -> ByteString
forall fmt a. Codec fmt a => fmt -> a -> ByteString
messageType Composite codecs
codecs)
  encode :: Composite (fmt : codecs) -> a -> IO Payload
encode Composite (fmt : codecs)
fmt =
    forall (c :: Constraint) (d :: Constraint) r.
(c || d) =>
((IsSat c ~ 'True, c) => r)
-> ((IsSat c ~ 'False, IsSat d ~ 'True, d) => r) -> r
dispatch @(Codec fmt a) @(Codec (Composite codecs) a)
      (case Composite (fmt : codecs)
fmt of CompositeCons codec
codec Composite codecs
_ -> codec -> a -> IO Payload
forall fmt a. Codec fmt a => fmt -> a -> IO Payload
encode codec
codec)
      (case Composite (fmt : codecs)
fmt of CompositeCons codec
_ Composite codecs
codecs -> Composite codecs -> a -> IO Payload
forall fmt a. Codec fmt a => fmt -> a -> IO Payload
encode Composite codecs
codecs)
  decode :: Composite (fmt : codecs) -> Payload -> IO (Either String a)
decode Composite (fmt : codecs)
fmt Payload
payload =
    forall (c :: Constraint) (d :: Constraint) r.
(c || d) =>
((IsSat c ~ 'True, c) => r)
-> ((IsSat c ~ 'False, IsSat d ~ 'True, d) => r) -> r
dispatch @(Codec fmt a) @(Codec (Composite codecs) a)
      ( case Composite (fmt : codecs)
fmt of
          CompositeCons codec
codec Composite codecs
codecs ->
            if ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (codec -> Proxy a -> ByteString
forall fmt a. Codec fmt a => fmt -> Proxy a -> ByteString
encoding codec
codec (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)) Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Payload
payload.payloadMetadata Map Text ByteString -> Text -> Maybe ByteString
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? Text
"encoding"
              then codec -> Payload -> IO (Either String a)
forall fmt a. Codec fmt a => fmt -> Payload -> IO (Either String a)
decode codec
codec Payload
payload
              else
                forall (ct :: Constraint) r.
IfSat ct =>
((IsSat ct ~ 'True, ct) => r) -> ((IsSat ct ~ 'False) => r) -> r
ifSat @(Codec (Composite codecs) a)
                  (Composite codecs -> Payload -> IO (Either String a)
forall fmt a. Codec fmt a => fmt -> Payload -> IO (Either String a)
decode Composite codecs
codecs Payload
payload)
                  (Either String a -> IO (Either String a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String a -> IO (Either String a))
-> Either String a -> IO (Either String a)
forall a b. (a -> b) -> a -> b
$ String -> Either String a
forall a b. a -> Either a b
Left String
"No codec for this type supports this payload")
      )
      (case Composite (fmt : codecs)
fmt of CompositeCons codec
_ Composite codecs
codecs -> Composite codecs -> Payload -> IO (Either String a)
forall fmt a. Codec fmt a => fmt -> Payload -> IO (Either String a)
decode Composite codecs
codecs Payload
payload)


defaultCodec :: Composite '[Null, Binary, Protobuf, JSON]
defaultCodec :: Composite '[Null, Binary, Protobuf, JSON]
defaultCodec = Null
-> Composite '[Binary, Protobuf, JSON]
-> Composite '[Null, Binary, Protobuf, JSON]
forall codec (codecs :: [*]).
codec -> Composite codecs -> Composite (codec : codecs)
CompositeCons Null
Temporal.Payload.Null (Composite '[Binary, Protobuf, JSON]
 -> Composite '[Null, Binary, Protobuf, JSON])
-> Composite '[Binary, Protobuf, JSON]
-> Composite '[Null, Binary, Protobuf, JSON]
forall a b. (a -> b) -> a -> b
$ Binary
-> Composite '[Protobuf, JSON]
-> Composite '[Binary, Protobuf, JSON]
forall codec (codecs :: [*]).
codec -> Composite codecs -> Composite (codec : codecs)
CompositeCons Binary
Binary (Composite '[Protobuf, JSON]
 -> Composite '[Binary, Protobuf, JSON])
-> Composite '[Protobuf, JSON]
-> Composite '[Binary, Protobuf, JSON]
forall a b. (a -> b) -> a -> b
$ Protobuf -> Composite '[JSON] -> Composite '[Protobuf, JSON]
forall codec (codecs :: [*]).
codec -> Composite codecs -> Composite (codec : codecs)
CompositeCons Protobuf
Protobuf (Composite '[JSON] -> Composite '[Protobuf, JSON])
-> Composite '[JSON] -> Composite '[Protobuf, JSON]
forall a b. (a -> b) -> a -> b
$ JSON -> Composite '[] -> Composite '[JSON]
forall codec (codecs :: [*]).
codec -> Composite codecs -> Composite (codec : codecs)
CompositeCons JSON
JSON Composite '[]
CompositeNil