{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

-- |
-- Module      :   Grisette.Internal.TH.DeriveUnifiedInterface
-- Copyright   :   (c) Sirui Lu 2024
-- License     :   BSD-3-Clause (see the LICENSE file)
--
-- Maintainer  :   siruilu@cs.washington.edu
-- Stability   :   Experimental
-- Portability :   GHC only
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)

-- | Add a 'Typeable' constraint to the modes.
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 []

-- | Add a primary unified constraint that applies to all the type parameters
-- with the desired kind.
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 []

-- | Provide an instance for a unified interface.
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"

-- | Derive an instance for a unified interface, with extra handlers.
deriveUnifiedInterfaceExtra ::
  [SomeDeriveTypeParamHandler] ->
  Name ->
  Name ->
  Name ->
  Q [Dec]
deriveUnifiedInterfaceExtra :: [SomeDeriveTypeParamHandler] -> Name -> Name -> Name -> Q [Dec]
deriveUnifiedInterfaceExtra [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]

-- | Derive an instance for a unified interface.
deriveUnifiedInterface :: Name -> Name -> Name -> Q [Dec]
deriveUnifiedInterface :: Name -> Name -> Name -> Q [Dec]
deriveUnifiedInterface = [SomeDeriveTypeParamHandler] -> Name -> Name -> Name -> Q [Dec]
deriveUnifiedInterfaceExtra []

-- | Derive instances for a list of types for a unified interface.
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)

-- | Derive an instance for a unified interface for functors, with extra
-- handlers.
deriveUnifiedInterface1Extra ::
  [SomeDeriveTypeParamHandler] ->
  Name ->
  Name ->
  Name ->
  Name ->
  Name ->
  Q [Dec]
deriveUnifiedInterface1Extra :: [SomeDeriveTypeParamHandler]
-> Name -> Name -> Name -> Name -> Name -> Q [Dec]
deriveUnifiedInterface1Extra [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]

-- | Derive an instance for a unified interface for functors.
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 []

-- | Derive instances for a list of types for a unified interface for functors.
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)

-- | Derive an instance for a unified interface, with extra handlers. The type
-- being derived may have functor type parameters.
deriveFunctorArgUnifiedInterfaceExtra ::
  [SomeDeriveTypeParamHandler] -> Name -> Name -> Name -> Name -> Name -> Q [Dec]
deriveFunctorArgUnifiedInterfaceExtra :: [SomeDeriveTypeParamHandler]
-> Name -> Name -> Name -> Name -> Name -> Q [Dec]
deriveFunctorArgUnifiedInterfaceExtra
  [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]

-- | Derive an instance for a unified interface. The type being derived may have
-- functor type parameters.
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 []

-- | Derive instances for a list of types for a unified interface. The types
-- being derived may have functor type parameters.
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)