{-# LANGUAGE TemplateHaskellQuotes #-}
module Data.Effect.Class.TH.Internal where
import Control.Monad (forM, replicateM, unless, when)
import Control.Monad.IO.Class (MonadIO)
import Data.List (intercalate, nub)
import Language.Haskell.TH.Lib (
appT,
conT,
patSynSigD,
sigT,
varT,
)
import Language.Haskell.TH.Syntax (
Con,
Cxt,
Dec (ClassD, SigD),
Info (ClassI),
Kind,
Name,
Q,
Quote (newName),
TyVarBndr (KindedTV, PlainTV),
Type (
AppKindT,
AppT,
ArrowT,
ConT,
ForallT,
ImplicitParamT,
InfixT,
ParensT,
PromotedT,
SigT,
StarT,
UInfixT,
VarT
),
nameBase,
reify,
)
import Control.Effect.Class (LiftIns (LiftIns))
import Control.Lens ((%~), (^?), _head, _last)
import Control.Monad.Writer (Any (Any), runWriterT, tell)
import Data.Bool (bool)
import Data.Char (toUpper)
import Data.Effect.Class.TH.HFunctor.Internal (DataInfo (DataInfo), infoToDataD, tyVarName)
import Data.Either (partitionEithers)
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.List.Extra (dropEnd)
import Data.Maybe (isNothing, mapMaybe)
import Language.Haskell.TH (
Bang (Bang),
Con (ForallC, GadtC),
SourceStrictness (NoSourceStrictness),
SourceUnpackedness (NoSourceUnpackedness),
Specificity (SpecifiedSpec),
arrowT,
conP,
implBidir,
mkName,
patSynD,
pragCompleteD,
prefixPatSyn,
tySynD,
varP,
)
import Language.Haskell.TH.Datatype (freeVariables)
generateEffectDataByEffInfo ::
EffectOrder ->
Name ->
EffectInfo ->
Q (DataInfo (), Dec)
generateEffectDataByEffInfo :: EffectOrder -> Name -> EffectInfo -> Q (DataInfo (), Dec)
generateEffectDataByEffInfo EffectOrder
order Name
effDataName EffectInfo
info = do
DataInfo ()
effDataInfo <- do
let pvs :: [TyVarBndr ()]
pvs = EffectInfo -> [TyVarBndr ()]
effParamVars EffectInfo
info
[TyVarBndr ()]
additionalTypeParams <- do
TyVarBndr ()
a <- do
Name
a <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV Name
a () Type
StarT
forall (f :: * -> *) a. Applicative f => a -> f a
pure case EffectOrder
order of
EffectOrder
FirstOrder -> [TyVarBndr ()
a]
EffectOrder
HigherOrder -> [forall a. TyVarBndr a -> TyVarBndr a
unkindTyVar forall a b. (a -> b) -> a -> b
$ EffectInfo -> TyVarBndr ()
effMonad EffectInfo
info, TyVarBndr ()
a]
[Con]
cons <- do
([(EffectOrder, String)]
errorMethods, [Con]
cons) <- do
[(Name, (EffectOrder, Con))]
consWithMethodInfo <- do
Type
effData <- do
let paramTypes :: [Q Type]
paramTypes = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. TyVarBndr a -> Q Type
tyVarType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TyVarBndr a -> TyVarBndr a
unkindTyVar) [TyVarBndr ()]
pvs
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
effDataName) [Q Type]
paramTypes
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (EffectInfo -> [MethodInterface]
effMethods EffectInfo
info) \MethodInterface
method ->
(MethodInterface -> Name
methodName MethodInterface
method,)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EffectInfo -> Type -> MethodInterface -> Q (EffectOrder, Con)
interfaceToCon EffectInfo
info Type
effData MethodInterface
method
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$
[(Name, (EffectOrder, Con))]
consWithMethodInfo forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Name
methodName, (EffectOrder
methodOrder, Con
con)) ->
if EffectOrder
methodOrder forall a. Eq a => a -> a -> Bool
== EffectOrder
order
then forall a b. b -> Either a b
Right Con
con
else forall a b. a -> Either a b
Left (EffectOrder
methodOrder, Name -> String
nameBase Name
methodName)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(EffectOrder, String)]
errorMethods) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
String
"Unexpected order of effect methods: "
forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate
String
", "
( [(EffectOrder, String)]
errorMethods forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(EffectOrder
methodOrder, String
name) ->
String
name forall a. Semigroup a => a -> a -> a
<> String
" [" forall a. Semigroup a => a -> a -> a
<> [forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ EffectOrder -> (Char, Char)
effectOrderSymbol EffectOrder
methodOrder] forall a. Semigroup a => a -> a -> a
<> String
"]"
)
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Con]
cons
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall flag.
[Type]
-> Name
-> [TyVarBndr flag]
-> [Con]
-> [DerivClause]
-> DataInfo flag
DataInfo [] Name
effDataName ([TyVarBndr ()]
pvs forall a. [a] -> [a] -> [a]
++ [TyVarBndr ()]
additionalTypeParams) [Con]
cons []
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DataInfo ()
effDataInfo, DataInfo () -> Dec
infoToDataD DataInfo ()
effDataInfo)
interfaceToCon ::
EffectInfo ->
Type ->
MethodInterface ->
Q (EffectOrder, Con)
interfaceToCon :: EffectInfo -> Type -> MethodInterface -> Q (EffectOrder, Con)
interfaceToCon EffectInfo
info Type
effData MethodInterface{[Type]
Type
Name
EffectOrder
methodCxt :: MethodInterface -> [Type]
methodReturnType :: MethodInterface -> Type
methodParamTypes :: MethodInterface -> [Type]
methodOrder :: MethodInterface -> EffectOrder
methodCxt :: [Type]
methodReturnType :: Type
methodParamTypes :: [Type]
methodOrder :: EffectOrder
methodName :: Name
methodName :: MethodInterface -> Name
..} =
(EffectOrder
methodOrder,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
Type
effDataFunctor <- case EffectOrder
methodOrder of
EffectOrder
FirstOrder -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
effData
EffectOrder
HigherOrder -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
effData forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (Type -> Type
unkindType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TyVarBndr a -> Q Type
tyVarType (EffectInfo -> TyVarBndr ()
effMonad EffectInfo
info))
let vars :: [Name]
vars =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
(\[Name]
acc Type
t -> forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ [Name]
acc forall a. [a] -> [a] -> [a]
++ forall a. TypeSubstitution a => a -> [Name]
freeVariables Type
t)
(forall a. TyVarBndr a -> Name
tyVarName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EffectInfo -> [TyVarBndr ()]
effParamVars EffectInfo
info)
([Type]
methodParamTypes forall a. [a] -> [a] -> [a]
++ [Type
methodReturnType])
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
[TyVarBndr Specificity] -> [Type] -> Con -> Con
ForallC ((forall flag. Name -> flag -> TyVarBndr flag
`PlainTV` Specificity
SpecifiedSpec) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vars) [Type]
methodCxt forall a b. (a -> b) -> a -> b
$
[Name] -> [BangType] -> Type -> Con
GadtC
[Name -> Name
renameMethodToCon Name
methodName]
([Type]
methodParamTypes forall a b. a -> (a -> b) -> b
& forall a b. (a -> b) -> [a] -> [b]
map (SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness,))
(Type -> Type -> Type
AppT Type
effDataFunctor Type
methodReturnType)
analyzeMethodInterface :: TyVarBndr () -> Type -> Q (EffectOrder, [Type], Type, Cxt)
analyzeMethodInterface :: TyVarBndr () -> Type -> Q (EffectOrder, [Type], Type, [Type])
analyzeMethodInterface TyVarBndr ()
m Type
interface = do
((Type
resultType, [Type]
cxt, [Type]
paramTypes), Any Bool
isHigherOrderMethod) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ Type -> WriterT Any Q (Type, [Type], [Type])
go Type
interface
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> a -> Bool -> a
bool EffectOrder
FirstOrder EffectOrder
HigherOrder Bool
isHigherOrderMethod, [Type]
paramTypes, Type
resultType, [Type]
cxt)
where
go :: Type -> WriterT Any Q (Type, [Type], [Type])
go = \case
Type
ArrowT `AppT` Type
l `AppT` Type
r -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. TyVarBndr a -> Name
tyVarName TyVarBndr ()
m Name -> Type -> Bool
`occurs` Type
l) forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Type
l :) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> WriterT Any Q (Type, [Type], [Type])
go Type
r
ForallT [TyVarBndr Specificity]
_ [Type]
cxt Type
u -> do
(Type
r, [Type]
c, [Type]
p) <- Type -> WriterT Any Q (Type, [Type], [Type])
go Type
u
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
r, [Type]
cxt forall a. [a] -> [a] -> [a]
++ [Type]
c, [Type]
p)
VarT Name
n `AppT` Type
a | Name
n forall a. Eq a => a -> a -> Bool
== forall a. TyVarBndr a -> Name
tyVarName TyVarBndr ()
m -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
a, [], [])
Type
other -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Expected a pure type of the form 'm a', but encountered: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
other
renameMethodToCon :: Name -> Name
renameMethodToCon :: Name -> Name
renameMethodToCon = String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. Cons s s a a => Traversal' s a
_head forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Char -> Char
toUpper) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
data EffectOrder = FirstOrder | HigherOrder
deriving (Int -> EffectOrder -> String -> String
[EffectOrder] -> String -> String
EffectOrder -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [EffectOrder] -> String -> String
$cshowList :: [EffectOrder] -> String -> String
show :: EffectOrder -> String
$cshow :: EffectOrder -> String
showsPrec :: Int -> EffectOrder -> String -> String
$cshowsPrec :: Int -> EffectOrder -> String -> String
Show, EffectOrder -> EffectOrder -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EffectOrder -> EffectOrder -> Bool
$c/= :: EffectOrder -> EffectOrder -> Bool
== :: EffectOrder -> EffectOrder -> Bool
$c== :: EffectOrder -> EffectOrder -> Bool
Eq, Eq EffectOrder
EffectOrder -> EffectOrder -> Bool
EffectOrder -> EffectOrder -> Ordering
EffectOrder -> EffectOrder -> EffectOrder
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EffectOrder -> EffectOrder -> EffectOrder
$cmin :: EffectOrder -> EffectOrder -> EffectOrder
max :: EffectOrder -> EffectOrder -> EffectOrder
$cmax :: EffectOrder -> EffectOrder -> EffectOrder
>= :: EffectOrder -> EffectOrder -> Bool
$c>= :: EffectOrder -> EffectOrder -> Bool
> :: EffectOrder -> EffectOrder -> Bool
$c> :: EffectOrder -> EffectOrder -> Bool
<= :: EffectOrder -> EffectOrder -> Bool
$c<= :: EffectOrder -> EffectOrder -> Bool
< :: EffectOrder -> EffectOrder -> Bool
$c< :: EffectOrder -> EffectOrder -> Bool
compare :: EffectOrder -> EffectOrder -> Ordering
$ccompare :: EffectOrder -> EffectOrder -> Ordering
Ord)
isHigherOrder :: EffectOrder -> Bool
isHigherOrder :: EffectOrder -> Bool
isHigherOrder = \case
EffectOrder
FirstOrder -> Bool
False
EffectOrder
HigherOrder -> Bool
True
defaultEffectDataNamer :: EffectOrder -> String -> String
defaultEffectDataNamer :: EffectOrder -> String -> String
defaultEffectDataNamer EffectOrder
order String
clsName =
String
effNameBase forall a. [a] -> [a] -> [a]
++ [Char
dataOrderSym]
where
(Char
clsOrderSym, Char
dataOrderSym) = EffectOrder -> (Char, Char)
effectOrderSymbol EffectOrder
order
effNameBase :: String
effNameBase =
if String
clsName forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. Snoc s s a a => Traversal' s a
_last forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Char
clsOrderSym
then forall a. Int -> [a] -> [a]
dropEnd Int
1 String
clsName
else String
clsName
effectOrderSymbol :: EffectOrder -> (Char, Char)
effectOrderSymbol :: EffectOrder -> (Char, Char)
effectOrderSymbol = \case
EffectOrder
FirstOrder -> (Char
'F', Char
'I')
EffectOrder
HigherOrder -> (Char
'H', Char
'S')
generateLiftInsPatternSynonyms :: Name -> EffectInfo -> Q [Dec]
generateLiftInsPatternSynonyms :: Name -> EffectInfo -> Q [Dec]
generateLiftInsPatternSynonyms Name
dataName EffectInfo
info = do
[(Name, [Dec])]
patSyns <-
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (EffectInfo -> [MethodInterface]
effMethods EffectInfo
info) \MethodInterface{[Type]
Type
Name
EffectOrder
methodCxt :: [Type]
methodReturnType :: Type
methodParamTypes :: [Type]
methodOrder :: EffectOrder
methodName :: Name
methodCxt :: MethodInterface -> [Type]
methodReturnType :: MethodInterface -> Type
methodParamTypes :: MethodInterface -> [Type]
methodOrder :: MethodInterface -> EffectOrder
methodName :: MethodInterface -> Name
..} -> do
let conName :: Name
conName = Name -> Name
renameMethodToCon Name
methodName
newConName :: Name
newConName = String -> Name
mkName forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
conName forall a. [a] -> [a] -> [a]
++ String
"S"
[Name]
args <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
methodParamTypes) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
Q Type
a <- forall (m :: * -> *). Quote m => Name -> m Type
varT forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
(Name
newConName,)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
patSynSigD
Name
newConName
[t|
() =>
($a ~ $(pure methodReturnType)) =>
$( foldr
(\l r -> arrowT `appT` pure l `appT` r)
[t|
$(liftInsType dataName $ tyVarName <$> effParamVars info)
$(varT $ tyVarName $ effMonad info)
$a
|]
methodParamTypes
)
|]
, forall (m :: * -> *).
Quote m =>
Name -> m PatSynArgs -> m PatSynDir -> m Pat -> m Dec
patSynD
Name
newConName
(forall (m :: * -> *). Quote m => [Name] -> m PatSynArgs
prefixPatSyn [Name]
args)
forall (m :: * -> *). Quote m => m PatSynDir
implBidir
(forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'LiftIns [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Pat
varP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args])
]
(forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [(Name, [Dec])]
patSyns ++)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall (m :: * -> *). Quote m => [Name] -> Maybe Name -> m Dec
pragCompleteD (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, [Dec])]
patSyns) forall a. Maybe a
Nothing]
generateLiftInsTypeSynonym :: EffectInfo -> Name -> Q Dec
generateLiftInsTypeSynonym :: EffectInfo -> Name -> Q Dec
generateLiftInsTypeSynonym EffectInfo
info Name
dataName = do
Name
nameS <- String -> Name
mkName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q String
renameI2S (Name -> String
nameBase Name
dataName)
forall (m :: * -> *).
Quote m =>
Name -> [TyVarBndr ()] -> m Type -> m Dec
tySynD
Name
nameS
([Name]
pvs forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall flag. Name -> flag -> TyVarBndr flag
`PlainTV` ()))
(Name -> [Name] -> Q Type
liftInsType Name
dataName [Name]
pvs)
where
pvs :: [Name]
pvs = forall a. TyVarBndr a -> Name
tyVarName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EffectInfo -> [TyVarBndr ()]
effParamVars EffectInfo
info
renameI2S :: String -> Q String
renameI2S :: String -> Q String
renameI2S String
name = String -> Q String
dropEndI String
name forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall a. [a] -> [a] -> [a]
++ String
"S")
dropEndI :: String -> Q String
dropEndI :: String -> Q String
dropEndI String
name =
if String
name forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. Snoc s s a a => Traversal' s a
_last forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Char
'I'
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
dropEnd Int
1 String
name
else forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"The name doesn't end in 'I': \"" forall a. Semigroup a => a -> a -> a
<> String
name forall a. Semigroup a => a -> a -> a
<> String
"\"."
liftInsType :: Name -> [Name] -> Q Type
liftInsType :: Name -> [Name] -> Q Type
liftInsType Name
dataName [Name]
pvs =
forall (m :: * -> *). Quote m => Name -> m Type
conT ''LiftIns forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
dataName) (forall (m :: * -> *). Quote m => Name -> m Type
varT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
pvs)
applyEffPVs :: Name -> [Name] -> Q Type
applyEffPVs :: Name -> [Name] -> Q Type
applyEffPVs Name
effClsName = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
effClsName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *). Quote m => Name -> m Type
varT
data EffectInfo = EffectInfo
{ EffectInfo -> [Type]
effCxts :: [Type]
, EffectInfo -> Name
effName :: Name
, EffectInfo -> [TyVarBndr ()]
effParamVars :: [TyVarBndr ()]
, EffectInfo -> TyVarBndr ()
effMonad :: TyVarBndr ()
, EffectInfo -> [MethodInterface]
effMethods :: [MethodInterface]
}
effParamVar :: (Name, Maybe Kind) -> TyVarBndr ()
effParamVar :: (Name, Maybe Type) -> TyVarBndr ()
effParamVar (Name
n, Maybe Type
k) = case Maybe Type
k of
Just Type
k' -> forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV Name
n () Type
k'
Maybe Type
Nothing -> forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n ()
data MethodInterface = MethodInterface
{ MethodInterface -> Name
methodName :: Name
, MethodInterface -> EffectOrder
methodOrder :: EffectOrder
, MethodInterface -> [Type]
methodParamTypes :: [Type]
, MethodInterface -> Type
methodReturnType :: Type
, MethodInterface -> [Type]
methodCxt :: Cxt
}
reifyEffectInfo :: Name -> Q EffectInfo
reifyEffectInfo :: Name -> Q EffectInfo
reifyEffectInfo Name
className = do
Info
info <- Name -> Q Info
reify Name
className
case Info
info of
ClassI (ClassD [Type]
cxts Name
name [TyVarBndr ()]
tyVars [FunDep]
_funDeps [Dec]
decs) [Dec]
_ -> do
([TyVarBndr ()]
paramVars, TyVarBndr ()
monad) <-
case [TyVarBndr ()]
tyVars of
[] ->
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
String
"The specified effect type class `"
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
name
forall a. [a] -> [a] -> [a]
++ String
"' has no monad type variable. "
forall a. [a] -> [a] -> [a]
++ String
"It is expected to be the last type variable."
[TyVarBndr ()]
vs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. [a] -> [a]
init [TyVarBndr ()]
vs, forall a. [a] -> a
last [TyVarBndr ()]
vs)
[Type]
-> Name
-> [TyVarBndr ()]
-> TyVarBndr ()
-> [MethodInterface]
-> EffectInfo
EffectInfo [Type]
cxts Name
name [TyVarBndr ()]
paramVars TyVarBndr ()
monad
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ do
(EffectOrder
order, [Type]
paramTypes, Type
retType, [Type]
cxt) <- TyVarBndr () -> Type -> Q (EffectOrder, [Type], Type, [Type])
analyzeMethodInterface TyVarBndr ()
monad Type
t
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> EffectOrder -> [Type] -> Type -> [Type] -> MethodInterface
MethodInterface Name
n EffectOrder
order [Type]
paramTypes Type
retType [Type]
cxt
| SigD Name
n Type
t <- [Dec]
decs
]
Info
other ->
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
String
"The specified name `"
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
className
forall a. [a] -> [a] -> [a]
++ String
"' is not a type class, but the following instead: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Info
other
effectType :: EffectInfo -> Q Type
effectType :: EffectInfo -> Q Type
effectType EffectInfo
info =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT
(forall (m :: * -> *). Quote m => Name -> m Type
conT forall a b. (a -> b) -> a -> b
$ EffectInfo -> Name
effName EffectInfo
info)
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. TyVarBndr a -> Q Type
tyVarType (EffectInfo -> [TyVarBndr ()]
effParamVars EffectInfo
info))
partitionSuperEffects :: EffectInfo -> (Cxt, [Type])
partitionSuperEffects :: EffectInfo -> ([Type], [Type])
partitionSuperEffects EffectInfo
info =
( forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe Type
extract) [Type]
cxts
, forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Type -> Maybe Type
extract (EffectInfo -> [Type]
effCxts EffectInfo
info)
)
where
cxts :: [Type]
cxts = EffectInfo -> [Type]
effCxts EffectInfo
info
m :: Name
m = forall a. TyVarBndr a -> Name
tyVarName (EffectInfo -> TyVarBndr ()
effMonad EffectInfo
info)
extract :: Type -> Maybe Type
extract = \case
ForallT [TyVarBndr Specificity]
_ [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 forall a. Eq a => a -> a -> Bool
== Name
m -> forall a. a -> Maybe a
Just Type
t
InfixT Type
t Name
_ (VarT Name
n) | Name
n forall a. Eq a => a -> a -> Bool
== Name
m -> forall a. a -> Maybe a
Just Type
t
UInfixT Type
t Name
_ (VarT Name
n) | Name
n forall a. Eq a => a -> a -> Bool
== Name
m -> forall a. a -> Maybe a
Just Type
t
AppKindT Type
t Type
_ -> Type -> Maybe Type
extract Type
t
ImplicitParamT String
_ Type
t -> Type -> Maybe Type
extract Type
t
Type
_ -> forall a. Maybe a
Nothing
superEffects :: EffectInfo -> [Type]
superEffects :: EffectInfo -> [Type]
superEffects = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. EffectInfo -> ([Type], [Type])
partitionSuperEffects
superEffectsWithoutBase :: EffectInfo -> [Type]
superEffectsWithoutBase :: EffectInfo -> [Type]
superEffectsWithoutBase =
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Bool
isBase) forall b c a. (b -> c) -> (a -> b) -> a -> c
. EffectInfo -> [Type]
superEffects
where
isBase :: Type -> Bool
isBase = \case
ConT Name
n -> Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [''Applicative, ''Functor, ''Monad, ''MonadIO]
Type
_ -> Bool
False
effectParamCxt :: EffectInfo -> Cxt
effectParamCxt :: EffectInfo -> [Type]
effectParamCxt = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. EffectInfo -> ([Type], [Type])
partitionSuperEffects
pureNamer :: (String -> String) -> Name -> Q Name
pureNamer :: (String -> String) -> Name -> Q Name
pureNamer String -> String
f = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
unkindType :: Type -> Type
unkindType :: Type -> Type
unkindType = \case
ForallT [TyVarBndr Specificity]
vs [Type]
ps Type
t -> [TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. TyVarBndr a -> TyVarBndr a
unkindTyVar [TyVarBndr Specificity]
vs) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
unkindType [Type]
ps) (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)
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)
Type
other -> Type
other
unkindTyVar :: TyVarBndr a -> TyVarBndr a
unkindTyVar :: forall a. TyVarBndr a -> TyVarBndr a
unkindTyVar (KindedTV Name
n a
s Type
_) = forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n a
s
unkindTyVar TyVarBndr a
unkinded = TyVarBndr a
unkinded
tyVarType :: TyVarBndr a -> Q Type
tyVarType :: forall a. TyVarBndr a -> Q Type
tyVarType (PlainTV Name
n a
_) = forall (m :: * -> *). Quote m => Name -> m Type
varT Name
n
tyVarType (KindedTV Name
n a
_ Type
k) = forall (m :: * -> *). Quote m => m Type -> Type -> m Type
sigT (forall (m :: * -> *). Quote m => Name -> m Type
varT Name
n) Type
k
tyVarKind :: TyVarBndr a -> Q Type
tyVarKind :: forall a. TyVarBndr a -> Q Type
tyVarKind (KindedTV Name
_ a
_ Type
k) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
k
tyVarKind (PlainTV Name
_ a
_) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"The type variable has no kind."
paramCount :: Type -> Int
paramCount :: Type -> Int
paramCount = \case
Type
ArrowT `AppT` Type
_ `AppT` Type
r -> Int
1 forall a. Num a => a -> a -> a
+ Type -> Int
paramCount Type
r
ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
t -> Type -> Int
paramCount Type
t
Type
_ -> Int
0
occurs :: Name -> Type -> Bool
occurs :: Name -> Type -> Bool
occurs Name
m = \case
ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
t -> Name
m Name -> Type -> Bool
`occurs` Type
t
AppT Type
l Type
r -> Name
m Name -> Type -> Bool
`occurs` Type
l Bool -> Bool -> Bool
|| Name
m Name -> Type -> Bool
`occurs` Type
r
SigT Type
t Type
_ -> Name
m Name -> Type -> Bool
`occurs` Type
t
VarT Name
n -> Name
n forall a. Eq a => a -> a -> Bool
== Name
m
ConT Name
n -> Name
n forall a. Eq a => a -> a -> Bool
== Name
m
PromotedT Name
n -> Name
n forall a. Eq a => a -> a -> Bool
== Name
m
InfixT Type
l Name
n Type
r -> Name
n forall a. Eq a => a -> a -> Bool
== Name
m Bool -> Bool -> Bool
|| Name
m Name -> Type -> Bool
`occurs` Type
l Bool -> Bool -> Bool
|| Name
m Name -> Type -> Bool
`occurs` Type
r
UInfixT Type
l Name
n Type
r -> Name
n forall a. Eq a => a -> a -> Bool
== Name
m Bool -> Bool -> Bool
|| Name
m Name -> Type -> Bool
`occurs` Type
l Bool -> Bool -> Bool
|| Name
m Name -> Type -> Bool
`occurs` Type
r
ParensT Type
t -> Name
m Name -> Type -> Bool
`occurs` Type
t
AppKindT Type
t Type
_ -> Name
m Name -> Type -> Bool
`occurs` Type
t
ImplicitParamT String
_ Type
t -> Name
m Name -> Type -> Bool
`occurs` Type
t
Type
_ -> Bool
False