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

-- |
-- Module      :   Grisette.Internal.TH.GADT.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.GADT.UnaryOpCommon
  ( UnaryOpClassConfig (..),
    UnaryOpFieldConfig (..),
    genUnaryOpClause,
    genUnaryOpClass,
  )
where

import Control.Monad (replicateM, zipWithM)
import qualified Data.Map as M
import Data.Maybe (catMaybes, mapMaybe)
import qualified Data.Set as S
import Grisette.Internal.TH.GADT.Common
  ( CheckArgsResult
      ( CheckArgsResult,
        argNewNames,
        constructors,
        isVarUsedInFields,
        keptNewNames,
        keptNewVars
      ),
    checkArgs,
  )
import Grisette.Internal.TH.Util (occName)
import Language.Haskell.TH
  ( Body (NormalB),
    Clause (Clause),
    Dec (FunD, InstanceD),
    Exp (ConE),
    Name,
    Pat (VarP, WildP),
    Pred,
    Q,
    Type (AppT, ArrowT, ConT, StarT, VarT),
    appE,
    conP,
    conT,
    newName,
    varE,
    varP,
    varT,
  )
import Language.Haskell.TH.Datatype
  ( ConstructorInfo (constructorFields, constructorName),
    TypeSubstitution (freeVariables),
    tvName,
  )
import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndr_, tvKind)

fieldExp :: [Name] -> M.Map Name Name -> Type -> Q Exp
fieldExp :: [Name] -> Map Name Name -> Type -> Q Exp
fieldExp [Name]
unaryOpFunNames Map Name Name
argToFunPat Type
ty = do
  let notContains :: Bool
notContains =
        Map Name Name -> Bool
forall k a. Map k a -> Bool
M.null (Map Name Name -> Bool) -> Map Name Name -> Bool
forall a b. (a -> b) -> a -> b
$
          Map Name Name -> Set Name -> Map Name Name
forall k a. Ord k => Map k a -> Set k -> Map k a
M.restrictKeys Map Name Name
argToFunPat ([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
ty])
  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 :: a -> Bool
typeHasNoArg a
ty =
        [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [a
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
  if Bool
notContains
    then 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
    else case Type
ty of
      Type
_ | Type -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Type
ty -> [|$(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)|]
      AppT Type
a Type
b | Type -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Type
a -> do
        [|
          $(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)
            $([Name] -> Map Name Name -> Type -> Q Exp
fieldExp [Name]
unaryOpFunNames Map Name Name
argToFunPat Type
b)
          |]
      AppT (AppT Type
a Type
b) Type
c
        | Type -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Type
a ->
            [|
              $(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)
                $([Name] -> Map Name Name -> Type -> Q Exp
fieldExp [Name]
unaryOpFunNames Map Name Name
argToFunPat Type
b)
                $([Name] -> Map Name Name -> Type -> Q Exp
fieldExp [Name]
unaryOpFunNames Map Name Name
argToFunPat Type
c)
              |]
      AppT (AppT (AppT Type
a Type
b) Type
c) Type
d
        | Type -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Type
a ->
            [|
              $(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)
                $([Name] -> Map Name Name -> Type -> Q Exp
fieldExp [Name]
unaryOpFunNames Map Name Name
argToFunPat Type
b)
                $([Name] -> Map Name Name -> Type -> Q Exp
fieldExp [Name]
unaryOpFunNames Map Name Name
argToFunPat Type
c)
                $([Name] -> Map Name Name -> Type -> Q Exp
fieldExp [Name]
unaryOpFunNames Map Name Name
argToFunPat Type
d)
              |]
      VarT Name
nm -> do
        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
"fieldExp: 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
"fieldExp: unsupported type: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
ty

patAndExps ::
  (M.Map Name Name -> Type -> Q Exp) -> [Name] -> [Type] -> Q ([Pat], [Exp])
patAndExps :: (Map Name Name -> Type -> Q Exp)
-> [Name] -> [Type] -> Q ([Pat], [Exp])
patAndExps Map Name Name -> Type -> Q Exp
fieldFunExpGen [Name]
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
  [(Name, Maybe Name)]
args <-
    (Name -> Q (Name, Maybe Name)) -> [Name] -> Q [(Name, Maybe 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
      ( \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, Maybe Name) -> Q (Name, Maybe Name)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nm, Name -> Maybe Name
forall a. a -> Maybe a
Just Name
pname)
            else (Name, Maybe Name) -> Q (Name, Maybe Name)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nm, Maybe Name
forall a. Maybe a
Nothing)
      )
      [Name]
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) -> Maybe (Name, Name))
-> [(Name, Maybe Name)] -> [(Name, Name)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Name
nm, Maybe Name
mpat) -> (Name -> (Name, Name)) -> Maybe 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,) Maybe Name
mpat) [(Name, Maybe Name)]
args
  let funPats :: [Pat]
funPats = ((Name, Maybe Name) -> Pat) -> [(Name, Maybe Name)] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pat -> (Name -> Pat) -> Maybe Name -> Pat
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Pat
WildP Name -> Pat
VarP (Maybe Name -> Pat)
-> ((Name, Maybe Name) -> Maybe Name) -> (Name, Maybe Name) -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Maybe Name) -> Maybe Name
forall a b. (a, b) -> b
snd) [(Name, Maybe Name)]
args
  [Exp]
fieldEvalSymFunExps <- (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 (Map Name Name -> Type -> Q Exp
fieldFunExpGen Map Name Name
argToFunPat) [Type]
fields
  ([Pat], [Exp]) -> Q ([Pat], [Exp])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat]
funPats, [Exp]
fieldEvalSymFunExps)

-- | Configuration for a unary function field expression generation on a GADT.
data UnaryOpFieldConfig = UnaryOpFieldConfig
  { UnaryOpFieldConfig -> [String]
extraPatNames :: [String],
    UnaryOpFieldConfig -> Exp -> [Exp] -> Q Exp
fieldCombineFun :: Exp -> [Exp] -> Q Exp
  }

-- | Generate a clause for a unary function on a GADT.
genUnaryOpClause ::
  [Name] ->
  UnaryOpFieldConfig ->
  [Name] ->
  ConstructorInfo ->
  Q Clause
genUnaryOpClause :: [Name]
-> UnaryOpFieldConfig -> [Name] -> ConstructorInfo -> Q Clause
genUnaryOpClause
  [Name]
unaryOpFunNames
  (UnaryOpFieldConfig {[String]
Exp -> [Exp] -> Q Exp
extraPatNames :: UnaryOpFieldConfig -> [String]
fieldCombineFun :: UnaryOpFieldConfig -> Exp -> [Exp] -> Q Exp
extraPatNames :: [String]
fieldCombineFun :: Exp -> [Exp] -> Q Exp
..})
  [Name]
argTypes
  ConstructorInfo
conInfo = do
    let fields :: [Type]
fields = ConstructorInfo -> [Type]
constructorFields ConstructorInfo
conInfo
    ([Pat]
funPats, [Exp]
fieldFunExps) <-
      (Map Name Name -> Type -> Q Exp)
-> [Name] -> [Type] -> Q ([Pat], [Exp])
patAndExps ([Name] -> Map Name Name -> Type -> Q Exp
fieldExp [Name]
unaryOpFunNames) [Name]
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
    [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)

    [Exp]
fieldExps <-
      (Name -> Exp -> Q Exp) -> [Name] -> [Exp] -> Q [Exp]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM
        ( \Name
nm Exp
fun ->
            Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
              ( (Q Exp -> Name -> Q Exp) -> Q Exp -> [Name] -> 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 Name
name -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE Q Exp
exp (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
name))
                  (Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
fun)
                  [Name]
extraPatNames
              )
              (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
nm)
        )
        [Name]
fieldsPatNames
        [Exp]
fieldFunExps

    Exp
resExp <- Exp -> [Exp] -> Q Exp
fieldCombineFun (Name -> Exp
ConE (ConstructorInfo -> Name
constructorName ConstructorInfo
conInfo)) [Exp]
fieldExps
    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]
funPats [Pat] -> [Pat] -> [Pat]
forall a. [a] -> [a] -> [a]
++ [Pat]
extraPats [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 -> UnaryOpFieldConfig
unaryOpFieldConfig :: UnaryOpFieldConfig,
    UnaryOpClassConfig -> [Name]
unaryOpInstanceNames :: [Name],
    UnaryOpClassConfig -> [Name]
unaryOpFunNames :: [Name]
  }

-- | Generate a unary operation type class instance for a GADT.
genUnaryOpClass ::
  UnaryOpClassConfig ->
  Int ->
  Name ->
  Q [Dec]
genUnaryOpClass :: UnaryOpClassConfig -> Int -> Name -> Q [Dec]
genUnaryOpClass (UnaryOpClassConfig {[Name]
UnaryOpFieldConfig
unaryOpFieldConfig :: UnaryOpClassConfig -> UnaryOpFieldConfig
unaryOpInstanceNames :: UnaryOpClassConfig -> [Name]
unaryOpFunNames :: UnaryOpClassConfig -> [Name]
unaryOpFieldConfig :: UnaryOpFieldConfig
unaryOpInstanceNames :: [Name]
unaryOpFunNames :: [Name]
..}) Int
n Name
typName = do
  CheckArgsResult {[Name]
[ConstructorInfo]
[TyVarBndr_ ()]
Name -> Bool
argNewNames :: CheckArgsResult -> [Name]
constructors :: CheckArgsResult -> [ConstructorInfo]
isVarUsedInFields :: CheckArgsResult -> Name -> Bool
keptNewNames :: CheckArgsResult -> [Name]
keptNewVars :: CheckArgsResult -> [TyVarBndr_ ()]
constructors :: [ConstructorInfo]
keptNewNames :: [Name]
keptNewVars :: [TyVarBndr_ ()]
argNewNames :: [Name]
isVarUsedInFields :: Name -> Bool
..} <-
    String -> Int -> Name -> Int -> Q CheckArgsResult
checkArgs
      (Name -> String
occName (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
      Int
n
  let ctxForVar :: TyVarBndr_ flag -> Q (Maybe Pred)
      ctxForVar :: forall flag. TyVarBndr_ flag -> Q (Maybe Type)
ctxForVar TyVarBndr_ flag
var = case TyVarBndr_ flag -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind TyVarBndr_ flag
var of
        Type
StarT -> Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Q Type -> Q (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|$(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ [Name] -> Name
forall a. HasCallStack => [a] -> a
head [Name]
unaryOpInstanceNames) $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ TyVarBndr_ flag -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndr_ flag
var)|]
        AppT (AppT Type
ArrowT Type
StarT) Type
StarT ->
          Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Q Type -> Q (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|$(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ [Name]
unaryOpInstanceNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
1) $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ TyVarBndr_ flag -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndr_ flag
var)|]
        AppT (AppT (AppT Type
ArrowT Type
StarT) Type
StarT) Type
StarT ->
          Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Q Type -> Q (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|$(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ [Name]
unaryOpInstanceNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
2) $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ TyVarBndr_ flag -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndr_ flag
var)|]
        AppT (AppT (AppT (AppT Type
ArrowT Type
StarT) Type
StarT) Type
StarT) Type
StarT ->
          Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Q Type -> Q (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|$(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ [Name]
unaryOpInstanceNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
3) $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ TyVarBndr_ flag -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndr_ flag
var)|]
        AppT (AppT (AppT (AppT Type
ArrowT Type
StarT) Type
StarT) Type
StarT) Type
_ ->
          String -> Q (Maybe Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Maybe Type)) -> String -> Q (Maybe Type)
forall a b. (a -> b) -> a -> b
$ String
"Unsupported kind: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show (TyVarBndr_ flag -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind TyVarBndr_ flag
var)
        Type
_ -> Maybe Type -> Q (Maybe Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Type
forall a. Maybe a
Nothing
  [Maybe Type]
ctxs <- (TyVarBndr_ () -> Q (Maybe Type))
-> [TyVarBndr_ ()] -> 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 TyVarBndr_ () -> Q (Maybe Type)
forall flag. TyVarBndr_ flag -> Q (Maybe Type)
ctxForVar ([TyVarBndr_ ()] -> Q [Maybe Type])
-> [TyVarBndr_ ()] -> Q [Maybe Type]
forall a b. (a -> b) -> a -> b
$ (TyVarBndr_ () -> Bool) -> [TyVarBndr_ ()] -> [TyVarBndr_ ()]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> Bool
isVarUsedInFields (Name -> Bool) -> (TyVarBndr_ () -> Name) -> TyVarBndr_ () -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr_ () -> Name
forall flag. TyVarBndr_ flag -> Name
tvName) [TyVarBndr_ ()]
keptNewVars
  [Clause]
clauses <-
    (ConstructorInfo -> Q Clause) -> [ConstructorInfo] -> Q [Clause]
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
      ([Name]
-> UnaryOpFieldConfig -> [Name] -> ConstructorInfo -> Q Clause
genUnaryOpClause [Name]
unaryOpFunNames UnaryOpFieldConfig
unaryOpFieldConfig [Name]
argNewNames)
      [ConstructorInfo]
constructors
  let instanceType :: Type
instanceType =
        Type -> Type -> Type
AppT (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ [Name]
unaryOpInstanceNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
n) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
          (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
$
            (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
VarT [Name]
keptNewNames
  let instanceFunName :: Name
instanceFunName = [Name]
unaryOpFunNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
n
  let instanceFun :: Dec
instanceFun = Name -> [Clause] -> Dec
FunD Name
instanceFunName [Clause]
clauses
  [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
        ([Maybe Type] -> [Type]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Type]
ctxs)
        Type
instanceType
        [Dec
instanceFun]
    ]