{-# LANGUAGE CPP             #-}
{-# LANGUAGE TemplateHaskell #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Effect.Machinery.TH
-- Copyright   :  (c) Michael Szvetits, 2020
-- License     :  BSD3 (see the file LICENSE)
-- Maintainer  :  typedbyte@qualified.name
-- Stability   :  stable
-- Portability :  portable
--
-- This module provides @TemplateHaskell@ functions to generate the handling,
-- lifting and tagging infrastructure for effect type classes.
-----------------------------------------------------------------------------
module Control.Effect.Machinery.TH
  ( -- * Common Generators
    makeEffect
  , makeHandler
  , makeFinder
  , makeLifter
    -- * Tag-based Generators
  , makeTaggedEffect
  , makeTaggedEffectWith
  , makeTagger
  , makeTaggerWith
  , makeUntagged
  , makeUntaggedWith
    -- * Lifting Convenience
  , liftL
  , runL
    -- * Naming Convention
  , removeApostrophe
  ) where

-- base
import Control.Monad          (forM, replicateM)
import Control.Monad.IO.Class (MonadIO)
import Data.Coerce            (coerce)
import Data.List              (isSuffixOf)
import Data.Maybe             (catMaybes, maybeToList)

-- monad-control
import Control.Monad.Trans.Control (liftWith, restoreT)

-- template-haskell
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax hiding (Lift, lift)

-- transformers
import Control.Monad.Trans.Class (lift)

import Control.Effect.Machinery.Tagger (Tagger(..), runTagger)
import Control.Effect.Machinery.Via    (Control, EachVia(..), Find, G, Handle,
                                        Lift, Via, runVia)

-----------------------------------------
-- Information about effect type classes.
-----------------------------------------
data EffectInfo = EffectInfo
  { EffectInfo -> [Type]
effCxts    :: [Type]
  , EffectInfo -> Name
effName    :: Name
  , EffectInfo -> [TyVarBndr]
effParams  :: [TyVarBndr]
  , EffectInfo -> TyVarBndr
effMonad   :: TyVarBndr
  , EffectInfo -> [Signature]
effMethods :: [Signature]
  }

data Signature = Signature
  { Signature -> Name
sigName :: Name
  , Signature -> Type
sigType :: Type
  }

-- Given a type class name, extracts infos about an effect.
effectInfo :: Name -> Q EffectInfo
effectInfo :: Name -> Q EffectInfo
effectInfo Name
className = do
  Info
info <- Name -> Q Info
reify Name
className
  case Info
info of
    ClassI (ClassD [Type]
cxts Name
name [TyVarBndr]
tyVars [FunDep]
_ [Dec]
decs) [Dec]
_ -> do
      ([TyVarBndr]
params, TyVarBndr
monad) <-
        case [TyVarBndr]
tyVars of
          [] -> String -> Q ([TyVarBndr], TyVarBndr)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                  (String -> Q ([TyVarBndr], TyVarBndr))
-> String -> Q ([TyVarBndr], TyVarBndr)
forall a b. (a -> b) -> a -> b
$  String
"The specified effect type class `"
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
name
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' has no monad type variable. "
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"It is expected to be the last type variable."
          [TyVarBndr]
vs -> ([TyVarBndr], TyVarBndr) -> Q ([TyVarBndr], TyVarBndr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a]
init [TyVarBndr]
vs, [TyVarBndr] -> TyVarBndr
forall a. [a] -> a
last [TyVarBndr]
vs)
      let sigs :: [Signature]
sigs = [Name -> Type -> Signature
Signature Name
n Type
t | SigD Name
n Type
t <- [Dec]
decs]
      EffectInfo -> Q EffectInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EffectInfo -> Q EffectInfo) -> EffectInfo -> Q EffectInfo
forall a b. (a -> b) -> a -> b
$ [Type]
-> Name -> [TyVarBndr] -> TyVarBndr -> [Signature] -> EffectInfo
EffectInfo [Type]
cxts Name
name [TyVarBndr]
params TyVarBndr
monad [Signature]
sigs
    Info
other ->
      String -> Q EffectInfo
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
         (String -> Q EffectInfo) -> String -> Q EffectInfo
forall a b. (a -> b) -> a -> b
$ String
"The specified name `"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
className
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is not a type class, but the following instead: "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Info -> String
forall a. Show a => a -> String
show Info
other

-- Constructs the type of an effect, i.e. the type class
-- without its monad parameter.
effectType :: EffectInfo -> Q Type
effectType :: EffectInfo -> Q Type
effectType EffectInfo
info =
  (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
    ( Q Type -> Q Type -> Q Type
appT )
    ( Name -> Q Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ EffectInfo -> Name
effName EffectInfo
info )
    ( (TyVarBndr -> Q Type) -> [TyVarBndr] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> Q Type
tyVarType (EffectInfo -> [TyVarBndr]
effParams EffectInfo
info) )

-- Extracts the super classes of an effect which have the
-- kind of effects. As an example, for the following effect ...
--
-- class (State s m, Monad m) => MyEffect s m where ...
--
-- ... this would return [State s, Monad].
superEffects :: EffectInfo -> [Type]
superEffects :: EffectInfo -> [Type]
superEffects EffectInfo
info =
  [Maybe Type] -> [Type]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Type] -> [Type]) -> [Maybe Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ (Type -> Maybe Type) -> [Type] -> [Maybe Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Maybe Type
extract (EffectInfo -> [Type]
effCxts EffectInfo
info)
    where
      m :: Name
m = TyVarBndr -> Name
tyVarName (EffectInfo -> TyVarBndr
effMonad EffectInfo
info)
      extract :: Type -> Maybe Type
extract = \case
        ForallT [TyVarBndr]
_ [Type]
_ Type
t -> Type -> Maybe Type
extract Type
t
        SigT Type
t Type
_      -> Type -> Maybe Type
extract Type
t
        ParensT Type
t     -> Type -> Maybe Type
extract Type
t
        Type
t `AppT` VarT Name
n      | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
t
        InfixT Type
t Name
_ (VarT Name
n)  | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
t
        UInfixT Type
t Name
_ (VarT Name
n) | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
t
#if __GLASGOW_HASKELL__ >= 808
        AppKindT Type
t Type
_ -> Type -> Maybe Type
extract Type
t
        ImplicitParamT String
_ Type
t -> Type -> Maybe Type
extract Type
t
#endif
        Type
_ -> Maybe Type
forall a. Maybe a
Nothing

-- Like superEffects, but ignores super classes from base
-- (i.e., Applicative, Functor, Monad, MonadIO).
superEffectsWithoutBase :: EffectInfo -> [Type]
superEffectsWithoutBase :: EffectInfo -> [Type]
superEffectsWithoutBase =
  (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Type -> Bool) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Bool
isBase) ([Type] -> [Type])
-> (EffectInfo -> [Type]) -> EffectInfo -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EffectInfo -> [Type]
superEffects 
    where
      isBase :: Type -> Bool
isBase = \case
        ConT Name
n -> Name
n Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [''Applicative, ''Functor, ''Monad, ''MonadIO]
        Type
_ -> Bool
False

-------------------------------------------------
-- Tagging information about effect type classes.
-------------------------------------------------
data TaggedInfo = TaggedInfo
  { TaggedInfo -> TyVarBndr
tgTag    :: TyVarBndr
  , TaggedInfo -> [TyVarBndr]
tgParams :: [TyVarBndr]
  }

-- Given an effect, extracts infos about the tag parameter.
taggedInfo :: EffectInfo -> Q TaggedInfo
taggedInfo :: EffectInfo -> Q TaggedInfo
taggedInfo EffectInfo
info =
  case EffectInfo -> [TyVarBndr]
effParams EffectInfo
info of
    []     -> String -> Q TaggedInfo
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"The effect has no tag parameter."
    (TyVarBndr
v:[TyVarBndr]
vs) -> TaggedInfo -> Q TaggedInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TaggedInfo -> Q TaggedInfo) -> TaggedInfo -> Q TaggedInfo
forall a b. (a -> b) -> a -> b
$ TyVarBndr -> [TyVarBndr] -> TaggedInfo
TaggedInfo TyVarBndr
v [TyVarBndr]
vs

-- | Generates the effect handling and lifting infrastructure for an effect which
-- does not have a tag type parameter. Requires the @TemplateHaskell@ language
-- extension.
--
-- Consider the following effect type class:
--
-- @
--     class 'Monad' m => MyEffect a b c m where
--       ...
-- @
--
-- @makeEffect ''MyEffect@ then generates three instances for this effect type
-- class ('Lift' for first-order effects, 'Control' for higher-order effects):
--
-- @
--     instance 'Handle' (MyEffect a b c) t m => MyEffect a b c ('EachVia' (MyEffect a b c : effs) t m) where
--       ...
--
--     instance {-\# OVERLAPPABLE \#-} 'Find' (MyEffect a b c) effs t m => MyEffect a b c ('EachVia' (other : effs) t m) where
--       ...
--
--     instance 'Lift'/'Control' (MyEffect a b c) t m => MyEffect a b c ('EachVia' \'[] t m) where
--       ...
-- @
--
-- The first instance indicates that @MyEffect@ was found at the head of the type
-- level list of effects to be handled, so @MyEffect@ is delegated to @t@.
--
-- The second instance indicates that @MyEffect@ was not found at the head of the
-- type level list of effects to be handled, so we must find @MyEffect@ in the tail @effs@
-- of the type level list.
--
-- The third instance indicates that @MyEffect@ could not be found in the type level
-- list of effects to be handled, so the effect must be delegated further down the monad
-- transformer stack in order to find its corresponding effect handler.
--
-- Without @TemplateHaskell@, you have to write these three instances by hand. These
-- instances can also be generated separately, see 'makeHandler', 'makeFinder' and
-- 'makeLifter'.
makeEffect :: Name -> Q [Dec]
makeEffect :: Name -> Q [Dec]
makeEffect Name
className = do
  EffectInfo
effInfo   <- Name -> Q EffectInfo
effectInfo Name
className
  Dec
hInstance <- EffectInfo -> Q Dec
handler EffectInfo
effInfo
  Dec
fInstance <- EffectInfo -> Q Dec
finder EffectInfo
effInfo
  Dec
lInstance <- EffectInfo -> Q Dec
lifter EffectInfo
effInfo
  Dec
tInstance <- EffectInfo -> Q Dec
identityTaggerInstance EffectInfo
effInfo
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
hInstance, Dec
fInstance, Dec
lInstance, Dec
tInstance]

-- | Similar to 'makeTaggedEffect', but only generates the tag-related definitions.
makeTagger :: Name -> Q [Dec]
makeTagger :: Name -> Q [Dec]
makeTagger = (String -> Q String) -> Name -> Q [Dec]
makeTaggerWith String -> Q String
removeApostrophe

-- | Similar to 'makeTaggedEffectWith', but only generates the tag-related definitions.
makeTaggerWith :: (String -> Q String) -> Name -> Q [Dec]
makeTaggerWith :: (String -> Q String) -> Name -> Q [Dec]
makeTaggerWith String -> Q String
mapping Name
className = do
  let f :: Name -> Q Name
f = (String -> Name) -> Q String -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Name
mkName (Q String -> Q Name) -> (Name -> Q String) -> Name -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q String
mapping (String -> Q String) -> (Name -> String) -> Name -> Q String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
  EffectInfo
effInfo <- Name -> Q EffectInfo
effectInfo Name
className
  TaggedInfo
tagInfo <- EffectInfo -> Q TaggedInfo
taggedInfo EffectInfo
effInfo
  (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q [Dec]
tagger Name -> Q Name
f EffectInfo
effInfo TaggedInfo
tagInfo

-- | Generates the effect handling and lifting infrastructure for an effect which
-- has a tag type parameter. It is expected that the tag type parameter is the first
-- type parameter of the effect type class. It is also expected that the names of the
-- effect type class and its methods end with an apostrophe \"'\". If you want more
-- control over the naming convention, use 'makeTaggedEffectWith'.
--
-- In general, this function generates everything that 'makeEffect' does, but also some
-- additional things. Consider the following effect type class:
--
-- @
--     class 'Monad' m => MyEffect' tag a b c m where
--       methodA' :: a -> m ()
--       methodB' :: b -> m ()
--       methodC' :: c -> m ()
-- @
--
-- @'makeTaggedEffect' \'\'MyEffect'@ then generates the following additional things:
--
-- * A type synonym for the untagged version of @MyEffect'@ with the name @MyEffect@
-- (note the missing apostrophe).
-- * Untagged versions of the effect methods, namely @methodA@, @methodB@ and @methodC@
-- (note the missing apostrophes).
-- * An instance of @MyEffect'@ for the type 'Tagger' which does not handle the effect,
-- but simply tags, retags or untags the @MyEffect'@ constraint of a computation.
-- * Three functions @tagMyEffect'@, @retagMyEffect'@ and @untagMyEffect'@ which make
-- use of the 'Tagger' instance.
--
-- As a rule of thumb, whenever you see an apostrophe suffix in the name of a definition
-- somewhere in this library, it has something to do with tags. Most of the time you
-- will use such definitions in combination with the language extension @TypeApplications@,
-- like:
--
-- @
--     ... forall tag ... methodA' @tag ...
--     tagMyEffect' \@\"newTag\" program
--     retagMyEffect' \@\"oldTag\" \@\"newTag\" program
--     untagMyEffect' \@\"erasedTag\" program
-- @
--
-- All the tag-related definitions can also be generated separately (i.e., without the
-- instances generated by 'makeEffect'), see 'makeTagger' and 'makeTaggerWith'.
makeTaggedEffect :: Name -> Q [Dec]
makeTaggedEffect :: Name -> Q [Dec]
makeTaggedEffect = (String -> Q String) -> Name -> Q [Dec]
makeTaggedEffectWith String -> Q String
removeApostrophe

-- | Similar to 'makeTaggedEffect', but allows to define a naming convention function
-- for the names of the effect type class and its methods. This function is used to
-- transform the name of a tagged definition (i.e., the type class or its methods) into
-- its untagged counterpart.
--
-- The default naming convention is enforced by 'removeApostrophe', which simply
-- removes the apostrophe \"'\" at the end of a name.
makeTaggedEffectWith :: (String -> Q String) -> Name -> Q [Dec]
makeTaggedEffectWith :: (String -> Q String) -> Name -> Q [Dec]
makeTaggedEffectWith String -> Q String
mapping Name
className = do
  let f :: Name -> Q Name
f = (String -> Name) -> Q String -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Name
mkName (Q String -> Q Name) -> (Name -> Q String) -> Name -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q String
mapping (String -> Q String) -> (Name -> String) -> Name -> Q String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
  EffectInfo
effInfo    <- Name -> Q EffectInfo
effectInfo Name
className
  TaggedInfo
tagInfo    <- EffectInfo -> Q TaggedInfo
taggedInfo EffectInfo
effInfo
  Dec
hInstance  <- EffectInfo -> Q Dec
handler EffectInfo
effInfo
  Dec
fInstance  <- EffectInfo -> Q Dec
finder EffectInfo
effInfo
  Dec
lInstance  <- EffectInfo -> Q Dec
lifter EffectInfo
effInfo
  [Dec]
taggerDecs <- (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q [Dec]
tagger Name -> Q Name
f EffectInfo
effInfo TaggedInfo
tagInfo
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
hInstance Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
fInstance Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
lInstance Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
taggerDecs)

-- | Given a list of function names, this function generates untagged versions
-- of them, i.e. it removes the tag type parameters  from their type signatures
-- (by applying 'G') and converts tagged effect type classes found in the
-- signature to their corresponding untagged type synonyms using 'removeApostrophe'.
--
-- @since 0.4.0.0
makeUntagged :: [Name] -> Q [Dec]
makeUntagged :: [Name] -> Q [Dec]
makeUntagged = (String -> Q String) -> [Name] -> Q [Dec]
makeUntaggedWith String -> Q String
removeApostrophe

-- | Similar to 'makeUntagged', but allows to define a naming convention function
-- for the names of the generated functions and the effect type classes modified
-- in the type signatures.
--
-- The default naming convention is enforced by 'removeApostrophe', which simply
-- removes the apostrophe \"'\" at the end of a name.
--
-- @since 0.4.0.0
makeUntaggedWith :: (String -> Q String) -> [Name] -> Q [Dec]
makeUntaggedWith :: (String -> Q String) -> [Name] -> Q [Dec]
makeUntaggedWith String -> Q String
mapping [Name]
names =
  let f :: Name -> Q Name
f = (String -> Name) -> Q String -> Q Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Name
mkName (Q String -> Q Name) -> (Name -> Q String) -> Name -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q String
mapping (String -> Q String) -> (Name -> String) -> Name -> Q String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase in
  ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Name] -> (Name -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name]
names ((Name -> Q [Dec]) -> Q [[Dec]]) -> (Name -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \Name
name -> do
    Info
info <- Name -> Q Info
reify Name
name
    case Info
info of
      VarI Name
funName Type
typ Maybe Dec
_ -> do
        Name
tag <- Type -> Q Name
findTagParameter Type
typ
        Name
genName <- Name -> Q Name
f Name
funName
        Dec
funSig <- Name -> Q Type -> Q Dec
sigD Name
genName (Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$ (Name -> Q Name) -> Name -> Type -> Q Type
replaceTag Name -> Q Name
f Name
tag Type
typ
        [Dec]
funDef <- [d| $(varP genName) = $(varE funName) @G |]
        Dec
funInline <- Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD Name
genName Inline
Inline RuleMatch
FunLike Phases
AllPhases
        [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
funSig Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
funInline Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
funDef)
      Info
other ->
        String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
           (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String
"Expected a function for name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
name
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", but encountered: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Info -> String
forall a. Show a => a -> String
show Info
other

-- | Similar to 'makeEffect', but only generates the effect type class instance
-- for handling an effect.
makeHandler :: Name -> Q [Dec]
makeHandler :: Name -> Q [Dec]
makeHandler Name
className = do
  EffectInfo
effInfo   <- Name -> Q EffectInfo
effectInfo Name
className
  Dec
hInstance <- EffectInfo -> Q Dec
handler EffectInfo
effInfo
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
hInstance]

-- | Similar to 'makeEffect', but only generates the effect type class instance
-- for finding the effect in the tail of the type level list.
--
-- @since 0.2.0.0
makeFinder :: Name -> Q [Dec]
makeFinder :: Name -> Q [Dec]
makeFinder Name
className = do
  EffectInfo
effInfo   <- Name -> Q EffectInfo
effectInfo Name
className
  Dec
fInstance <- EffectInfo -> Q Dec
finder EffectInfo
effInfo
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
fInstance]

-- | Similar to 'makeEffect', but only generates the effect type class instance
-- for lifting an effect.
makeLifter :: Name -> Q [Dec]
makeLifter :: Name -> Q [Dec]
makeLifter Name
className = do
  EffectInfo
effInfo   <- Name -> Q EffectInfo
effectInfo Name
className
  Dec
lInstance <- EffectInfo -> Q Dec
lifter EffectInfo
effInfo
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
lInstance]

tagger :: (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q [Dec]
tagger :: (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q [Dec]
tagger Name -> Q Name
f EffectInfo
effInfo TaggedInfo
tagInfo = do
  [Dec]
taggerFuns   <- EffectInfo -> TaggedInfo -> Q [Dec]
taggerFunctions EffectInfo
effInfo TaggedInfo
tagInfo
  Dec
untaggedSyn  <- (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q Dec
untaggedSynonym Name -> Q Name
f EffectInfo
effInfo TaggedInfo
tagInfo
  [Dec]
untaggedFuns <- (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q [Dec]
untaggedFunctions Name -> Q Name
f EffectInfo
effInfo TaggedInfo
tagInfo
  Dec
taggerInst   <- EffectInfo -> TaggedInfo -> Q Dec
taggerInstance EffectInfo
effInfo TaggedInfo
tagInfo
  [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
untaggedSyn
    Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
taggerInst
    Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
taggerFuns
   [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
untaggedFuns

handler :: EffectInfo -> Q Dec
handler :: EffectInfo -> Q Dec
handler EffectInfo
info = do
  [Dec]
funs   <- EffectInfo -> Q [Dec]
handlerFunctions EffectInfo
info
  Name
others <- String -> Q Name
newName String
"others"
  Name
trafo  <- String -> Q Name
newName String
"t"
  CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD
    ( Name -> Name -> CxtQ
instanceHandleCxt Name
others Name
trafo )
    ( Q Type -> Name -> EffectInfo -> Q Type
instanceHead (Q Type
promotedConsT Q Type -> Q Type -> Q Type
`appT` EffectInfo -> Q Type
effectType EffectInfo
info Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
others) Name
trafo EffectInfo
info )
    ( (Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
funs )
  where
    instanceHandleCxt :: Name -> Name -> Q Cxt
    instanceHandleCxt :: Name -> Name -> CxtQ
instanceHandleCxt Name
others Name
trafo = [Q Type] -> CxtQ
cxt
      [
        Name -> Q Type
conT ''Handle
          Q Type -> Q Type -> Q Type
`appT` [Q Type] -> Q Type
typeLevelList ((Type -> Q Type) -> [Type] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Type] -> [Q Type]) -> [Type] -> [Q Type]
forall a b. (a -> b) -> a -> b
$ EffectInfo -> [Type]
superEffects EffectInfo
info)
          Q Type -> Q Type -> Q Type
`appT` EffectInfo -> Q Type
effectType EffectInfo
info
          Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
others
          Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
trafo
          Q Type -> Q Type -> Q Type
`appT` TyVarBndr -> Q Type
tyVarType (EffectInfo -> TyVarBndr
effMonad EffectInfo
info)
      ]

finder :: EffectInfo -> Q Dec
finder :: EffectInfo -> Q Dec
finder EffectInfo
info = do
  [Dec]
funs  <- EffectInfo -> Q [Dec]
finderFunctions EffectInfo
info
  Name
other <- String -> Q Name
newName String
"other"
  Name
effs  <- String -> Q Name
newName String
"effs"
  Name
trafo <- String -> Q Name
newName String
"t"
  Maybe Overlap -> CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceWithOverlapD
    ( Overlap -> Maybe Overlap
forall a. a -> Maybe a
Just Overlap
Overlappable )
    ( Name -> Name -> Name -> CxtQ
instanceFinderCxt Name
other Name
effs Name
trafo )
    ( Q Type -> Name -> EffectInfo -> Q Type
instanceHead (Q Type
promotedConsT Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
other Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
effs) Name
trafo EffectInfo
info )
    ( (Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
funs )
  where
    instanceFinderCxt :: Name -> Name -> Name -> Q Cxt
    instanceFinderCxt :: Name -> Name -> Name -> CxtQ
instanceFinderCxt Name
other Name
effs Name
trafo = [Q Type] -> CxtQ
cxt
      [
        Name -> Q Type
conT ''Find
          Q Type -> Q Type -> Q Type
`appT` [Q Type] -> Q Type
typeLevelList ((Type -> Q Type) -> [Type] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Type] -> [Q Type]) -> [Type] -> [Q Type]
forall a b. (a -> b) -> a -> b
$ EffectInfo -> [Type]
superEffects EffectInfo
info)
          Q Type -> Q Type -> Q Type
`appT` EffectInfo -> Q Type
effectType EffectInfo
info
          Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
other
          Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
effs
          Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
trafo
          Q Type -> Q Type -> Q Type
`appT` TyVarBndr -> Q Type
tyVarType (EffectInfo -> TyVarBndr
effMonad EffectInfo
info)
      ]

lifter :: EffectInfo -> Q Dec
lifter :: EffectInfo -> Q Dec
lifter EffectInfo
info = do
  let
    monad :: TyVarBndr
monad = EffectInfo -> TyVarBndr
effMonad EffectInfo
info
    liftType :: Name
liftType =
      if (Signature -> Bool) -> [Signature] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TyVarBndr -> Signature -> Bool
isHigherOrder TyVarBndr
monad) (EffectInfo -> [Signature]
effMethods EffectInfo
info)
      then ''Control
      else ''Lift
  [Dec]
funs  <- EffectInfo -> Q [Dec]
lifterFunctions EffectInfo
info
  Name
trafo <- String -> Q Name
newName String
"t"
  CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD
    ( Name -> Name -> CxtQ
instanceLiftControlCxt Name
liftType Name
trafo )
    ( Q Type -> Name -> EffectInfo -> Q Type
instanceHead Q Type
promotedNilT Name
trafo EffectInfo
info )
    ( (Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
funs )
  where
    instanceLiftControlCxt :: Name -> Name -> Q Cxt
    instanceLiftControlCxt :: Name -> Name -> CxtQ
instanceLiftControlCxt Name
name Name
trafo = [Q Type] -> CxtQ
cxt
      [
        Name -> Q Type
conT Name
name
          Q Type -> Q Type -> Q Type
`appT` [Q Type] -> Q Type
typeLevelList ((Type -> Q Type) -> [Type] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Type] -> [Q Type]) -> [Type] -> [Q Type]
forall a b. (a -> b) -> a -> b
$ EffectInfo -> [Type]
superEffects EffectInfo
info)
          Q Type -> Q Type -> Q Type
`appT` EffectInfo -> Q Type
effectType EffectInfo
info
          Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
trafo
          Q Type -> Q Type -> Q Type
`appT` TyVarBndr -> Q Type
tyVarType (EffectInfo -> TyVarBndr
effMonad EffectInfo
info)
      ]

instanceHead :: Q Type -> Name -> EffectInfo -> Q Type
instanceHead :: Q Type -> Name -> EffectInfo -> Q Type
instanceHead Q Type
effs Name
trafo EffectInfo
info =
  EffectInfo -> Q Type
effectType EffectInfo
info
    Q Type -> Q Type -> Q Type
`appT` (
      Name -> Q Type
conT ''EachVia
        Q Type -> Q Type -> Q Type
`appT` Q Type
effs
        Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT Name
trafo
        Q Type -> Q Type -> Q Type
`appT` TyVarBndr -> Q Type
tyVarType (EffectInfo -> TyVarBndr
effMonad EffectInfo
info)
      )

taggerFunctions :: EffectInfo -> TaggedInfo -> Q [Dec]
taggerFunctions :: EffectInfo -> TaggedInfo -> Q [Dec]
taggerFunctions EffectInfo
effInfo TaggedInfo
tagInfo = do
  let tagVar :: TyVarBndr
tagVar       = TaggedInfo -> TyVarBndr
tgTag TaggedInfo
tagInfo
      nameString :: String
nameString   = Name -> String
nameBase (EffectInfo -> Name
effName EffectInfo
effInfo)
      tagFName :: Name
tagFName     = String -> Name
mkName (String
"tag"   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nameString)
      retagFName :: Name
retagFName   = String -> Name
mkName (String
"retag" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nameString)
      untagFName :: Name
untagFName   = String -> Name
mkName (String
"untag" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nameString)
  Name
new    <- String -> Q Name
newName String
"new"
  [Dec]
tagF   <- Name
-> EffectInfo
-> TaggedInfo
-> Maybe TyVarBndr
-> Maybe Name
-> Q [Dec]
taggerFunction Name
tagFName EffectInfo
effInfo TaggedInfo
tagInfo Maybe TyVarBndr
forall a. Maybe a
Nothing (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
new)
  [Dec]
retagF <- Name
-> EffectInfo
-> TaggedInfo
-> Maybe TyVarBndr
-> Maybe Name
-> Q [Dec]
taggerFunction Name
retagFName EffectInfo
effInfo TaggedInfo
tagInfo (TyVarBndr -> Maybe TyVarBndr
forall a. a -> Maybe a
Just TyVarBndr
tagVar) (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
new)
  [Dec]
untagF <- Name
-> EffectInfo
-> TaggedInfo
-> Maybe TyVarBndr
-> Maybe Name
-> Q [Dec]
taggerFunction Name
untagFName EffectInfo
effInfo TaggedInfo
tagInfo (TyVarBndr -> Maybe TyVarBndr
forall a. a -> Maybe a
Just TyVarBndr
tagVar) Maybe Name
forall a. Maybe a
Nothing
  [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]
tagF [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
retagF [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
untagF
  
taggerFunction :: Name -> EffectInfo -> TaggedInfo -> Maybe TyVarBndr -> Maybe Name -> Q [Dec]
taggerFunction :: Name
-> EffectInfo
-> TaggedInfo
-> Maybe TyVarBndr
-> Maybe Name
-> Q [Dec]
taggerFunction Name
funName EffectInfo
effInfo TaggedInfo
tagInfo Maybe TyVarBndr
tag Maybe Name
new = do
  Name
mName <- String -> Q Name
newName String
"m"
  Name
aName <- String -> Q Name
newName String
"a"
  Type
gType <- [t| G |]
  let m :: Q Type
m           = Name -> Q Type
varT Name
mName
      a :: Q Type
a           = Name -> Q Type
varT Name
aName
      params :: [TyVarBndr]
params      = TaggedInfo -> [TyVarBndr]
tgParams TaggedInfo
tagInfo
      tagParam :: Q Type
tagParam    = Q Type -> (TyVarBndr -> Q Type) -> Maybe TyVarBndr -> Q Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
gType) (Name -> Q Type
varT (Name -> Q Type) -> (TyVarBndr -> Name) -> TyVarBndr -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Name
tyVarName) Maybe TyVarBndr
tag
      newParam :: Q Type
newParam    = Q Type -> (Name -> Q Type) -> Maybe Name -> Q Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
gType) Name -> Q Type
varT Maybe Name
new
      tagVars :: [TyVarBndr]
tagVars     = Maybe TyVarBndr -> [TyVarBndr]
forall a. Maybe a -> [a]
maybeToList Maybe TyVarBndr
tag [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ Maybe TyVarBndr -> [TyVarBndr]
forall a. Maybe a -> [a]
maybeToList ((Name -> TyVarBndr) -> Maybe Name -> Maybe TyVarBndr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> TyVarBndr
PlainTV Maybe Name
new)
      forallVars :: [TyVarBndr]
forallVars  = (TyVarBndr -> TyVarBndr) -> [TyVarBndr] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> TyVarBndr
unkindTyVar ([TyVarBndr]
tagVars [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ [TyVarBndr]
params) [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ [Name -> TyVarBndr
PlainTV Name
mName, Name -> TyVarBndr
PlainTV Name
aName]
      paramTypes :: [Q Type]
paramTypes  = (TyVarBndr -> Q Type) -> [TyVarBndr] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyVarBndr -> Q Type
tyVarType (TyVarBndr -> Q Type)
-> (TyVarBndr -> TyVarBndr) -> TyVarBndr -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> TyVarBndr
unkindTyVar) [TyVarBndr]
params
      effType :: Q Type
effType     = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ EffectInfo -> Name
effName EffectInfo
effInfo) (Q Type
tagParam Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: [Q Type]
paramTypes)
      effList :: [Q Type]
effList     = Q Type
effType Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: (Type -> Q Type) -> [Type] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EffectInfo -> [Type]
superEffectsWithoutBase EffectInfo
effInfo)
      untagList :: [Q Type]
untagList =
        case Maybe TyVarBndr
tag of
            Maybe TyVarBndr
Nothing -> (Q Type -> Q Type) -> [Q Type] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Type -> Type) -> Q Type -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Type -> Type -> Type
replace (TyVarBndr -> Name
tyVarName (TyVarBndr -> Name) -> TyVarBndr -> Name
forall a b. (a -> b) -> a -> b
$ TaggedInfo -> TyVarBndr
tgTag TaggedInfo
tagInfo) Type
gType)) [Q Type]
effList
            Just TyVarBndr
_  -> [Q Type]
effList
      taggerType :: Q Type
taggerType = [t| Tagger $tagParam $newParam |]
      viaType :: Q Type
viaType =
        case [Q Type]
untagList of
#if __GLASGOW_HASKELL__ >= 808
          [Q Type
e] -> Q Type -> Name -> Q Type -> Q Type
uInfixT Q Type
e ''Via Q Type
taggerType
          [Q Type]
es  -> Q Type -> Name -> Q Type -> Q Type
uInfixT ([Q Type] -> Q Type
typeLevelList [Q Type]
es) ''EachVia Q Type
taggerType
#else
          [e] -> conT ''Via `appT` e `appT` taggerType
          es  -> conT ''EachVia `appT` typeLevelList es `appT` taggerType
#endif
      funSigType :: Q Type
funSigType = [t| $viaType $m $a -> $m $a |]
  Dec
funSig    <- Name -> Q Type -> Q Dec
sigD Name
funName (Q Type -> Q Dec) -> Q Type -> Q Dec
forall a b. (a -> b) -> a -> b
$ [TyVarBndr] -> CxtQ -> Q Type -> Q Type
forallT [TyVarBndr]
forallVars ([Q Type] -> CxtQ
cxt []) Q Type
funSigType
  [Dec]
funDef    <- [d| $(varP funName) = runTagger . runVia |]
  Dec
funInline <- Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD Name
funName Inline
Inline RuleMatch
FunLike Phases
AllPhases
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
funSig Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
funInline Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
funDef)
    where
      replace :: Name -> Type -> Type -> Type
      replace :: Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag = \case
        ConT Name
n `AppT` VarT Name
param | Name
param Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
oldTag -> Name -> Type
ConT Name
n Type -> Type -> Type
`AppT` Type
newTag
        ForallT [TyVarBndr]
vars [Type]
ctx Type
t -> [TyVarBndr] -> [Type] -> Type -> Type
ForallT [TyVarBndr]
vars [Type]
ctx (Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag Type
t)
        AppT Type
l Type
r           -> Type -> Type -> Type
AppT (Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag Type
l) Type
r
        SigT Type
t Type
k           -> Type -> Type -> Type
SigT (Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag Type
t) Type
k
        InfixT Type
l Name
n Type
r       -> Type -> Name -> Type -> Type
InfixT (Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag Type
l) Name
n (Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag Type
r)
        UInfixT Type
l Name
n Type
r      -> Type -> Name -> Type -> Type
UInfixT (Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag Type
l) Name
n (Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag Type
r)
        ParensT Type
t          -> Type -> Type
ParensT (Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag Type
t)
#if __GLASGOW_HASKELL__ >= 808
        AppKindT Type
t Type
k -> Type -> Type -> Type
AppKindT (Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag Type
t) Type
k
        ImplicitParamT String
s Type
t -> String -> Type -> Type
ImplicitParamT String
s (Name -> Type -> Type -> Type
replace Name
oldTag Type
newTag Type
t)
#endif
        Type
other              -> Type
other

untaggedSynonym :: (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q Dec
untaggedSynonym :: (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q Dec
untaggedSynonym Name -> Q Name
f EffectInfo
effInfo TaggedInfo
tagInfo = do
  Name
synName <- Name -> Q Name
f (EffectInfo -> Name
effName EffectInfo
effInfo)
  Name -> [TyVarBndr] -> Q Type -> Q Dec
tySynD
    ( Name
synName )
    ( [TyVarBndr]
params  )
    ( (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ EffectInfo -> Name
effName EffectInfo
effInfo) (Name -> Q Type
conT ''G Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: (TyVarBndr -> Q Type) -> [TyVarBndr] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> Q Type
tyVarType [TyVarBndr]
params) )
  where
    params :: [TyVarBndr]
params = (TyVarBndr -> TyVarBndr) -> [TyVarBndr] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> TyVarBndr
unkindTyVar (TaggedInfo -> [TyVarBndr]
tgParams TaggedInfo
tagInfo)

untaggedFunctions :: (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q [Dec]
untaggedFunctions :: (Name -> Q Name) -> EffectInfo -> TaggedInfo -> Q [Dec]
untaggedFunctions Name -> Q Name
f EffectInfo
effInfo TaggedInfo
tagInfo = do
  Name
synName <- Name -> Q Name
f (EffectInfo -> Name
effName EffectInfo
effInfo)
  ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
    [Signature] -> (Signature -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (EffectInfo -> [Signature]
effMethods EffectInfo
effInfo)
      ((Signature -> Q [Dec]) -> Q [[Dec]])
-> (Signature -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ (Name -> Q Name) -> Q Type -> Signature -> Q [Dec]
untaggedFunction Name -> Q Name
f
      (Q Type -> Signature -> Q [Dec]) -> Q Type -> Signature -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
          ( Q Type -> Q Type -> Q Type
appT         )
          ( Name -> Q Type
conT Name
synName )
          ( (TyVarBndr -> Q Type) -> [TyVarBndr] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyVarBndr -> Q Type
tyVarType (TyVarBndr -> Q Type)
-> (TyVarBndr -> TyVarBndr) -> TyVarBndr -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> TyVarBndr
unkindTyVar) ([TyVarBndr] -> [Q Type]) -> [TyVarBndr] -> [Q Type]
forall a b. (a -> b) -> a -> b
$ TaggedInfo -> [TyVarBndr]
tgParams TaggedInfo
tagInfo [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ [EffectInfo -> TyVarBndr
effMonad EffectInfo
effInfo] )

untaggedFunction :: (Name -> Q Name) -> Q Type -> Signature -> Q [Dec]
untaggedFunction :: (Name -> Q Name) -> Q Type -> Signature -> Q [Dec]
untaggedFunction Name -> Q Name
f Q Type
effType Signature
sig = do
  let originalName :: Name
originalName = Signature -> Name
sigName Signature
sig
      signatureBody :: Q Type
signatureBody = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Type
unkindType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Signature -> Type
sigType Signature
sig)
  Name
funName   <- Name -> Q Name
f Name
originalName
  Dec
funSig    <- Name -> Q Type -> Q Dec
sigD Name
funName [t| $effType => $signatureBody |]
  [Dec]
funDef    <- [d| $(varP funName) = $(varE originalName) @G |]
  Dec
funInline <- Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD Name
funName Inline
Inline RuleMatch
FunLike Phases
AllPhases
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
funSig Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
funInline Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
funDef)

taggerInstance :: EffectInfo -> TaggedInfo -> Q Dec
taggerInstance :: EffectInfo -> TaggedInfo -> Q Dec
taggerInstance EffectInfo
effInfo TaggedInfo
tagInfo = do
  Name
newTagName <- String -> Q Name
newName String
"new"
  let new :: Q Type
new = Name -> Q Type
varT Name
newTagName
      monadName :: Name
monadName = TyVarBndr -> Name
tyVarName (EffectInfo -> TyVarBndr
effMonad EffectInfo
effInfo)
      m :: Q Type
m = Name -> Q Type
varT Name
monadName
      tag :: Q Type
tag = TyVarBndr -> Q Type
tyVarType (TaggedInfo -> TyVarBndr
tgTag TaggedInfo
tagInfo)
      effType :: Q Type
effType = Name -> Q Type
conT (EffectInfo -> Name
effName EffectInfo
effInfo)
      paramTypes :: [Q Type]
paramTypes = (TyVarBndr -> Q Type) -> [TyVarBndr] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> Q Type
tyVarType (TaggedInfo -> [TyVarBndr]
tgParams TaggedInfo
tagInfo)
      taggerType :: Q Type
taggerType = [t| Tagger $tag $new $m |]
      cxtParams :: [Q Type]
cxtParams  = Q Type
new Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: [Q Type]
paramTypes [Q Type] -> [Q Type] -> [Q Type]
forall a. [a] -> [a] -> [a]
++ [Q Type
m]
      headParams :: [Q Type]
headParams = Q Type
tag Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: [Q Type]
paramTypes [Q Type] -> [Q Type] -> [Q Type]
forall a. [a] -> [a] -> [a]
++ [Q Type
taggerType]
  [Dec]
funs <-
    ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
      [Signature] -> (Signature -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (EffectInfo -> [Signature]
effMethods EffectInfo
effInfo) ((Signature -> Q [Dec]) -> Q [[Dec]])
-> (Signature -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ Q Type -> Name -> Signature -> Q [Dec]
taggerInstanceFunction Q Type
new Name
monadName
  CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD
    ( [Q Type] -> CxtQ
cxt [(Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
appT Q Type
effType [Q Type]
cxtParams] )
    ( (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
appT Q Type
effType [Q Type]
headParams )
    ( (Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
funs )

taggerInstanceFunction :: Q Type -> Name -> Signature -> Q [Dec]
taggerInstanceFunction :: Q Type -> Name -> Signature -> Q [Dec]
taggerInstanceFunction Q Type
new Name
monad Signature
sig = do
  let typ :: Type
typ = Signature -> Type
sigType Signature
sig
      funName :: Name
funName = Signature -> Name
sigName Signature
sig
      expr :: Q Exp
expr = [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive [] [| Tagger |] [| runTagger |] Name
monad Type
typ
      typeAppliedName :: Q Exp
typeAppliedName = Name -> Q Exp
varE Name
funName Q Exp -> Q Type -> Q Exp
`appTypeE` Q Type
new
  [Dec]
funDef    <- [d| $(varP funName) = $expr $typeAppliedName |]
  Dec
funInline <- Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD Name
funName Inline
Inline RuleMatch
FunLike Phases
AllPhases
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
funInline Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
funDef)

identityTaggerInstance :: EffectInfo -> Q Dec
identityTaggerInstance :: EffectInfo -> Q Dec
identityTaggerInstance EffectInfo
info = do
  Name
oldTagName <- String -> Q Name
newName String
"tag"
  Name
newTagName <- String -> Q Name
newName String
"new"
  let old :: Q Type
old = Name -> Q Type
varT Name
oldTagName
      new :: Q Type
new = Name -> Q Type
varT Name
newTagName
      monadName :: Name
monadName = TyVarBndr -> Name
tyVarName (EffectInfo -> TyVarBndr
effMonad EffectInfo
info)
      m :: Q Type
m = Name -> Q Type
varT Name
monadName
      effType :: Q Type
effType = Name -> Q Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ EffectInfo -> Name
effName EffectInfo
info
      paramTypes :: [Q Type]
paramTypes = (TyVarBndr -> Q Type) -> [TyVarBndr] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> Q Type
tyVarType (EffectInfo -> [TyVarBndr]
effParams EffectInfo
info)
      taggerType :: Q Type
taggerType = [t| Tagger $old $new $m |]
      cxtParams :: [Q Type]
cxtParams  = [Q Type]
paramTypes [Q Type] -> [Q Type] -> [Q Type]
forall a. [a] -> [a] -> [a]
++ [Q Type
m]
      headParams :: [Q Type]
headParams = [Q Type]
paramTypes [Q Type] -> [Q Type] -> [Q Type]
forall a. [a] -> [a] -> [a]
++ [Q Type
taggerType]
  [Dec]
funs <-
    ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
      [Signature] -> (Signature -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (EffectInfo -> [Signature]
effMethods EffectInfo
info) ((Signature -> Q [Dec]) -> Q [[Dec]])
-> (Signature -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$
        Q Exp -> Q Exp -> TyVarBndr -> [TyVarBndr] -> Signature -> Q [Dec]
function [| Tagger |] [| runTagger |] (EffectInfo -> TyVarBndr
effMonad EffectInfo
info) (EffectInfo -> [TyVarBndr]
effParams EffectInfo
info)
  CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD
    ( [Q Type] -> CxtQ
cxt [(Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
appT Q Type
effType [Q Type]
cxtParams] )
    ( (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
appT Q Type
effType [Q Type]
headParams )
    ( (Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
funs )

handlerFunctions :: EffectInfo -> Q [Dec]
handlerFunctions :: EffectInfo -> Q [Dec]
handlerFunctions EffectInfo
info =
  ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
    (Signature -> Q [Dec]) -> [Signature] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
      ( Q Exp -> Q Exp -> TyVarBndr -> [TyVarBndr] -> Signature -> Q [Dec]
function [| EachVia |] [| runVia |] (EffectInfo -> TyVarBndr
effMonad EffectInfo
info) (EffectInfo -> [TyVarBndr]
effParams EffectInfo
info) )
      ( EffectInfo -> [Signature]
effMethods EffectInfo
info )

finderFunctions :: EffectInfo -> Q [Dec]
finderFunctions :: EffectInfo -> Q [Dec]
finderFunctions EffectInfo
info =
  ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
    (Signature -> Q [Dec]) -> [Signature] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
      ( Q Exp -> Q Exp -> TyVarBndr -> [TyVarBndr] -> Signature -> Q [Dec]
function [| liftL |] [| runL |] (EffectInfo -> TyVarBndr
effMonad EffectInfo
info) (EffectInfo -> [TyVarBndr]
effParams EffectInfo
info) )
      ( EffectInfo -> [Signature]
effMethods EffectInfo
info )

lifterFunctions :: EffectInfo -> Q [Dec]
lifterFunctions :: EffectInfo -> Q [Dec]
lifterFunctions EffectInfo
info =
  let m :: TyVarBndr
m = EffectInfo -> TyVarBndr
effMonad EffectInfo
info
      params :: [TyVarBndr]
params = EffectInfo -> [TyVarBndr]
effParams EffectInfo
info
      invalid :: Q a
invalid = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
         (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
"Could not generate effect instance because the operation is "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"invalid for higher-order effects."
  in
  ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
    [Signature] -> (Signature -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (EffectInfo -> [Signature]
effMethods EffectInfo
info) ((Signature -> Q [Dec]) -> Q [[Dec]])
-> (Signature -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \Signature
sig ->
      if TyVarBndr -> Signature -> Bool
isHigherOrder TyVarBndr
m Signature
sig
      then TyVarBndr -> [TyVarBndr] -> Signature -> Q [Dec]
higherFunction TyVarBndr
m [TyVarBndr]
params Signature
sig
      else Q Exp -> Q Exp -> TyVarBndr -> [TyVarBndr] -> Signature -> Q [Dec]
function [| lift |] Q Exp
forall a. Q a
invalid TyVarBndr
m [TyVarBndr]
params Signature
sig

function :: Q Exp -> Q Exp -> TyVarBndr -> [TyVarBndr] -> Signature -> Q [Dec]
function :: Q Exp -> Q Exp -> TyVarBndr -> [TyVarBndr] -> Signature -> Q [Dec]
function Q Exp
f Q Exp
inv TyVarBndr
monad [TyVarBndr]
params Signature
sig = do
  let m :: Name
m = TyVarBndr -> Name
tyVarName TyVarBndr
monad
      funName :: Name
funName = Signature -> Name
sigName Signature
sig
      paramTypes :: [Q Type]
paramTypes = (TyVarBndr -> Q Type) -> [TyVarBndr] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> Q Type
tyVarType [TyVarBndr]
params
      typeAppliedName :: Q Exp
typeAppliedName = (Q Exp -> Q Type -> Q Exp) -> Q Exp -> [Q Type] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Type -> Q Exp
appTypeE (Name -> Q Exp
varE Name
funName) [Q Type]
paramTypes
      expr :: Q Exp
expr = [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive [] Q Exp
f Q Exp
inv Name
m (Signature -> Type
sigType Signature
sig)
  [Dec]
funDef    <- [d| $(varP funName) = $expr $typeAppliedName |]
  Dec
funInline <- Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD Name
funName Inline
Inline RuleMatch
FunLike Phases
AllPhases
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
funInline Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
funDef)

higherFunction :: TyVarBndr -> [TyVarBndr] -> Signature -> Q [Dec]
higherFunction :: TyVarBndr -> [TyVarBndr] -> Signature -> Q [Dec]
higherFunction TyVarBndr
monad [TyVarBndr]
params Signature
sig = do
  let m :: Name
m = TyVarBndr -> Name
tyVarName TyVarBndr
monad
      typ :: Type
typ = Signature -> Type
sigType Signature
sig
      funName :: Name
funName = Signature -> Name
sigName Signature
sig
      paramTypes :: [Q Type]
paramTypes = (TyVarBndr -> Q Type) -> [TyVarBndr] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> Q Type
tyVarType [TyVarBndr]
params
      restores :: [Type]
restores = Bool -> Name -> Type -> [Type]
restorables Bool
False Name
m Type
typ
      expr :: Q Exp
expr = [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive [Type]
restores [| id |] [| run . runVia |] Name
m Type
typ
  [Name]
fParams <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Type -> Int
paramCount Type
typ) (String -> Q Name
newName String
"x")    
  Type
resType <- Name -> Type -> Q Type
resultType Name
m Type
typ
  let typeAppliedName :: Q Exp
typeAppliedName = (Q Exp -> Q Type -> Q Exp) -> Q Exp -> [Q Type] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Type -> Q Exp
appTypeE (Name -> Q Exp
varE Name
funName) [Q Type]
paramTypes
      appliedExp :: Q Exp
appliedExp = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
appE Q Exp
expr (Q Exp
typeAppliedName Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Name -> Q Exp) -> [Name] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Q Exp
varE [Name]
fParams)
      body :: Q Exp
body =
        [| EachVia $
            (liftWith $ \ $([p|run|]) -> $appliedExp)
              >>= $(traverseExp resType) (restoreT . pure)
        |]
  Dec
funDef    <- Name -> [ClauseQ] -> Q Dec
funD Name
funName [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause ((Name -> PatQ) -> [Name] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> PatQ
varP [Name]
fParams) (Q Exp -> BodyQ
normalB Q Exp
body) []]
  Dec
funInline <- Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD Name
funName Inline
Inline RuleMatch
FunLike Phases
AllPhases
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
funDef, Dec
funInline]
  where
    restorables :: Bool -> Name -> Type -> [Type]
    restorables :: Bool -> Name -> Type -> [Type]
restorables Bool
neg Name
m = \case
      VarT Name
n `AppT` Type
a
        | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m Bool -> Bool -> Bool
&& Bool
neg        -> [Type
a]
      Type
ArrowT `AppT` Type
a `AppT` Type
r -> Bool -> Name -> Type -> [Type]
restorables (Bool -> Bool
not Bool
neg) Name
m Type
a [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ Bool -> Name -> Type -> [Type]
restorables Bool
neg Name
m Type
r
      ForallT [TyVarBndr]
_ [Type]
_ Type
t            -> Bool -> Name -> Type -> [Type]
restorables Bool
neg Name
m Type
t
      SigT Type
t Type
_                 -> Bool -> Name -> Type -> [Type]
restorables Bool
neg Name
m Type
t
      ParensT Type
t                -> Bool -> Name -> Type -> [Type]
restorables Bool
neg Name
m Type
t
#if __GLASGOW_HASKELL__ >= 808
      AppKindT Type
t Type
_ -> Bool -> Name -> Type -> [Type]
restorables Bool
neg Name
m Type
t
      ImplicitParamT String
_ Type
t -> Bool -> Name -> Type -> [Type]
restorables Bool
neg Name
m Type
t
#endif
      Type
other -> String -> [Type]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
        (String -> [Type]) -> String -> [Type]
forall a b. (a -> b) -> a -> b
$  String
"Encountered an unknown term when finding restorables: "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
other
    traverseExp :: Type -> Q Exp
    traverseExp :: Type -> Q Exp
traverseExp = \case
      ForallT [TyVarBndr]
_ [Type]
_ Type
t -> Type -> Q Exp
traverseExp Type
t
      AppT Type
_ Type
r      -> Type -> Q Exp
traverseRec Type
r
      SigT Type
t Type
_      -> Type -> Q Exp
traverseExp Type
t
      InfixT Type
_ Name
_ Type
r  -> Type -> Q Exp
traverseRec Type
r
      UInfixT Type
_ Name
_ Type
r -> Type -> Q Exp
traverseRec Type
r
      ParensT Type
t     -> Type -> Q Exp
traverseExp Type
t
#if __GLASGOW_HASKELL__ >= 808
      AppKindT Type
t Type
_ -> Type -> Q Exp
traverseExp Type
t
      ImplicitParamT String
_ Type
t -> Type -> Q Exp
traverseExp Type
t
#endif
      Type
_             -> [| id |]
      where
        traverseRec :: Type -> Q Exp
traverseRec Type
t = [| traverse . $(traverseExp t) |]

derive :: [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive :: [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive [Type]
rs Q Exp
f Q Exp
inv Name
m = \case
  -- TODO: This is missing some cases - see algorithm of DeriveFunctor.
  Type
t | Bool -> Bool
not (Name -> Type -> Bool
contains Name
m Type
t) ->
    [| id |]
  VarT Name
n `AppT` Type
_ | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m ->
    Q Exp
f
  Type
ArrowT `AppT` Type
arg `AppT` Type
res ->
    let rf :: Q Exp
rf = [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive [Type]
rs Q Exp
f Q Exp
inv Name
m Type
res
        af :: Q Exp
af = [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive [Type]
rs Q Exp
inv Q Exp
f Name
m Type
arg
    in if Type -> [Type] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Type
arg [Type]
rs
       then [| \x b -> $rf (((x =<<) . EachVia . restoreT . pure) b) |]
       else [| \x b -> $rf (x ($af b)) |]
  ForallT [TyVarBndr]
_ [Type]
_ Type
t ->
    [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive [Type]
rs Q Exp
f Q Exp
inv Name
m Type
t
#if __GLASGOW_HASKELL__ >= 808
  AppKindT Type
t Type
_ ->
    [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive [Type]
rs Q Exp
f Q Exp
inv Name
m Type
t
  ImplicitParamT String
_ Type
t ->
    [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive [Type]
rs Q Exp
f Q Exp
inv Name
m Type
t
#endif
  Type
other -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
     (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Could not generate effect instance because an unknown structure "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"was encountered: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
other

---------------------
-- Utility functions.
---------------------

-- Throws away all kind information and forall from a type.
unkindType :: Type -> Type
unkindType :: Type -> Type
unkindType = \case
  -- We could need the following line if we want to preserve foralls
  --ForallT vs ps t -> ForallT (fmap unkindTyVar vs) (fmap unkindType ps) (unkindType t)
  ForallT [TyVarBndr]
_ [Type]
_ Type
t -> Type -> Type
unkindType Type
t
  AppT Type
l Type
r      -> Type -> Type -> Type
AppT (Type -> Type
unkindType Type
l) (Type -> Type
unkindType Type
r)
  SigT Type
t Type
_      -> Type
t
  InfixT Type
l Name
n Type
r  -> Type -> Name -> Type -> Type
InfixT (Type -> Type
unkindType Type
l) Name
n (Type -> Type
unkindType Type
r)
  UInfixT Type
l Name
n Type
r -> Type -> Name -> Type -> Type
UInfixT (Type -> Type
unkindType Type
l) Name
n (Type -> Type
unkindType Type
r)
  ParensT Type
t     -> Type -> Type
ParensT (Type -> Type
unkindType Type
t)
#if __GLASGOW_HASKELL__ >= 808
  AppKindT Type
t Type
_ -> Type -> Type
unkindType Type
t
  ImplicitParamT String
s Type
t -> String -> Type -> Type
ImplicitParamT String
s (Type -> Type
unkindType Type
t)
#endif
  Type
other         -> Type
other

-- Throws away the kind information of a type variable.
unkindTyVar :: TyVarBndr -> TyVarBndr
unkindTyVar :: TyVarBndr -> TyVarBndr
unkindTyVar (KindedTV Name
n Type
_) = Name -> TyVarBndr
PlainTV Name
n
unkindTyVar TyVarBndr
unkinded       = TyVarBndr
unkinded

-- Returns the name of a type variable.
tyVarName :: TyVarBndr -> Name
tyVarName :: TyVarBndr -> Name
tyVarName (PlainTV  Name
n  ) = Name
n
tyVarName (KindedTV Name
n Type
_) = Name
n

-- Converts a type variable to a type.
tyVarType :: TyVarBndr -> Q Type
tyVarType :: TyVarBndr -> Q Type
tyVarType (PlainTV Name
n   ) = Name -> Q Type
varT Name
n
tyVarType (KindedTV Name
n Type
k) = Q Type -> Type -> Q Type
sigT (Name -> Q Type
varT Name
n) Type
k

-- Counts the parameters of a type.
paramCount :: Type -> Int
paramCount :: Type -> Int
paramCount = \case
  Type
ArrowT `AppT` Type
_ `AppT` Type
r -> Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Type -> Int
paramCount Type
r
  ForallT [TyVarBndr]
_ [Type]
_ Type
t            -> Type -> Int
paramCount Type
t
  Type
_                        -> Int
0

-- | Adds an effect @eff@ to the type level list of effects that need to be
-- handled by the transformer @t@. From a structural point of view, this is
-- analogous to @lift@ in the @mtl@ ecosystem. This function comes in handy
-- when writing the 'Find'-based instance of an effect by hand.
--
-- @since 0.2.0.0
liftL :: EachVia effs t m a -> EachVia (eff : effs) t m a
liftL :: EachVia effs t m a -> EachVia (eff : effs) t m a
liftL = EachVia effs t m a -> EachVia (eff : effs) t m a
coerce
{-# INLINE liftL #-}

-- | Removes an effect @eff@ from the type level list of effects that need to be
-- handled by the transformer @t@. From a structural point of view, this is
-- analogous to the @run...@ functions in the @mtl@ ecosystem. This function
-- comes in handy when writing the 'Find'-based instance of an effect by hand.
--
-- @since 0.2.0.0
runL :: EachVia (eff : effs) t m a -> EachVia effs t m a
runL :: EachVia (eff : effs) t m a -> EachVia effs t m a
runL = EachVia (eff : effs) t m a -> EachVia effs t m a
coerce
{-# INLINE runL #-}

-- | Extracts the untagged name from a name which is expected to end with \"\'\".
-- In other words, this function removes the suffix \"\'\" from a given name,
-- or fails otherwise.
removeApostrophe :: String -> Q String
removeApostrophe :: String -> Q String
removeApostrophe String
name =
  if String
"'" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
name then
    String -> Q String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Q String) -> String -> Q String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
init String
name
  else
    String -> Q String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q String) -> String -> Q String
forall a b. (a -> b) -> a -> b
$ String
"Tagged effect and function names are expected to end with \"'\"."

-- Converts a list of types to a type-level list.
typeLevelList :: [Q Type] -> Q Type
typeLevelList :: [Q Type] -> Q Type
typeLevelList []     = Q Type
promotedNilT
typeLevelList (Q Type
t:[Q Type]
ts) = Q Type
promotedConsT Q Type -> Q Type -> Q Type
`appT` Q Type
t Q Type -> Q Type -> Q Type
`appT` [Q Type] -> Q Type
typeLevelList [Q Type]
ts

-- Returns the result type of a monadic type m.
-- Example: X -> Y -> Z -> m a
-- Returns: a
resultType :: Name -> Type -> Q Type
resultType :: Name -> Type -> Q Type
resultType Name
m = \case
  VarT Name
n `AppT` Type
a | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m -> Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
a
  Type
ArrowT `AppT` Type
_ `AppT` Type
r -> Name -> Type -> Q Type
resultType Name
m Type
r
  ForallT [TyVarBndr]
_ [Type]
_ Type
t            -> Name -> Type -> Q Type
resultType Name
m Type
t
  SigT Type
t Type
_                 -> Name -> Type -> Q Type
resultType Name
m Type
t
  ParensT Type
t                -> Name -> Type -> Q Type
resultType Name
m Type
t
#if __GLASGOW_HASKELL__ >= 808
  AppKindT Type
t Type
_ -> Name -> Type -> Q Type
resultType Name
m Type
t
  ImplicitParamT String
_ Type
t -> Name -> Type -> Q Type
resultType Name
m Type
t
#endif
  Type
other -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
    (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$  String
"Expected a return type of the form 'm a', but encountered: "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
other

-- Checks if a name m appears somewhere in a type.
contains :: Name -> Type -> Bool
contains :: Name -> Type -> Bool
contains Name
m = \case
  ForallT [TyVarBndr]
_ [Type]
_ Type
t -> Name -> Type -> Bool
contains Name
m Type
t
  AppT Type
l Type
r      -> Name -> Type -> Bool
contains Name
m Type
l Bool -> Bool -> Bool
|| Name -> Type -> Bool
contains Name
m Type
r
  SigT Type
t Type
_      -> Name -> Type -> Bool
contains Name
m Type
t
  VarT Name
n        -> Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m
  ConT Name
n        -> Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m
  PromotedT Name
n   -> Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m
  InfixT Type
l Name
n Type
r  -> Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m Bool -> Bool -> Bool
|| Name -> Type -> Bool
contains Name
m Type
l Bool -> Bool -> Bool
|| Name -> Type -> Bool
contains Name
m Type
r
  UInfixT Type
l Name
n Type
r -> Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m Bool -> Bool -> Bool
|| Name -> Type -> Bool
contains Name
m Type
l Bool -> Bool -> Bool
|| Name -> Type -> Bool
contains Name
m Type
r
  ParensT Type
t     -> Name -> Type -> Bool
contains Name
m Type
t
#if __GLASGOW_HASKELL__ >= 808
  AppKindT Type
t Type
_ -> Name -> Type -> Bool
contains Name
m Type
t
  ImplicitParamT String
_ Type
t -> Name -> Type -> Bool
contains Name
m Type
t
#endif
  Type
_             -> Bool
False

-- Given a monad type variable m and a type, checks if the
-- type is a higher-order type where m is in negative position.
isHigherType :: TyVarBndr -> Type -> Bool
isHigherType :: TyVarBndr -> Type -> Bool
isHigherType TyVarBndr
monad = Bool -> Type -> Bool
go Bool
False
  where
    m :: Name
m = TyVarBndr -> Name
tyVarName TyVarBndr
monad
    go :: Bool -> Type -> Bool
go Bool
negPos = \case
      VarT Name
n `AppT` Type
_ | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m -> Bool
negPos
      Type
ArrowT `AppT` Type
a `AppT` Type
r ->
        Bool -> Type -> Bool
go (Bool -> Bool
not Bool
negPos) Type
a Bool -> Bool -> Bool
|| Bool -> Type -> Bool
go Bool
negPos Type
r
      ForallT [TyVarBndr]
_ [Type]
_ Type
t ->
        Bool -> Type -> Bool
go Bool
negPos Type
t
      Type
_ ->
        Bool
False

-- Given a monad type variable m and a signature, checks if its
-- type is a higher-order type where m is in negative position.
isHigherOrder :: TyVarBndr -> Signature -> Bool
isHigherOrder :: TyVarBndr -> Signature -> Bool
isHigherOrder TyVarBndr
monad = TyVarBndr -> Type -> Bool
isHigherType TyVarBndr
monad (Type -> Bool) -> (Signature -> Type) -> Signature -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signature -> Type
sigType

-- Finds the first ("leftmost") type parameter of a type, which
-- is expected to be the tag type parameter.
findTagParameter :: Type -> Q Name
findTagParameter :: Type -> Q Name
findTagParameter Type
typ =
  case Type -> Maybe Name
go Type
typ of
    Just Name
n -> Name -> Q Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
    Maybe Name
Nothing ->
      String -> Q Name
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"Cannot find the tag parameter of the type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
typ
  where
    go :: Type -> Maybe Name
    go :: Type -> Maybe Name
go = \case
      ForallT [TyVarBndr]
tyVars [Type]
ctx Type
t ->
        case (TyVarBndr -> Bool) -> [TyVarBndr] -> [TyVarBndr]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (TyVarBndr -> Bool) -> TyVarBndr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Bool
isStar) [TyVarBndr]
tyVars of
          (TyVarBndr
v:[TyVarBndr]
_) -> Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ TyVarBndr -> Name
tyVarName TyVarBndr
v
          [] ->
            case [Maybe Name] -> [Name]
forall a. [Maybe a] -> [a]
catMaybes ((Type -> Maybe Name) -> [Type] -> [Maybe Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Maybe Name
go [Type]
ctx) of
              (Name
n:[Name]
_) -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
              [] -> Type -> Maybe Name
go Type
t
      AppT Type
l Type
r ->
        case Type -> Maybe Name
go Type
l of
          Just Name
n  -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
          Maybe Name
Nothing -> Type -> Maybe Name
go Type
r
      SigT Type
t Type
_ -> Type -> Maybe Name
go Type
t
      VarT Name
n -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
      InfixT Type
l Name
_ Type
r ->
        case Type -> Maybe Name
go Type
l of
          Just Name
n  -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
          Maybe Name
Nothing -> Type -> Maybe Name
go Type
r
      UInfixT Type
l Name
_ Type
r ->
        case Type -> Maybe Name
go Type
l of
          Just Name
n  -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
          Maybe Name
Nothing -> Type -> Maybe Name
go Type
r
      ParensT Type
t -> Type -> Maybe Name
go Type
t
#if __GLASGOW_HASKELL__ >= 808
      AppKindT Type
t Type
_ -> Type -> Maybe Name
go Type
t
      ImplicitParamT String
_ Type
t -> Type -> Maybe Name
go Type
t
#endif
      Type
_ -> Maybe Name
forall a. Maybe a
Nothing
    -- We need this because the first type parameter
    -- is often 'k' for the kind of the tag. We ignore it.
    isStar :: TyVarBndr -> Bool
    isStar :: TyVarBndr -> Bool
isStar (PlainTV Name
_) = Bool
True
    isStar (KindedTV Name
_ Type
StarT) = Bool
True
    isStar TyVarBndr
_ = Bool
False

-- Replaces the tag parameter with its G-counterpart, simplifying
-- types to their untagged synonym if possible.
replaceTag :: (Name -> Q Name) -> Name -> Type -> Q Type
replaceTag :: (Name -> Q Name) -> Name -> Type -> Q Type
replaceTag Name -> Q Name
f Name
tag = \case
  -- We eliminate outermost forall variables completely for now,
  -- to make the type signatures more readable.
  -- If we want to preserve it, we might need something
  -- like the line below.
  -- filter (not . (== tag) . tyVarName) tyVars
  ForallT [TyVarBndr]
_tyVars [Type]
cxts Type
t -> Type -> Q Type
go ([TyVarBndr] -> [Type] -> Type -> Type
ForallT [] [Type]
cxts Type
t)
  Type
other -> Type -> Q Type
go Type
other
  where
    go :: Type -> Q Type
go = \case
      ForallT [TyVarBndr]
tyVars [Type]
cxts Type
t ->
        [TyVarBndr] -> CxtQ -> Q Type -> Q Type
forallT
          ( (TyVarBndr -> TyVarBndr) -> [TyVarBndr] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> TyVarBndr
unkindTyVar [TyVarBndr]
tyVars )
          ( [Q Type] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q Type] -> CxtQ) -> [Q Type] -> CxtQ
forall a b. (a -> b) -> a -> b
$ (Type -> Q Type) -> [Type] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Q Type
go [Type]
cxts )
          ( Type -> Q Type
go Type
t )
#if __GLASGOW_HASKELL__ >= 808
      ConT Name
n `AppT` Type
eff `AppT` Type
t | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Via Bool -> Bool -> Bool
|| Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''EachVia ->
        Type -> Q Type
go (Type -> Name -> Type -> Type
UInfixT Type
eff Name
n Type
t)
#endif
      ConT Name
n `AppT` VarT Name
t | Name
t Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
tag ->
        Name -> Q Name
f Name
n Q Name -> (Name -> Q Type) -> Q Type
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Q Type
conT
      AppT Type
l Type
r ->
        Q Type -> Q Type -> Q Type
appT (Type -> Q Type
go Type
l) (Type -> Q Type
go Type
r)
      SigT Type
t Type
_ ->
        Type -> Q Type
go Type
t -- eliminate kinds for readability.
      VarT Name
n | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
tag -> Name -> Q Type
conT ''G
             | Bool
otherwise -> Name -> Q Type
varT Name
n
      InfixT Type
l Name
n Type
r ->
        Q Type -> Name -> Q Type -> Q Type
infixT (Type -> Q Type
go Type
l) Name
n (Type -> Q Type
go Type
r)
      UInfixT Type
l Name
n Type
r ->
        Q Type -> Name -> Q Type -> Q Type
uInfixT (Type -> Q Type
go Type
l) Name
n (Type -> Q Type
go Type
r)
      ParensT Type
t ->
        Q Type -> Q Type
parensT (Type -> Q Type
go Type
t)
#if __GLASGOW_HASKELL__ >= 808
      AppKindT Type
t Type
k ->
        Q Type -> Q Type -> Q Type
appKindT (Type -> Q Type
go Type
t) (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
k)
      ImplicitParamT String
s Type
t ->
        String -> Q Type -> Q Type
implicitParamT String
s (Type -> Q Type
go Type
t)
#endif
      Type
other ->
        Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
other