{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}

module Effect.TH
  ( defineEffectType,
    makeEffect,
    makeReification,
    makeInterpretation,
  )
where

import Control.Monad
import Data.Bifunctor
import Data.Char (toLower, toUpper)
import qualified Data.Map as Map
import Effect.Internal
import Language.Haskell.TH
import Language.Haskell.TH.Datatype

-- I'd like for this to work, but I think it can't work because of some TH stage restrictions?
--
--
-- -- | Given a class of monads @X@, the macro
-- --
-- -- > autoMagic ''X
-- --
-- -- will set everything up so that you can
-- --
-- -- 1. use the same syntax as in @X@ to write 'AST's, and
-- --
-- -- 2. interpret 'AST's written usgin this syntax.
-- --
-- -- This works by defining an "effect type" @XEffect@ and
-- --
-- -- 1. an @X@ instance for any @AST ops@ where @ops@ contains @XEffect@
-- --
-- -- 2. an 'InterpretEffect m XEffect' for any monad @m@ with @X m@.
-- --
-- -- In particular, you can also mix and match effect types and their classes'
-- -- syntax in one @AST ops@, as long as they are all in @ops@.
-- --
-- -- For more detail, see the comments at 'defineEffectType' and 'makeEffect',
-- -- around which this is a wrapper.
-- autoMagic :: Name -> Q [Dec]
-- autoMagic className = do
--   d1 <- defineEffectType className
--   d2 <- makeEffect className (mkEffectName className)
--   return $ d1 ++ d2

-- | Generate the effect type corresponding to a class.
--
-- By, example, given
--
-- > class (...) => Foo a b m where
-- >   foo :: a -> b -> m ()
-- >   bar :: forall c. Ord c => (c -> m a) -> b -> m (c, Bool)
--
-- the macro
--
-- > defineEffectType ''Foo
--
-- writes an effect type like
--
-- > data FooEffect a b :: Effect where
-- >   Foo :: a -> b -> FooEffect a b m ()
-- >   Bar :: forall c. Ord c => (c -> m a) -> b -> FooEffect a b m (c, Bool)
--
-- There are two naming conventions here:
--
-- __naming convention 1__: The effect type corresponding to the class @X@ is
-- called @XEffect@. For example, 'MonadError' corresponds to
-- 'MonadErrorEffect'.
--
-- __naming convention 2__: The names of the constructors of @XEffect@ must be
-- exactly the names of the methods of the class @X@, just starting with an
-- upper-case letter.
--
-- This macro furhtermore assumes that the last type variable in the the class
-- definition (here, that's @m@) is of kind @Type -> Type@.  This makes sense
-- for our application, because our classes will normally be classes of monads.
defineEffectType :: Name -> Q [Dec]
defineEffectType :: Name -> Q [Dec]
defineEffectType Name
className = do
  ClassI (ClassD [Type]
_ Name
_ [TyVarBndr ()]
varsAndM [FunDep]
_ [Dec]
methods) [Dec]
_ <- Name -> Q Info
reify Name
className
  let -- any type variables in the class definition besides the last
      vars :: [TyVarBndr ()]
vars = [TyVarBndr ()] -> [TyVarBndr ()]
forall a. HasCallStack => [a] -> [a]
init [TyVarBndr ()]
varsAndM
      varNames :: [Name]
varNames = TyVarBndr () -> Name
forall flag. TyVarBndr flag -> Name
nameFromTyVarBndr (TyVarBndr () -> Name) -> [TyVarBndr ()] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr ()]
vars

      -- the last type variable in the class definition (i.e. the type the class is making a constraint on)
      mVar :: TyVarBndr ()
mVar = [TyVarBndr ()] -> TyVarBndr ()
forall a. HasCallStack => [a] -> a
last [TyVarBndr ()]
varsAndM
      mName :: Name
mName = TyVarBndr () -> Name
forall flag. TyVarBndr flag -> Name
nameFromTyVarBndr TyVarBndr ()
mVar

      effectName :: Name
effectName = Name -> Name
mkEffectName Name
className
      effectType :: Type
effectType = (Type -> Name -> Type) -> Type -> [Name] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Type
t Name
n -> Type -> Type -> Type
AppT Type
t (Name -> Type
VarT Name
n)) (Name -> Type
ConT Name
effectName) [Name]
varNames
  (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [])
    (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Q Con]
-> [Q DerivClause]
-> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [m Con]
-> [m DerivClause]
-> m Dec
dataD
      ([Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [])
      Name
effectName
      ( (TyVarBndr () -> TyVarBndr ()) -> [TyVarBndr ()] -> [TyVarBndr ()]
forall a b. (a -> b) -> [a] -> [b]
map
          ( \case
              PlainTV Name
n ()
_ -> Name -> () -> TyVarBndr ()
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n ()
              KindedTV Name
n ()
_ Type
t -> Name -> () -> Type -> TyVarBndr ()
forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV Name
n () Type
t
          )
          [TyVarBndr ()]
vars
      )
      (Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''Effect)
      ( (Dec -> Q Con) -> [Dec] -> [Q Con]
forall a b. (a -> b) -> [a] -> [b]
map
          ( \case
              SigD Name
methodName Type
methodType -> do
                let ([TyVarBndr Specificity]
methodTyVars, [Type]
methodConstraints, [Type]
tys) = case Type
methodType of
                      ForallT [TyVarBndr Specificity]
tvars [Type]
ctx Type
ty -> ([TyVarBndr Specificity]
tvars, [Type]
ctx, Type -> [Type]
destructFunctionType Type
ty)
                      Type
ty -> ([], [], Type -> [Type]
destructFunctionType Type
ty)
                    codomain :: Type
codomain = case [Type] -> Type
forall a. HasCallStack => [a] -> a
last [Type]
tys of
                      AppT Type
_m Type
x -> Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
effectType (Name -> Type
VarT Name
mName)) Type
x
                      Type
_ ->
                        [Char] -> Type
forall a. HasCallStack => [Char] -> a
error ([Char] -> Type) -> [Char] -> Type
forall a b. (a -> b) -> a -> b
$
                          [Char]
"Expecting every method of the class "
                            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
nameBase Name
className
                            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" to return something of the form \"m a\" for some a, but got something like "
                            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show ([Type] -> Type
forall a. HasCallStack => [a] -> a
last [Type]
tys)
                    argTypes :: [Type]
argTypes = [Type] -> [Type]
forall a. HasCallStack => [a] -> [a]
init [Type]
tys
                [TyVarBndr Specificity] -> Q [Type] -> Q Con -> Q Con
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m [Type] -> m Con -> m Con
forallC
                  ( (TyVarBndr () -> TyVarBndr Specificity)
-> [TyVarBndr ()] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> [a] -> [b]
map
                      ( \case
                          PlainTV Name
n ()
_ -> Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n Specificity
SpecifiedSpec
                          KindedTV Name
n ()
_ Type
t -> Name -> Specificity -> Type -> TyVarBndr Specificity
forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV Name
n Specificity
SpecifiedSpec Type
t
                      )
                      [TyVarBndr ()]
varsAndM
                      [TyVarBndr Specificity]
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. [a] -> [a] -> [a]
++ [TyVarBndr Specificity]
methodTyVars
                  )
                  ([Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
methodConstraints)
                  ( [Name] -> [Q StrictType] -> Q Type -> Q Con
forall (m :: * -> *).
Quote m =>
[Name] -> [m StrictType] -> m Type -> m Con
gadtC
                      [Name -> Name
upperFirst Name
methodName]
                      ((Type -> Q StrictType) -> [Type] -> [Q StrictType]
forall a b. (a -> b) -> [a] -> [b]
map (StrictType -> Q StrictType
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (StrictType -> Q StrictType)
-> (Type -> StrictType) -> Type -> Q StrictType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness,)) [Type]
argTypes)
                      (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
codomain)
                  )
              Dec
_ -> [Char] -> Q Con
forall a. HasCallStack => [Char] -> a
error [Char]
"I made a wrong assumption about TH's reification of classes: expected a list of signature declarations using the 'SigD' constructor"
          )
          [Dec]
methods
      )
      []

-- | Automatically write "reification" and "interpretation" instances for an
-- effect type and its associated class of monads.
--
-- Assume a class definition like
--
-- > class (SomeConstraint a, MonadBar b m) => MonadFoo a b m
--
-- and an effect type defined like
--
-- > data MonadFooEffect a b :: Effect
--
-- Then the macro
--
-- > makeEffect ''MonadFoo ''MonadFooEffect
--
-- will expand into two instance definitions:
--
-- 1. The "reification" instance
--
-- > instance (SomeConstraint a,
-- >           EffectInject (MonadBarEffect b) ops,
-- >           EffectInject (MonadFooEffect a b) ops)
-- >   => MonadFoo a b (AST ops)
--
-- says that an 'AST' whose list @ops@ of effect types contains
-- @MonadFooEffect@ is a @MonadFoo@. In order for this instance to make sense,
-- though, we'll have to add at least satisfy the constraints that were already
-- there on the class definition of @MonadFoo@. Therefore, we have to add
--
-- - @SomeConstraint a@,
--
-- - a constraint that implies @MonadBar b (AST ops)@: That is the reason for
--   the constraint @EffectInject (MonadBarEffect b) ops@. This macro assumes
--   that the only way for an 'AST' to become a @MonadX@ for some @X@ is to
--   contain the correct effect type @MonadXEffect@. That is, we employ the same
--   naming conventions as explained at 'defineEffectType'.
--
-- 2.  the "interpretation" instance
--
-- > instance (MonadFoo a b m) => InterpretEffect m (MonadFooEffect a b)
--
-- says that for any @MonadFoo a b m@, we can interpret the effects described
-- by @MonadFooEffect a b@ into @m@.
--
--
-- /remark for the general case/: This macro works by using the "additional
-- constraints" arguments to 'makeReification' and 'makeInterpretation'. If you
-- want to generate the instances with other constraints, you'll have to use
-- these two macros directly.
makeEffect :: Name -> Name -> Q [Dec]
makeEffect :: Name -> Name -> Q [Dec]
makeEffect Name
className Name
effectName = do
  ClassI (ClassD [Type]
ctx Name
_ [TyVarBndr ()]
vars [FunDep]
_ [Dec]
_) [Dec]
_ <- Name -> Q Info
reify Name
className
  let names :: [Name]
names = TyVarBndr () -> Name
forall flag. TyVarBndr flag -> Name
nameFromTyVarBndr (TyVarBndr () -> Name) -> [TyVarBndr ()] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr ()]
vars
      -- The context of the class definition (i.e. its constraints, as a
      -- function of the type variables used. The list of 'Name's containss all
      -- of the "extra" type variables, and the singular 'Name' is the name of
      -- the monad @m@.
      ctxAsFunction :: [Name] -> Name -> [Type]
      ctxAsFunction :: [Name] -> Name -> [Type]
ctxAsFunction [Name]
extraNames Name
mName =
        Map Name Type -> [Type] -> [Type]
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution
          ([(Name, Type)] -> Map Name Type
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Type)] -> Map Name Type)
-> [(Name, Type)] -> Map Name Type
forall a b. (a -> b) -> a -> b
$ [Name] -> [Type] -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
names (Name -> Type
VarT (Name -> Type) -> [Name] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
extraNames [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name
mName]))
          [Type]
ctx
  [Dec]
d1 <- ([Name] -> Name -> Q Type) -> Name -> Name -> Q [Dec]
makeReification (([Name] -> Name -> [Type]) -> [Name] -> Name -> Q Type
reificationExtraConstraints [Name] -> Name -> [Type]
ctxAsFunction) Name
className Name
effectName
  [Dec]
d2 <- ([Name] -> Name -> Q Type) -> Name -> Name -> Q [Dec]
makeInterpretation (([Name] -> Name -> [Type]) -> [Name] -> Name -> Q Type
interpretationExtraConstraints [Name] -> Name -> [Type]
ctxAsFunction) Name
className Name
effectName
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
d1 [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
d2
  where
    reificationExtraConstraints,
      interpretationExtraConstraints ::
        ([Name] -> Name -> [Type]) -> [Name] -> Name -> Q Type

    reificationExtraConstraints :: ([Name] -> Name -> [Type]) -> [Name] -> Name -> Q Type
reificationExtraConstraints [Name] -> Name -> [Type]
ctx [Name]
extraNames Name
opsName = do
      Name
dummyName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"dummy"
      [Type] -> Type
bigTuple
        ([Type] -> Type) -> Q [Type] -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Q (Maybe Type)) -> [Type] -> Q [Type]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM
          ( \Type
constraint ->
              if Name
dummyName Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
constraint
                then case Type
constraint of
                  AppT Type
c Type
x
                    | Type
x Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
dummyName ->
                        if Type
c Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
ConT ''Monad
                          then Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Q Type -> Q (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|EffectInject $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name -> Name) -> Type -> Type
onFirst Name -> Name
mkEffectName Type
c)) $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
opsName)|]
                          else Maybe Type -> Q (Maybe Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Type
forall a. Maybe a
Nothing
                  Type
_ -> [Char] -> Q (Maybe Type)
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q (Maybe Type)) -> [Char] -> Q (Maybe Type)
forall a b. (a -> b) -> a -> b
$ [Char]
"The class '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
nameBase Name
className [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"' has a constraint where the \"monad\" argument isn't the last. The TH can't (yet) handle this. Try using 'makeInterpretation' and 'makeReification' directly"
                else Maybe Type -> Q (Maybe Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Type -> Q (Maybe Type)) -> Maybe Type -> Q (Maybe Type)
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Type
forall a. a -> Maybe a
Just Type
constraint
          )
          ([Name] -> Name -> [Type]
ctx [Name]
extraNames Name
dummyName)

    interpretationExtraConstraints :: ([Name] -> Name -> [Type]) -> [Name] -> Name -> Q Type
interpretationExtraConstraints [Name] -> Name -> [Type]
_ [Name]
_ Name
_ = [t|()|]

    -- on a type constructor applied to some arguments apply some
    -- transformation to the name of the constructor
    onFirst :: (Name -> Name) -> Type -> Type
    onFirst :: (Name -> Name) -> Type -> Type
onFirst Name -> Name
f (ConT Name
n) = Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Name
f Name
n
    onFirst Name -> Name
f (AppT Type
a Type
b) = Type -> Type -> Type
AppT ((Name -> Name) -> Type -> Type
onFirst Name -> Name
f Type
a) Type
b
    onFirst Name -> Name
_ Type
_ = [Char] -> Type
forall a. HasCallStack => [Char] -> a
error [Char]
"expected a type constructor applied to some arguments"

    -- make a big tuple of the form (...((((), a), b), c) ...) out of a list like [a, b, c]
    bigTuple :: [Type] -> Type
    bigTuple :: [Type] -> Type
bigTuple = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Type -> Type -> Type
AppT (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT (Int -> Type
TupleT Int
2)) (Int -> Type
TupleT Int
0)

-- | Write a "reification" instance for an effect type. Such an instance
-- allows writing 'AST's containing effects of that type using the syntax of
-- a class like 'MonadError', 'MonadState'...
--
-- For example, given the effect type
--
-- > data ErrorEffect e m a where
-- >   ThrowError :: e -> ErrorEffect e m a
-- >   CatchError :: m a -> (e -> m a) -> ErrorEffect e m a
--
-- the TH splice
--
-- > makeReification
-- >   (\[e] ops -> [t|SomeConstraint $(varT e) $(varT ops)|])
-- >   ''MonadError
-- >   ''ErrorEffect
--
-- will expand into an instance like
--
-- > instance (SomeConstraint e ops, EffectInject (ErrorEffect e) ops) => MonadError e (AST ops) where
-- >   throwError err = astInject (ThrowError err)
-- >   catchError acts handler = astInject (CatchError acts handler)
--
-- For this to work, it is expected that:
--
-- - The first quoted type passed to the splice is the class that you want to
--   use for your syntax. Its kind should be @(* -> *) -> Constraint@
--
-- - The second quoted type is the effect type.
--   Its kind should be @(* -> *) -> * -> *@.
--
-- - The constructor names of the effect type are exactly the method names
--   of the class, just beginning with an upper case letter.
makeReification ::
  -- | additional constraints for the instance head, depending on the names of
  -- extra type variables belonging to the effect type, and of @ops@
  ([Name] -> Name -> Q Type) ->
  -- | class name
  Name ->
  -- | the effect type
  Name ->
  Q [Dec]
makeReification :: ([Name] -> Name -> Q Type) -> Name -> Name -> Q [Dec]
makeReification [Name] -> Name -> Q Type
qExtraConstraints Name
className Name
effectName = do
  Name
opsName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"ops"
  let ops :: Type
ops = Name -> Type
VarT Name
opsName
  DatatypeInfo
    { datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeInstTypes = [Type]
instTypes, -- we expect at least two types here, namely the "nesting" monad, and the return value
      datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
constructors
    } <-
    Name -> Q DatatypeInfo
reifyDatatype Name
effectName
  let tyVarNames :: [Name]
tyVarNames =
        -- all type variables that the type constructor is applied to
        (Type -> Name) -> [Type] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map
          ( \case
              VarT Name
name -> Name
name
              SigT (VarT Name
name) Type
_ -> Name
name
              Type
_ -> [Char] -> Name
forall a. HasCallStack => [Char] -> a
error [Char]
"effect datatype declaration must only have type variables"
          )
          [Type]
instTypes
  let extraTyVarNames :: [Name]
extraTyVarNames = case [Name] -> [Name]
forall a. [a] -> [a]
reverse [Name]
tyVarNames of
        Name
_ : Name
_ : [Name]
l -> [Name] -> [Name]
forall a. [a] -> [a]
reverse [Name]
l
        [Name]
_ -> [Char] -> [Name]
forall a. HasCallStack => [Char] -> a
error [Char]
"expecting at least two type arguments in effect type"
  Type
extraConstraints <- [Name] -> Name -> Q Type
qExtraConstraints [Name]
extraTyVarNames Name
opsName
  [Dec]
methodImplementations <- (ConstructorInfo -> Q Dec) -> [ConstructorInfo] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name -> [Name] -> ConstructorInfo -> Q Dec
matchAndHandleConstructor Name
opsName [Name]
extraTyVarNames) [ConstructorInfo]
constructors
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return
    [ Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD
        Maybe Overlap
forall a. Maybe a
Nothing
        [ Type
extraConstraints,
          Type -> Type -> Type
AppT
            ( Type -> Type -> Type
AppT
                (Name -> Type
ConT ''EffectInject)
                ( (Type -> Name -> Type) -> Type -> [Name] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                    (\Type
t Name
n -> Type -> Type -> Type
AppT Type
t (Name -> Type
VarT Name
n))
                    (Name -> Type
ConT Name
effectName)
                    [Name]
extraTyVarNames
                )
            )
            Type
ops
        ]
        ( Type -> Type -> Type
AppT
            ( (Type -> Name -> Type) -> Type -> [Name] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                (\Type
t Name
n -> Type -> Type -> Type
AppT Type
t (Name -> Type
VarT Name
n))
                (Name -> Type
ConT Name
className)
                [Name]
extraTyVarNames
            )
            (Type -> Type -> Type
AppT (Name -> Type
ConT ''AST) Type
ops)
        )
        [Dec]
methodImplementations
    ]
  where
    matchAndHandleConstructor :: Name -> [Name] -> ConstructorInfo -> Q Dec
    matchAndHandleConstructor :: Name -> [Name] -> ConstructorInfo -> Q Dec
matchAndHandleConstructor Name
_ [Name]
_ ConstructorInfo {constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
InfixConstructor} =
      [Char] -> Q Dec
forall a. HasCallStack => [Char] -> a
error [Char]
"infix constructors for effects not (yet) supported"
    matchAndHandleConstructor
      Name
opsName
      [Name]
extraTyVarNames
      ConstructorInfo {constructorName :: ConstructorInfo -> Name
constructorName = Name
name, constructorFields :: ConstructorInfo -> [Type]
constructorFields = [Type]
argTypes} =
        Name -> [Name] -> Name -> Int -> Q Dec
handleConstructor Name
opsName [Name]
extraTyVarNames Name
name ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
argTypes)

    handleConstructor :: Name -> [Name] -> Name -> Int -> Q Dec
    handleConstructor :: Name -> [Name] -> Name -> Int -> Q Dec
handleConstructor Name
opsName [Name]
extraTyVarNames Name
cName Int
argc = do
      [Name]
varNames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
argc ([Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x")
      Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$
        Name -> [Clause] -> Dec
FunD
          (Name -> Name
lowerFirst Name
cName)
          [ [Pat] -> Body -> [Dec] -> Clause
Clause
              ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varNames)
              ( Exp -> Body
NormalB
                  (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE
                    ( Exp -> Type -> Exp
AppTypeE
                        ( Exp -> Type -> Exp
AppTypeE
                            (Name -> Exp
VarE 'astInject)
                            ( (Type -> Name -> Type) -> Type -> [Name] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                                (\Type
t Name
n -> Type -> Type -> Type
AppT Type
t (Name -> Type
VarT Name
n))
                                (Name -> Type
ConT Name
effectName)
                                [Name]
extraTyVarNames
                            )
                        )
                        (Name -> Type
VarT Name
opsName)
                    )
                  (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Name -> Exp) -> Exp -> [Name] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                    (\Exp
expr Name
argName -> Exp -> Exp -> Exp
AppE Exp
expr (Name -> Exp
VarE Name
argName))
                    (Name -> Exp
ConE Name
cName)
                    [Name]
varNames
              )
              []
          ]

-- | Write an "interpretation" instance for an effect type. Such an instance
-- allows one to evaluate 'AST's using the effect type. (For example, using 'interpretAST')
--
-- For example, given the effect type
--
-- > data ErrorEffect e m a where
-- >   ThrowError :: e -> ErrorEffect e m a
-- >   CatchError :: m a -> (e -> m a) -> ErrorEffect e m a
--
-- the TH splice
--
-- > makeInterpretation (\[e] m -> [t|SomeConstraint $(varT e) $(varT m)|]) [t|ErrorEffect $(varT (mkName "e"))|]
--
-- will expand into an instance like
--
-- > instance (SomeConstraint e m, MonadError e m) => InterpretEffect m (ErrorEffect e) where
-- >   interpretEffect _ (ThrowError err) = throwError @e err
-- >   interpretEffect evalAST (CatchError acts handler) = catchError @e (evalAST acts) (evalAST . handler)
--
-- For this to work, it is expected that:
--
-- - The first quoted type passed to the splice is the class of monads that yow
--   want to interpret the effect into. Its kind should be @(* -> *) ->
--   Constraint@
--
-- - The second quoted type is the effect type.
--   Its kind should be @(* -> *) -> * -> *@.
--
-- - The constructor names of the effect type are exactly the method names
--   of the class, just beginning with an upper case letter.
--
-- - The arguments of constructors of the effect type only use @m@ in
--   positive positions. This is not a restriction of the TemplateHaskell, but a
--   restriction of the library. You can only "nest" 'AST's in positive position.
--
-- - For now, the TemplateHaskell works only if the arguments of constructors
--   of the effect type only use the following type constructors:
--     - The name of the "nesting" monad (here, that's @m@) applied to some type
--     - Function Types (i.e. @->@, or 'ArrowT' in TH)
--     - List Types (i.e. 'ListT' in TH)
--     - @Maybe@, @Either@, or @(,)@ applied to some type(s)
--     - @IO@ applied to some type
--     - Parenheses (i.e. 'ParensT' in TH)
--     - Type Variables (i.e. 'VarT' in TH)
--     - Type Constructors of types of kind @*@
makeInterpretation ::
  -- | additional constraints for the instance head, depending on the names of
  -- extra type variables belonging to the effect type, and of @m@
  ([Name] -> Name -> Q Type) ->
  -- | class name
  Name ->
  -- | effect type name
  Name ->
  Q [Dec]
makeInterpretation :: ([Name] -> Name -> Q Type) -> Name -> Name -> Q [Dec]
makeInterpretation [Name] -> Name -> Q Type
qExtraConstraints Name
className Name
effectName = do
  Name
mName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"m"
  let m :: Type
m = Name -> Type
VarT Name
mName
  DatatypeInfo
    { datatypeInstTypes :: DatatypeInfo -> [Type]
datatypeInstTypes = [Type]
instTypes, -- we expect at least two types here, namely the "nesting" monad, and the return value
      datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
constructors
    } <-
    Name -> Q DatatypeInfo
reifyDatatype Name
effectName
  let tyVarNames :: [Name]
tyVarNames =
        -- all type variables that the type constructor is applied to
        (Type -> Name) -> [Type] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map
          ( \case
              VarT Name
name -> Name
name
              SigT (VarT Name
name) Type
_ -> Name
name
              Type
_ -> [Char] -> Name
forall a. HasCallStack => [Char] -> a
error [Char]
"effect datatype declaration must only have type variables"
          )
          [Type]
instTypes
  let (Name
nestVarName, [Name]
extraTyVarNames) = case [Name] -> [Name]
forall a. [a] -> [a]
reverse [Name]
tyVarNames of
        Name
_ : Name
x : [Name]
l -> (Name
x, [Name] -> [Name]
forall a. [a] -> [a]
reverse [Name]
l)
        [Name]
_ -> [Char] -> (Name, [Name])
forall a. HasCallStack => [Char] -> a
error [Char]
"expecting at least two type arguments in effect type"
  Type
extraConstraints <- [Name] -> Name -> Q Type
qExtraConstraints [Name]
extraTyVarNames Name
mName
  Dec
implementation <- Name -> [Clause] -> Dec
FunD 'interpretEffect ([Clause] -> Dec) -> Q [Clause] -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ConstructorInfo -> Q Clause) -> [ConstructorInfo] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Name] -> Name -> ConstructorInfo -> Q Clause
matchAndHandleConstructor [Name]
extraTyVarNames Name
nestVarName) [ConstructorInfo]
constructors
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return
    [ Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD
        Maybe Overlap
forall a. Maybe a
Nothing
        [ Type
extraConstraints,
          (Type -> Name -> Type) -> Type -> [Name] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
            (\Type
t Name
n -> Type -> Type -> Type
AppT Type
t (Name -> Type
VarT Name
n))
            (Name -> Type
ConT Name
className)
            ([Name]
extraTyVarNames [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name
mName])
        ]
        ( Type -> Type -> Type
AppT
            (Type -> Type -> Type
AppT (Name -> Type
ConT ''InterpretEffect) Type
m)
            ((Type -> Name -> Type) -> Type -> [Name] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Type
t Name
n -> Type -> Type -> Type
AppT Type
t (Name -> Type
VarT Name
n)) (Name -> Type
ConT Name
effectName) [Name]
extraTyVarNames)
        )
        [Dec
implementation]
    ]
  where
    matchAndHandleConstructor :: [Name] -> Name -> ConstructorInfo -> Q Clause
    matchAndHandleConstructor :: [Name] -> Name -> ConstructorInfo -> Q Clause
matchAndHandleConstructor [Name]
_ Name
_ ConstructorInfo {constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
InfixConstructor} =
      [Char] -> Q Clause
forall a. HasCallStack => [Char] -> a
error [Char]
"infix constructors for effects not (yet) supported"
    matchAndHandleConstructor
      [Name]
extraTyVarNames
      Name
nestVarName
      ConstructorInfo {constructorName :: ConstructorInfo -> Name
constructorName = Name
name, constructorFields :: ConstructorInfo -> [Type]
constructorFields = [Type]
argTypes} =
        [Name] -> Name -> Name -> [Type] -> Q Clause
handleConstructor [Name]
extraTyVarNames Name
nestVarName Name
name [Type]
argTypes

    handleConstructor :: [Name] -> Name -> Name -> [Type] -> Q Clause
    handleConstructor :: [Name] -> Name -> Name -> [Type] -> Q Clause
handleConstructor [Name]
extraTyVarNames Name
nestVarName Name
cName [Type]
argTypes = do
      [Name]
varNames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
argTypes) ([Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x")
      Name
evalASTName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"evalAST"
      [(Exp, Bool)]
handledArguments <-
        ((Type, Name) -> Q (Exp, Bool))
-> [(Type, Name)] -> Q [(Exp, Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
          ( \(Type
argType, Name
varName) ->
              Bool -> Name -> Name -> Type -> Exp -> Q (Exp, Bool)
handleConstructorArg Bool
True Name
nestVarName Name
evalASTName Type
argType (Name -> Exp
VarE Name
varName)
          )
          ([Type] -> [Name] -> [(Type, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
argTypes [Name]
varNames)
      Clause -> Q Clause
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$
        [Pat] -> Body -> [Dec] -> Clause
Clause
          [ if ((Exp, Bool) -> Bool) -> [(Exp, Bool)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Exp, Bool) -> Bool
forall a b. (a, b) -> b
snd [(Exp, Bool)]
handledArguments
              then Name -> Pat
VarP Name
evalASTName
              else Pat
WildP,
            Name -> [Type] -> [Pat] -> Pat
ConP Name
cName [] ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varNames)
          ]
          ( Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$
              (Exp -> (Exp, Bool) -> Exp) -> Exp -> [(Exp, Bool)] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                (\Exp
f (Exp
x, Bool
_) -> Exp -> Exp -> Exp
AppE Exp
f Exp
x)
                ((Exp -> Name -> Exp) -> Exp -> [Name] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Exp
e Name
v -> Exp -> Type -> Exp
AppTypeE Exp
e (Name -> Type
VarT Name
v)) (Name -> Exp
VarE (Name -> Exp) -> (Name -> Name) -> Name -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
lowerFirst (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ Name
cName) [Name]
extraTyVarNames)
                [(Exp, Bool)]
handledArguments
          )
          []

-- | Helper function for 'makeInterpretation'. This is a hairy one, so let me
-- explain:
--
-- Assume your effect type is defined by something like
--
-- > data Quux m a where
-- >   Quux :: Either (m a, IO x) [b -> m a] -> Quux m a
--
-- (The precise types don't matter, they're just there to illustrate the level
-- of complexity we might encounter.) Then, the "interpretation" instance takes
-- the form
--
-- > instance SomeConstraint m => InterpretEffect m Quux where
-- >   interpretEffect evalAST (Quux arg) = quux arg'
--
-- where @arg@ will be of type
--
-- > Either (AST ops a, IO x) [b -> AST ops a]
--
-- What this function accomplishes is generate the term @arg'@ of type
--
-- > Either (m a, IO a) [b -> m a]
--
-- (where @m@ is the "domain of interpretation" in the instance). Note that the
-- difference between these two types is just that @AST ops@ is replaced by
-- @m@. We can write @arg'@ given @arg@, because we have the function
--
-- > evalAST :: AST ops a -> m a
--
-- which allows us to transform every /positive/ occurrence of @AST ops a@ into
-- @m a@. (To see why negative positions don't work, assume we have @arg :: AST
-- ops a -> b@. Given only @evalAST@, we'll not be able to construct a function
-- of type @m a -> b@.)
handleConstructorArg ::
  -- | Are we in a positive position at the moment?
  Bool ->
  -- | 'Name' of the "nesting" monad in the effect type definition (this is
  -- the penultimate argument of the effect type, the one of kind @* -> *@).
  Name ->
  -- | 'Name' of the function @evalAST@ that evaluates "nested" 'AST's in effects
  Name ->
  -- | Type of the constructor argument we're currently handling
  Type ->
  -- | expression we're slowly building up while traversing the type
  Exp ->
  -- | final expression, together with a boolean that indicates whether we used
  -- @evalAST@
  Q (Exp, Bool)
--
-- If the type of the constructor argument is @m a@, where @m@ is the "nesting"
-- monad, we'll have to use @evalAST@. (But only in positive positions)
--
handleConstructorArg :: Bool -> Name -> Name -> Type -> Exp -> Q (Exp, Bool)
handleConstructorArg Bool
polarity Name
nestName Name
evalASTName (AppT (VarT Name
x) Type
_) Exp
expr
  | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
nestName =
      if Bool
polarity
        then (,Bool
True) (Exp -> (Exp, Bool)) -> Q Exp -> Q (Exp, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [e|$(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
evalASTName) $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
expr)|]
        else [Char] -> Q (Exp, Bool)
forall a. HasCallStack => [Char] -> a
error [Char]
"effect nesting in negative position"
--
-- If the type of the constructor argument of the form @l -> r@, we'll have to
-- pre- and post-compose with the correct functions in order to turn all @AST
-- ops a@ into @m a@. Luckily, we can compute these functions recursively from
-- the shapes of @l@ and @r@.
--
-- Note that we'll have to flip the polarity for the left side!
--
handleConstructorArg Bool
polarity Name
nestName Name
evalASTName (AppT (AppT Type
ArrowT Type
l) Type
r) Exp
expr = do
  Name
aName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"a"
  (Exp
le, Bool
evalASTusedL) <- Bool -> Name -> Name -> Type -> Exp -> Q (Exp, Bool)
handleConstructorArg (Bool -> Bool
not Bool
polarity) Name
nestName Name
evalASTName Type
l (Name -> Exp
VarE Name
aName)
  (Exp
re, Bool
evalASTusedR) <- Bool -> Name -> Name -> Type -> Exp -> Q (Exp, Bool)
handleConstructorArg Bool
polarity Name
nestName Name
evalASTName Type
r (Name -> Exp
VarE Name
aName)
  (,Bool
evalASTusedL Bool -> Bool -> Bool
|| Bool
evalASTusedR)
    (Exp -> (Exp, Bool)) -> Q Exp -> Q (Exp, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [e|(\ $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
aName) -> $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
re)) . $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
expr) . (\ $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
aName) -> $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
le))|]
--
-- The trick to recursively compute the correct functions to apply to subtypes
-- and then combine them works for constructor arguments of the shapes @[...]@,
-- @Maybe ...@, @Either ... ...@, and @(..., ...)@.
--
-- The general pattern to note is that
--
-- - @[]@ and @Maybe@ are functors, so if we know how to transform a single
--   element, we can just use @fmap@
--
-- - @Either@ and @(,)@ are 'Bifunctor's, so we can use 'bimap'
--
-- - @->@ is also a bifunctor (in the category-theoretical sense), namely the
--   Hom-functor. The only difference to the other two bifunctors is the fact
--   that it is contravariant in its first argument, but the "pre- and
--   post-composition operation" /is/ its 'bimap'.
--
handleConstructorArg Bool
polarity Name
nestName Name
evalASTName (AppT Type
ListT Type
t) Exp
expr = do
  Name
aName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"a"
  (Exp
te, Bool
evalASTused) <- Bool -> Name -> Name -> Type -> Exp -> Q (Exp, Bool)
handleConstructorArg Bool
polarity Name
nestName Name
evalASTName Type
t (Name -> Exp
VarE Name
aName)
  (,Bool
evalASTused) (Exp -> (Exp, Bool)) -> Q Exp -> Q (Exp, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [e|map (\ $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
aName) -> $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
te)) $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
expr)|]
handleConstructorArg Bool
polarity Name
nestName Name
evalASTName (AppT (ConT Name
x) Type
t) Exp
expr
  | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Maybe = do
      Name
aName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"a"
      (Exp
te, Bool
evalASTused) <- Bool -> Name -> Name -> Type -> Exp -> Q (Exp, Bool)
handleConstructorArg Bool
polarity Name
nestName Name
evalASTName Type
t (Name -> Exp
VarE Name
aName)
      (,Bool
evalASTused) (Exp -> (Exp, Bool)) -> Q Exp -> Q (Exp, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [e|fmap (\ $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
aName) -> $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
te)) $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
expr)|]
handleConstructorArg Bool
polarity Name
nestName Name
evalASTName (AppT (AppT Type
x Type
l) Type
r) Exp
expr
  | Type
x Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''Either Bool -> Bool -> Bool
|| Type
x Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Type
TupleT Int
2 = do
      Name
aName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"a"
      (Exp
le, Bool
evalASTusedL) <- Bool -> Name -> Name -> Type -> Exp -> Q (Exp, Bool)
handleConstructorArg Bool
polarity Name
nestName Name
evalASTName Type
l (Name -> Exp
VarE Name
aName)
      (Exp
re, Bool
evalASTusedR) <- Bool -> Name -> Name -> Type -> Exp -> Q (Exp, Bool)
handleConstructorArg Bool
polarity Name
nestName Name
evalASTName Type
r (Name -> Exp
VarE Name
aName)
      (,Bool
evalASTusedL Bool -> Bool -> Bool
|| Bool
evalASTusedR)
        (Exp -> (Exp, Bool)) -> Q Exp -> Q (Exp, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [e|bimap (\ $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
aName) -> $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
le)) (\ $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
aName) -> $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
re)) $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
expr)|]
--
-- If the type of the constructor argument is @IO a@, there's nothing to do.
-- Just keep it.
--
handleConstructorArg Bool
_polarity Name
_nestName Name
_evalASTName (AppT (ConT Name
x) Type
_) Exp
expr
  | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''IO = (Exp, Bool) -> Q (Exp, Bool)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
expr, Bool
False)
--
-- Parentheses can be ignored.
--
handleConstructorArg Bool
polarity Name
nestName Name
evalASTName (ParensT Type
t) Exp
expr =
  Bool -> Name -> Name -> Type -> Exp -> Q (Exp, Bool)
handleConstructorArg Bool
polarity Name
nestName Name
evalASTName Type
t Exp
expr
--
-- For a solidary type variable or type constructor there's nothing to do.
--
handleConstructorArg Bool
_ Name
_ Name
_ (VarT Name
_) Exp
expr = (Exp, Bool) -> Q (Exp, Bool)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
expr, Bool
False)
handleConstructorArg Bool
_ Name
_ Name
_ (ConT Name
_) Exp
expr = (Exp, Bool) -> Q (Exp, Bool)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
expr, Bool
False)
--
-- catchall for all types that we can't handle at the moment.
--
handleConstructorArg Bool
_ Name
_ Name
_ Type
t Exp
_ = [Char] -> Q (Exp, Bool)
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q (Exp, Bool)) -> [Char] -> Q (Exp, Bool)
forall a b. (a -> b) -> a -> b
$ [Char]
"Effect argument type of this shape is not (yet) supported: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
t

-- * Helper functions

-- | Transform a name so that the first letter is lower case.
lowerFirst :: Name -> Name
lowerFirst :: Name -> Name
lowerFirst = [Char] -> Name
mkName ([Char] -> Name) -> (Name -> [Char]) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
lowerFirstString ([Char] -> [Char]) -> (Name -> [Char]) -> Name -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
nameBase
  where
    lowerFirstString :: [Char] -> [Char]
lowerFirstString (Char
c : [Char]
cs) = Char -> Char
toLower Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
cs
    lowerFirstString [] = [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"empty name. This can't happen unless I wrote some very weird TemplateHaskell."

-- | Transform a name so that the first letter is upper case.
upperFirst :: Name -> Name
upperFirst :: Name -> Name
upperFirst = [Char] -> Name
mkName ([Char] -> Name) -> (Name -> [Char]) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
upperFirstString ([Char] -> [Char]) -> (Name -> [Char]) -> Name -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
nameBase
  where
    upperFirstString :: [Char] -> [Char]
upperFirstString (Char
c : [Char]
cs) = Char -> Char
toUpper Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
cs
    upperFirstString [] = [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"empty name. This can't happen unless I wrote some very weird TemplateHaskell."

-- | Get the corresponding effect name for the name of a class. The naming
-- scheme is that @X@ will correspond to @XEffect@.
mkEffectName :: Name -> Name
mkEffectName :: Name -> Name
mkEffectName = [Char] -> Name
mkName ([Char] -> Name) -> (Name -> [Char]) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Effect") ([Char] -> [Char]) -> (Name -> [Char]) -> Name -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
nameBase

mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM a -> m (Maybe b)
_ [] = [b] -> m [b]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
mapMaybeM a -> m (Maybe b)
f (a
x : [a]
xs) = do
  Maybe b
my <- a -> m (Maybe b)
f a
x
  case Maybe b
my of
    Maybe b
Nothing -> (a -> m (Maybe b)) -> [a] -> m [b]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM a -> m (Maybe b)
f [a]
xs
    Just b
y -> (b
y b -> [b] -> [b]
forall a. a -> [a] -> [a]
:) ([b] -> [b]) -> m [b] -> m [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> m (Maybe b)) -> [a] -> m [b]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM a -> m (Maybe b)
f [a]
xs

-- | From a type variable binder, extract the name of the variable.
nameFromTyVarBndr :: TyVarBndr flag -> Name
nameFromTyVarBndr :: forall flag. TyVarBndr flag -> Name
nameFromTyVarBndr =
  \case
    PlainTV Name
x flag
_ -> Name
x
    KindedTV Name
x flag
_ Type
_ -> Name
x

-- | destructure a type of the form @a -> b -> c -> ... -> x@ into a list like
-- @[a,b,c,...x]@.
destructFunctionType :: Type -> [Type]
destructFunctionType :: Type -> [Type]
destructFunctionType (AppT (AppT Type
ArrowT Type
l) Type
r) = Type
l Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
destructFunctionType Type
r
destructFunctionType Type
x = [Type
x]