{-# LANGUAGE CPP #-}
{-# OPTIONS_HADDOCK not-home #-}
-- | This module contains Template Haskell functions for generating definitions of functions that send effect
-- operations. You mostly won't want to import this module directly; The "Cleff" module reexports the main
-- functionalities of this module.
--
-- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be
-- extra careful if you're to depend on this module.
module Cleff.Internal.TH where

import           Cleff.Internal.Effect
import           Cleff.Internal.Monad
import           Control.Monad                (join)
import           Data.Char                    (toLower)
import           Data.Foldable                (foldl')
import qualified Data.Map.Strict              as Map
import           Data.Maybe                   (maybeToList)
import           Language.Haskell.TH
import           Language.Haskell.TH.Datatype (ConstructorInfo (constructorName), DatatypeInfo (datatypeCons),
                                               TypeSubstitution (applySubstitution), reifyDatatype)
import           Language.Haskell.TH.PprLib   (text, (<>))
import           Prelude                      hiding ((<>))

-- | For a datatype @T@ representing an effect, @'makeEffect' T@ generates functions defintions for performing the
-- operations of @T@ via 'send'. The naming rule is changing the first uppercase letter in the constructor name to
-- lowercase or removing the @:@ symbol in the case of operator constructors. Also, this function will preserve any
-- fixity declarations defined on the constructors.
--
-- Because of the limitations of Template Haskell, all constructors of @T@ should be /polymorphic in the monad type/,
-- if they are to be used by 'makeEffect'. For example, this is not OK:
--
-- @
-- data Limited :: 'Effect' where
--   Noop :: Limited ('Eff' es) ()
-- @
--
-- because the monad type @'Eff' es@ is not a fully polymorphic type variable.
--
-- This function is also "weaker" than @polysemy@'s @makeSem@, because this function cannot properly handle some
-- cases involving complex higher order effects. Those cases are rare, though. See the tests for more details.
makeEffect :: Name -> Q [Dec]
makeEffect :: Name -> Q [Dec]
makeEffect = Bool -> Name -> Q [Dec]
makeSmartCons Bool
True

-- | Like 'makeEffect', but doesn't generate type signatures. This is useful when you want to attach Haddock
-- documentation to the function signature, /e.g./:
--
-- @
-- data Identity :: 'Effect' where
--   Noop :: Identity m ()
-- 'makeEffect_' ''Identity
--
-- -- | Perform nothing at all.
-- noop :: Identity ':>' es => 'Eff' es ()
-- @
--
-- Be careful that the function signatures must be added /after/ the 'makeEffect_' call.
makeEffect_ :: Name -> Q [Dec]
makeEffect_ :: Name -> Q [Dec]
makeEffect_ = Bool -> Name -> Q [Dec]
makeSmartCons Bool
False

-- | This is the function underlying 'makeEffect' and 'makeEffect_'. You can switch between the behavior of two by
-- changing the 'Bool' parameter to 'True' (generating signatures) or 'False' (not generating signatures).
makeSmartCons :: Bool -> Name -> Q [Dec]
makeSmartCons :: Bool -> Name -> Q [Dec]
makeSmartCons Bool
makeSig Name
effName = do
  DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
effName
  [[Dec]] -> [Dec]
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Bool -> Name -> Q [Dec]
makeCon Bool
makeSig) (ConstructorInfo -> Name
constructorName (ConstructorInfo -> Name) -> [ConstructorInfo] -> [Name]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstructorInfo] -> [ConstructorInfo]
forall a. [a] -> [a]
reverse (DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
info))

-- | Make a single function definition of a certain effect operation.
makeCon :: Bool -> Name -> Q [Dec]
makeCon :: Bool -> Name -> Q [Dec]
makeCon Bool
makeSig Name
name = do
  Maybe Fixity
fixity <- Name -> Q (Maybe Fixity)
reifyFixity Name
name
  Type
typ <- Name -> Q Info
reify Name
name Q Info -> (Info -> Q Type) -> Q Type
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    DataConI Name
_ Type
typ Name
_ -> Type -> Q Type
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
typ
    Info
_ -> String -> Q Type
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ Doc -> String
forall a. Show a => a -> String
show
      (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"'" Doc -> Doc -> Doc
<> Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
name Doc -> Doc -> Doc
<> String -> Doc
text String
"' is not a constructor"

  Type
effVar <- Name -> Type
VarT (Name -> Type) -> Q Name -> Q Type
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName String
"es"

  let actionCtx :: [Type]
actionCtx = Type -> [Type]
extractCtx Type
typ
  ([Type]
actionPar, (Type
effTy, Name
monadVar, Type
resTy)) <- Type -> Q ([Type], (Type, Name, Type))
forall (m :: Type -> Type).
MonadFail m =>
Type -> m ([Type], (Type, Name, Type))
extractPar Type
typ

  let fnName :: Name
fnName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
toSmartConName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name
  [Name]
fnArgs <- (Type -> Q Name) -> [Type] -> Q [Name]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Q Name -> Type -> Q Name
forall a b. a -> b -> a
const (Q Name -> Type -> Q Name) -> Q Name -> Type -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"x") [Type]
actionPar

  let
    fnBody :: Exp
fnBody = Name -> Exp
VarE 'send Exp -> Exp -> Exp
`AppE` (Exp -> Name -> Exp) -> Exp -> [Name] -> Exp
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Exp
f -> Exp -> Exp -> Exp
AppE Exp
f (Exp -> Exp) -> (Name -> Exp) -> Name -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) (Name -> Exp
ConE Name
name) [Name]
fnArgs
    fnSig :: Type
fnSig = [TyVarBndr] -> [Type] -> Type -> Type
ForallT [] (Type -> Name -> Type -> Type
UInfixT Type
effTy ''(:>) Type
effVar Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
actionCtx)
      ([Type] -> Type -> Type -> Name -> Type -> Type
forall t. [Type] -> Type -> t -> Name -> Type -> Type
makeTyp [Type]
actionPar Type
effVar Type
effTy Name
monadVar Type
resTy)

  [Dec] -> Q [Dec]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
    Maybe Dec -> [Dec]
forall a. Maybe a -> [a]
maybeToList ((Fixity -> Name -> Dec
`InfixD` Name
name) (Fixity -> Dec) -> Maybe Fixity -> Maybe Dec
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Fixity
fixity) [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++
    [ Name -> Type -> Dec
SigD Name
fnName Type
fnSig | Bool
makeSig ] [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++
    [ Name -> [Clause] -> Dec
FunD Name
fnName [[Pat] -> Body -> [Dec] -> Clause
Clause (Name -> Pat
VarP (Name -> Pat) -> [Name] -> [Pat]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fnArgs) (Exp -> Body
NormalB Exp
fnBody) []] ]

  where
    toSmartConName :: String -> String
toSmartConName (Char
':' : String
xs) = String
xs
    toSmartConName (Char
x : String
xs)   = Char -> Char
toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
    toSmartConName String
_          = String -> String
forall a. HasCallStack => String -> a
error String
"Cleff.makeEffect: Empty constructor name. Please report this as a bug."

    extractCtx :: Type -> [Type]
extractCtx (ForallT [TyVarBndr]
_ [Type]
ctx Type
t) = [Type]
ctx [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ Type -> [Type]
extractCtx Type
t
    extractCtx Type
_                 = []

    extractPar :: Type -> m ([Type], (Type, Name, Type))
extractPar (ForallT [TyVarBndr]
_ [Type]
_ Type
t) = Type -> m ([Type], (Type, Name, Type))
extractPar Type
t
    extractPar (SigT Type
t Type
_) = Type -> m ([Type], (Type, Name, Type))
extractPar Type
t
    extractPar (ParensT Type
t) = Type -> m ([Type], (Type, Name, Type))
extractPar Type
t
    extractPar (Type
ArrowT `AppT` Type
a `AppT` Type
t) = do
      ([Type]
args, (Type, Name, Type)
ret) <- Type -> m ([Type], (Type, Name, Type))
extractPar Type
t
      ([Type], (Type, Name, Type)) -> m ([Type], (Type, Name, Type))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Type
a Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
args, (Type, Name, Type)
ret)
#if MIN_VERSION_template_haskell(2,17,0)
    extractPar (MulArrowT `AppT` _ `AppT` a `AppT` t) = do
      (args, ret) <- extractPar t
      pure (a : args, ret)
#endif

    extractPar (Type
effTy `AppT` VarT Name
monadVar `AppT` Type
resTy) = ([Type], (Type, Name, Type)) -> m ([Type], (Type, Name, Type))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([], (Type
effTy, Name
monadVar, Type
resTy))
    extractPar ty :: Type
ty@(Type
_ `AppT` Type
m `AppT` Type
_) = String -> m ([Type], (Type, Name, Type))
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> m ([Type], (Type, Name, Type)))
-> String -> m ([Type], (Type, Name, Type))
forall a b. (a -> b) -> a -> b
$ Doc -> String
forall a. Show a => a -> String
show
      (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"The effect monad argument '" Doc -> Doc -> Doc
<> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
m
      Doc -> Doc -> Doc
<> String -> Doc
text String
"' in the effect '" Doc -> Doc -> Doc
<> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty Doc -> Doc -> Doc
<> String -> Doc
text String
"' is not a type variable"
    extractPar Type
t = String -> m ([Type], (Type, Name, Type))
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> m ([Type], (Type, Name, Type)))
-> String -> m ([Type], (Type, Name, Type))
forall a b. (a -> b) -> a -> b
$ Doc -> String
forall a. Show a => a -> String
show
      (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"The type '" Doc -> Doc -> Doc
<> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
t
      Doc -> Doc -> Doc
<> String -> Doc
text String
"' does not have the shape of an effect (i.e. has a polymorphic monad type and a result type)"

    makeTyp :: [Type] -> Type -> t -> Name -> Type -> Type
makeTyp [] Type
effVar t
_ Name
_ Type
resTy = Name -> Type
ConT ''Eff Type -> Type -> Type
`AppT` Type
effVar Type -> Type -> Type
`AppT` Type
resTy
    makeTyp (Type
parTy : [Type]
pars) Type
effVar t
effTy Name
monadVar Type
resTy =
      Type
ArrowT Type -> Type -> Type
`AppT` Name -> Type -> Type -> Type
forall a. TypeSubstitution a => Name -> Type -> a -> a
substMnd Name
monadVar Type
effVar Type
parTy Type -> Type -> Type
`AppT` [Type] -> Type -> t -> Name -> Type -> Type
makeTyp [Type]
pars Type
effVar t
effTy Name
monadVar Type
resTy

    substMnd :: Name -> Type -> a -> a
substMnd Name
monadVar Type
effVar = Map Name Type -> a -> a
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution (Name -> Type -> Map Name Type
forall k a. k -> a -> Map k a
Map.singleton Name
monadVar (Type -> Map Name Type) -> Type -> Map Name Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''Eff Type -> Type -> Type
`AppT` Type
effVar)