{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Temporal.TH.Internal where

import Data.Char
import qualified Data.Text as Text
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Lib
import qualified Language.Haskell.TH.Syntax as TH
import Temporal.Activity (Activity)
import Temporal.TH.Classes
import Temporal.Workflow


isOperator :: TH.Name -> Bool
isOperator :: Name -> Bool
isOperator Name
name =
  case Name -> [Char]
TH.nameBase Name
name of
    (Char
c : [Char]
_) -> (Char -> Bool
isSymbol Char
c Bool -> Bool -> Bool
|| Char -> Bool
isPunctuation Char
c) Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_'
    [Char]
_ -> Bool
False


-- N.B. This is used for declaring an instance in the current module,
-- so it can't be used outside of local instance declaration code, as it will
-- be out of scope.
fnSingDataAndConName :: TH.Name -> TH.Name
fnSingDataAndConName :: Name -> Name
fnSingDataAndConName Name
n
  | Name -> Bool
isOperator Name
n = [Char] -> Name
TH.mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
TH.nameBase Name
n
  | Bool
otherwise = [Char] -> Name
TH.mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ case Name -> [Char]
TH.nameBase Name
n of
      (Char
c : [Char]
rest) -> Char -> Char
toUpper Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
rest
      [] -> [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"fnSingDataAndConName: empty name"


makeFnDecls :: forall m. (TH.Quote m, TH.Quasi m) => TH.Name -> TH.Type -> m [TH.Dec]
makeFnDecls :: forall (m :: * -> *). (Quote m, Quasi m) => Name -> Type -> m [Dec]
makeFnDecls Name
n Type
t = do
  let dName :: Name
dName = Name -> Name
fnSingDataAndConName Name
n
  dataDec <-
    m Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [m Con]
-> [m DerivClause]
-> m Dec
forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [m Con]
-> [m DerivClause]
-> m Dec
dataD
      ([m Type] -> m Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [])
      Name
dName
      []
      Maybe Type
forall a. Maybe a
Nothing
      [ Name -> [m BangType] -> m Con
forall (m :: * -> *). Quote m => Name -> [m BangType] -> m Con
normalC Name
dName []
      ]
      []
  instDecs <-
    [d|
      instance Fn $(conT dName) where
        type FnType $(conT dName) = $(pure t)
        fnName _ = Text.pack $(TH.litE (TH.stringL $ show n))
        fnDefinition _ = $(varE n)
        fnSing = $(TH.conE dName)
      |]
  pure $ dataDec : instDecs


-- Safe to use in other modules, because we're using the Symbol to find it.
fnSingE :: forall m. (TH.Quote m, TH.Quasi m) => TH.Name -> m TH.Exp
fnSingE :: forall (m :: * -> *). (Quote m, Quasi m) => Name -> m Exp
fnSingE Name
n = [e|fnSing :: $(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)|]


splitArgsAndResult :: TH.Type -> ([TH.Type], TH.Type)
splitArgsAndResult :: Type -> (Cxt, Type)
splitArgsAndResult (TH.AppT (TH.AppT Type
TH.ArrowT Type
arg) Type
res) = let (Cxt
args, Type
result) = Type -> (Cxt, Type)
splitArgsAndResult Type
res in (Type
arg Type -> Cxt -> Cxt
forall a. a -> [a] -> [a]
: Cxt
args, Type
result)
splitArgsAndResult Type
res = ([], Type
res)


-- Get the 'a' out of 'Activity env a'
extractActivityResultType :: TH.Type -> TH.Type
extractActivityResultType :: Type -> Type
extractActivityResultType (TH.AppT (TH.AppT (TH.ConT Name
_) Type
_) Type
res) = Type
res
extractActivityResultType Type
_ = [Char] -> Type
forall a. HasCallStack => [Char] -> a
error [Char]
"Not a type application on Activity"


-- Get the 'a' out of 'Workflow a'
extractWorkflowResultType :: TH.Type -> TH.Type
extractWorkflowResultType :: Type -> Type
extractWorkflowResultType (TH.AppT (TH.ConT Name
_) Type
res) = Type
res
extractWorkflowResultType Type
_ = [Char] -> Type
forall a. HasCallStack => [Char] -> a
error [Char]
"Not a type application on Workflow"


isWorkflowFunction :: TH.Type -> Bool
isWorkflowFunction :: Type -> Bool
isWorkflowFunction Type
t = case Type -> (Cxt, Type)
splitArgsAndResult Type
t of
  (Cxt
_, TH.AppT (TH.ConT Name
n) Type
_) -> Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Workflow
  (Cxt, Type)
_ -> Bool
False


isActivityFunction :: TH.Type -> Bool
isActivityFunction :: Type -> Bool
isActivityFunction Type
t = case Type -> (Cxt, Type)
splitArgsAndResult Type
t of
  (Cxt
_, TH.AppT (TH.AppT (TH.ConT Name
n) Type
_) Type
_) -> Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Activity
  (Cxt, Type)
_ -> Bool
False


makeWorkflowWrapped :: TH.Type -> TH.Type
makeWorkflowWrapped :: Type -> Type
makeWorkflowWrapped = Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT ''Workflow)


makeWorkflowResultWrapped :: TH.Type -> TH.Type
makeWorkflowResultWrapped :: Type -> Type
makeWorkflowResultWrapped = Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT ''WorkflowResult)


makeTaskWrapped :: TH.Type -> TH.Type
makeTaskWrapped :: Type -> Type
makeTaskWrapped = Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT ''Task)


reapplyArgs :: ([TH.Type], TH.Type) -> TH.Type
reapplyArgs :: (Cxt, Type) -> Type
reapplyArgs (Cxt
args, Type
res) =
  -- add an arrow between all of the args into the result
  (Type -> Type -> Type) -> Type -> Cxt -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
TH.AppT (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
TH.AppT Type
TH.ArrowT) Type
res Cxt
args


retypeAsWorkflow
  :: Monad m
  => (TH.Type -> TH.Type)
  -- ^ Result extractor
  -> (TH.Type -> TH.Type)
  -- ^ Result wrapper
  -> TH.Type
  -> m TH.Type
retypeAsWorkflow :: forall (m :: * -> *).
Monad m =>
(Type -> Type) -> (Type -> Type) -> Type -> m Type
retypeAsWorkflow Type -> Type
extract Type -> Type
wrap Type
t = Type -> m Type
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> m Type) -> Type -> m Type
forall a b. (a -> b) -> a -> b
$ (Cxt, Type) -> Type
reapplyArgs (Cxt
args, Type -> Type
makeWorkflowWrapped (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
wrap (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
extract Type
res)
  where
    (Cxt
args, Type
res) = Type -> (Cxt, Type)
splitArgsAndResult Type
t


mkNconE :: (TH.Quote m) => TH.Name -> m TH.Exp
mkNconE :: forall (m :: * -> *). Quote m => Name -> m Exp
mkNconE Name
n = Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE 'pure m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`TH.appE` Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
TH.conE Name
n