{-# 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
  , makeLifter
    -- * Tag-based Generators

  , makeTaggedEffect
  , makeTaggedEffectWith
  , makeTagger
  , makeTaggerWith
    -- * Naming Convention

  , removeApostrophe
  ) where

-- base

import Control.Monad (forM, replicateM)
import Data.List     (isSuffixOf)
import Data.Maybe    (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.Kind   (Control, Handle, Lift)
import Control.Effect.Machinery.Tagger (Tagger, runTagger)
import Control.Effect.Machinery.Via    (G, Via(Via), runVia)

data ClassInfo = ClassInfo
  { ClassInfo -> Cxt
clsCxt     :: Cxt
  , ClassInfo -> Name
clsName     :: Name
  , ClassInfo -> [TyVarBndr]
clsTyVars   :: [TyVarBndr]
  , ClassInfo -> [FunDep]
_clsFunDeps :: [FunDep]
  , ClassInfo -> [Dec]
clsDecs     :: [Dec]
  }

data EffectInfo = EffectInfo
  { EffectInfo -> Cxt
_effCxt       :: Cxt
  , EffectInfo -> Q Type
effType      :: Q Type
  , EffectInfo -> [TyVarBndr]
effParams    :: [TyVarBndr]
  , EffectInfo -> TyVarBndr
effMonad     :: TyVarBndr
  , EffectInfo -> Name
effName      :: Name
  , EffectInfo -> Name
effTrafoName :: Name
  , EffectInfo -> [Signature]
effSigs      :: [Signature]
  }

data TaggedInfo = TaggedInfo
  { TaggedInfo -> TyVarBndr
tgTag     :: TyVarBndr
  , TaggedInfo -> [TyVarBndr]
tgParams  :: [TyVarBndr]
  , TaggedInfo -> TyVarBndr
tgMonad   :: TyVarBndr
  , TaggedInfo -> Name
tgEffName :: Name
  , TaggedInfo -> String -> Q String
tgNameMap :: String -> Q String
  , TaggedInfo -> [Signature]
tgSigs    :: [Signature]
  }

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

synonymName :: TaggedInfo -> Q Name
synonymName :: TaggedInfo -> Q Name
synonymName info :: TaggedInfo
info = (String -> Q String) -> Name -> Q Name
mapName (TaggedInfo -> String -> Q String
tgNameMap TaggedInfo
info) (TaggedInfo -> Name
tgEffName TaggedInfo
info)

resultType :: Name -> Type -> Q Type
resultType :: Name -> Type -> Q Type
resultType m :: Name
m typ :: Type
typ =
  case Type
typ of
    VarT n :: Name
n `AppT` a :: 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
    ArrowT `AppT` _ `AppT` r :: Type
r -> Name -> Type -> Q Type
resultType Name
m Type
r
    ForallT _ _ t :: Type
t            -> Name -> Type -> Q Type
resultType Name
m Type
t
    SigT t :: Type
t _                 -> Name -> Type -> Q Type
resultType Name
m Type
t
    ParensT t :: Type
t                -> Name -> Type -> Q Type
resultType Name
m Type
t
    other :: 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
$  "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

restorables :: Bool -> Name -> Type -> [Type]
restorables :: Bool -> Name -> Type -> Cxt
restorables neg :: Bool
neg m :: Name
m typ :: Type
typ =
  case Type
typ of
    VarT n :: Name
n `AppT` a :: Type
a | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m Bool -> Bool -> Bool
&& Bool
neg -> [Type
a]
    ArrowT `AppT` a :: Type
a `AppT` r :: Type
r        -> Bool -> Name -> Type -> Cxt
restorables (Bool -> Bool
not Bool
neg) Name
m Type
a Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Bool -> Name -> Type -> Cxt
restorables Bool
neg Name
m Type
r
    ForallT _ _ t :: Type
t                   -> Bool -> Name -> Type -> Cxt
restorables Bool
neg Name
m Type
t
    SigT t :: Type
t _                        -> Bool -> Name -> Type -> Cxt
restorables Bool
neg Name
m Type
t
    ParensT t :: Type
t                       -> Bool -> Name -> Type -> Cxt
restorables Bool
neg Name
m Type
t
    other :: Type
other -> String -> Cxt
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
      (String -> Cxt) -> String -> Cxt
forall a b. (a -> b) -> a -> b
$  "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

isHigherType :: TyVarBndr -> Type -> Bool
isHigherType :: TyVarBndr -> Type -> Bool
isHigherType monad :: TyVarBndr
monad = Bool -> Type -> Bool
go Bool
False
  where
    m :: Name
m = TyVarBndr -> Name
tyVarName TyVarBndr
monad
    go :: Bool -> Type -> Bool
go negPos :: Bool
negPos typ :: Type
typ =
      case Type
typ of
        VarT n :: Name
n `AppT` _ | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m -> Bool
negPos
        ArrowT `AppT` a :: Type
a `AppT` r :: 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 _ _ t :: Type
t ->
          Bool -> Type -> Bool
go Bool
negPos Type
t
        _ ->
          Bool
False

isHigherOrder :: TyVarBndr -> Signature -> Bool
isHigherOrder :: TyVarBndr -> Signature -> Bool
isHigherOrder monad :: 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

signature :: Dec -> Q Signature
signature :: Dec -> Q Signature
signature dec :: Dec
dec =
  case Dec
dec of
    SigD name :: Name
name typ :: Type
typ ->
      Signature -> Q Signature
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Type -> Signature
Signature Name
name Type
typ)
    other :: Dec
other ->
      String -> Q Signature
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
         (String -> Q Signature) -> String -> Q Signature
forall a b. (a -> b) -> a -> b
$ "The generation of the effect handling machinery currently supports"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ " only signatures, but encountered: "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Dec -> String
forall a. Show a => a -> String
show Dec
other

unkindTyVar :: TyVarBndr -> TyVarBndr
unkindTyVar :: TyVarBndr -> TyVarBndr
unkindTyVar (KindedTV n :: Name
n _) = Name -> TyVarBndr
PlainTV Name
n
unkindTyVar unkinded :: TyVarBndr
unkinded       = TyVarBndr
unkinded

tyVarName :: TyVarBndr -> Name
tyVarName :: TyVarBndr -> Name
tyVarName (PlainTV  n :: Name
n  ) = Name
n
tyVarName (KindedTV n :: Name
n _) = Name
n

tyVarType :: TyVarBndr -> Q Type
tyVarType :: TyVarBndr -> Q Type
tyVarType (PlainTV n :: Name
n   ) = Name -> Q Type
varT Name
n
tyVarType (KindedTV n :: Name
n k :: Type
k) = Q Type -> Type -> Q Type
sigT (Name -> Q Type
varT Name
n) Type
k

effectVars :: ClassInfo -> Q ([TyVarBndr], TyVarBndr)
effectVars :: ClassInfo -> Q ([TyVarBndr], TyVarBndr)
effectVars info :: ClassInfo
info =
  case ClassInfo -> [TyVarBndr]
clsTyVars ClassInfo
info 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
$  "The specified effect type class `"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase (ClassInfo -> Name
clsName ClassInfo
info)
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' has no monad type variable. "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ "It is expected to be the last type variable."
    vs :: [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)

effectInfo :: ClassInfo -> Q EffectInfo
effectInfo :: ClassInfo -> Q EffectInfo
effectInfo info :: ClassInfo
info = do
  (params :: [TyVarBndr]
params, clsM :: TyVarBndr
clsM) <- ClassInfo -> Q ([TyVarBndr], TyVarBndr)
effectVars ClassInfo
info
  Name
t <- String -> Q Name
newName "t"
  [Signature]
sigs <- (Dec -> Q Signature) -> [Dec] -> Q [Signature]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Dec -> Q Signature
signature (ClassInfo -> [Dec]
clsDecs ClassInfo
info)
  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
$
    Cxt
-> Q Type
-> [TyVarBndr]
-> TyVarBndr
-> Name
-> Name
-> [Signature]
-> EffectInfo
EffectInfo
      ( ClassInfo -> Cxt
clsCxt ClassInfo
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
$ ClassInfo -> Name
clsName ClassInfo
info) ((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) )
      ( [TyVarBndr]
params       )
      ( TyVarBndr
clsM         )
      ( ClassInfo -> Name
clsName ClassInfo
info )
      ( Name
t            )
      ( [Signature]
sigs         )

extractTag :: [TyVarBndr] -> Q (TyVarBndr, [TyVarBndr])
extractTag :: [TyVarBndr] -> Q (TyVarBndr, [TyVarBndr])
extractTag []     = String -> Q (TyVarBndr, [TyVarBndr])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "The effect has no tag parameter."
extractTag (v :: TyVarBndr
v:vs :: [TyVarBndr]
vs) = (TyVarBndr, [TyVarBndr]) -> Q (TyVarBndr, [TyVarBndr])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyVarBndr
v, [TyVarBndr]
vs)

-- | 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 name :: String
name =
  if "'" 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
$ "Tagged effect and function names are expected to end with \"'\"."

mapName :: (String -> Q String) -> Name -> Q Name
mapName :: (String -> Q String) -> Name -> Q Name
mapName f :: String -> Q String
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
f (String -> Q String) -> (Name -> String) -> Name -> Q String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase

taggedInfo :: (String -> Q String) -> EffectInfo -> Q TaggedInfo
taggedInfo :: (String -> Q String) -> EffectInfo -> Q TaggedInfo
taggedInfo f :: String -> Q String
f info :: EffectInfo
info = do
  (tag :: TyVarBndr
tag, params :: [TyVarBndr]
params) <- [TyVarBndr] -> Q (TyVarBndr, [TyVarBndr])
extractTag (EffectInfo -> [TyVarBndr]
effParams EffectInfo
info)
  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]
-> TyVarBndr
-> Name
-> (String -> Q String)
-> [Signature]
-> TaggedInfo
TaggedInfo
      ( TyVarBndr
tag           )
      ( [TyVarBndr]
params        )
      ( EffectInfo -> TyVarBndr
effMonad EffectInfo
info )
      ( EffectInfo -> Name
effName EffectInfo
info  )
      ( String -> Q String
f             )
      ( EffectInfo -> [Signature]
effSigs EffectInfo
info  )

classInfo :: Name -> Q ClassInfo
classInfo :: Name -> Q ClassInfo
classInfo className :: Name
className = do
  Info
info <- Name -> Q Info
reify Name
className
  case Info
info of
    ClassI (ClassD context :: Cxt
context name :: Name
name tyVars :: [TyVarBndr]
tyVars funDeps :: [FunDep]
funDeps decs :: [Dec]
decs) _ ->
      ClassInfo -> Q ClassInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cxt -> Name -> [TyVarBndr] -> [FunDep] -> [Dec] -> ClassInfo
ClassInfo Cxt
context Name
name [TyVarBndr]
tyVars [FunDep]
funDeps [Dec]
decs)
    other :: Info
other ->
      String -> Q ClassInfo
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
         (String -> Q ClassInfo) -> String -> Q ClassInfo
forall a b. (a -> b) -> a -> b
$ "The specified name `"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
className
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' 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

instanceCxt :: Name -> EffectInfo -> Q Cxt
instanceCxt :: Name -> EffectInfo -> Q Cxt
instanceCxt name :: Name
name info :: EffectInfo
info = [Q Type] -> Q Cxt
cxt
  [
    Name -> Q Type
conT Name
name
      Q Type -> Q Type -> Q Type
`appT` EffectInfo -> Q Type
effType EffectInfo
info
      Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT (EffectInfo -> Name
effTrafoName EffectInfo
info)
      Q Type -> Q Type -> Q Type
`appT` TyVarBndr -> Q Type
tyVarType (EffectInfo -> TyVarBndr
effMonad EffectInfo
info)
  ]

instanceHead :: Q Type -> EffectInfo -> Q Type
instanceHead :: Q Type -> EffectInfo -> Q Type
instanceHead eff :: Q Type
eff info :: EffectInfo
info =
  EffectInfo -> Q Type
effType EffectInfo
info
    Q Type -> Q Type -> Q Type
`appT` (
      Name -> Q Type
conT ''Via
        Q Type -> Q Type -> Q Type
`appT` Q Type
eff
        Q Type -> Q Type -> Q Type
`appT` Name -> Q Type
varT (EffectInfo -> Name
effTrafoName EffectInfo
info)
        Q Type -> Q Type -> Q Type
`appT` TyVarBndr -> Q Type
tyVarType (EffectInfo -> TyVarBndr
effMonad EffectInfo
info)
      )

-- | 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 two 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 ('Via' (MyEffect a b c) t m) where

--       ...

--

--     instance {-\# OVERLAPPABLE \#-} 'Lift'/'Control' (MyEffect a b c) t m => MyEffect a b c ('Via' eff t m) where

--       ...

-- @

--

-- Without @TemplateHaskell@, you have to write these instances by hand. These

-- two instances can also be generated separately, see 'makeHandler' and 'makeLifter'.

makeEffect :: Name -> Q [Dec]
makeEffect :: Name -> Q [Dec]
makeEffect className :: Name
className = do
  ClassInfo
clsInfo   <- Name -> Q ClassInfo
classInfo Name
className
  EffectInfo
effInfo   <- ClassInfo -> Q EffectInfo
effectInfo ClassInfo
clsInfo
  Dec
hInstance <- EffectInfo -> Q Dec
handler EffectInfo
effInfo
  Dec
lInstance <- EffectInfo -> Q Dec
lifter EffectInfo
effInfo
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
hInstance, Dec
lInstance]

-- | 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 f :: String -> Q String
f className :: Name
className = do
  ClassInfo
clsInfo <- Name -> Q ClassInfo
classInfo Name
className
  EffectInfo
effInfo <- ClassInfo -> Q EffectInfo
effectInfo ClassInfo
clsInfo
  TaggedInfo
tagInfo <- (String -> Q String) -> EffectInfo -> Q TaggedInfo
taggedInfo String -> Q String
f EffectInfo
effInfo
  TaggedInfo -> Q [Dec]
tagger 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 f :: String -> Q String
f className :: Name
className = do
  ClassInfo
clsInfo    <- Name -> Q ClassInfo
classInfo Name
className
  EffectInfo
effInfo    <- ClassInfo -> Q EffectInfo
effectInfo ClassInfo
clsInfo
  TaggedInfo
tagInfo    <- (String -> Q String) -> EffectInfo -> Q TaggedInfo
taggedInfo String -> Q String
f EffectInfo
effInfo
  Dec
hInstance  <- EffectInfo -> Q Dec
handler EffectInfo
effInfo
  Dec
lInstance  <- EffectInfo -> Q Dec
lifter EffectInfo
effInfo
  [Dec]
taggerDecs <- TaggedInfo -> Q [Dec]
tagger 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
lInstance Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
taggerDecs)

-- | Similar to 'makeEffect', but only generates the effect type class instance

-- for handling an effect.

makeHandler :: Name -> Q [Dec]
makeHandler :: Name -> Q [Dec]
makeHandler className :: Name
className = do
  ClassInfo
clsInfo   <- Name -> Q ClassInfo
classInfo Name
className
  EffectInfo
effInfo   <- ClassInfo -> Q EffectInfo
effectInfo ClassInfo
clsInfo
  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 lifting an effect.

makeLifter :: Name -> Q [Dec]
makeLifter :: Name -> Q [Dec]
makeLifter className :: Name
className = do
  ClassInfo
clsInfo   <- Name -> Q ClassInfo
classInfo Name
className
  EffectInfo
effInfo   <- ClassInfo -> Q EffectInfo
effectInfo ClassInfo
clsInfo
  Dec
lInstance <- EffectInfo -> Q Dec
lifter EffectInfo
effInfo
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
lInstance]

tagger :: TaggedInfo -> Q [Dec]
tagger :: TaggedInfo -> Q [Dec]
tagger info :: TaggedInfo
info = do
  [Dec]
taggerFuns   <- TaggedInfo -> Q [Dec]
taggerFunctions TaggedInfo
info
  Dec
untaggedSyn  <- TaggedInfo -> Q Dec
untaggedSynonym TaggedInfo
info
  [Dec]
untaggedFuns <- TaggedInfo -> Q [Dec]
untaggedFunctions TaggedInfo
info
  Dec
taggerInst   <- TaggedInfo -> Q Dec
taggerInstance TaggedInfo
info
  [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 info :: EffectInfo
info = do
  [Dec]
funs <- EffectInfo -> Q [Dec]
handlerFunctions EffectInfo
info
  Q Cxt -> Q Type -> [Q Dec] -> Q Dec
instanceD
    ( Name -> EffectInfo -> Q Cxt
instanceCxt ''Handle EffectInfo
info )
    ( Q Type -> EffectInfo -> Q Type
instanceHead (EffectInfo -> Q Type
effType EffectInfo
info) 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 )

lifter :: EffectInfo -> Q Dec
lifter :: EffectInfo -> Q Dec
lifter info :: EffectInfo
info = do
  let
    monad :: TyVarBndr
monad = EffectInfo -> TyVarBndr
effMonad EffectInfo
info
    context :: Name
context =
      if (Signature -> Bool) -> [Signature] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TyVarBndr -> Signature -> Bool
isHigherOrder TyVarBndr
monad) (EffectInfo -> [Signature]
effSigs EffectInfo
info)
      then ''Control
      else ''Lift
  [Dec]
funs <- EffectInfo -> Q [Dec]
lifterFunctions EffectInfo
info
  Name
eff  <- String -> Q Name
newName "eff"
  Maybe Overlap -> Q Cxt -> Q Type -> [Q Dec] -> Q Dec
instanceWithOverlapD
    ( Overlap -> Maybe Overlap
forall a. a -> Maybe a
Just Overlap
Overlappable )
    ( Name -> EffectInfo -> Q Cxt
instanceCxt Name
context EffectInfo
info )
    ( Q Type -> EffectInfo -> Q Type
instanceHead (Name -> Q Type
varT Name
eff) 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 )

taggerFunctions :: TaggedInfo -> Q [Dec]
taggerFunctions :: TaggedInfo -> Q [Dec]
taggerFunctions info :: TaggedInfo
info = do
  let params :: [TyVarBndr]
params       = TaggedInfo -> [TyVarBndr]
tgParams TaggedInfo
info
      tagVar :: TyVarBndr
tagVar       = TaggedInfo -> TyVarBndr
tgTag TaggedInfo
info
      effectName :: Name
effectName   = TaggedInfo -> Name
tgEffName TaggedInfo
info
      nameString :: String
nameString   = Name -> String
nameBase Name
effectName
      tagFName :: Name
tagFName     = String -> Name
mkName ("tag"   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nameString)
      retagFName :: Name
retagFName   = String -> Name
mkName ("retag" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nameString)
      untagFName :: Name
untagFName   = String -> Name
mkName ("untag" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nameString)
  Name
tag    <- String -> Q Name
newName (Name -> String
nameBase (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ TyVarBndr -> Name
tyVarName TyVarBndr
tagVar)
  Name
new    <- String -> Q Name
newName "new"
  [Dec]
tagF   <- Name -> Name -> Maybe Name -> Maybe Name -> [TyVarBndr] -> Q [Dec]
taggerFunction Name
effectName Name
tagFName Maybe Name
forall a. Maybe a
Nothing (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
new) [TyVarBndr]
params
  [Dec]
retagF <- Name -> Name -> Maybe Name -> Maybe Name -> [TyVarBndr] -> Q [Dec]
taggerFunction Name
effectName Name
retagFName (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
tag) (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
new) [TyVarBndr]
params
  [Dec]
untagF <- Name -> Name -> Maybe Name -> Maybe Name -> [TyVarBndr] -> Q [Dec]
taggerFunction Name
effectName Name
untagFName (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
tag) Maybe Name
forall a. Maybe a
Nothing [TyVarBndr]
params
  [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 -> Name -> Maybe Name -> Maybe Name -> [TyVarBndr] -> Q [Dec]
taggerFunction :: Name -> Name -> Maybe Name -> Maybe Name -> [TyVarBndr] -> Q [Dec]
taggerFunction baseName :: Name
baseName funName :: Name
funName tag :: Maybe Name
tag new :: Maybe Name
new params :: [TyVarBndr]
params = do
  Name
mName <- String -> Q Name
newName "m"
  Name
aName <- String -> Q Name
newName "a"
  let m :: Q Type
m           = Name -> Q Type
varT Name
mName
      a :: Q Type
a           = Name -> Q Type
varT Name
aName
      tagParam :: Q Type
tagParam    = Q Type -> (Name -> Q Type) -> Maybe Name -> Q Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [t| G |] Name -> Q Type
varT Maybe Name
tag
      newParam :: Q Type
newParam    = Q Type -> (Name -> Q Type) -> Maybe Name -> Q Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [t| G |] Name -> Q Type
varT Maybe Name
new
      tagNames :: [Name]
tagNames    = Maybe Name -> [Name]
forall a. Maybe a -> [a]
maybeToList Maybe Name
tag [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Maybe Name -> [Name]
forall a. Maybe a -> [a]
maybeToList Maybe Name
new
      paramNames :: [Name]
paramNames  = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVarBndr -> Name
tyVarName [TyVarBndr]
params
      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
      forallNames :: [Name]
forallNames = [Name]
tagNames [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
paramNames [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name
mName, Name
aName]
      forallTypes :: [TyVarBndr]
forallTypes = (Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> TyVarBndr
PlainTV [Name]
forallNames
      effectType :: Q Type
effectType  = (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
baseName) (Q Type
tagParam Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: [Q Type]
paramTypes)
  Type
funSigType <- [t| ($effectType `Via` Tagger $tagParam $newParam) $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] -> Q Cxt -> Q Type -> Q Type
forallT [TyVarBndr]
forallTypes ([Q Type] -> Q Cxt
cxt []) (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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)

untaggedSynonym :: TaggedInfo -> Q Dec
untaggedSynonym :: TaggedInfo -> Q Dec
untaggedSynonym info :: TaggedInfo
info = do
  Name
synName <- TaggedInfo -> Q Name
synonymName TaggedInfo
info
  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
effectName) (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
    effectName :: Name
effectName = TaggedInfo -> Name
tgEffName TaggedInfo
info
    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
info)

untaggedFunctions :: TaggedInfo -> Q [Dec]
untaggedFunctions :: TaggedInfo -> Q [Dec]
untaggedFunctions info :: TaggedInfo
info = do
  Name
synName <- TaggedInfo -> Q Name
synonymName TaggedInfo
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] -> (Signature -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (TaggedInfo -> [Signature]
tgSigs TaggedInfo
info)
      ((Signature -> Q [Dec]) -> Q [[Dec]])
-> (Signature -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ (String -> Q String) -> Q Type -> Signature -> Q [Dec]
untaggedFunction (TaggedInfo -> String -> Q String
tgNameMap TaggedInfo
info)
      (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
info [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ [TaggedInfo -> TyVarBndr
tgMonad TaggedInfo
info] )

untaggedFunction :: (String -> Q String) -> Q Type -> Signature -> Q [Dec]
untaggedFunction :: (String -> Q String) -> Q Type -> Signature -> Q [Dec]
untaggedFunction f :: String -> Q String
f effectType :: Q Type
effectType sig :: 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   <- (String -> Q String) -> Name -> Q Name
mapName String -> Q String
f Name
originalName
  Dec
funSig    <- Name -> Q Type -> Q Dec
sigD Name
funName [t| $effectType => $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 :: TaggedInfo -> Q Dec
taggerInstance :: TaggedInfo -> Q Dec
taggerInstance info :: TaggedInfo
info = do
  Name
newTagName <- String -> Q Name
newName "new"
  let new :: Q Type
new = Name -> Q Type
varT Name
newTagName
      monadName :: Name
monadName = TyVarBndr -> Name
tyVarName (TaggedInfo -> TyVarBndr
tgMonad TaggedInfo
info)
      m :: Q Type
m = Name -> Q Type
varT Name
monadName
      tag :: Q Type
tag = TyVarBndr -> Q Type
tyVarType (TaggedInfo -> TyVarBndr
tgTag TaggedInfo
info)
      effectType :: Q Type
effectType = Name -> Q Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ TaggedInfo -> Name
tgEffName TaggedInfo
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 (TaggedInfo -> [TyVarBndr]
tgParams TaggedInfo
info)
      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 (TaggedInfo -> [Signature]
tgSigs TaggedInfo
info) ((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
  Q Cxt -> Q Type -> [Q Dec] -> Q Dec
instanceD
    ( [Q Type] -> Q Cxt
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
effectType [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
effectType [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 new :: Q Type
new monad :: Name
monad sig :: Signature
sig = do
  let typ :: Type
typ = Signature -> Type
sigType Signature
sig
      funName :: Name
funName = Signature -> Name
sigName Signature
sig
      expr :: Q Exp
expr = Cxt -> 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)

paramCount :: Type -> Int
paramCount :: Type -> Int
paramCount typ :: Type
typ =
  case Type
typ of
    ArrowT `AppT` _ `AppT` r :: Type
r -> 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Type -> Int
paramCount Type
r
    ForallT _ _ t :: Type
t            -> Type -> Int
paramCount Type
t
    _                        -> 0

invalid :: Q Exp
invalid :: Q Exp
invalid = 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
$ "Could not generate effect instance because the operation is "
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ "invalid for higher-order effects."

handlerFunctions :: EffectInfo -> Q [Dec]
handlerFunctions :: EffectInfo -> Q [Dec]
handlerFunctions info :: 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 [| Via |] [| runVia |] (EffectInfo -> TyVarBndr
effMonad EffectInfo
info) (EffectInfo -> [TyVarBndr]
effParams EffectInfo
info) )
      ( EffectInfo -> [Signature]
effSigs EffectInfo
info )

lifterFunctions :: EffectInfo -> Q [Dec]
lifterFunctions :: EffectInfo -> Q [Dec]
lifterFunctions info :: EffectInfo
info =
  let m :: TyVarBndr
m = EffectInfo -> TyVarBndr
effMonad EffectInfo
info
      params :: [TyVarBndr]
params = EffectInfo -> [TyVarBndr]
effParams EffectInfo
info
  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]
effSigs EffectInfo
info) ((Signature -> Q [Dec]) -> Q [[Dec]])
-> (Signature -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \sig :: 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
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 f :: Q Exp
f inv :: Q Exp
inv monad :: TyVarBndr
monad params :: [TyVarBndr]
params sig :: 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 = Cxt -> 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 monad :: TyVarBndr
monad params :: [TyVarBndr]
params sig :: 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 :: Cxt
restores = Bool -> Name -> Type -> Cxt
restorables Bool
False Name
m Type
typ
      expr :: Q Exp
expr = Cxt -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive Cxt
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 "x")    
  Type
res     <- 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 =
        [| Via $
            (liftWith $ \ $([p|run|]) -> $appliedExp)
              >>= $(traverseExp res) (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]

unkindType :: Type -> Type
unkindType :: Type -> Type
unkindType typ :: Type
typ =
  case Type
typ of
    -- 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 _ _ t :: Type
t -> Type -> Type
unkindType Type
t
    AppT l :: Type
l r :: Type
r      -> Type -> Type -> Type
AppT (Type -> Type
unkindType Type
l) (Type -> Type
unkindType Type
r)
    SigT t :: Type
t _      -> Type
t
    InfixT l :: Type
l n :: Name
n r :: Type
r  -> Type -> Name -> Type -> Type
InfixT (Type -> Type
unkindType Type
l) Name
n (Type -> Type
unkindType Type
r)
    UInfixT l :: Type
l n :: Name
n r :: Type
r -> Type -> Name -> Type -> Type
UInfixT (Type -> Type
unkindType Type
l) Name
n (Type -> Type
unkindType Type
r)
    ParensT t :: Type
t     -> Type -> Type
ParensT (Type -> Type
unkindType Type
t)
    other :: Type
other         -> Type
other

contains :: Name -> Type -> Bool
contains :: Name -> Type -> Bool
contains m :: Name
m typ :: Type
typ =
  case Type
typ of
    ForallT _ _ t :: Type
t -> Name -> Type -> Bool
contains Name
m Type
t
    AppT l :: Type
l r :: Type
r      -> Name -> Type -> Bool
contains Name
m Type
l Bool -> Bool -> Bool
|| Name -> Type -> Bool
contains Name
m Type
r
    SigT t :: Type
t _      -> Name -> Type -> Bool
contains Name
m Type
t
    VarT n :: Name
n        -> Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m
    ConT n :: Name
n        -> Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m
    PromotedT n :: Name
n   -> Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m
    InfixT l :: Type
l n :: Name
n r :: 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 l :: Type
l n :: Name
n r :: 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 t :: Type
t     -> Name -> Type -> Bool
contains Name
m Type
t
    _             -> Bool
False

derive :: [Type] -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive :: Cxt -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive rs :: Cxt
rs f :: Q Exp
f inv :: Q Exp
inv m :: Name
m typ :: Type
typ =
  -- TODO: This is missing some cases - see algorithm of DeriveFunctor.

  case Type
typ of
    t :: Type
t | Bool -> Bool
not (Name -> Type -> Bool
contains Name
m Type
t) ->
      [| id |]
    VarT n :: Name
n `AppT` _ | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
m ->
      Q Exp
f
    ArrowT `AppT` arg :: Type
arg `AppT` res :: Type
res ->
      let rf :: Q Exp
rf = Cxt -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive Cxt
rs Q Exp
f Q Exp
inv Name
m Type
res
          af :: Q Exp
af = Cxt -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive Cxt
rs Q Exp
inv Q Exp
f Name
m Type
arg
      in if Type -> Cxt -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Type
arg Cxt
rs
         then [| \x b -> $rf (((x =<<) . Via . restoreT . pure) b) |]
         else [| \x b -> $rf (x ($af b)) |]
    ForallT _ _ t :: Type
t ->
      Cxt -> Q Exp -> Q Exp -> Name -> Type -> Q Exp
derive Cxt
rs Q Exp
f Q Exp
inv Name
m Type
t
    other :: 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
$ "Could not generate effect instance because an unknown structure "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ "was encountered: "
      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 typ :: Type
typ =
  case Type
typ of
    ForallT _ _ t :: Type
t -> Type -> Q Exp
traverseExp Type
t
    AppT _ r :: Type
r      -> Type -> Q Exp
traverseRec Type
r
    SigT t :: Type
t _      -> Type -> Q Exp
traverseExp Type
t
    InfixT _ _ r :: Type
r  -> Type -> Q Exp
traverseRec Type
r
    UInfixT _ _ r :: Type
r -> Type -> Q Exp
traverseRec Type
r
    ParensT t :: Type
t     -> Type -> Q Exp
traverseExp Type
t
    _             -> [| id |]
  where
    traverseRec :: Type -> Q Exp
traverseRec t :: Type
t = [| traverse . $(traverseExp t) |]