{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}

-- |
-- Module      :   Grisette.Internal.TH.DeriveTypeParamHandler
-- 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.DeriveTypeParamHandler
  ( DeriveTypeParamHandler (..),
    NatShouldBePositive (..),
    IsFPBits (..),
    PrimaryConstraint (..),
    SomeDeriveTypeParamHandler (..),
  )
where

import GHC.TypeLits (KnownNat, Nat, type (<=))
import Grisette.Internal.SymPrim.FP (ValidFP)
import Grisette.Internal.TH.Util
  ( allSameKind,
    classParamKinds,
    concatPreds,
    getTypeWithMaybeSubst,
  )
import Language.Haskell.TH (Kind, Name, Pred, Q, Type (ConT), appT, conT)
import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndrUnit, tvKind)

-- | A derive type param handler handles type parameters and provides
-- constraints or instantiations for them.
--
-- The first argument is the number of types that are zipped together. For
-- most classes, this is 1, but for some classes, like 'Grisette.ToCon', this is
-- 2.
--
-- The second argument is the handler itself.
--
-- The third argument is a list of type parameters and their constraints. Each
-- entry in the list corresponds to a type parameter of the datatype. The
-- first element in the pair is a list of zipped type parameters with possibly
-- concrete types. For example, if we are deriving 'Grisette.ToCon' for
-- `Either`, the argument will be:
--
-- > [([(e0, Nothing), (e1, Nothing)], Nothing),
-- >  ([(a0, Nothing), (a1, Nothing)], Nothing)]
--
-- We can see that the type parameters for the concrete and symbolic `Either`
-- types are zipped together: the first element of the list are for the error
-- types, and the second element of the list are for the value types.
--
-- The handler may concretize some types, or add constraints based on the type
-- parameters.
class DeriveTypeParamHandler handler where
  handleTypeParams ::
    Int ->
    handler ->
    [([(TyVarBndrUnit, Maybe Type)], Maybe [Pred])] ->
    Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Pred])]
  handleBody :: handler -> [[Type]] -> Q [Pred]

-- | Ensures that type parameters with the kind 'Nat' are known and positive.
data NatShouldBePositive = NatShouldBePositive

instance DeriveTypeParamHandler NatShouldBePositive where
  handleTypeParams :: Int
-> NatShouldBePositive
-> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
handleTypeParams Int
_ NatShouldBePositive
_ = (([(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])
handle)
    where
      handle ::
        [(TyVarBndrUnit, Maybe Type)] ->
        Maybe [Pred] ->
        Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Pred])
      handle :: [(TyVarBndrUnit, Maybe Type)]
-> Maybe [Type] -> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
handle [] 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 [(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
"NatShouldBePositive: All type parameters must be aligned "
      handle ((TyVarBndrUnit, Maybe Type)
ty : [(TyVarBndrUnit, Maybe Type)]
tys) Maybe [Type]
Nothing
        | TyVarBndrUnit -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind ((TyVarBndrUnit, Maybe Type) -> TyVarBndrUnit
forall a b. (a, b) -> a
fst (TyVarBndrUnit, Maybe Type)
ty) Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''Nat = do
            let (Q Type
t : [Q Type]
ts) = ((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)
ty (TyVarBndrUnit, Maybe Type)
-> [(TyVarBndrUnit, Maybe Type)] -> [(TyVarBndrUnit, Maybe Type)]
forall a. a -> [a] -> [a]
: [(TyVarBndrUnit, Maybe Type)]
tys
            Type
knownPred <- [t|KnownNat $Q Type
t|]
            Type
geq1Pred <- [t|1 <= $Q Type
t|]
            [Type]
eqPreds <- (Q Type -> Q Type) -> [Q 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 (\Q Type
t' -> [t|$Q Type
t ~ $Q Type
t'|]) [Q 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)
ty (TyVarBndrUnit, Maybe Type)
-> [(TyVarBndrUnit, Maybe Type)] -> [(TyVarBndrUnit, Maybe Type)]
forall a. a -> [a] -> [a]
: [(TyVarBndrUnit, Maybe Type)]
tys, [Type] -> Maybe [Type]
forall a. a -> Maybe a
Just ([Type] -> Maybe [Type]) -> [Type] -> Maybe [Type]
forall a b. (a -> b) -> a -> b
$ Type
knownPred Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type
geq1Pred Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
eqPreds)
      handle [(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 :: NatShouldBePositive -> [[Type]] -> Q [Type]
handleBody NatShouldBePositive
_ [[Type]]
_ = [Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | Ensures that the type parameters are valid for floating point operations.
data IsFPBits = IsFPBits {IsFPBits -> Int
ebIdx :: Int, IsFPBits -> Int
sbIdx :: Int}

instance DeriveTypeParamHandler IsFPBits where
  handleTypeParams :: Int
-> IsFPBits
-> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
handleTypeParams Int
_ (IsFPBits Int
ebIdx Int
sbIdx) [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
tys
    | Int
ebIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [([(TyVarBndrUnit, Maybe Type)], 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
"IsFPBits: ebIdx out of bounds"
    | Int
sbIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [([(TyVarBndrUnit, Maybe Type)], 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
"IsFPBits: sbIdx out of bounds"
    | Bool
otherwise = do
        let eb :: ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
eb = [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
tys [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> Int -> ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
forall a. HasCallStack => [a] -> Int -> a
!! Int
ebIdx
        let ebts :: [Q Type]
ebts = ((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)], Maybe [Type])
-> [(TyVarBndrUnit, Maybe Type)]
forall a b. (a, b) -> a
fst ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
eb)
        let sb :: ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
sb = [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
tys [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> Int -> ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
forall a. HasCallStack => [a] -> Int -> a
!! Int
sbIdx
        let sbts :: [Q Type]
sbts = ((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)], Maybe [Type])
-> [(TyVarBndrUnit, Maybe Type)]
forall a b. (a, b) -> a
fst ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
sb)
        case ([Q Type]
ebts, [Q Type]
sbts) of
          ([Q Type], [Q Type])
_
            | [Q Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Type]
ebts Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Q Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Type]
sbts ->
                String -> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])])
-> String -> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
forall a b. (a -> b) -> a -> b
$
                  String
"IsFPBits: eb and sb must have the same number of type "
                    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"parameters. This might happen because of a bug in "
                    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Grisette"
            | Bool -> Bool
not ([TyVarBndrUnit] -> Bool
allSameKind ((TyVarBndrUnit, Maybe Type) -> TyVarBndrUnit
forall a b. (a, b) -> a
fst ((TyVarBndrUnit, Maybe Type) -> TyVarBndrUnit)
-> [(TyVarBndrUnit, Maybe Type)] -> [TyVarBndrUnit]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> [(TyVarBndrUnit, Maybe Type)]
forall a b. (a, b) -> a
fst ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
eb)) ->
                String -> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"IsFPBits: All type parameters must be aligned"
            | Bool -> Bool
not ([TyVarBndrUnit] -> Bool
allSameKind ((TyVarBndrUnit, Maybe Type) -> TyVarBndrUnit
forall a b. (a, b) -> a
fst ((TyVarBndrUnit, Maybe Type) -> TyVarBndrUnit)
-> [(TyVarBndrUnit, Maybe Type)] -> [TyVarBndrUnit]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
-> [(TyVarBndrUnit, Maybe Type)]
forall a b. (a, b) -> a
fst ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
sb)) ->
                String -> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"IsFPBits: All type parameters must be aligned"
          ([], []) -> [([(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
          ((Q Type
et : [Q Type]
ets), (Q Type
st : [Q Type]
sts)) -> do
            Type
validFloat <- [t|ValidFP $Q Type
et $Q Type
st|]
            [Type]
eqebPreds <- (Q Type -> Q Type) -> [Q 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 (\Q Type
et' -> [t|$Q Type
et ~ $Q Type
et'|]) [Q Type]
ets
            [Type]
eqsbPreds <- (Q Type -> Q Type) -> [Q 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 (\Q Type
st' -> [t|$Q Type
st ~ $Q Type
st'|]) [Q Type]
sts
            [([(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
$
              (Int
 -> ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
 -> ([(TyVarBndrUnit, Maybe Type)], Maybe [Type]))
-> [Int]
-> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                ( \Int
i ([(TyVarBndrUnit, Maybe Type)]
ts, Maybe [Type]
preds) ->
                    if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ebIdx
                      then
                        ( [(TyVarBndrUnit, Maybe Type)]
ts,
                          Maybe [Type] -> Maybe [Type] -> Maybe [Type]
concatPreds
                            ([Type] -> Maybe [Type]
forall a. a -> Maybe a
Just ([Type] -> Maybe [Type]) -> [Type] -> Maybe [Type]
forall a b. (a -> b) -> a -> b
$ Type
validFloat Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
eqebPreds [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
eqsbPreds)
                            Maybe [Type]
preds
                        )
                      else
                        if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
sbIdx
                          then ([(TyVarBndrUnit, Maybe Type)]
ts, Maybe [Type] -> Maybe [Type] -> Maybe [Type]
concatPreds ([Type] -> Maybe [Type]
forall a. a -> Maybe a
Just []) Maybe [Type]
preds)
                          else ([(TyVarBndrUnit, Maybe Type)]
ts, Maybe [Type]
preds)
                )
                [Int
0 ..]
                [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
tys
          ([Q Type], [Q Type])
_ -> String -> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"IsFPBits: This should never happen"
  handleBody :: IsFPBits -> [[Type]] -> Q [Type]
handleBody IsFPBits
_ [[Type]]
_ = [Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | Adds a primary constraint to the type parameters. It applies the class
-- to each type parameter that are zipped into a list, with the desired kinds.
--
-- For example, if we are deriving 'Grisette.ToCon' for `Either`, and the input
-- to this handler is as follows:
--
-- > [([(e0, Nothing), (e1, Nothing)], Nothing),
-- >  ([(a0, Nothing), (a1, Nothing)], Nothing)]
--
-- Then this will generate constraints for the type parameters of `Either`:
--
-- > [([(e0, Nothing), (e1, Nothing)], Just [ToCon e0 e1]),
-- >  ([(a0, Nothing), (a1, Nothing)], Just [ToCon a0 a1])]
--
-- Type parameters that are already handled by other handlers can be ignored.
data PrimaryConstraint = PrimaryConstraint
  { PrimaryConstraint -> Name
className :: Name,
    PrimaryConstraint -> Bool
ignoreIfAlreadyHandled :: Bool
  }

instance DeriveTypeParamHandler PrimaryConstraint where
  handleTypeParams :: Int
-> PrimaryConstraint
-> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
handleTypeParams
    Int
_
    (PrimaryConstraint Name
className Bool
ignoreIfAlreadyHandled)
    [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
tys = do
      [Type]
kinds <- Name -> Q [Type]
classParamKinds Name
className
      (([(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 ([Type]
-> [(TyVarBndrUnit, Maybe Type)]
-> Maybe [Type]
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
handle [Type]
kinds)) [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
tys
      where
        handle ::
          [Kind] ->
          [(TyVarBndrUnit, Maybe Type)] ->
          Maybe [Pred] ->
          Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Pred])
        handle :: [Type]
-> [(TyVarBndrUnit, Maybe Type)]
-> Maybe [Type]
-> Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Type])
handle [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]
_ [(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
"PrimaryConstraint: All type parameters must be aligned"
        handle [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]
kinds [(TyVarBndrUnit, Maybe Type)]
tys Maybe [Type]
preds
          | (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 (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
className) ([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]
_ [(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 :: PrimaryConstraint -> [[Type]] -> Q [Type]
handleBody (PrimaryConstraint Name
_ Bool
_) [[Type]]
_ = [Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | A type that can handle type parameters.
data SomeDeriveTypeParamHandler where
  SomeDeriveTypeParamHandler ::
    (DeriveTypeParamHandler handler) =>
    handler ->
    SomeDeriveTypeParamHandler

instance DeriveTypeParamHandler SomeDeriveTypeParamHandler where
  handleTypeParams :: Int
-> SomeDeriveTypeParamHandler
-> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
handleTypeParams Int
n (SomeDeriveTypeParamHandler handler
h) = Int
-> handler
-> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
forall handler.
DeriveTypeParamHandler handler =>
Int
-> handler
-> [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
-> Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Type])]
handleTypeParams Int
n handler
h
  handleBody :: SomeDeriveTypeParamHandler -> [[Type]] -> Q [Type]
handleBody (SomeDeriveTypeParamHandler handler
h) = handler -> [[Type]] -> Q [Type]
forall handler.
DeriveTypeParamHandler handler =>
handler -> [[Type]] -> Q [Type]
handleBody handler
h