{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Temporal.TH.Classes where

import Data.Kind (Type)
import Data.Maybe (fromMaybe)
import qualified Data.Text as Text
import Data.Typeable
import qualified Language.Haskell.TH.Syntax as TH
import RequireCallStack (provideCallStack)
import Temporal.Activity
import Temporal.Activity.Definition
import Temporal.Payload
import Temporal.Workflow
import Temporal.Workflow.Definition


class Fn t where
  type FnType t :: Type
  fnName :: t -> Text.Text
  fnDefinition :: t -> (RequireCallStack => FnType t)
  fnSing :: t


fn :: Fn t => Proxy t -> t
fn :: forall t. Fn t => Proxy t -> t
fn Proxy t
_ = t
forall t. Fn t => t
fnSing


data WorkflowConfig codec = WorkflowConfig
  { -- clientDefaultOptions :: Maybe StartWorkflowOptions
    -- , childWorkflowDefaultOptions :: Maybe StartChildWorkflowOptions
    forall codec. WorkflowConfig codec -> Maybe Text
workflowConfigNameOverride :: Maybe Text.Text
  , forall codec. WorkflowConfig codec -> [Text]
workflowConfigAliases :: [Text.Text]
  , -- TODO, add support for custom metadata like alerting channels
    -- , customMetadata :: _
    forall codec. WorkflowConfig codec -> codec
workflowConfigCodec :: codec
  }
  deriving stock (Int -> WorkflowConfig codec -> ShowS
[WorkflowConfig codec] -> ShowS
WorkflowConfig codec -> String
(Int -> WorkflowConfig codec -> ShowS)
-> (WorkflowConfig codec -> String)
-> ([WorkflowConfig codec] -> ShowS)
-> Show (WorkflowConfig codec)
forall codec. Show codec => Int -> WorkflowConfig codec -> ShowS
forall codec. Show codec => [WorkflowConfig codec] -> ShowS
forall codec. Show codec => WorkflowConfig codec -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall codec. Show codec => Int -> WorkflowConfig codec -> ShowS
showsPrec :: Int -> WorkflowConfig codec -> ShowS
$cshow :: forall codec. Show codec => WorkflowConfig codec -> String
show :: WorkflowConfig codec -> String
$cshowList :: forall codec. Show codec => [WorkflowConfig codec] -> ShowS
showList :: [WorkflowConfig codec] -> ShowS
Show, (forall (m :: * -> *). Quote m => WorkflowConfig codec -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    WorkflowConfig codec -> Code m (WorkflowConfig codec))
-> Lift (WorkflowConfig codec)
forall codec (m :: * -> *).
(Lift codec, Quote m) =>
WorkflowConfig codec -> m Exp
forall codec (m :: * -> *).
(Lift codec, Quote m) =>
WorkflowConfig codec -> Code m (WorkflowConfig codec)
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => WorkflowConfig codec -> m Exp
forall (m :: * -> *).
Quote m =>
WorkflowConfig codec -> Code m (WorkflowConfig codec)
$clift :: forall codec (m :: * -> *).
(Lift codec, Quote m) =>
WorkflowConfig codec -> m Exp
lift :: forall (m :: * -> *). Quote m => WorkflowConfig codec -> m Exp
$cliftTyped :: forall codec (m :: * -> *).
(Lift codec, Quote m) =>
WorkflowConfig codec -> Code m (WorkflowConfig codec)
liftTyped :: forall (m :: * -> *).
Quote m =>
WorkflowConfig codec -> Code m (WorkflowConfig codec)
TH.Lift)


class (Fn f) => WorkflowFn (f :: Type) where
  type WorkflowCodec f :: Type
  type WorkflowCodec _ = JSON


  workflowImpl :: RequireCallStack => f -> ProvidedWorkflow (FnType f)
  default workflowImpl
    :: ( RequireCallStack
       , FnType f ~ (ArgsOf (FnType f) :->: Workflow (ResultOf Workflow (FnType f)))
       , FunctionSupportsCodec (WorkflowCodec f) (ArgsOf (FnType f)) (ResultOf Workflow (FnType f))
       )
    => f
    -> ProvidedWorkflow (FnType f)
  workflowImpl f
x = f
-> WorkflowConfig (WorkflowCodec f) -> ProvidedWorkflow (FnType f)
forall f codec.
(RequireCallStack, Fn f,
 FnType f
 ~ (ArgsOf (FnType f) :->: Workflow (ResultOf Workflow (FnType f))),
 FunctionSupportsCodec
   codec (ArgsOf (FnType f)) (ResultOf Workflow (FnType f))) =>
f -> WorkflowConfig codec -> ProvidedWorkflow (FnType f)
workflowRefWithCodec f
x (f -> WorkflowConfig (WorkflowCodec f)
forall f. WorkflowFn f => f -> WorkflowConfig (WorkflowCodec f)
workflowConfig f
x)


  workflowConfig :: f -> WorkflowConfig (WorkflowCodec f)
  default workflowConfig :: (WorkflowCodec f ~ JSON) => f -> WorkflowConfig (WorkflowCodec f)
  workflowConfig f
_ = WorkflowConfig JSON
WorkflowConfig (WorkflowCodec f)
defaultWorkflowConfig


newtype WorkflowImpl f = WorkflowImpl f


instance (Fn f, WorkflowFn f) => WorkflowDef (WorkflowImpl f) where
  workflowDefinition :: WorkflowImpl f -> WorkflowDefinition
workflowDefinition (WorkflowImpl f
f) = (RequireCallStackImpl => WorkflowDefinition) -> WorkflowDefinition
forall r. (RequireCallStackImpl => r) -> r
provideCallStack (f -> ProvidedWorkflow (FnType f)
forall f.
(WorkflowFn f, RequireCallStack) =>
f -> ProvidedWorkflow (FnType f)
Temporal.TH.Classes.workflowImpl f
f).definition


instance (Fn f, WorkflowFn f) => WorkflowRef (WorkflowImpl f) where
  type WorkflowArgs (WorkflowImpl f) = ArgsOf (FnType f)
  type WorkflowResult (WorkflowImpl f) = ResultOf Workflow (FnType f)
  workflowRef :: WorkflowImpl f
-> KnownWorkflow
     (WorkflowArgs (WorkflowImpl f)) (WorkflowResult (WorkflowImpl f))
workflowRef (WorkflowImpl f
f) = (RequireCallStackImpl =>
 KnownWorkflow (ArgsOf (FnType f)) (ResultOf Workflow (FnType f)))
-> KnownWorkflow (ArgsOf (FnType f)) (ResultOf Workflow (FnType f))
forall r. (RequireCallStackImpl => r) -> r
provideCallStack (f -> ProvidedWorkflow (FnType f)
forall f.
(WorkflowFn f, RequireCallStack) =>
f -> ProvidedWorkflow (FnType f)
Temporal.TH.Classes.workflowImpl f
f).reference


defaultWorkflowConfig :: WorkflowConfig JSON
defaultWorkflowConfig :: WorkflowConfig JSON
defaultWorkflowConfig = Maybe Text -> [Text] -> JSON -> WorkflowConfig JSON
forall codec. Maybe Text -> [Text] -> codec -> WorkflowConfig codec
WorkflowConfig Maybe Text
forall a. Maybe a
Nothing [] JSON
JSON


workflowRefWithCodec
  :: ( RequireCallStack
     , Fn f
     , FnType f ~ (ArgsOf (FnType f) :->: Workflow (ResultOf Workflow (FnType f)))
     , FunctionSupportsCodec codec (ArgsOf (FnType f)) (ResultOf Workflow (FnType f))
     )
  => f
  -> WorkflowConfig codec
  -> ProvidedWorkflow (FnType f)
workflowRefWithCodec :: forall f codec.
(RequireCallStack, Fn f,
 FnType f
 ~ (ArgsOf (FnType f) :->: Workflow (ResultOf Workflow (FnType f))),
 FunctionSupportsCodec
   codec (ArgsOf (FnType f)) (ResultOf Workflow (FnType f))) =>
f -> WorkflowConfig codec -> ProvidedWorkflow (FnType f)
workflowRefWithCodec f
p WorkflowConfig codec
conf = codec
-> Text
-> (RequireCallStackImpl => FnType f)
-> ProvidedWorkflow (FnType f)
forall codec f.
(f ~ (ArgsOf f :->: Workflow (ResultOf Workflow f)),
 FunctionSupportsCodec codec (ArgsOf f) (ResultOf Workflow f)) =>
codec -> Text -> (RequireCallStackImpl => f) -> ProvidedWorkflow f
provideWorkflow WorkflowConfig codec
conf.workflowConfigCodec (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (f -> Text
forall t. Fn t => t -> Text
fnName f
p) (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ WorkflowConfig codec -> Maybe Text
forall codec. WorkflowConfig codec -> Maybe Text
workflowConfigNameOverride WorkflowConfig codec
conf) ((RequireCallStackImpl => FnType f) -> ProvidedWorkflow (FnType f))
-> (RequireCallStackImpl => FnType f)
-> ProvidedWorkflow (FnType f)
forall a b. (a -> b) -> a -> b
$ f -> RequireCallStack => FnType f
forall t. Fn t => t -> RequireCallStack => FnType t
fnDefinition f
p


data ActivityConfig c = ActivityConfig
  { forall c. ActivityConfig c -> Maybe Text
activityConfigNameOverride :: Maybe Text.Text
  , -- TODO, add support for custom metadata like alerting channels
    -- , customMetadata :: _
    forall c. ActivityConfig c -> [Text]
activityConfigAliases :: [Text.Text]
  , forall c. ActivityConfig c -> c
activityConfigCodec :: c
  }
  deriving stock ((forall (m :: * -> *). Quote m => ActivityConfig c -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    ActivityConfig c -> Code m (ActivityConfig c))
-> Lift (ActivityConfig c)
forall c (m :: * -> *).
(Lift c, Quote m) =>
ActivityConfig c -> m Exp
forall c (m :: * -> *).
(Lift c, Quote m) =>
ActivityConfig c -> Code m (ActivityConfig c)
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => ActivityConfig c -> m Exp
forall (m :: * -> *).
Quote m =>
ActivityConfig c -> Code m (ActivityConfig c)
$clift :: forall c (m :: * -> *).
(Lift c, Quote m) =>
ActivityConfig c -> m Exp
lift :: forall (m :: * -> *). Quote m => ActivityConfig c -> m Exp
$cliftTyped :: forall c (m :: * -> *).
(Lift c, Quote m) =>
ActivityConfig c -> Code m (ActivityConfig c)
liftTyped :: forall (m :: * -> *).
Quote m =>
ActivityConfig c -> Code m (ActivityConfig c)
TH.Lift)


defaultActivityConfig :: ActivityConfig JSON
defaultActivityConfig :: ActivityConfig JSON
defaultActivityConfig = Maybe Text -> [Text] -> JSON -> ActivityConfig JSON
forall c. Maybe Text -> [Text] -> c -> ActivityConfig c
ActivityConfig Maybe Text
forall a. Maybe a
Nothing [] JSON
JSON


type family FnActivityEnv f where
  FnActivityEnv (Activity env _a) = env
  FnActivityEnv (_ -> Activity env _a) = env
  FnActivityEnv (_ -> b) = FnActivityEnv b


class (Fn f, Typeable (FnActivityEnv (FnType f))) => ActivityFn f where
  type ActivityCodec f :: Type
  type ActivityCodec _ = JSON


  activityEnvType :: f -> TypeRep
  activityEnvType f
_ = Proxy (FnActivityEnv (FnType f)) -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy (FnActivityEnv (FnType f))
forall {k} (t :: k). Proxy t
Proxy :: Proxy (FnActivityEnv (FnType f)))


  activityImpl
    :: ( RequireCallStack
       )
    => f
    -> ProvidedActivity (FnActivityEnv (FnType f)) (FnType f)
  default activityImpl
    :: ( RequireCallStack
       , env ~ FnActivityEnv (FnType f)
       , FnType f ~ (ArgsOf (FnType f) :->: Activity env (ResultOf (Activity env) (FnType f)))
       , FunctionSupportsCodec (ActivityCodec f) (ArgsOf (FnType f)) (ResultOf (Activity env) (FnType f))
       )
    => f
    -> ProvidedActivity (FnActivityEnv (FnType f)) (FnType f)
  activityImpl f
x = f -> ActivityCodec f -> ProvidedActivity env (FnType f)
forall f env codec.
(RequireCallStack, ActivityFn f, env ~ FnActivityEnv (FnType f),
 FnType f
 ~ (ArgsOf (FnType f)
    :->: Activity env (ResultOf (Activity env) (FnType f))),
 FunctionSupportsCodec
   codec (ArgsOf (FnType f)) (ResultOf (Activity env) (FnType f))) =>
f -> codec -> ProvidedActivity env (FnType f)
activityRefWithCodec f
x (ActivityConfig (ActivityCodec f) -> ActivityCodec f
forall c. ActivityConfig c -> c
activityConfigCodec (ActivityConfig (ActivityCodec f) -> ActivityCodec f)
-> ActivityConfig (ActivityCodec f) -> ActivityCodec f
forall a b. (a -> b) -> a -> b
$ f -> ActivityConfig (ActivityCodec f)
forall f. ActivityFn f => f -> ActivityConfig (ActivityCodec f)
activityConfig f
x)


  activityConfig :: f -> ActivityConfig (ActivityCodec f)
  default activityConfig :: (ActivityCodec f ~ JSON) => f -> ActivityConfig (ActivityCodec f)
  activityConfig f
_ = ActivityConfig JSON
ActivityConfig (ActivityCodec f)
defaultActivityConfig


newtype ActivityImpl f = ActivityImpl f


instance (Fn f, ActivityFn f) => ActivityDef (ActivityImpl f) where
  type ActivityDefinitionEnv (ActivityImpl f) = FnActivityEnv (FnType f)
  activityDefinition :: ActivityImpl f
-> ActivityDefinition (ActivityDefinitionEnv (ActivityImpl f))
activityDefinition (ActivityImpl f
f) = (RequireCallStackImpl =>
 ActivityDefinition (FnActivityEnv (FnType f)))
-> ActivityDefinition (FnActivityEnv (FnType f))
forall r. (RequireCallStackImpl => r) -> r
provideCallStack (f -> ProvidedActivity (FnActivityEnv (FnType f)) (FnType f)
forall f.
(ActivityFn f, RequireCallStack) =>
f -> ProvidedActivity (FnActivityEnv (FnType f)) (FnType f)
Temporal.TH.Classes.activityImpl f
f).definition


instance (Fn f, ActivityFn f) => ActivityRef (ActivityImpl f) where
  type ActivityArgs (ActivityImpl f) = ArgsOf (FnType f)
  type ActivityResult (ActivityImpl f) = ResultOf (Activity (FnActivityEnv (FnType f))) (FnType f)
  activityRef :: ActivityImpl f
-> KnownActivity
     (ActivityArgs (ActivityImpl f)) (ActivityResult (ActivityImpl f))
activityRef (ActivityImpl f
f) = (RequireCallStackImpl =>
 KnownActivity
   (ArgsOf (FnType f))
   (ResultOf (Activity (FnActivityEnv (FnType f))) (FnType f)))
-> KnownActivity
     (ArgsOf (FnType f))
     (ResultOf (Activity (FnActivityEnv (FnType f))) (FnType f))
forall r. (RequireCallStackImpl => r) -> r
provideCallStack (f -> ProvidedActivity (FnActivityEnv (FnType f)) (FnType f)
forall f.
(ActivityFn f, RequireCallStack) =>
f -> ProvidedActivity (FnActivityEnv (FnType f)) (FnType f)
Temporal.TH.Classes.activityImpl f
f).reference


activityRefWithCodec
  :: ( RequireCallStack
     , ActivityFn f
     , env ~ FnActivityEnv (FnType f)
     , FnType f ~ (ArgsOf (FnType f) :->: Activity env (ResultOf (Activity env) (FnType f)))
     , FunctionSupportsCodec codec (ArgsOf (FnType f)) (ResultOf (Activity env) (FnType f))
     )
  => f
  -> codec
  -> ProvidedActivity env (FnType f)
activityRefWithCodec :: forall f env codec.
(RequireCallStack, ActivityFn f, env ~ FnActivityEnv (FnType f),
 FnType f
 ~ (ArgsOf (FnType f)
    :->: Activity env (ResultOf (Activity env) (FnType f))),
 FunctionSupportsCodec
   codec (ArgsOf (FnType f)) (ResultOf (Activity env) (FnType f))) =>
f -> codec -> ProvidedActivity env (FnType f)
activityRefWithCodec f
p codec
c =
  codec -> Text -> FnType f -> ProvidedActivity env (FnType f)
forall codec env f.
(f ~ (ArgsOf f :->: Activity env (ResultOf (Activity env) f)),
 FunctionSupportsCodec
   codec (ArgsOf f) (ResultOf (Activity env) f)) =>
codec -> Text -> f -> ProvidedActivity env f
provideActivity
    codec
c
    (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (f -> Text
forall t. Fn t => t -> Text
fnName f
p) (ActivityConfig (ActivityCodec f) -> Maybe Text
forall c. ActivityConfig c -> Maybe Text
activityConfigNameOverride (ActivityConfig (ActivityCodec f) -> Maybe Text)
-> ActivityConfig (ActivityCodec f) -> Maybe Text
forall a b. (a -> b) -> a -> b
$ f -> ActivityConfig (ActivityCodec f)
forall f. ActivityFn f => f -> ActivityConfig (ActivityCodec f)
activityConfig f
p))
    (f -> RequireCallStack => FnType f
forall t. Fn t => t -> RequireCallStack => FnType t
fnDefinition f
p)