{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
-- | Generate functions for performing operations of dynamically dispatched
-- effects via Template Haskell.
module Effectful.TH
  ( makeEffect
  , makeEffect_
  ) where

import Control.Monad
import Data.Char (toLower)
import Data.Foldable qualified as F
import Data.Map.Strict qualified as Map
import Data.Maybe
import Language.Haskell.TH
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Datatype.TyVarBndr

import Effectful
import Effectful.Dispatch.Dynamic

-- | For an effect data type @E@, @'makeEffect' E@ generates the appropriate
-- instance of 'DispatchOf' as well as functions for performing operations of
-- @E@ by 'send'ing them to the effect handler.
--
-- >>> :{
--   data E :: Effect where
--     Op1 :: Int -> m a -> E m a
--     Op2 :: IOE :> es => Int -> E (Eff es) ()
--     Op3 :: (forall r. m r -> m r) -> E m Int
--   makeEffect ''E
-- :}
--
-- >>> :kind! DispatchOf E
-- DispatchOf E :: Dispatch
-- ...Dynamic
--
-- >>> :i op1
-- op1 :: (HasCallStack, E :> es) => Int -> Eff es a -> Eff es a
-- ...
--
-- >>> :i op2
-- op2 :: (HasCallStack, E :> es, IOE :> es) => Int -> Eff es ()
-- ...
--
-- >>> :i op3
-- op3 ::
--   (HasCallStack, E :> es) =>
--   (forall r. Eff es r -> Eff es r) -> Eff es Int
-- ...
--
-- The naming rule changes the first uppercase letter in the constructor name to
-- lowercase or removes the @:@ symbol in case of operators. Any fixity
-- annotations defined for the constructors are preserved for the corresponding
-- definitions.
--
-- If the constructor declaration has Haddock, then this is reused for the
-- sending functions, otherwise a simple placeholder is used.
makeEffect :: Name -> Q [Dec]
makeEffect :: Name -> Q [Dec]
makeEffect = Bool -> Name -> Q [Dec]
makeEffectImpl Bool
True

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

makeEffectImpl :: Bool -> Name -> Q [Dec]
makeEffectImpl :: Bool -> Name -> Q [Dec]
makeEffectImpl Bool
makeSig Name
effName = do
  Q ()
checkRequiredExtensions
  DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
effName
  Dec
dispatch <- do
    Type
e <- Type -> [Type] -> Q Type
getEff (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> Name
datatypeName DatatypeInfo
info) (Type -> Type -> Type
forall a b. a -> b -> a
const Type
WildCardT (Type -> Type) -> [Type] -> [Type]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DatatypeInfo -> [Type]
datatypeInstTypes DatatypeInfo
info)
    let dispatchE :: Type
dispatchE = Name -> Type
ConT ''DispatchOf Type -> Type -> Type
`AppT` Type
e
        dynamic :: Type
dynamic   = Name -> Type
PromotedT 'Dynamic
    Dec -> Q Dec
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> (TySynEqn -> Dec) -> TySynEqn -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TySynEqn -> Dec
TySynInstD (TySynEqn -> Q Dec) -> TySynEqn -> Q Dec
forall a b. (a -> b) -> a -> b
$ Maybe [TyVarBndr ()] -> Type -> Type -> TySynEqn
TySynEqn Maybe [TyVarBndr ()]
forall a. Maybe a
Nothing Type
dispatchE Type
dynamic
  [[Dec]]
ops <- (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)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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
<$> DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
info)
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
dispatch Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [[Dec]] -> [Dec]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [[Dec]]
forall a. [a] -> [a]
reverse [[Dec]]
ops)
  where
    getEff :: Type -> [Type] -> Q Type
    getEff :: Type -> [Type] -> Q Type
getEff Type
e = \case
      [Type
m, Type
r]   -> do
        String -> Type -> Type -> Q ()
forall {f :: Type -> Type}.
MonadFail f =>
String -> Type -> Type -> f ()
checkKind String
"the next to last" (Type
ArrowT Type -> Type -> Type
`AppT` Type
StarT Type -> Type -> Type
`AppT` Type
StarT) Type
m
        String -> Type -> Type -> Q ()
forall {f :: Type -> Type}.
MonadFail f =>
String -> Type -> Type -> f ()
checkKind String
"the last" Type
StarT Type
r
        Type -> Q Type
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
e
      (Type
v : [Type]
vs) -> Type -> [Type] -> Q Type
getEff (Type
e Type -> Type -> Type
`AppT` Type -> Type
forgetKind Type
v) [Type]
vs
      [Type]
_        -> String -> Q Type
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"The effect data type needs at least 2 type parameters"
      where
        forgetKind :: Type -> Type
forgetKind = \case
          SigT Type
v Type
_ -> Type
v
          Type
ty       -> Type
ty

    checkKind :: String -> Type -> Type -> f ()
checkKind String
which Type
expected = \case
      SigT (VarT Name
_) Type
k
        | Type
k Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
expected -> () -> f ()
forall a. a -> f a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
        | Bool
otherwise -> String -> f ()
forall a. String -> f a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail
           (String -> f ()) -> String -> f ()
forall a b. (a -> b) -> a -> b
$ String
"Expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
which String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" type parameter to have a kind "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
expected String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
k
      -- Weird type, let it through and see what happens.
      Type
_ -> () -> f ()
forall a. a -> f a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()

-- | Generate a single definition of an 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 a b. Q a -> (a -> Q b) -> Q b
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 a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
typ
    Info
_ -> String -> Q Type
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String
"Not a data constructor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
name

  ([Type]
actionParams, (Type
effTy, Either Name Name
ename, Type
resTy)) <- Type -> Q ([Type], (Type, Either Name Name, Type))
extractParams Type
typ

  -- The 'ename' can be either:
  --
  -- - A variable for the monad, in which case we need to generate the @es@
  --   variable and substitute it later for 'Eff es'.
  --
  -- - A variable 'es' for the local 'Eff es' if the monad parameter was locally
  --   substituted in the contructor.
  --
  -- For example in the following effect:
  --
  -- data E :: Effect where
  --   E1 :: Int -> E m ()
  --   E2 :: IOE :> es => E (Eff es) ()
  --
  -- Processing 'E1' will yield 'Right m', but 'E2' will yield 'Left es'.
  --
  -- In the first case we need to substitute the variable ourselves in a few
  -- places, but in the second we're good since it was already substituted.
  (Name
esName, Maybe Name
maybeMonadName) <- case Either Name Name
ename of
    Left  Name
esName    -> (Name, Maybe Name) -> Q (Name, Maybe Name)
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Name
esName, Maybe Name
forall a. Maybe a
Nothing)
    Right Name
monadName -> (, Name -> Maybe Name
forall a. a -> Maybe a
Just Name
monadName) (Name -> (Name, Maybe Name)) -> Q Name -> Q (Name, Maybe Name)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"es"

  let fnName :: Name
fnName = String -> Name
mkName (String -> Name) -> (String -> String) -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toSmartConName (String -> Name) -> String -> Name
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)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"x") [Type]
actionParams

  let esVar :: Type
esVar = Name -> Type
VarT Name
esName

      substM :: Type -> Type
      substM :: Type -> Type
substM = case Maybe Name
maybeMonadName of
        Just Name
m  -> Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution (Map Name Type -> Type -> Type)
-> (Type -> Map Name Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type -> Map Name Type
forall k a. k -> a -> Map k a
Map.singleton Name
m (Type -> Type -> Type) -> Type -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''Eff Type -> Type -> Type
`AppT` Type
esVar
        Maybe Name
Nothing -> Type -> Type
forall a. a -> a
id

      ([TyVarBndrSpec]
origActionVars, [Type]
actionCtx) = Type -> ([TyVarBndrSpec], [Type])
extractCtx Type
typ
      actionVars :: [TyVarBndrSpec]
actionVars = case Maybe Name
maybeMonadName of
        Just Name
m  -> (TyVarBndrSpec -> Bool) -> [TyVarBndrSpec] -> [TyVarBndrSpec]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Name
m Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/=) (Name -> Bool) -> (TyVarBndrSpec -> Name) -> TyVarBndrSpec -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndrSpec -> Name
forall flag. TyVarBndr_ flag -> Name
tvName) [TyVarBndrSpec]
origActionVars
                [TyVarBndrSpec] -> [TyVarBndrSpec] -> [TyVarBndrSpec]
forall a. [a] -> [a] -> [a]
++ [Name -> Type -> TyVarBndrSpec
kindedTVSpecified Name
esName (Type -> TyVarBndrSpec) -> Type -> TyVarBndrSpec
forall a b. (a -> b) -> a -> b
$ Type
ListT Type -> Type -> Type
`AppT` Name -> Type
ConT ''Effect]
        Maybe Name
Nothing -> [TyVarBndrSpec]
origActionVars

#if MIN_VERSION_template_haskell(2,17,0)
  -- In GHC >= 9.0 it's possible to generate the following body:
  --
  -- e x1 .. xN = send (E @ty1 .. @tyN x1 .. xN)
  --
  -- because specificities of constructor variables are exposed.
  --
  -- This allows to generate functions for such effects:
  --
  -- type family F ty :: Type
  -- data AmbEff :: Effect where
  --   AmbEff :: Int -> AmbEff m (F ty)
  --
  -- Sadly the version for GHC < 9 will not compile due to ambiguity error.
  let fnBody :: Exp
fnBody =
        let tyApps :: [Type]
tyApps = ((TyVarBndrSpec -> Maybe Type) -> [TyVarBndrSpec] -> [Type]
forall a b. (a -> Maybe b) -> [a] -> [b]
`mapMaybe` [TyVarBndrSpec]
origActionVars) ((TyVarBndrSpec -> Maybe Type) -> [Type])
-> (TyVarBndrSpec -> Maybe Type) -> [Type]
forall a b. (a -> b) -> a -> b
$ \TyVarBndrSpec
v -> case TyVarBndrSpec -> Specificity
forall flag. TyVarBndr_ flag -> flag
tvFlag TyVarBndrSpec
v of
              Specificity
InferredSpec  -> Maybe Type
forall a. Maybe a
Nothing
              Specificity
SpecifiedSpec -> Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ if Maybe Name
maybeMonadName Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Maybe Name
forall a. a -> Maybe a
Just (TyVarBndrSpec -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrSpec
v)
                                      then Name -> Type
ConT ''Eff Type -> Type -> Type
`AppT` Type
esVar
                                      else Name -> Type
VarT (TyVarBndrSpec -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrSpec
v)

            effCon :: Exp
effCon = if Bool
makeSig
              then (Exp -> Type -> Exp) -> Exp -> [Type] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' Exp -> Type -> Exp
AppTypeE (Name -> Exp
ConE Name
name) [Type]
tyApps
              else                  Name -> Exp
ConE Name
name
        in Name -> Exp
VarE 'send Exp -> Exp -> Exp
`AppE` (Exp -> Name -> Exp) -> Exp -> [Name] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.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) Exp
effCon [Name]
fnArgs
#else
  -- In GHC < 9.0, generate the following body:
  --
  -- e :: E v1 .. vN :> es => x1 -> .. -> xK -> E v1 .. vN (Eff es) r
  -- e x1 .. xK = send (E x1 .. xN :: E v1 .. vK (Eff es) r)
  let fnBody =
        let effOp  = F.foldl' (\f -> AppE f . VarE) (ConE name) fnArgs
            effSig = effTy `AppT` (ConT ''Eff `AppT` esVar) `AppT` substM resTy
        in if makeSig
           then VarE 'send `AppE` SigE effOp effSig
           else VarE 'send `AppE`      effOp
#endif
  let fnSig :: Type
fnSig = [TyVarBndrSpec] -> [Type] -> Type -> Type
ForallT [TyVarBndrSpec]
actionVars
        (Name -> Type
ConT ''HasCallStack Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> Name -> Type -> Type
UInfixT Type
effTy ''(:>) Type
esVar Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
actionCtx)
        (Type -> (Type -> Type) -> Type -> [Type] -> Type
makeTyp Type
esVar Type -> Type
substM Type
resTy [Type]
actionParams)

  let mkDec :: Fixity -> Dec
mkDec Fixity
fix =
#if MIN_VERSION_template_haskell(2,22,0)
        InfixD fix DataNamespaceSpecifier name
#else
        Fixity -> Name -> Dec
InfixD Fixity
fix Name
name
#endif
      rest :: [Dec]
rest = 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) []]
           Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Maybe Dec -> [Dec]
forall a. Maybe a -> [a]
maybeToList (Fixity -> Dec
mkDec (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]
++ [Dec]
rest) ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> [Dec] -> Q [Dec]
withHaddock Name
name [Name -> Type -> Dec
SigD Name
fnName Type
fnSig | Bool
makeSig]

----------------------------------------
-- Helpers

toSmartConName :: String -> String
toSmartConName :: String -> String
toSmartConName = \case
  (Char
':' : String
xs) -> String
xs
  (Char
x : String
xs)   -> Char -> Char
toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
  String
_          -> String -> String
forall a. HasCallStack => String -> a
error String
"empty constructor name"

extractCtx :: Type -> ([TyVarBndrSpec], Cxt)
extractCtx :: Type -> ([TyVarBndrSpec], [Type])
extractCtx = \case
  ForallT [TyVarBndrSpec]
vars [Type]
ctx Type
_ -> ([TyVarBndrSpec]
vars, [Type]
ctx)
  Type
ty                 -> String -> ([TyVarBndrSpec], [Type])
forall a. HasCallStack => String -> a
error (String -> ([TyVarBndrSpec], [Type]))
-> String -> ([TyVarBndrSpec], [Type])
forall a b. (a -> b) -> a -> b
$ String
"unexpected type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
ty

extractParams :: Type -> Q ([Type], (Type, Either Name Name, Type))
extractParams :: Type -> Q ([Type], (Type, Either Name Name, Type))
extractParams = \case
  ForallT [TyVarBndrSpec]
_ [Type]
_ Type
ty -> Type -> Q ([Type], (Type, Either Name Name, Type))
extractParams Type
ty
  SigT Type
ty Type
_ -> Type -> Q ([Type], (Type, Either Name Name, Type))
extractParams Type
ty
  ParensT Type
ty -> Type -> Q ([Type], (Type, Either Name Name, Type))
extractParams Type
ty
  Type
ArrowT `AppT` Type
a `AppT` Type
ty -> do
    ([Type]
args, (Type, Either Name Name, Type)
ret) <- Type -> Q ([Type], (Type, Either Name Name, Type))
extractParams Type
ty
    ([Type], (Type, Either Name Name, Type))
-> Q ([Type], (Type, Either Name Name, Type))
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Type
a Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
args, (Type, Either Name Name, Type)
ret)
#if MIN_VERSION_template_haskell(2,17,0)
  Type
MulArrowT `AppT` Type
_ `AppT` Type
a `AppT` Type
ty -> do
    ([Type]
args, (Type, Either Name Name, Type)
ret) <- Type -> Q ([Type], (Type, Either Name Name, Type))
extractParams Type
ty
    ([Type], (Type, Either Name Name, Type))
-> Q ([Type], (Type, Either Name Name, Type))
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Type
a Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
args, (Type, Either Name Name, Type)
ret)
#endif
  Type
effTy `AppT` Type
monadTy `AppT` Type
resTy -> case Type
monadTy of
    VarT Name
monadName -> ([Type], (Type, Either Name Name, Type))
-> Q ([Type], (Type, Either Name Name, Type))
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([], (Type
effTy, Name -> Either Name Name
forall a b. b -> Either a b
Right Name
monadName, Type
resTy))
    ConT Name
eff `AppT` VarT Name
esName
      | Name
eff Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Eff -> ([Type], (Type, Either Name Name, Type))
-> Q ([Type], (Type, Either Name Name, Type))
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([], (Type
effTy, Name -> Either Name Name
forall a b. a -> Either a b
Left Name
esName, Type
resTy))
    Type
ty -> String -> Q ([Type], (Type, Either Name Name, Type))
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q ([Type], (Type, Either Name Name, Type)))
-> String -> Q ([Type], (Type, Either Name Name, Type))
forall a b. (a -> b) -> a -> b
$ String
"Invalid instantiation of the monad parameter: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
ty
  Type
ty -> String -> Q ([Type], (Type, Either Name Name, Type))
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q ([Type], (Type, Either Name Name, Type)))
-> String -> Q ([Type], (Type, Either Name Name, Type))
forall a b. (a -> b) -> a -> b
$ String
"Unexpected type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
ty

makeTyp :: Type -> (Type -> Type) -> Type -> [Type] -> Type
makeTyp :: Type -> (Type -> Type) -> Type -> [Type] -> Type
makeTyp Type
esVar Type -> Type
substM Type
resTy = \case
  []       -> Name -> Type
ConT ''Eff Type -> Type -> Type
`AppT` Type
esVar Type -> Type -> Type
`AppT` Type -> Type
substM Type
resTy
  (Type
p : [Type]
ps) -> Type
ArrowT Type -> Type -> Type
`AppT` Type -> Type
substM Type
p Type -> Type -> Type
`AppT` Type -> (Type -> Type) -> Type -> [Type] -> Type
makeTyp Type
esVar Type -> Type
substM Type
resTy [Type]
ps

withHaddock :: Name -> [Dec] -> Q [Dec]
#if MIN_VERSION_template_haskell(2,18,0)
withHaddock :: Name -> [Dec] -> Q [Dec]
withHaddock Name
name [Dec]
decs = do 
  Maybe String
existingHaddock <- DocLoc -> Q (Maybe String)
getDoc (Name -> DocLoc
DeclDoc Name
name)
  let newDoc :: String
newDoc = 
        case Maybe String
existingHaddock of
          Just String
doc -> String
doc
          Maybe String
Nothing -> String
"Perform the operation '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'."
  String -> Q [Dec] -> Q [Dec]
withDecsDoc String
newDoc ([Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [Dec]
decs)
#else
withHaddock _ decs = pure decs
#endif

checkRequiredExtensions :: Q ()
checkRequiredExtensions :: Q ()
checkRequiredExtensions = do
  [Extension]
missing <- (Extension -> Q Bool) -> [Extension] -> Q [Extension]
forall (m :: Type -> Type) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> Q Bool -> Q Bool
forall a b. (a -> b) -> Q a -> Q b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (Q Bool -> Q Bool) -> (Extension -> Q Bool) -> Extension -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Extension -> Q Bool
isExtEnabled) [Extension]
exts
  let ppMissing :: [String]
ppMissing = (Extension -> String) -> [Extension] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\Extension
ext -> String
"{-# LANGUAGE " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Extension -> String
forall a. Show a => a -> String
show Extension
ext String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" #-}") [Extension]
missing
  Bool -> Q () -> Q ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless ([Extension] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Extension]
missing) (Q () -> Q ()) -> ([String] -> Q ()) -> [String] -> Q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q ()
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q ()) -> ([String] -> String) -> [String] -> Q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> Q ()) -> [String] -> Q ()
forall a b. (a -> b) -> a -> b
$
    [ String
"Generating functions requires additional language extensions.\n"
    , String
"You can enable them by adding them to the 'default-extensions'"
    , String
"field in the .cabal file or the following pragmas to the beginning"
    , String
"of the source file:\n"
    ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ppMissing
  where
    exts :: [Extension]
exts = [ Extension
FlexibleContexts
           , Extension
ScopedTypeVariables
#if MIN_VERSION_template_haskell(2,17,0)
           , Extension
TypeApplications
#endif
           , Extension
TypeFamilies
           , Extension
TypeOperators
           ]