{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      :   Grisette.Internal.TH.Derivation.UnaryOpCommon
-- 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.Derivation.UnaryOpCommon
  ( UnaryOpClassConfig (..),
    UnaryOpFieldConfig (..),
    UnaryOpConfig (..),
    UnaryOpFunConfig (..),
    FieldFunExp,
    defaultFieldResFun,
    defaultFieldFunExp,
    genUnaryOpClass,
    defaultUnaryOpInstanceTypeFromConfig,
  )
where

import Control.Monad (replicateM, zipWithM)
import qualified Data.List as List
import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import qualified Data.Set as S
import Grisette.Internal.TH.Derivation.Common
  ( CheckArgsResult
      ( CheckArgsResult,
        argVars,
        constructors,
        keptVars
      ),
    DeriveConfig (unconstrainedPositions),
    checkArgs,
    ctxForVar,
    evalModeSpecializeList,
    extraConstraint,
    freshenCheckArgsResult,
    isVarUsedInFields,
    specializeResult,
  )
import Grisette.Internal.TH.Util (allUsedNames)
import Language.Haskell.TH
  ( Body (NormalB),
    Clause (Clause),
    Dec (FunD, InstanceD),
    Exp (VarE),
    Kind,
    Name,
    Pat (VarP, WildP),
    Q,
    Type (AppT, ConT, VarT),
    appE,
    clause,
    conP,
    conT,
    funD,
    nameBase,
    newName,
    normalB,
    varE,
    varP,
  )
import Language.Haskell.TH.Datatype
  ( ConstructorInfo (constructorFields, constructorName, constructorVariant),
    ConstructorVariant,
    TypeSubstitution (freeVariables),
    resolveTypeSynonyms,
  )

-- | Type of field function expression generator.
type FieldFunExp = M.Map Name Name -> M.Map Name [Name] -> Type -> Q Exp

-- | Default field function expression generator.
defaultFieldFunExp :: [Name] -> FieldFunExp
defaultFieldFunExp :: [Name] -> FieldFunExp
defaultFieldFunExp [Name]
unaryOpFunNames Map Name Name
argToFunPat Map Name [Name]
_ = Type -> Q Exp
go
  where
    go :: Type -> Q Exp
go Type
ty = do
      let allArgNames :: Set Name
allArgNames = Map Name Name -> Set Name
forall k a. Map k a -> Set k
M.keysSet Map Name Name
argToFunPat
      let typeHasNoArg :: Type -> Bool
typeHasNoArg Type
ty =
            [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList ([Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type
ty])
              Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` Set Name
allArgNames
              Set Name -> Set Name -> Bool
forall a. Eq a => a -> a -> Bool
== Set Name
forall a. Set a
S.empty
      let fun0 :: Q Exp
fun0 = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Name] -> Name
forall a. HasCallStack => [a] -> a
head [Name]
unaryOpFunNames
          fun1 :: Type -> Q Exp
fun1 Type
b = [|$(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Name]
unaryOpFunNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
1) $(Type -> Q Exp
go Type
b)|]
          fun2 :: Type -> Type -> Q Exp
fun2 Type
b Type
c = [|$(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Name]
unaryOpFunNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
2) $(Type -> Q Exp
go Type
b) $(Type -> Q Exp
go Type
c)|]
          fun3 :: Type -> Type -> Type -> Q Exp
fun3 Type
b Type
c Type
d =
            [|$(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Name]
unaryOpFunNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
3) $(Type -> Q Exp
go Type
b) $(Type -> Q Exp
go Type
c) $(Type -> Q Exp
go Type
d)|]
      case Type
ty of
        AppT (AppT (AppT (VarT Name
_) Type
b) Type
c) Type
d -> Type -> Type -> Type -> Q Exp
fun3 Type
b Type
c Type
d
        AppT (AppT (VarT Name
_) Type
b) Type
c -> Type -> Type -> Q Exp
fun2 Type
b Type
c
        AppT (VarT Name
_) Type
b -> Type -> Q Exp
fun1 Type
b
        Type
_ | Type -> Bool
typeHasNoArg Type
ty -> Q Exp
fun0
        AppT Type
a Type
b | Type -> Bool
typeHasNoArg Type
a -> Type -> Q Exp
fun1 Type
b
        AppT (AppT Type
a Type
b) Type
c | Type -> Bool
typeHasNoArg Type
a -> Type -> Type -> Q Exp
fun2 Type
b Type
c
        AppT (AppT (AppT Type
a Type
b) Type
c) Type
d | Type -> Bool
typeHasNoArg Type
a -> Type -> Type -> Type -> Q Exp
fun3 Type
b Type
c Type
d
        VarT Name
nm -> case Name -> Map Name Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
nm Map Name Name
argToFunPat of
          Just Name
pname -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pname
          Maybe Name
_ -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"defaultFieldFunExp: unsupported type: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
ty
        Type
_ -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"defaultFieldFunExp: unsupported type: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
ty

-- | Configuration for a unary function field expression generation on a GADT.
data UnaryOpConfig where
  UnaryOpConfig ::
    (UnaryOpFunConfig config) => config -> [Name] -> UnaryOpConfig

-- | Default field result function.
defaultFieldResFun ::
  ConstructorVariant -> Name -> [Exp] -> Int -> Exp -> Exp -> Q (Exp, [Bool])
defaultFieldResFun :: ConstructorVariant
-> Name -> [Exp] -> Int -> Exp -> Exp -> Q (Exp, [Bool])
defaultFieldResFun ConstructorVariant
_ Name
_ [Exp]
extraPatExps Int
_ Exp
fieldPatExp Exp
defaultFieldFunExp = do
  Exp
res <-
    Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
      ( (Q Exp -> Exp -> Q Exp) -> Q Exp -> [Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
          (\Q Exp
exp Exp
name -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE Q Exp
exp (Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
name))
          (Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
defaultFieldFunExp)
          [Exp]
extraPatExps
      )
      (Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
fieldPatExp)
  (Exp, [Bool]) -> Q (Exp, [Bool])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
res, (Bool
True Bool -> [Exp] -> [Bool]
forall a b. a -> [b] -> [a]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Exp]
extraPatExps))

funPatAndExps ::
  FieldFunExp ->
  (Int -> [String]) ->
  [(Type, Kind)] ->
  [Type] ->
  Q ([Pat], [[Pat]], [Exp])
funPatAndExps :: FieldFunExp
-> (Int -> [String])
-> [(Type, Type)]
-> [Type]
-> Q ([Pat], [[Pat]], [Exp])
funPatAndExps FieldFunExp
fieldFunExpGen Int -> [String]
extraLiftedPatNames [(Type, Type)]
argTypes [Type]
fields = do
  let usedArgs :: Set Name
usedArgs = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList ([Name] -> Set Name) -> [Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ [Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type]
fields
  let liftedNames :: [String]
liftedNames = Int -> [String]
extraLiftedPatNames ([(Type, Type)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Type, Type)]
argTypes)
  [(Name, Maybe (Name, [Name]))]
args <-
    ((Type, Type) -> Q (Name, Maybe (Name, [Name])))
-> [(Type, Type)] -> Q [(Name, Maybe (Name, [Name]))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
      ( \(Type
ty, Type
_) -> do
          case Type
ty of
            VarT Name
nm ->
              if Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Name
nm Set Name
usedArgs
                then do
                  Name
pname <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"p"
                  [Name]
epname <- (String -> Q Name) -> [String] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName [String]
liftedNames
                  (Name, Maybe (Name, [Name])) -> Q (Name, Maybe (Name, [Name]))
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nm, (Name, [Name]) -> Maybe (Name, [Name])
forall a. a -> Maybe a
Just (Name
pname, [Name]
epname))
                else (Name, Maybe (Name, [Name])) -> Q (Name, Maybe (Name, [Name]))
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ('undefined, Maybe (Name, [Name])
forall a. Maybe a
Nothing)
            Type
_ -> (Name, Maybe (Name, [Name])) -> Q (Name, Maybe (Name, [Name]))
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ('undefined, Maybe (Name, [Name])
forall a. Maybe a
Nothing)
      )
      [(Type, Type)]
argTypes
  let argToFunPat :: Map Name Name
argToFunPat =
        [(Name, Name)] -> Map Name Name
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, Name)] -> Map Name Name)
-> [(Name, Name)] -> Map Name Name
forall a b. (a -> b) -> a -> b
$ ((Name, Maybe (Name, [Name])) -> Maybe (Name, Name))
-> [(Name, Maybe (Name, [Name]))] -> [(Name, Name)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Name
nm, Maybe (Name, [Name])
mpat) -> ((Name, [Name]) -> (Name, Name))
-> Maybe (Name, [Name]) -> Maybe (Name, Name)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Name
nm,) (Name -> (Name, Name))
-> ((Name, [Name]) -> Name) -> (Name, [Name]) -> (Name, Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, [Name]) -> Name
forall a b. (a, b) -> a
fst) Maybe (Name, [Name])
mpat) [(Name, Maybe (Name, [Name]))]
args
  let argToLiftedPat :: Map Name [Name]
argToLiftedPat =
        [(Name, [Name])] -> Map Name [Name]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, [Name])] -> Map Name [Name])
-> [(Name, [Name])] -> Map Name [Name]
forall a b. (a -> b) -> a -> b
$ ((Name, Maybe (Name, [Name])) -> Maybe (Name, [Name]))
-> [(Name, Maybe (Name, [Name]))] -> [(Name, [Name])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Name
nm, Maybe (Name, [Name])
mpat) -> ((Name, [Name]) -> (Name, [Name]))
-> Maybe (Name, [Name]) -> Maybe (Name, [Name])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Name
nm,) ([Name] -> (Name, [Name]))
-> ((Name, [Name]) -> [Name]) -> (Name, [Name]) -> (Name, [Name])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, [Name]) -> [Name]
forall a b. (a, b) -> b
snd) Maybe (Name, [Name])
mpat) [(Name, Maybe (Name, [Name]))]
args
  let funPats :: [Pat]
funPats = ((Name, Maybe (Name, [Name])) -> Pat)
-> [(Name, Maybe (Name, [Name]))] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pat -> ((Name, [Name]) -> Pat) -> Maybe (Name, [Name]) -> Pat
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Pat
WildP (Name -> Pat
VarP (Name -> Pat) -> ((Name, [Name]) -> Name) -> (Name, [Name]) -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, [Name]) -> Name
forall a b. (a, b) -> a
fst) (Maybe (Name, [Name]) -> Pat)
-> ((Name, Maybe (Name, [Name])) -> Maybe (Name, [Name]))
-> (Name, Maybe (Name, [Name]))
-> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Maybe (Name, [Name])) -> Maybe (Name, [Name])
forall a b. (a, b) -> b
snd) [(Name, Maybe (Name, [Name]))]
args
  let extraLiftedPats :: [[Pat]]
extraLiftedPats =
        ((Name, Maybe (Name, [Name])) -> [Pat])
-> [(Name, Maybe (Name, [Name]))] -> [[Pat]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
          ( [Pat] -> ((Name, [Name]) -> [Pat]) -> Maybe (Name, [Name]) -> [Pat]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
              (Int -> Pat -> [Pat]
forall a. Int -> a -> [a]
replicate ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
liftedNames) Pat
WildP)
              ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP ([Name] -> [Pat])
-> ((Name, [Name]) -> [Name]) -> (Name, [Name]) -> [Pat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, [Name]) -> [Name]
forall a b. (a, b) -> b
snd)
              (Maybe (Name, [Name]) -> [Pat])
-> ((Name, Maybe (Name, [Name])) -> Maybe (Name, [Name]))
-> (Name, Maybe (Name, [Name]))
-> [Pat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Maybe (Name, [Name])) -> Maybe (Name, [Name])
forall a b. (a, b) -> b
snd
          )
          [(Name, Maybe (Name, [Name]))]
args
  [Exp]
defaultFieldFunExps <-
    (Type -> Q Exp) -> [Type] -> Q [Exp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
      (FieldFunExp
fieldFunExpGen Map Name Name
argToFunPat Map Name [Name]
argToLiftedPat)
      [Type]
fields
  ([Pat], [[Pat]], [Exp]) -> Q ([Pat], [[Pat]], [Exp])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat]
funPats, [[Pat]]
extraLiftedPats, [Exp]
defaultFieldFunExps)

-- | Generate a clause for a unary function on a GADT.
genUnaryOpFieldClause ::
  UnaryOpFieldConfig ->
  [(Type, Kind)] ->
  Int ->
  Int ->
  ConstructorInfo ->
  Q Clause
genUnaryOpFieldClause :: UnaryOpFieldConfig
-> [(Type, Type)] -> Int -> Int -> ConstructorInfo -> Q Clause
genUnaryOpFieldClause
  (UnaryOpFieldConfig {[String]
Int -> [String]
Int
-> Int
-> ConstructorVariant
-> Name
-> [Exp]
-> [Exp]
-> Q (Exp, [Bool])
FieldFunExp
ConstructorVariant
-> Name -> [Exp] -> Int -> Exp -> Exp -> Q (Exp, [Bool])
extraPatNames :: [String]
extraLiftedPatNames :: Int -> [String]
fieldResFun :: ConstructorVariant
-> Name -> [Exp] -> Int -> Exp -> Exp -> Q (Exp, [Bool])
fieldCombineFun :: Int
-> Int
-> ConstructorVariant
-> Name
-> [Exp]
-> [Exp]
-> Q (Exp, [Bool])
fieldFunExp :: FieldFunExp
fieldFunExp :: UnaryOpFieldConfig -> FieldFunExp
fieldCombineFun :: UnaryOpFieldConfig
-> Int
-> Int
-> ConstructorVariant
-> Name
-> [Exp]
-> [Exp]
-> Q (Exp, [Bool])
fieldResFun :: UnaryOpFieldConfig
-> ConstructorVariant
-> Name
-> [Exp]
-> Int
-> Exp
-> Exp
-> Q (Exp, [Bool])
extraLiftedPatNames :: UnaryOpFieldConfig -> Int -> [String]
extraPatNames :: UnaryOpFieldConfig -> [String]
..})
  [(Type, Type)]
argTypes
  Int
totalConNumber
  Int
conIdx
  ConstructorInfo
conInfo = do
    [Type]
fields <- (Type -> Q Type) -> [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 Type -> Q Type
resolveTypeSynonyms ([Type] -> Q [Type]) -> [Type] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> [Type]
constructorFields ConstructorInfo
conInfo
    ([Pat]
funPats, [[Pat]]
funLiftedPats, [Exp]
defaultFieldFunExps) <-
      FieldFunExp
-> (Int -> [String])
-> [(Type, Type)]
-> [Type]
-> Q ([Pat], [[Pat]], [Exp])
funPatAndExps FieldFunExp
fieldFunExp Int -> [String]
extraLiftedPatNames [(Type, Type)]
argTypes [Type]
fields
    [Name]
extraPatNames <- (String -> Q Name) -> [String] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName [String]
extraPatNames
    let extraPatExps :: [Exp]
extraPatExps = (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Exp
VarE [Name]
extraPatNames
    [Name]
fieldsPatNames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
fields) (Q Name -> Q [Name]) -> Q Name -> Q [Name]
forall a b. (a -> b) -> a -> b
$ String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"field"
    let extraPats :: [Pat]
extraPats = (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP [Name]
extraPatNames
    Pat
fieldPats <- Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (ConstructorInfo -> Name
constructorName ConstructorInfo
conInfo) ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldsPatNames)
    let fieldPatExps :: [Exp]
fieldPatExps = (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Exp
VarE [Name]
fieldsPatNames

    [(Exp, [Bool])]
fieldResExpsAndArgsUsed <-
      [Q (Exp, [Bool])] -> Q [(Exp, [Bool])]
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 (Exp, [Bool])] -> Q [(Exp, [Bool])])
-> [Q (Exp, [Bool])] -> Q [(Exp, [Bool])]
forall a b. (a -> b) -> a -> b
$
        (Int -> Exp -> Exp -> Q (Exp, [Bool]))
-> [Int] -> [Exp] -> [Exp] -> [Q (Exp, [Bool])]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3
          ( ConstructorVariant
-> Name -> [Exp] -> Int -> Exp -> Exp -> Q (Exp, [Bool])
fieldResFun
              (ConstructorInfo -> ConstructorVariant
constructorVariant ConstructorInfo
conInfo)
              (ConstructorInfo -> Name
constructorName ConstructorInfo
conInfo)
              [Exp]
extraPatExps
          )
          [Int
0 ..]
          [Exp]
fieldPatExps
          [Exp]
defaultFieldFunExps
    let fieldResExps :: [Exp]
fieldResExps = (Exp, [Bool]) -> Exp
forall a b. (a, b) -> a
fst ((Exp, [Bool]) -> Exp) -> [(Exp, [Bool])] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Exp, [Bool])]
fieldResExpsAndArgsUsed
    let extraArgsUsedByFields :: [[Bool]]
extraArgsUsedByFields = (Exp, [Bool]) -> [Bool]
forall a b. (a, b) -> b
snd ((Exp, [Bool]) -> [Bool]) -> [(Exp, [Bool])] -> [[Bool]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Exp, [Bool])]
fieldResExpsAndArgsUsed

    (Exp
resExp, [Bool]
extraArgsUsedByResult) <-
      Int
-> Int
-> ConstructorVariant
-> Name
-> [Exp]
-> [Exp]
-> Q (Exp, [Bool])
fieldCombineFun
        Int
totalConNumber
        Int
conIdx
        (ConstructorInfo -> ConstructorVariant
constructorVariant ConstructorInfo
conInfo)
        (ConstructorInfo -> Name
constructorName ConstructorInfo
conInfo)
        [Exp]
extraPatExps
        [Exp]
fieldResExps
    let resUsedNames :: Set Name
resUsedNames = Exp -> Set Name
allUsedNames Exp
resExp
    let extraArgsUsed :: [Bool]
extraArgsUsed =
          ([Bool] -> Bool) -> [[Bool]] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([[Bool]] -> [Bool]) -> [[Bool]] -> [Bool]
forall a b. (a -> b) -> a -> b
$
            [[Bool]] -> [[Bool]]
forall a. [[a]] -> [[a]]
List.transpose ([[Bool]] -> [[Bool]]) -> [[Bool]] -> [[Bool]]
forall a b. (a -> b) -> a -> b
$
              [Bool]
extraArgsUsedByResult [Bool] -> [[Bool]] -> [[Bool]]
forall a. a -> [a] -> [a]
: [[Bool]]
extraArgsUsedByFields
    let extraArgsPats :: [Pat]
extraArgsPats =
          (Pat -> Bool -> Pat) -> [Pat] -> [Bool] -> [Pat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
            (\Pat
pat Bool
used -> if Bool
used then Pat
pat else Pat
WildP)
            [Pat]
extraPats
            [Bool]
extraArgsUsed
    let transformPat :: Pat -> Pat
transformPat (VarP Name
nm) =
          if Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Name
nm Set Name
resUsedNames then Name -> Pat
VarP Name
nm else Pat
WildP
        transformPat Pat
p = Pat
p
    Clause -> Q Clause
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$
      [Pat] -> Body -> [Dec] -> Clause
Clause
        ( (Pat -> Pat) -> [Pat] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pat -> Pat
transformPat ([Pat] -> [Pat]) -> [Pat] -> [Pat]
forall a b. (a -> b) -> a -> b
$
            [[Pat]] -> [Pat]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Pat -> [Pat] -> [Pat]) -> [Pat] -> [[Pat]] -> [[Pat]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (:) [Pat]
funPats [[Pat]]
funLiftedPats)
              [Pat] -> [Pat] -> [Pat]
forall a. [a] -> [a] -> [a]
++ [Pat]
extraArgsPats
              [Pat] -> [Pat] -> [Pat]
forall a. [a] -> [a] -> [a]
++ [Pat
fieldPats]
        )
        (Exp -> Body
NormalB Exp
resExp)
        []

-- | Configuration for a unary operation type class generation on a GADT.
data UnaryOpClassConfig = UnaryOpClassConfig
  { UnaryOpClassConfig -> [UnaryOpConfig]
unaryOpConfigs :: [UnaryOpConfig],
    UnaryOpClassConfig -> [Name]
unaryOpInstanceNames :: [Name],
    UnaryOpClassConfig -> Maybe [Name]
unaryOpContextNames :: Maybe [Name],
    UnaryOpClassConfig -> DeriveConfig -> Q [(Type, Type)]
unaryOpExtraVars :: DeriveConfig -> Q [(Type, Kind)],
    UnaryOpClassConfig
-> DeriveConfig
-> [(Type, Type)]
-> [(Type, Type)]
-> Name
-> Q Type
unaryOpInstanceTypeFromConfig ::
      DeriveConfig ->
      [(Type, Kind)] ->
      [(Type, Kind)] ->
      Name ->
      Q Type,
    UnaryOpClassConfig -> Bool
unaryOpAllowExistential :: Bool
  }

-- | Default unary operation instance type generator.
defaultUnaryOpInstanceTypeFromConfig ::
  DeriveConfig -> [(Type, Kind)] -> [(Type, Kind)] -> Name -> Q Type
defaultUnaryOpInstanceTypeFromConfig :: DeriveConfig -> [(Type, Type)] -> [(Type, Type)] -> Name -> Q Type
defaultUnaryOpInstanceTypeFromConfig DeriveConfig
_ [(Type, Type)]
_ [(Type, Type)]
_ = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT

-- | Configuration for the derivation rules for a unary operation that can be
-- derived by transforming each field and then combining the results.
data UnaryOpFieldConfig = UnaryOpFieldConfig
  { UnaryOpFieldConfig -> [String]
extraPatNames :: [String],
    UnaryOpFieldConfig -> Int -> [String]
extraLiftedPatNames :: Int -> [String],
    UnaryOpFieldConfig
-> ConstructorVariant
-> Name
-> [Exp]
-> Int
-> Exp
-> Exp
-> Q (Exp, [Bool])
fieldResFun ::
      ConstructorVariant ->
      Name ->
      [Exp] ->
      Int ->
      Exp ->
      Exp ->
      Q (Exp, [Bool]),
    UnaryOpFieldConfig
-> Int
-> Int
-> ConstructorVariant
-> Name
-> [Exp]
-> [Exp]
-> Q (Exp, [Bool])
fieldCombineFun ::
      -- \| Total number of constructors
      Int ->
      -- \| Constructor index
      Int ->
      -- \| Constructor variant
      ConstructorVariant ->
      -- \| Constructor name
      Name ->
      -- \| Extra pattern expressions
      [Exp] ->
      -- \| Field result expressions
      [Exp] ->
      Q (Exp, [Bool]),
    UnaryOpFieldConfig -> FieldFunExp
fieldFunExp :: FieldFunExp
  }

-- | Configuration for the derivation rules for a unary operation.
class UnaryOpFunConfig config where
  genUnaryOpFun ::
    -- | Derive configuration
    DeriveConfig ->
    -- | Configuration
    config ->
    -- | Function names
    [Name] ->
    -- | Number of functor arguments to the class
    Int ->
    -- | Extra variables
    [(Type, Kind)] ->
    -- | Kept variables
    [(Type, Kind)] ->
    -- | Argument variables
    [(Type, Kind)] ->
    -- | Whether the variable is used in fields
    (Name -> Bool) ->
    -- | Constructor infos
    [ConstructorInfo] ->
    Q Dec

instance UnaryOpFunConfig UnaryOpFieldConfig where
  genUnaryOpFun :: DeriveConfig
-> UnaryOpFieldConfig
-> [Name]
-> Int
-> [(Type, Type)]
-> [(Type, Type)]
-> [(Type, Type)]
-> (Name -> Bool)
-> [ConstructorInfo]
-> Q Dec
genUnaryOpFun DeriveConfig
_ UnaryOpFieldConfig
_ [Name]
funNames Int
n [(Type, Type)]
_ [(Type, Type)]
_ [(Type, Type)]
_ Name -> Bool
_ [] =
    Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ([Name]
funNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
n) [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|error "impossible"|]) []]
  genUnaryOpFun DeriveConfig
_ UnaryOpFieldConfig
config [Name]
funNames Int
n [(Type, Type)]
_ [(Type, Type)]
_ [(Type, Type)]
argTypes Name -> Bool
_ [ConstructorInfo]
constructors = do
    [Clause]
clauses <-
      (Int -> ConstructorInfo -> Q Clause)
-> [Int] -> [ConstructorInfo] -> Q [Clause]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM
        ( UnaryOpFieldConfig
-> [(Type, Type)] -> Int -> Int -> ConstructorInfo -> Q Clause
genUnaryOpFieldClause
            UnaryOpFieldConfig
config
            [(Type, Type)]
argTypes
            ([ConstructorInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
constructors)
        )
        [Int
0 ..]
        [ConstructorInfo]
constructors
    let instanceFunName :: Name
instanceFunName = [Name]
funNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
n
    Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD Name
instanceFunName [Clause]
clauses

-- | Generate a unary operation type class instance for a data type.
genUnaryOpClass ::
  DeriveConfig ->
  UnaryOpClassConfig ->
  Int ->
  Name ->
  Q [Dec]
genUnaryOpClass :: DeriveConfig -> UnaryOpClassConfig -> Int -> Name -> Q [Dec]
genUnaryOpClass DeriveConfig
deriveConfig (UnaryOpClassConfig {Bool
[Name]
[UnaryOpConfig]
Maybe [Name]
DeriveConfig -> Q [(Type, Type)]
DeriveConfig -> [(Type, Type)] -> [(Type, Type)] -> Name -> Q Type
unaryOpConfigs :: UnaryOpClassConfig -> [UnaryOpConfig]
unaryOpInstanceNames :: UnaryOpClassConfig -> [Name]
unaryOpContextNames :: UnaryOpClassConfig -> Maybe [Name]
unaryOpExtraVars :: UnaryOpClassConfig -> DeriveConfig -> Q [(Type, Type)]
unaryOpInstanceTypeFromConfig :: UnaryOpClassConfig
-> DeriveConfig
-> [(Type, Type)]
-> [(Type, Type)]
-> Name
-> Q Type
unaryOpAllowExistential :: UnaryOpClassConfig -> Bool
unaryOpConfigs :: [UnaryOpConfig]
unaryOpInstanceNames :: [Name]
unaryOpContextNames :: Maybe [Name]
unaryOpExtraVars :: DeriveConfig -> Q [(Type, Type)]
unaryOpInstanceTypeFromConfig :: DeriveConfig -> [(Type, Type)] -> [(Type, Type)] -> Name -> Q Type
unaryOpAllowExistential :: Bool
..}) Int
n Name
typName = do
  result :: CheckArgsResult
result@CheckArgsResult {[(Type, Type)]
[ConstructorInfo]
argVars :: CheckArgsResult -> [(Type, Type)]
constructors :: CheckArgsResult -> [ConstructorInfo]
keptVars :: CheckArgsResult -> [(Type, Type)]
constructors :: [ConstructorInfo]
keptVars :: [(Type, Type)]
argVars :: [(Type, Type)]
..} <-
    [(Int, EvalModeTag)] -> CheckArgsResult -> Q CheckArgsResult
specializeResult (DeriveConfig -> [(Int, EvalModeTag)]
evalModeSpecializeList DeriveConfig
deriveConfig)
      (CheckArgsResult -> Q CheckArgsResult)
-> Q CheckArgsResult -> Q CheckArgsResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Bool -> CheckArgsResult -> Q CheckArgsResult
freshenCheckArgsResult Bool
True
      (CheckArgsResult -> Q CheckArgsResult)
-> Q CheckArgsResult -> Q CheckArgsResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Int -> Name -> Bool -> Int -> Q CheckArgsResult
checkArgs
        (Name -> String
nameBase (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ [Name] -> Name
forall a. HasCallStack => [a] -> a
head [Name]
unaryOpInstanceNames)
        ([Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
unaryOpInstanceNames Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        Name
typName
        Bool
unaryOpAllowExistential
        Int
n
  [(Type, Type)]
extraVars <- DeriveConfig -> Q [(Type, Type)]
unaryOpExtraVars DeriveConfig
deriveConfig

  let isTypeUsedInFields :: Type -> Bool
isTypeUsedInFields (VarT Name
nm) = CheckArgsResult -> Name -> Bool
isVarUsedInFields CheckArgsResult
result Name
nm
      isTypeUsedInFields Type
_ = Bool
False
  [Type]
contextInstanceTypes <-
    (Name -> Q Type) -> [Name] -> Q [Type]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
      (DeriveConfig -> [(Type, Type)] -> [(Type, Type)] -> Name -> Q Type
unaryOpInstanceTypeFromConfig DeriveConfig
deriveConfig [(Type, Type)]
extraVars [(Type, Type)]
keptVars)
      ([Name] -> Maybe [Name] -> [Name]
forall a. a -> Maybe a -> a
fromMaybe [Name]
unaryOpInstanceNames Maybe [Name]
unaryOpContextNames)
  [Maybe Type]
ctxs <-
    ((Type, Type) -> Q (Maybe Type))
-> [(Type, Type)] -> Q [Maybe Type]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Type -> Type -> Q (Maybe Type)) -> (Type, Type) -> Q (Maybe Type)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Type -> Type -> Q (Maybe Type))
 -> (Type, Type) -> Q (Maybe Type))
-> (Type -> Type -> Q (Maybe Type))
-> (Type, Type)
-> Q (Maybe Type)
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> Type -> Q (Maybe Type)
ctxForVar [Type]
contextInstanceTypes) ([(Type, Type)] -> Q [Maybe Type])
-> [(Type, Type)] -> Q [Maybe Type]
forall a b. (a -> b) -> a -> b
$
      ((Type, Type) -> Bool) -> [(Type, Type)] -> [(Type, Type)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Type -> Bool
isTypeUsedInFields (Type -> Bool) -> ((Type, Type) -> Type) -> (Type, Type) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type, Type) -> Type
forall a b. (a, b) -> a
fst) ([(Type, Type)] -> [(Type, Type)])
-> [(Type, Type)] -> [(Type, Type)]
forall a b. (a -> b) -> a -> b
$
        ((Int, (Type, Type)) -> (Type, Type))
-> [(Int, (Type, Type))] -> [(Type, Type)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, (Type, Type)) -> (Type, Type)
forall a b. (a, b) -> b
snd ([(Int, (Type, Type))] -> [(Type, Type)])
-> [(Int, (Type, Type))] -> [(Type, Type)]
forall a b. (a -> b) -> a -> b
$
          ((Int, (Type, Type)) -> Bool)
-> [(Int, (Type, Type))] -> [(Int, (Type, Type))]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Int, (Type, Type)) -> Bool) -> (Int, (Type, Type)) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DeriveConfig -> [Int]
unconstrainedPositions DeriveConfig
deriveConfig) (Int -> Bool)
-> ((Int, (Type, Type)) -> Int) -> (Int, (Type, Type)) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, (Type, Type)) -> Int
forall a b. (a, b) -> a
fst) ([(Int, (Type, Type))] -> [(Int, (Type, Type))])
-> [(Int, (Type, Type))] -> [(Int, (Type, Type))]
forall a b. (a -> b) -> a -> b
$
            [Int] -> [(Type, Type)] -> [(Int, (Type, Type))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [(Type, Type)]
keptVars
  let keptType :: Type
keptType = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
typName) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ ((Type, Type) -> Type) -> [(Type, Type)] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Type, Type) -> Type
forall a b. (a, b) -> a
fst [(Type, Type)]
keptVars
  [Dec]
instanceFuns <-
    (UnaryOpConfig -> Q Dec) -> [UnaryOpConfig] -> Q [Dec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
      ( \(UnaryOpConfig config
config [Name]
funNames) ->
          DeriveConfig
-> config
-> [Name]
-> Int
-> [(Type, Type)]
-> [(Type, Type)]
-> [(Type, Type)]
-> (Name -> Bool)
-> [ConstructorInfo]
-> Q Dec
forall config.
UnaryOpFunConfig config =>
DeriveConfig
-> config
-> [Name]
-> Int
-> [(Type, Type)]
-> [(Type, Type)]
-> [(Type, Type)]
-> (Name -> Bool)
-> [ConstructorInfo]
-> Q Dec
genUnaryOpFun
            DeriveConfig
deriveConfig
            config
config
            [Name]
funNames
            Int
n
            [(Type, Type)]
extraVars
            [(Type, Type)]
keptVars
            [(Type, Type)]
argVars
            (CheckArgsResult -> Name -> Bool
isVarUsedInFields CheckArgsResult
result)
            [ConstructorInfo]
constructors
      )
      [UnaryOpConfig]
unaryOpConfigs
  let instanceName :: Name
instanceName = [Name]
unaryOpInstanceNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
n
  [Type]
instanceTypes <-
    (Name -> Q Type) -> [Name] -> Q [Type]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
      (DeriveConfig -> [(Type, Type)] -> [(Type, Type)] -> Name -> Q Type
unaryOpInstanceTypeFromConfig DeriveConfig
deriveConfig [(Type, Type)]
extraVars [(Type, Type)]
keptVars)
      [Name]
unaryOpInstanceNames
  let instanceType :: Type
instanceType = Type -> Type -> Type
AppT ([Type]
instanceTypes [Type] -> Int -> Type
forall a. HasCallStack => [a] -> Int -> a
!! Int
n) Type
keptType
  [Type]
extraPreds <-
    DeriveConfig
-> Name
-> Name
-> [(Type, Type)]
-> [(Type, Type)]
-> [ConstructorInfo]
-> Q [Type]
extraConstraint
      DeriveConfig
deriveConfig
      Name
typName
      Name
instanceName
      [(Type, Type)]
extraVars
      [(Type, Type)]
keptVars
      [ConstructorInfo]
constructors
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return
    [ Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD
        Maybe Overlap
forall a. Maybe a
Nothing
        ( [Type]
extraPreds
            [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ if [ConstructorInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
constructors
              then []
              else [Maybe Type] -> [Type]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Type]
ctxs
        )
        Type
instanceType
        [Dec]
instanceFuns
    ]