{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{-# HLINT ignore "Use ++" #-}

{- |
Module      : Temporal.TH
Description : Template Haskell utilities for Temporal Workflow and Activity definitions
Stability   : experimental
Portability : POSIX

The `Temporal.TH` module provides Template Haskell-based utilities for defining,
configuring, and registering Temporal Workflows and Activities in a type-safe and
declarative manner. This module simplifies the process of integrating Temporal
with Haskell applications by automating much of the boilerplate code typically
required for setting up Workflows and Activities.

Key features of this module include:

1. Automatic registration of Workflows and Activities.
2. Type-safe configuration options for both Workflows and Activities.
3. Generation of necessary typeclass instances for Workflow and Activity functions.
4. Support for custom naming and aliasing of Activities.
5. Integration with Haskell's strong type system to ensure correctness at compile-time.

The main functions provided by this module are:

- 'registerWorkflow' and 'registerWorkflowWithOptions': For registering Workflow functions.
- 'registerActivity' and 'registerActivityWithOptions': For registering Activity functions.
- 'discoverDefinitions': For automatically discovering and collecting all defined Workflows and Activities.

When you apply the registration functions to your Workflow and Activity functions,
a number of things happen automatically:

1. The registration functions generate a new data type with the same name as your Workflow or Activity function (capitalized).
   Example: If you define a Workflow function named @myWorkflow@, the generated data type will be named @MyWorkflow@.
2. A number of type classes are generated or derived for your Workflow or Activity function to support invoking them.

Example usage:

@
{\-# LANGUAGE DerivingVia #-\}
{\-# LANGUAGE TemplateHaskell #-\}
{\-# LANGUAGE ImportQualifiedPost #-\}

module MyWorkflows where

import Language.Haskell.TH (newDeclarationGroup)
import RequireCallStack (provideCallStack)
import Temporal.Activity
import Temporal.TH
import Temporal.TH.Options
import Temporal.Workflow
import Temporal.Client qualified as Client

-- Simple activity registration
actWithoutTimeoutDefault :: Activity () ()
actWithoutTimeoutDefault = pure ()
\$(registerActivity 'actWithoutTimeoutDefault)

-- Activity registration with name override
actWithNameOverride :: Activity () ()
actWithNameOverride = pure ()
\$(registerActivityWithOptions 'actWithNameOverride defaultActivityConfiguration
  { actNameOverride = Just "my-name"
  })

-- Activity registration with aliases
actWithAliases :: Activity () ()
actWithAliases = pure ()
\$(registerActivityWithOptions 'actWithAliases defaultActivityConfiguration
  { actAliases = ["alias1", "alias2"]
  })

-- Workflow registration
myWorkflow :: Int -> Workflow ()
myWorkflow _ = pure ()
\$(registerWorkflow 'myWorkflow)

-- Use newDeclarationGroup to separate Template Haskell splices
\$(newDeclarationGroup)

-- Workflow referencing a child workflow
workflowReferencingChild :: Workflow ()
workflowReferencingChild = provideCallStack do
  _ <- startChildWorkflow MyWorkflow defaultChildWorkflowOptions 0
  executeChildWorkflow MyWorkflow defaultChildWorkflowOptions 1

-- Activity referencing a workflow
actionReferencingWorkflow :: Activity () ()
actionReferencingWorkflow = provideCallStack do
  _ <- Client.start MyWorkflow "1" (Client.startWorkflowOptions (TaskQueue "foo")) 1
  Client.execute MyWorkflow "2" (Client.startWorkflowOptions (TaskQueue "foo")) 1
@

Note the use of 'newDeclarationGroup' from "Language.Haskell.TH" to separate
Template Haskell splices, which can be necessary in some cases to avoid
compilation errors– namely, when you want to invoke a Workflow or Activity later
in the same module.

The one use case where the TH mechanism struggles is when you want to use the
'continueAsNew' function from "Temporal.Workflow" in a Workflow to start a new
instance of the same Workflow. In this case, you can define the machinery manually:

@
workflowThatContinuesAsNew :: Int -> Workflow ()
workflowThatContinuesAsNew x = do
  if x < 1000
  then continueAsNew WorkflowThatContinuesAsNew defaultContinueAsNewOptions (x + 1)
  else return ()

data WorkflowThatContinuesAsNew = WorkflowThatContinuesAsNew
  deriving anyclass (WorkflowFn)
  deriving (WorkflowDef, WorkflowRef) via WorkflowImpl WorkflowThatContinuesAsNew

instance Fn WorkflowThatContinuesAsNew where
  fnName = Text.pack $ show 'workflowThatContinuesAsNew
  fnDefinition _ = provideCallStack workflowThatContinuesAsNew
  fnSing = WorkflowThatContinuesAsNew
@
-}
module Temporal.TH (
  discoverDefinitions,
  SomeDict,
  SomeDictOf (..),
  registerActivity,
  registerActivityWithOptions,
  ActivityConfig (..),
  defaultActivityConfig,
  registerWorkflow,
  registerWorkflowWithOptions,
  WorkflowConfig (..),
  defaultWorkflowConfig,
  Fn (..),
  WorkflowFn (..),
  WorkflowRef (..),
  WorkflowDef (..),
  ActivityFn (..),
  ActivityRef (..),
  ActivityDef (..),
  fnSingE,
  fnSingDataAndConName,
  ActivityImpl (..),
  WorkflowImpl (..),
  bringRegisteredTemporalFunctionsIntoScope,
) where

import qualified Data.HashMap.Strict as Map
import Data.Typeable
import DiscoverInstances
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Lib
import qualified Language.Haskell.TH.Syntax as TH
import qualified Temporal.Activity as Act
import Temporal.Activity.Definition (ActivityDef (..))
import Temporal.TH.Classes
import Temporal.TH.Internal
import Temporal.Worker (Definitions (..))
import Temporal.Workflow
import qualified Temporal.Workflow as Wf
import Temporal.Workflow.Definition (WorkflowDef (..))


registerActivityWithOptions :: forall codec m. (TH.Quote m, TH.Quasi m, TH.Lift codec) => TH.Name -> ActivityConfig codec -> m [TH.Dec]
registerActivityWithOptions :: forall codec (m :: * -> *).
(Quote m, Quasi m, Lift codec) =>
Name -> ActivityConfig codec -> m [Dec]
registerActivityWithOptions Name
n ActivityConfig codec
conf = do
  fnType <- Name -> m Type
forall (m :: * -> *). Quasi m => Name -> m Type
TH.qReifyType Name
n
  let dataName = Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> m Type) -> Name -> m Type
forall a b. (a -> b) -> a -> b
$ Name -> Name
fnSingDataAndConName Name
n
  baseDecls <- makeFnDecls n fnType
  actDefs <-
    [d|
      instance Temporal.TH.Classes.ActivityFn $dataName where
        activityConfig _ = conf


      deriving via (Temporal.TH.Classes.ActivityImpl $dataName) instance ActivityRef $dataName


      deriving via (Temporal.TH.Classes.ActivityImpl $dataName) instance ActivityDef $dataName
      |]
  pure $ concat [baseDecls, actDefs]


registerActivity :: forall m. (TH.Quote m, TH.Quasi m) => TH.Name -> m [TH.Dec]
registerActivity :: forall (m :: * -> *). (Quote m, Quasi m) => Name -> m [Dec]
registerActivity Name
n = Name -> ActivityConfig JSON -> m [Dec]
forall codec (m :: * -> *).
(Quote m, Quasi m, Lift codec) =>
Name -> ActivityConfig codec -> m [Dec]
registerActivityWithOptions Name
n ActivityConfig JSON
defaultActivityConfig


registerWorkflowWithOptions :: forall codec m. (TH.Quote m, TH.Quasi m, TH.Lift codec) => TH.Name -> WorkflowConfig codec -> m [TH.Dec]
registerWorkflowWithOptions :: forall codec (m :: * -> *).
(Quote m, Quasi m, Lift codec) =>
Name -> WorkflowConfig codec -> m [Dec]
registerWorkflowWithOptions Name
n WorkflowConfig codec
conf = do
  fnType <- Name -> m Type
forall (m :: * -> *). Quasi m => Name -> m Type
TH.qReifyType Name
n
  let dataName = Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> m Type) -> Name -> m Type
forall a b. (a -> b) -> a -> b
$ Name -> Name
fnSingDataAndConName Name
n
  baseDecls <- makeFnDecls n fnType
  additionalDecls <-
    [d|
      instance Temporal.TH.Classes.WorkflowFn $dataName where
        workflowConfig _ = conf


      deriving via (Temporal.TH.Classes.WorkflowImpl $dataName) instance WorkflowRef $dataName


      deriving via (Temporal.TH.Classes.WorkflowImpl $dataName) instance WorkflowDef $dataName
      |]

  pure $ concat [baseDecls, additionalDecls]


registerWorkflow :: forall m. (TH.Quote m, TH.Quasi m) => TH.Name -> m [TH.Dec]
registerWorkflow :: forall (m :: * -> *). (Quote m, Quasi m) => Name -> m [Dec]
registerWorkflow Name
n = Name -> WorkflowConfig JSON -> m [Dec]
forall codec (m :: * -> *).
(Quote m, Quasi m, Lift codec) =>
Name -> WorkflowConfig codec -> m [Dec]
registerWorkflowWithOptions Name
n WorkflowConfig JSON
defaultWorkflowConfig


-- | Alias for 'newDeclarationGroup' that makes the intent a bit more clear.
bringRegisteredTemporalFunctionsIntoScope :: TH.Q [TH.Dec]
bringRegisteredTemporalFunctionsIntoScope :: Q [Dec]
bringRegisteredTemporalFunctionsIntoScope = Q [Dec]
TH.newDeclarationGroup


---------------------------------------------------------------------------------------
-- Produce dictionaries

discoverDefinitions
  :: forall env
   . (RequireCallStack, Typeable env)
  => [SomeDict WorkflowFn]
  -> [SomeDict ActivityFn]
  -> Definitions env
discoverDefinitions :: forall env.
(RequireCallStack, Typeable env) =>
[SomeDict WorkflowFn] -> [SomeDict ActivityFn] -> Definitions env
discoverDefinitions [SomeDict WorkflowFn]
wfs [SomeDict ActivityFn]
acts =
  let
    aliasedWfs :: [(Text, WorkflowDefinition)]
aliasedWfs =
      (SomeDict WorkflowFn -> [(Text, WorkflowDefinition)])
-> [SomeDict WorkflowFn] -> [(Text, WorkflowDefinition)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        ( \(SomeDictOf Proxy a
inst) ->
            let def :: WorkflowDefinition
def = ProvidedWorkflow (FnType a) -> WorkflowDefinition
forall f. ProvidedWorkflow f -> WorkflowDefinition
Wf.definition (ProvidedWorkflow (FnType a) -> WorkflowDefinition)
-> ProvidedWorkflow (FnType a) -> WorkflowDefinition
forall a b. (a -> b) -> a -> b
$ a -> ProvidedWorkflow (FnType a)
forall f.
(WorkflowFn f, RequireCallStack) =>
f -> ProvidedWorkflow (FnType f)
Temporal.TH.Classes.workflowImpl (a -> ProvidedWorkflow (FnType a))
-> a -> ProvidedWorkflow (FnType a)
forall a b. (a -> b) -> a -> b
$ Proxy a -> a
forall t. Fn t => Proxy t -> t
fn Proxy a
inst
            in (WorkflowDefinition -> Text
Wf.workflowName WorkflowDefinition
def, WorkflowDefinition
def) (Text, WorkflowDefinition)
-> [(Text, WorkflowDefinition)] -> [(Text, WorkflowDefinition)]
forall a. a -> [a] -> [a]
: (Text -> (Text, WorkflowDefinition))
-> [Text] -> [(Text, WorkflowDefinition)]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
alias -> (Text
alias, WorkflowDefinition
def {Wf.workflowName = alias})) (WorkflowConfig (WorkflowCodec a) -> [Text]
forall codec. WorkflowConfig codec -> [Text]
workflowConfigAliases (WorkflowConfig (WorkflowCodec a) -> [Text])
-> WorkflowConfig (WorkflowCodec a) -> [Text]
forall a b. (a -> b) -> a -> b
$ a -> WorkflowConfig (WorkflowCodec a)
forall f. WorkflowFn f => f -> WorkflowConfig (WorkflowCodec f)
workflowConfig (a -> WorkflowConfig (WorkflowCodec a))
-> a -> WorkflowConfig (WorkflowCodec a)
forall a b. (a -> b) -> a -> b
$ Proxy a -> a
forall t. Fn t => Proxy t -> t
fn Proxy a
inst)
        )
        [SomeDict WorkflowFn]
wfs
    aliasedActs :: [(Text, ActivityDefinition env)]
aliasedActs =
      (SomeDict ActivityFn -> [(Text, ActivityDefinition env)])
-> [SomeDict ActivityFn] -> [(Text, ActivityDefinition env)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        ( \(SomeDictOf Proxy a
inst) -> case ActivityDefinition (FnActivityEnv (FnType a))
-> Maybe (ActivityDefinition env)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast (ProvidedActivity (FnActivityEnv (FnType a)) (FnType a)
-> ActivityDefinition (FnActivityEnv (FnType a))
forall env f. ProvidedActivity env f -> ActivityDefinition env
Act.definition (ProvidedActivity (FnActivityEnv (FnType a)) (FnType a)
 -> ActivityDefinition (FnActivityEnv (FnType a)))
-> ProvidedActivity (FnActivityEnv (FnType a)) (FnType a)
-> ActivityDefinition (FnActivityEnv (FnType a))
forall a b. (a -> b) -> a -> b
$ a -> ProvidedActivity (FnActivityEnv (FnType a)) (FnType a)
forall f.
(ActivityFn f, RequireCallStack) =>
f -> ProvidedActivity (FnActivityEnv (FnType f)) (FnType f)
Temporal.TH.Classes.activityImpl (a -> ProvidedActivity (FnActivityEnv (FnType a)) (FnType a))
-> a -> ProvidedActivity (FnActivityEnv (FnType a)) (FnType a)
forall a b. (a -> b) -> a -> b
$ Proxy a -> a
forall t. Fn t => Proxy t -> t
fn Proxy a
inst) of
            Just (ActivityDefinition env
def :: Act.ActivityDefinition env) ->
              (ActivityDefinition env -> Text
forall env. ActivityDefinition env -> Text
Act.activityName ActivityDefinition env
def, ActivityDefinition env
def) (Text, ActivityDefinition env)
-> [(Text, ActivityDefinition env)]
-> [(Text, ActivityDefinition env)]
forall a. a -> [a] -> [a]
: (Text -> (Text, ActivityDefinition env))
-> [Text] -> [(Text, ActivityDefinition env)]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
alias -> (Text
alias, ActivityDefinition env
def {Act.activityName = alias})) (ActivityConfig (ActivityCodec a) -> [Text]
forall c. ActivityConfig c -> [Text]
activityConfigAliases (ActivityConfig (ActivityCodec a) -> [Text])
-> ActivityConfig (ActivityCodec a) -> [Text]
forall a b. (a -> b) -> a -> b
$ a -> ActivityConfig (ActivityCodec a)
forall f. ActivityFn f => f -> ActivityConfig (ActivityCodec f)
activityConfig (a -> ActivityConfig (ActivityCodec a))
-> a -> ActivityConfig (ActivityCodec a)
forall a b. (a -> b) -> a -> b
$ Proxy a -> a
forall t. Fn t => Proxy t -> t
fn Proxy a
inst)
            Maybe (ActivityDefinition env)
Nothing -> []
        )
        [SomeDict ActivityFn]
acts
  in
    HashMap Text WorkflowDefinition
-> HashMap Text (ActivityDefinition env) -> Definitions env
forall env.
HashMap Text WorkflowDefinition
-> HashMap Text (ActivityDefinition env) -> Definitions env
Definitions
      ((WorkflowDefinition -> WorkflowDefinition -> WorkflowDefinition)
-> [(Text, WorkflowDefinition)] -> HashMap Text WorkflowDefinition
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
Map.fromListWith (\WorkflowDefinition
l WorkflowDefinition
_ -> [Char] -> WorkflowDefinition
forall a. HasCallStack => [Char] -> a
error ([Char]
"Encountered duplicate Workflow definition names: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show (WorkflowDefinition -> Text
Wf.workflowName WorkflowDefinition
l))) [(Text, WorkflowDefinition)]
aliasedWfs)
      ((ActivityDefinition env
 -> ActivityDefinition env -> ActivityDefinition env)
-> [(Text, ActivityDefinition env)]
-> HashMap Text (ActivityDefinition env)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
Map.fromListWith (\ActivityDefinition env
l ActivityDefinition env
_ -> [Char] -> ActivityDefinition env
forall a. HasCallStack => [Char] -> a
error ([Char]
"Encountered duplicate Activity definition names: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show (ActivityDefinition env -> Text
forall env. ActivityDefinition env -> Text
Act.activityName ActivityDefinition env
l))) [(Text, ActivityDefinition env)]
aliasedActs)