{-# LANGUAGE TemplateHaskell #-}

{-# OPTIONS_HADDOCK not-home #-}

-- | This module provides Template Haskell functions for automatically generating
-- effect operation functions (that is, functions that use 'send') from a given
-- effect algebra. For example, using the @FileSystem@ effect from the example in
-- the module documentation for "Polysemy", we can write the following:
--
-- @
-- data FileSystem m a where
--   ReadFile  :: 'FilePath' -> FileSystem 'String'
--   WriteFile :: 'FilePath' -> 'String' -> FileSystem ()
--
-- 'makeSem' ''FileSystem
-- @
--
-- This will automatically generate (approximately) the following functions:
--
-- @
-- readFile :: 'Member' FileSystem r => 'FilePath' -> 'Sem' r 'String'
-- readFile a = 'send' (ReadFile a)
--
-- writeFile :: 'Member' FileSystem r => 'FilePath' -> 'String' -> 'Sem' r ()
-- writeFile a b = 'send' (WriteFile a b)
-- @
module Polysemy.Internal.TH.Effect
  ( makeSem
  , makeSem_
  ) where

import Control.Monad
import Language.Haskell.TH
import Language.Haskell.TH.Datatype
import Polysemy.Internal.CustomErrors (DefiningModule)
import Polysemy.Internal.TH.Common


-- TODO: write tests for what should (not) compile

------------------------------------------------------------------------------
-- | If @T@ is a GADT representing an effect algebra, as described in the
-- module documentation for "Polysemy", @$('makeSem' ''T)@ automatically
-- generates a smart constructor for every data constructor of @T@. This also
-- works for data family instances. Names of smart constructors are created by
-- changing first letter to lowercase or removing prefix @:@ in case of
-- operators. Fixity declaration is preserved for both normal names and
-- operators.
--
-- @since 0.1.2.0
makeSem :: Name -> Q [Dec]
makeSem :: Name -> Q [Dec]
makeSem = Bool -> Name -> Q [Dec]
genFreer Bool
True


------------------------------------------------------------------------------
-- | Like 'makeSem', but does not provide type signatures and fixities. This
-- can be used to attach Haddock comments to individual arguments for each
-- generated function.
--
-- @
-- data Output o m a where
--   Output :: o -> Output o m ()
--
-- makeSem_ ''Output
--
-- -- | Output the value \@o\@.
-- output :: forall o r
--        .  Member (Output o) r
--        => o         -- ^ Value to output.
--        -> Sem r ()  -- ^ No result.
-- @
--
-- Because of limitations in Template Haskell, signatures have to follow some
-- rules to work properly:
--
-- * 'makeSem_' must be used /before/ the explicit type signatures
-- * signatures have to specify argument of 'Sem' representing union of
-- effects as @r@ (e.g. @'Sem' r ()@)
-- * all arguments in effect's type constructor have to follow naming scheme
-- from data constructor's declaration:
--
-- @
-- data Foo e m a where
--   FooC1 :: Foo x m ()
--   FooC2 :: Foo (Maybe x) m ()
-- @
--
-- should have @x@ in type signature of @fooC1@:
--
-- @fooC1 :: forall x r. Member (Foo x) r => Sem r ()@
--
-- and @Maybe x@ in signature of @fooC2@:
--
-- @fooC2 :: forall x r. Member (Foo (Maybe x)) r => Sem r ()@
--
-- * all effect's type variables and @r@ have to be explicitly quantified
-- using @forall@ (order is not important)
--
-- These restrictions may be removed in the future, depending on changes to
-- the compiler.
--
-- Change in (TODO(Sandy): version): in case of GADTs, signatures now only use
-- names from data constructor's type and not from type constructor
-- declaration.
--
-- @since 0.1.2.0
makeSem_ :: Name -> Q [Dec]
makeSem_ :: Name -> Q [Dec]
makeSem_ = Bool -> Name -> Q [Dec]
genFreer Bool
False
-- NOTE(makeSem_):
-- This function uses an ugly hack to work --- it changes names in data
-- constructor's type to capturable ones. This allows user to provide them to
-- us from their signature through 'forall' with 'ScopedTypeVariables'
-- enabled, so that we can compile liftings of constructors with ambiguous
-- type arguments (see issue #48).
--
-- Please, change this as soon as GHC provides some way of inspecting
-- signatures, replacing code or generating haddock documentation in TH.


------------------------------------------------------------------------------
-- | Generates declarations and possibly signatures for functions to lift GADT
-- constructors into 'Sem' actions.
genFreer :: Bool -> Name -> Q [Dec]
genFreer :: Bool -> Name -> Q [Dec]
genFreer Bool
should_mk_sigs Name
type_name = do
  [Extension] -> Q ()
checkExtensions [Extension
ScopedTypeVariables, Extension
FlexibleContexts, Extension
DataKinds]
  (Name
dt_name, [ConLiftInfo]
cl_infos) <- Name -> Q (Name, [ConLiftInfo])
getEffectMetadata Name
type_name
  Bool
tyfams_on  <- Extension -> Q Bool
isExtEnabled Extension
TypeFamilies
  [Dec]
def_mod_fi <- [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Name -> Maybe [Q TyVarBndrUnit] -> [TypeQ] -> TypeQ -> Q Dec
tySynInstDCompat
                             ''DefiningModule
                             Maybe [Q TyVarBndrUnit]
forall a. Maybe a
Nothing
                             [Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> TypeQ) -> Type -> TypeQ
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
dt_name]
                             (TyLit -> Type
LitT (TyLit -> Type) -> (Loc -> TyLit) -> Loc -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TyLit
StrTyLit (String -> TyLit) -> (Loc -> String) -> Loc -> TyLit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> String
loc_module (Loc -> Type) -> Q Loc -> TypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
location)
                         | Bool
tyfams_on
                         ]
  [[Dec]]
decs <- (ConLiftInfo -> Q [Dec]) -> [ConLiftInfo] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Bool -> ConLiftInfo -> Q [Dec]
genDec Bool
should_mk_sigs) [ConLiftInfo]
cl_infos

  let sigs :: [[Dec]]
sigs = if Bool
should_mk_sigs then ConLiftInfo -> [Dec]
genSig (ConLiftInfo -> [Dec]) -> [ConLiftInfo] -> [[Dec]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConLiftInfo]
cl_infos else []

  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [[Dec]] -> [Dec]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Dec]] -> [Dec]) -> [[Dec]] -> [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
def_mod_fi [Dec] -> [[Dec]] -> [[Dec]]
forall a. a -> [a] -> [a]
: [[Dec]]
sigs [[Dec]] -> [[Dec]] -> [[Dec]]
forall a. [a] -> [a] -> [a]
++ [[Dec]]
decs


------------------------------------------------------------------------------
-- | Generates signature for lifting function and type arguments to apply in
-- its body on effect's data constructor.
genSig :: ConLiftInfo -> [Dec]
genSig :: ConLiftInfo -> [Dec]
genSig ConLiftInfo
cli
  =  [Dec] -> (Fixity -> [Dec]) -> Maybe Fixity -> [Dec]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Dec -> [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> [Dec]) -> (Fixity -> Dec) -> Fixity -> [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fixity -> Name -> Dec) -> Name -> Fixity -> Dec
forall a b c. (a -> b -> c) -> b -> a -> c
flip Fixity -> Name -> Dec
InfixD (ConLiftInfo -> Name
cliFunName ConLiftInfo
cli)) (ConLiftInfo -> Maybe Fixity
cliFunFixity ConLiftInfo
cli)
  [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [ Name -> Type -> Dec
SigD (ConLiftInfo -> Name
cliFunName ConLiftInfo
cli) (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$ Type -> Type
quantifyType
       (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ [TyVarBndrUnit] -> Cxt -> Type -> Type
ForallT [] (Type
member_cxt Type -> Cxt -> Cxt
forall a. a -> [a] -> [a]
: ConLiftInfo -> Cxt
cliFunCxt ConLiftInfo
cli)
       (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Cxt -> Type
foldArrowTs Type
sem
       (Cxt -> Type) -> Cxt -> Type
forall a b. (a -> b) -> a -> b
$ ((Name, Type) -> Type) -> [(Name, Type)] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name, Type) -> Type
forall a b. (a, b) -> b
snd
       ([(Name, Type)] -> Cxt) -> [(Name, Type)] -> Cxt
forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
cli
     ]
  where
    member_cxt :: Type
member_cxt = Name -> ConLiftInfo -> Type
makeMemberConstraint (ConLiftInfo -> Name
cliUnionName ConLiftInfo
cli) ConLiftInfo
cli
    sem :: Type
sem        = Name -> Type -> Type
makeSemType (ConLiftInfo -> Name
cliUnionName ConLiftInfo
cli) (ConLiftInfo -> Type
cliEffRes ConLiftInfo
cli)


------------------------------------------------------------------------------
-- | Builds a function definition of the form
-- @x a b c = send (X a b c :: E m a)@.
genDec :: Bool -> ConLiftInfo -> Q [Dec]
genDec :: Bool -> ConLiftInfo -> Q [Dec]
genDec Bool
should_mk_sigs ConLiftInfo
cli = do
  let fun_args_names :: [Name]
fun_args_names = (Name, Type) -> Name
forall a b. (a, b) -> a
fst ((Name, Type) -> Name) -> [(Name, Type)] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
cli

  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ Pragma -> Dec
PragmaD (Pragma -> Dec) -> Pragma -> Dec
forall a b. (a -> b) -> a -> b
$ Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP (ConLiftInfo -> Name
cliFunName ConLiftInfo
cli) Inline
Inlinable RuleMatch
ConLike Phases
AllPhases
    , Name -> [Clause] -> Dec
FunD (ConLiftInfo -> Name
cliFunName ConLiftInfo
cli)
        [ [Pat] -> Body -> [Dec] -> Clause
Clause (Name -> Pat
VarP (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fun_args_names)
                 (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Bool -> ConLiftInfo -> Exp
makeUnambiguousSend Bool
should_mk_sigs ConLiftInfo
cli)
                 []
        ]
    ]