{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Grisette.Internal.TH.DeriveUnifiedInterface
( TypeableMode (..),
PrimaryUnifiedConstraint (..),
UnifiedInstance (..),
deriveUnifiedInterfaceExtra,
deriveUnifiedInterface,
deriveUnifiedInterfaces,
deriveUnifiedInterface1Extra,
deriveUnifiedInterface1,
deriveUnifiedInterface1s,
deriveFunctorArgUnifiedInterfaceExtra,
deriveFunctorArgUnifiedInterface,
deriveFunctorArgUnifiedInterfaces,
)
where
import Control.Monad (unless)
import Data.Typeable (Typeable)
import Grisette.Internal.TH.DeriveInstanceProvider
( DeriveInstanceProvider (instanceDeclaration),
)
import Grisette.Internal.TH.DeriveTypeParamHandler
( DeriveTypeParamHandler (handleBody, handleTypeParams),
NatShouldBePositive (NatShouldBePositive),
SomeDeriveTypeParamHandler (SomeDeriveTypeParamHandler),
)
import Grisette.Internal.TH.DeriveWithHandlers (deriveWithHandlers)
import Grisette.Internal.TH.Util
( allSameKind,
classParamKinds,
concatPreds,
getTypeWithMaybeSubst,
tvIsMode,
tvIsStar,
tvIsStarToStar,
)
import Grisette.Unified.Internal.EvalModeTag (EvalModeTag)
import Grisette.Unified.Internal.Util (withMode)
import Language.Haskell.TH
( Dec,
Exp,
Inline (Inline),
Kind,
Name,
Phases (AllPhases),
Pred,
Q,
RuleMatch (FunLike),
Type (ConT),
appT,
conT,
instanceD,
lam1E,
newName,
normalB,
pragInlD,
valD,
varE,
varP,
)
import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndrUnit, kindedTV, tvKind)
data TypeableMode = TypeableMode
instance DeriveTypeParamHandler TypeableMode where
handleTypeParams :: Int
-> TypeableMode
-> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
handleTypeParams Int
n TypeableMode
_ [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
tys = do
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$
String
"TypeableMode: unified type class should have exactly one type "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"parameter"
let numModeParam :: Int
numModeParam = [[(TyVarBndrUnit, Maybe Type)]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[(TyVarBndrUnit, Maybe Type)]] -> Int)
-> [[(TyVarBndrUnit, Maybe Type)]] -> Int
forall a b. (a -> b) -> a -> b
$ (([(TyVarBndrUnit, Maybe Type)] -> Bool)
-> [[(TyVarBndrUnit, Maybe Type)]]
-> [[(TyVarBndrUnit, Maybe Type)]]
forall a. (a -> Bool) -> [a] -> [a]
filter (TyVarBndrUnit -> Bool
forall flag. TyVarBndr_ flag -> Bool
tvIsMode (TyVarBndrUnit -> Bool)
-> ([(TyVarBndrUnit, Maybe Type)] -> TyVarBndrUnit)
-> [(TyVarBndrUnit, Maybe Type)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyVarBndrUnit, Maybe Type) -> TyVarBndrUnit
forall a b. (a, b) -> a
fst ((TyVarBndrUnit, Maybe Type) -> TyVarBndrUnit)
-> ([(TyVarBndrUnit, Maybe Type)] -> (TyVarBndrUnit, Maybe Type))
-> [(TyVarBndrUnit, Maybe Type)]
-> TyVarBndrUnit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TyVarBndrUnit, Maybe Type)] -> (TyVarBndrUnit, Maybe Type)
forall a. HasCallStack => [a] -> a
head)) ([[(TyVarBndrUnit, Maybe Type)]]
-> [[(TyVarBndrUnit, Maybe Type)]])
-> [[(TyVarBndrUnit, Maybe Type)]]
-> [[(TyVarBndrUnit, Maybe Type)]]
forall a b. (a -> b) -> a -> b
$ ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> [(TyVarBndrUnit, Maybe Type)]
forall a b. (a, b) -> a
fst (([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> [(TyVarBndrUnit, Maybe Type)])
-> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> [[(TyVarBndrUnit, Maybe Type)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
tys
[([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
newTys <-
if Int
numModeParam Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then do
Name
nm <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"mode"
[([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])])
-> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
forall a b. (a -> b) -> a -> b
$
( [(Name -> Type -> TyVarBndrUnit
kindedTV Name
nm (Name -> Type
ConT ''EvalModeTag), Maybe Type
forall a. Maybe a
Nothing)],
Maybe [Type]
forall a. Maybe a
Nothing
)
([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
forall a. a -> [a] -> [a]
: [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
tys
else
if Int
numModeParam Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
then [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
tys
else String -> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"TypeableMode: multiple mode type variables found"
(([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type]))
-> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (([(TyVarBndrUnit, Maybe Type)]
-> Maybe [Type] -> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type]))
-> ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [(TyVarBndrUnit, Maybe Type)]
-> Maybe [Type] -> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
handleMode) [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
newTys
where
handleMode ::
[(TyVarBndrUnit, Maybe Type)] ->
Maybe [Pred] ->
Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Pred])
handleMode :: [(TyVarBndrUnit, Maybe Type)]
-> Maybe [Type] -> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
handleMode [(TyVarBndrUnit
tv, Maybe Type
substTy)] Maybe [Type]
preds | TyVarBndrUnit -> Bool
forall flag. TyVarBndr_ flag -> Bool
tvIsMode TyVarBndrUnit
tv = do
Type
typeable <- [t|Typeable $(TyVarBndrUnit -> Maybe Type -> Q Type
getTypeWithMaybeSubst TyVarBndrUnit
tv Maybe Type
substTy)|]
([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(TyVarBndrUnit
tv, Maybe Type
substTy)], Maybe [Type] -> Maybe [Type] -> Maybe [Type]
concatPreds ([Type] -> Maybe [Type]
forall a. a -> Maybe a
Just [Type
typeable]) Maybe [Type]
preds)
handleMode [(TyVarBndrUnit, Maybe Type)]
tys Maybe [Type]
preds = ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(TyVarBndrUnit, Maybe Type)]
tys, Maybe [Type]
preds)
handleBody :: TypeableMode -> [[Type]] -> Q [Type]
handleBody TypeableMode
_ [[Type]]
_ = [Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
data PrimaryUnifiedConstraint = PrimaryUnifiedConstraint Name Bool
instance DeriveTypeParamHandler PrimaryUnifiedConstraint where
handleTypeParams :: Int
-> PrimaryUnifiedConstraint
-> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
handleTypeParams
Int
n
(PrimaryUnifiedConstraint Name
className Bool
ignoreIfAlreadyHandled)
[([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
tys = do
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$
String
"TypeableMode: unified type class should have exactly one type "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"parameter"
[Type]
kinds <- Name -> Q [Type]
classParamKinds Name
className
let modes :: [[(TyVarBndrUnit, Maybe Type)]]
modes = ([(TyVarBndrUnit, Maybe Type)] -> Bool)
-> [[(TyVarBndrUnit, Maybe Type)]]
-> [[(TyVarBndrUnit, Maybe Type)]]
forall a. (a -> Bool) -> [a] -> [a]
filter (TyVarBndrUnit -> Bool
forall flag. TyVarBndr_ flag -> Bool
tvIsMode (TyVarBndrUnit -> Bool)
-> ([(TyVarBndrUnit, Maybe Type)] -> TyVarBndrUnit)
-> [(TyVarBndrUnit, Maybe Type)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyVarBndrUnit, Maybe Type) -> TyVarBndrUnit
forall a b. (a, b) -> a
fst ((TyVarBndrUnit, Maybe Type) -> TyVarBndrUnit)
-> ([(TyVarBndrUnit, Maybe Type)] -> (TyVarBndrUnit, Maybe Type))
-> [(TyVarBndrUnit, Maybe Type)]
-> TyVarBndrUnit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TyVarBndrUnit, Maybe Type)] -> (TyVarBndrUnit, Maybe Type)
forall a. HasCallStack => [a] -> a
head) ([[(TyVarBndrUnit, Maybe Type)]]
-> [[(TyVarBndrUnit, Maybe Type)]])
-> [[(TyVarBndrUnit, Maybe Type)]]
-> [[(TyVarBndrUnit, Maybe Type)]]
forall a b. (a -> b) -> a -> b
$ ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> [(TyVarBndrUnit, Maybe Type)]
forall a b. (a, b) -> a
fst (([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> [(TyVarBndrUnit, Maybe Type)])
-> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> [[(TyVarBndrUnit, Maybe Type)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
tys
case [[(TyVarBndrUnit, Maybe Type)]]
modes of
[] -> String -> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"PrimaryUnifiedConstraint: No mode type variable found"
[[(TyVarBndrUnit, Maybe Type)
md]] -> do
Type
mdTy <- (TyVarBndrUnit -> Maybe Type -> Q Type)
-> (TyVarBndrUnit, Maybe Type) -> Q Type
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TyVarBndrUnit -> Maybe Type -> Q Type
getTypeWithMaybeSubst (TyVarBndrUnit, Maybe Type)
md
(([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type]))
-> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (([(TyVarBndrUnit, Maybe Type)]
-> Maybe [Type] -> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type]))
-> ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (([(TyVarBndrUnit, Maybe Type)]
-> Maybe [Type] -> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type]))
-> ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type]))
-> ([(TyVarBndrUnit, Maybe Type)]
-> Maybe [Type] -> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type]))
-> ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
forall a b. (a -> b) -> a -> b
$ [Type]
-> Type
-> [(TyVarBndrUnit, Maybe Type)]
-> Maybe [Type]
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
handle [Type]
kinds Type
mdTy) [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
tys
[[(TyVarBndrUnit, Maybe Type)]
_] ->
String -> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"PrimaryUnifiedConstraint: multiple mode type variables found"
[[(TyVarBndrUnit, Maybe Type)]]
_ ->
String -> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"PrimaryUnifiedConstraint: multiple mode type variables found"
where
handle ::
[Kind] ->
Type ->
[(TyVarBndrUnit, Maybe Type)] ->
Maybe [Pred] ->
Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Pred])
handle :: [Type]
-> Type
-> [(TyVarBndrUnit, Maybe Type)]
-> Maybe [Type]
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
handle [Type]
_ Type
_ [] Maybe [Type]
preds = ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Maybe [Type]
preds)
handle [Type]
_ Type
_ [(TyVarBndrUnit, Maybe Type)]
tys (Just [Type]
preds)
| Bool
ignoreIfAlreadyHandled =
([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(TyVarBndrUnit, Maybe Type)]
tys, [Type] -> Maybe [Type]
forall a. a -> Maybe a
Just [Type]
preds)
handle [Type]
_ Type
_ [(TyVarBndrUnit, Maybe Type)]
tys Maybe [Type]
_
| Bool -> Bool
not ([TyVarBndrUnit] -> Bool
allSameKind (((TyVarBndrUnit, Maybe Type) -> TyVarBndrUnit)
-> [(TyVarBndrUnit, Maybe Type)] -> [TyVarBndrUnit]
forall a b. (a -> b) -> [a] -> [b]
map (TyVarBndrUnit, Maybe Type) -> TyVarBndrUnit
forall a b. (a, b) -> a
fst [(TyVarBndrUnit, Maybe Type)]
tys)) =
String -> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
String
"PrimaryUnifiedConstraint: All type parameters must be aligned"
handle [Type]
kinds Type
modety [(TyVarBndrUnit, Maybe Type)]
tys Maybe [Type]
preds
| Name -> Type
ConT ''EvalModeTag Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: (TyVarBndrUnit -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind (TyVarBndrUnit -> Type)
-> ((TyVarBndrUnit, Maybe Type) -> TyVarBndrUnit)
-> (TyVarBndrUnit, Maybe Type)
-> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyVarBndrUnit, Maybe Type) -> TyVarBndrUnit
forall a b. (a, b) -> a
fst ((TyVarBndrUnit, Maybe Type) -> Type)
-> [(TyVarBndrUnit, Maybe Type)] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TyVarBndrUnit, Maybe Type)]
tys) [Type] -> [Type] -> Bool
forall a. Eq a => a -> a -> Bool
== [Type]
kinds = do
[Type]
ts <- ((TyVarBndrUnit, Maybe Type) -> Q Type)
-> [(TyVarBndrUnit, Maybe Type)] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((TyVarBndrUnit -> Maybe Type -> Q Type)
-> (TyVarBndrUnit, Maybe Type) -> Q Type
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TyVarBndrUnit -> Maybe Type -> Q Type
getTypeWithMaybeSubst) [(TyVarBndrUnit, Maybe Type)]
tys
Type
cls <-
(Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
className) (Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
modety)) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
forall a b. (a -> b) -> a -> b
$
Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> [Type] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
ts
([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(TyVarBndrUnit, Maybe Type)]
tys, Maybe [Type] -> Maybe [Type] -> Maybe [Type]
concatPreds ([Type] -> Maybe [Type]
forall a. a -> Maybe a
Just [Type
cls]) Maybe [Type]
preds)
handle [Type]
_ Type
_ [(TyVarBndrUnit, Maybe Type)]
tys Maybe [Type]
preds = ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(TyVarBndrUnit, Maybe Type)]
tys, Maybe [Type]
preds)
handleBody :: PrimaryUnifiedConstraint -> [[Type]] -> Q [Type]
handleBody (PrimaryUnifiedConstraint Name
_ Bool
_) [[Type]]
_ = [Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
data UnifiedInstance = UnifiedInstance
{ UnifiedInstance -> Name
_cls :: Name,
UnifiedInstance -> Name
_clsWithFunc :: Name,
UnifiedInstance -> Name
_withFunc :: Name,
UnifiedInstance -> Maybe Name
_withFunc1 :: Maybe Name
}
instance DeriveInstanceProvider UnifiedInstance where
instanceDeclaration :: UnifiedInstance
-> [[(TyVarBndrUnit, Maybe Type)]] -> [Type] -> [Type] -> Q [Dec]
instanceDeclaration
(UnifiedInstance Name
cls Name
clsWithFunc Name
withFunc Maybe Name
maybeWithFunc1)
[[(TyVarBndrUnit, Maybe Type)]]
tys'
[Type]
ctx
[Type]
ty' = do
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (([(TyVarBndrUnit, Maybe Type)] -> Bool)
-> [[(TyVarBndrUnit, Maybe Type)]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool)
-> ([(TyVarBndrUnit, Maybe Type)] -> Int)
-> [(TyVarBndrUnit, Maybe Type)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TyVarBndrUnit, Maybe Type)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [[(TyVarBndrUnit, Maybe Type)]]
tys') (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"UnifiedInstance: only support classes with one type parameter"
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ty' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
String -> Q ()
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"UnifiedInstance: only support classes with one type parameter"
let tys :: [(TyVarBndrUnit, Maybe Type)]
tys = [(TyVarBndrUnit, Maybe Type)] -> (TyVarBndrUnit, Maybe Type)
forall a. HasCallStack => [a] -> a
head ([(TyVarBndrUnit, Maybe Type)] -> (TyVarBndrUnit, Maybe Type))
-> [[(TyVarBndrUnit, Maybe Type)]] -> [(TyVarBndrUnit, Maybe Type)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[(TyVarBndrUnit, Maybe Type)]]
tys'
let modes :: [Q Type]
modes =
((TyVarBndrUnit, Maybe Type) -> Q Type)
-> [(TyVarBndrUnit, Maybe Type)] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map ((TyVarBndrUnit -> Maybe Type -> Q Type)
-> (TyVarBndrUnit, Maybe Type) -> Q Type
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TyVarBndrUnit -> Maybe Type -> Q Type
getTypeWithMaybeSubst) ([(TyVarBndrUnit, Maybe Type)] -> [Q Type])
-> [(TyVarBndrUnit, Maybe Type)] -> [Q Type]
forall a b. (a -> b) -> a -> b
$ ((TyVarBndrUnit, Maybe Type) -> Bool)
-> [(TyVarBndrUnit, Maybe Type)] -> [(TyVarBndrUnit, Maybe Type)]
forall a. (a -> Bool) -> [a] -> [a]
filter (TyVarBndrUnit -> Bool
forall flag. TyVarBndr_ flag -> Bool
tvIsMode (TyVarBndrUnit -> Bool)
-> ((TyVarBndrUnit, Maybe Type) -> TyVarBndrUnit)
-> (TyVarBndrUnit, Maybe Type)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyVarBndrUnit, Maybe Type) -> TyVarBndrUnit
forall a b. (a, b) -> a
fst) [(TyVarBndrUnit, Maybe Type)]
tys
let stars :: [Q Type]
stars =
((TyVarBndrUnit, Maybe Type) -> Q Type)
-> [(TyVarBndrUnit, Maybe Type)] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map ((TyVarBndrUnit -> Maybe Type -> Q Type)
-> (TyVarBndrUnit, Maybe Type) -> Q Type
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TyVarBndrUnit -> Maybe Type -> Q Type
getTypeWithMaybeSubst) ([(TyVarBndrUnit, Maybe Type)] -> [Q Type])
-> [(TyVarBndrUnit, Maybe Type)] -> [Q Type]
forall a b. (a -> b) -> a -> b
$ ((TyVarBndrUnit, Maybe Type) -> Bool)
-> [(TyVarBndrUnit, Maybe Type)] -> [(TyVarBndrUnit, Maybe Type)]
forall a. (a -> Bool) -> [a] -> [a]
filter (TyVarBndrUnit -> Bool
forall flag. TyVarBndr_ flag -> Bool
tvIsStar (TyVarBndrUnit -> Bool)
-> ((TyVarBndrUnit, Maybe Type) -> TyVarBndrUnit)
-> (TyVarBndrUnit, Maybe Type)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyVarBndrUnit, Maybe Type) -> TyVarBndrUnit
forall a b. (a, b) -> a
fst) [(TyVarBndrUnit, Maybe Type)]
tys
let starToStars :: [Q Type]
starToStars =
((TyVarBndrUnit, Maybe Type) -> Q Type)
-> [(TyVarBndrUnit, Maybe Type)] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map ((TyVarBndrUnit -> Maybe Type -> Q Type)
-> (TyVarBndrUnit, Maybe Type) -> Q Type
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TyVarBndrUnit -> Maybe Type -> Q Type
getTypeWithMaybeSubst) ([(TyVarBndrUnit, Maybe Type)] -> [Q Type])
-> [(TyVarBndrUnit, Maybe Type)] -> [Q Type]
forall a b. (a -> b) -> a -> b
$
((TyVarBndrUnit, Maybe Type) -> Bool)
-> [(TyVarBndrUnit, Maybe Type)] -> [(TyVarBndrUnit, Maybe Type)]
forall a. (a -> Bool) -> [a] -> [a]
filter (TyVarBndrUnit -> Bool
forall flag. TyVarBndr_ flag -> Bool
tvIsStarToStar (TyVarBndrUnit -> Bool)
-> ((TyVarBndrUnit, Maybe Type) -> TyVarBndrUnit)
-> (TyVarBndrUnit, Maybe Type)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyVarBndrUnit, Maybe Type) -> TyVarBndrUnit
forall a b. (a, b) -> a
fst) [(TyVarBndrUnit, Maybe Type)]
tys
case [Q Type]
modes of
[] -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"UnifiedInstance: no mode type variables found"
[Q Type
md] -> do
[Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
[ Q [Type] -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD
([Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
ctx)
[t|$(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
cls) $Q Type
md $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ [Type] -> Type
forall a. HasCallStack => [a] -> a
head [Type]
ty')|]
[ Q Type
-> Name -> Name -> [Q Type] -> Maybe Name -> [Q Type] -> Q Dec
body Q Type
md Name
clsWithFunc Name
withFunc [Q Type]
stars Maybe Name
maybeWithFunc1 [Q Type]
starToStars,
Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
clsWithFunc Inline
Inline RuleMatch
FunLike Phases
AllPhases
]
]
[Q Type]
_ -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"UnifiedInstance: multiple mode type variables found"
where
applyWithFunc :: Name -> Q Type -> Q Type -> Q Exp -> Q Exp
applyWithFunc :: Name -> Q Type -> Q Type -> Q Exp -> Q Exp
applyWithFunc Name
withFunc Q Type
mode Q Type
var Q Exp
exp =
[|$(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
withFunc) @($Q Type
mode) @($Q Type
var) $Q Exp
exp|]
body ::
Q Type -> Name -> Name -> [Q Type] -> Maybe Name -> [Q Type] -> Q Dec
body :: Q Type
-> Name -> Name -> [Q Type] -> Maybe Name -> [Q Type] -> Q Dec
body Q Type
mode Name
clsWithFunc Name
withFunc [Q Type]
starVars Maybe Name
maybeWithFunc1 [Q Type]
starToStarVars =
do
Name
var <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"
let arg :: Q Pat
arg = Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
var
let branch :: Q Exp
branch = (Q Type -> Q Exp -> Q Exp) -> Q Exp -> [Q Type] -> Q Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Name -> Q Type -> Q Type -> Q Exp -> Q Exp
applyWithFunc Name
withFunc Q Type
mode) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
var) [Q Type]
starVars
let withModeFunc :: Name
withModeFunc = 'withMode
case (Maybe Name
maybeWithFunc1, [Q Type]
starToStarVars) of
(Maybe Name
_, []) -> do
let exp :: Q Exp
exp =
Q Pat -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E
Q Pat
arg
[|$(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
withModeFunc) @($Q Type
mode) $Q Exp
branch $Q Exp
branch|]
Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
clsWithFunc) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
exp) []
(Just Name
withFunc1, [Q Type]
_) -> do
let branchWithFunc1 :: Q Exp
branchWithFunc1 =
(Q Type -> Q Exp -> Q Exp) -> Q Exp -> [Q Type] -> Q Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Name -> Q Type -> Q Type -> Q Exp -> Q Exp
applyWithFunc Name
withFunc1 Q Type
mode) Q Exp
branch [Q Type]
starToStarVars
let exp :: Q Exp
exp =
Q Pat -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E
Q Pat
arg
[|
$(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
withModeFunc)
@($Q Type
mode)
$Q Exp
branchWithFunc1
$Q Exp
branchWithFunc1
|]
Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
clsWithFunc) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
exp) []
(Maybe Name
Nothing, [Q Type]
_) ->
String -> Q Dec
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Dec) -> String -> Q Dec
forall a b. (a -> b) -> a -> b
$
String
"UnifiedInstance: withFunc1 is not provided, type have "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"functor type parameters"
deriveUnifiedInterfaceExtra ::
[SomeDeriveTypeParamHandler] ->
Name ->
Name ->
Name ->
Q [Dec]
[SomeDeriveTypeParamHandler]
extraHandlers Name
cls Name
withFunc Name
name =
[SomeDeriveTypeParamHandler]
-> UnifiedInstance -> Bool -> Int -> [Name] -> Q [Dec]
forall provider.
DeriveInstanceProvider provider =>
[SomeDeriveTypeParamHandler]
-> provider -> Bool -> Int -> [Name] -> Q [Dec]
deriveWithHandlers
( [SomeDeriveTypeParamHandler]
extraHandlers
[SomeDeriveTypeParamHandler]
-> [SomeDeriveTypeParamHandler] -> [SomeDeriveTypeParamHandler]
forall a. Semigroup a => a -> a -> a
<> [ TypeableMode -> SomeDeriveTypeParamHandler
forall handler.
DeriveTypeParamHandler handler =>
handler -> SomeDeriveTypeParamHandler
SomeDeriveTypeParamHandler TypeableMode
TypeableMode,
NatShouldBePositive -> SomeDeriveTypeParamHandler
forall handler.
DeriveTypeParamHandler handler =>
handler -> SomeDeriveTypeParamHandler
SomeDeriveTypeParamHandler NatShouldBePositive
NatShouldBePositive,
PrimaryUnifiedConstraint -> SomeDeriveTypeParamHandler
forall handler.
DeriveTypeParamHandler handler =>
handler -> SomeDeriveTypeParamHandler
SomeDeriveTypeParamHandler (PrimaryUnifiedConstraint -> SomeDeriveTypeParamHandler)
-> PrimaryUnifiedConstraint -> SomeDeriveTypeParamHandler
forall a b. (a -> b) -> a -> b
$ Name -> Bool -> PrimaryUnifiedConstraint
PrimaryUnifiedConstraint Name
cls Bool
False
]
)
(Name -> Name -> Name -> Maybe Name -> UnifiedInstance
UnifiedInstance Name
cls Name
withFunc Name
withFunc Maybe Name
forall a. Maybe a
Nothing)
Bool
True
Int
0
[Name
name]
deriveUnifiedInterface :: Name -> Name -> Name -> Q [Dec]
deriveUnifiedInterface :: Name -> Name -> Name -> Q [Dec]
deriveUnifiedInterface = [SomeDeriveTypeParamHandler] -> Name -> Name -> Name -> Q [Dec]
deriveUnifiedInterfaceExtra []
deriveUnifiedInterfaces :: Name -> Name -> [Name] -> Q [Dec]
deriveUnifiedInterfaces :: Name -> Name -> [Name] -> Q [Dec]
deriveUnifiedInterfaces Name
cls Name
withFunc =
([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
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])
-> ([Name] -> Q [[Dec]]) -> [Name] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name -> Name -> Name -> Q [Dec]
deriveUnifiedInterface Name
cls Name
withFunc)
deriveUnifiedInterface1Extra ::
[SomeDeriveTypeParamHandler] ->
Name ->
Name ->
Name ->
Name ->
Name ->
Q [Dec]
[SomeDeriveTypeParamHandler]
extraHandlers Name
cls Name
withFunc Name
cls1 Name
withFunc1 Name
name =
[SomeDeriveTypeParamHandler]
-> UnifiedInstance -> Bool -> Int -> [Name] -> Q [Dec]
forall provider.
DeriveInstanceProvider provider =>
[SomeDeriveTypeParamHandler]
-> provider -> Bool -> Int -> [Name] -> Q [Dec]
deriveWithHandlers
( [SomeDeriveTypeParamHandler]
extraHandlers
[SomeDeriveTypeParamHandler]
-> [SomeDeriveTypeParamHandler] -> [SomeDeriveTypeParamHandler]
forall a. Semigroup a => a -> a -> a
<> [ TypeableMode -> SomeDeriveTypeParamHandler
forall handler.
DeriveTypeParamHandler handler =>
handler -> SomeDeriveTypeParamHandler
SomeDeriveTypeParamHandler TypeableMode
TypeableMode,
NatShouldBePositive -> SomeDeriveTypeParamHandler
forall handler.
DeriveTypeParamHandler handler =>
handler -> SomeDeriveTypeParamHandler
SomeDeriveTypeParamHandler NatShouldBePositive
NatShouldBePositive,
PrimaryUnifiedConstraint -> SomeDeriveTypeParamHandler
forall handler.
DeriveTypeParamHandler handler =>
handler -> SomeDeriveTypeParamHandler
SomeDeriveTypeParamHandler (PrimaryUnifiedConstraint -> SomeDeriveTypeParamHandler)
-> PrimaryUnifiedConstraint -> SomeDeriveTypeParamHandler
forall a b. (a -> b) -> a -> b
$ Name -> Bool -> PrimaryUnifiedConstraint
PrimaryUnifiedConstraint Name
cls Bool
False,
PrimaryUnifiedConstraint -> SomeDeriveTypeParamHandler
forall handler.
DeriveTypeParamHandler handler =>
handler -> SomeDeriveTypeParamHandler
SomeDeriveTypeParamHandler (PrimaryUnifiedConstraint -> SomeDeriveTypeParamHandler)
-> PrimaryUnifiedConstraint -> SomeDeriveTypeParamHandler
forall a b. (a -> b) -> a -> b
$ Name -> Bool -> PrimaryUnifiedConstraint
PrimaryUnifiedConstraint Name
cls1 Bool
False
]
)
(Name -> Name -> Name -> Maybe Name -> UnifiedInstance
UnifiedInstance Name
cls1 Name
withFunc1 Name
withFunc (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
withFunc1))
Bool
True
Int
1
[Name
name]
deriveUnifiedInterface1 ::
Name -> Name -> Name -> Name -> Name -> Q [Dec]
deriveUnifiedInterface1 :: Name -> Name -> Name -> Name -> Name -> Q [Dec]
deriveUnifiedInterface1 = [SomeDeriveTypeParamHandler]
-> Name -> Name -> Name -> Name -> Name -> Q [Dec]
deriveUnifiedInterface1Extra []
deriveUnifiedInterface1s ::
Name -> Name -> Name -> Name -> [Name] -> Q [Dec]
deriveUnifiedInterface1s :: Name -> Name -> Name -> Name -> [Name] -> Q [Dec]
deriveUnifiedInterface1s Name
cls Name
withFunc Name
cls1 Name
withFunc1 =
([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
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])
-> ([Name] -> Q [[Dec]]) -> [Name] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name -> Name -> Name -> Name -> Name -> Q [Dec]
deriveUnifiedInterface1 Name
cls Name
withFunc Name
cls1 Name
withFunc1)
deriveFunctorArgUnifiedInterfaceExtra ::
[SomeDeriveTypeParamHandler] -> Name -> Name -> Name -> Name -> Name -> Q [Dec]
[SomeDeriveTypeParamHandler]
extraHandlers
Name
cls
Name
withFunc
Name
cls1
Name
withFunc1
Name
name =
[SomeDeriveTypeParamHandler]
-> UnifiedInstance -> Bool -> Int -> [Name] -> Q [Dec]
forall provider.
DeriveInstanceProvider provider =>
[SomeDeriveTypeParamHandler]
-> provider -> Bool -> Int -> [Name] -> Q [Dec]
deriveWithHandlers
( [SomeDeriveTypeParamHandler]
extraHandlers
[SomeDeriveTypeParamHandler]
-> [SomeDeriveTypeParamHandler] -> [SomeDeriveTypeParamHandler]
forall a. Semigroup a => a -> a -> a
<> [ TypeableMode -> SomeDeriveTypeParamHandler
forall handler.
DeriveTypeParamHandler handler =>
handler -> SomeDeriveTypeParamHandler
SomeDeriveTypeParamHandler TypeableMode
TypeableMode,
NatShouldBePositive -> SomeDeriveTypeParamHandler
forall handler.
DeriveTypeParamHandler handler =>
handler -> SomeDeriveTypeParamHandler
SomeDeriveTypeParamHandler NatShouldBePositive
NatShouldBePositive,
PrimaryUnifiedConstraint -> SomeDeriveTypeParamHandler
forall handler.
DeriveTypeParamHandler handler =>
handler -> SomeDeriveTypeParamHandler
SomeDeriveTypeParamHandler (PrimaryUnifiedConstraint -> SomeDeriveTypeParamHandler)
-> PrimaryUnifiedConstraint -> SomeDeriveTypeParamHandler
forall a b. (a -> b) -> a -> b
$ Name -> Bool -> PrimaryUnifiedConstraint
PrimaryUnifiedConstraint Name
cls Bool
False,
PrimaryUnifiedConstraint -> SomeDeriveTypeParamHandler
forall handler.
DeriveTypeParamHandler handler =>
handler -> SomeDeriveTypeParamHandler
SomeDeriveTypeParamHandler (PrimaryUnifiedConstraint -> SomeDeriveTypeParamHandler)
-> PrimaryUnifiedConstraint -> SomeDeriveTypeParamHandler
forall a b. (a -> b) -> a -> b
$ Name -> Bool -> PrimaryUnifiedConstraint
PrimaryUnifiedConstraint Name
cls1 Bool
False
]
)
(Name -> Name -> Name -> Maybe Name -> UnifiedInstance
UnifiedInstance Name
cls Name
withFunc Name
withFunc (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
withFunc1))
Bool
True
Int
0
[Name
name]
deriveFunctorArgUnifiedInterface ::
Name -> Name -> Name -> Name -> Name -> Q [Dec]
deriveFunctorArgUnifiedInterface :: Name -> Name -> Name -> Name -> Name -> Q [Dec]
deriveFunctorArgUnifiedInterface = [SomeDeriveTypeParamHandler]
-> Name -> Name -> Name -> Name -> Name -> Q [Dec]
deriveFunctorArgUnifiedInterfaceExtra []
deriveFunctorArgUnifiedInterfaces ::
Name -> Name -> Name -> Name -> [Name] -> Q [Dec]
deriveFunctorArgUnifiedInterfaces :: Name -> Name -> Name -> Name -> [Name] -> Q [Dec]
deriveFunctorArgUnifiedInterfaces Name
cls Name
withFunc Name
cls1 Name
withFunc1 =
([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
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])
-> ([Name] -> Q [[Dec]]) -> [Name] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name -> Name -> Name -> Name -> Name -> Q [Dec]
deriveFunctorArgUnifiedInterface Name
cls Name
withFunc Name
cls1 Name
withFunc1)