{-# LANGUAGE CPP, TemplateHaskell #-}

{-# OPTIONS_HADDOCK not-home #-}

-- | This module provides Template Haskell functions for automatically generating
-- effect operation functions (that is, functions that use 'Polysemy.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 :: 'Polysemy.Member' FileSystem r => 'FilePath' -> 'Polysemy.Sem' r 'String'
-- readFile a = 'Polysemy.send' (ReadFile a)
--
-- writeFile :: 'Polysemy.Member' FileSystem r => 'FilePath' -> 'String' -> 'Polysemy.Sem' r ()
-- writeFile a b = 'Polysemy.send' (WriteFile a b)
-- @
module Polysemy.Internal.TH.Effect
  ( makeSem
  , makeSem_
  ) where

import Control.Monad
import Language.Haskell.TH
#if __GLASGOW_HASKELL__ >= 902
import Language.Haskell.TH.Syntax (addModFinalizer)
#endif
import Language.Haskell.TH.Datatype
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 'Polysemy.Sem' representing union of
-- effects as @r@ (e.g. @'Polysemy.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 users 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 'Polysemy.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]
  [ConLiftInfo]
cl_infos <- Name -> Q [ConLiftInfo]
getEffectMetadata Name
type_name
  [[Dec]]
decs <- 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConLiftInfo]
cl_infos else []
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ [[Dec]]
sigs 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
  =  forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
  forall a. [a] -> [a] -> [a]
++ [ Name -> Type -> Dec
SigD (ConLiftInfo -> Name
cliFunName ConLiftInfo
cli) forall a b. (a -> b) -> a -> b
$ Type -> Type
quantifyType
       forall a b. (a -> b) -> a -> b
$ [TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT [] (Type
member_cxt forall a. a -> [a] -> [a]
: ConLiftInfo -> Cxt
cliFunCxt ConLiftInfo
cli)
       forall a b. (a -> b) -> a -> b
$ Type -> Cxt -> Type
foldArrowTs Type
sem
       forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd
       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 = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConLiftInfo -> [(Name, Type)]
cliFunArgs ConLiftInfo
cli
#if __GLASGOW_HASKELL__ >= 902
  Maybe String
doc <- DocLoc -> Q (Maybe String)
getDoc forall a b. (a -> b) -> a -> b
$ Name -> DocLoc
DeclDoc forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> Name
cliConName ConLiftInfo
cli
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Q () -> Q ()
addModFinalizer forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocLoc -> String -> Q ()
putDoc (Name -> DocLoc
DeclDoc forall a b. (a -> b) -> a -> b
$ ConLiftInfo -> Name
cliFunName ConLiftInfo
cli)) Maybe String
doc
#endif
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ Pragma -> Dec
PragmaD 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fun_args_names)
                 (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ Bool -> ConLiftInfo -> Exp
makeUnambiguousSend Bool
should_mk_sigs ConLiftInfo
cli)
                 []
        ]
    ]