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

-- |
-- Module      :   Grisette.Internal.TH.Derivation.ConvertOpCommon
-- 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.ConvertOpCommon
  ( genConvertOpClass,
    ConvertOpClassConfig (..),
    defaultFieldFunExp,
  )
where

import Control.Monad (foldM, replicateM, zipWithM)
import qualified Data.Map as M
import Data.Maybe (catMaybes, mapMaybe)
import qualified Data.Set as S
import Grisette.Internal.Core.Data.Class.UnionView (unionToCon)
import Grisette.Internal.Internal.Decl.Core.Control.Monad.Union (Union)
import Grisette.Internal.Internal.Decl.Core.Data.Class.TryMerge (toUnionSym)
import Grisette.Internal.TH.Derivation.Common
  ( CheckArgsResult (argVars, constructors, keptVars),
    DeriveConfig
      ( DeriveConfig,
        bitSizePositions,
        evalModeConfig,
        fpBitSizePositions,
        needExtraMergeableUnderEvalMode,
        needExtraMergeableWithConcretizedEvalMode,
        unconstrainedPositions
      ),
    EvalModeConfig (EvalModeConstraints, EvalModeSpecified),
    checkArgs,
    extraBitSizeConstraint,
    extraEvalModeConstraint,
    extraExtraMergeableConstraint,
    extraFpBitSizeConstraint,
    freshenCheckArgsResult,
    isVarUsedInFields,
  )
import Grisette.Internal.TH.Util (allUsedNames)
import Grisette.Internal.Unified.EvalModeTag (EvalModeTag (C, S))
import Grisette.Internal.Unified.Util
  ( EvalModeConvertible (withModeConvertible'),
  )
import Language.Haskell.TH
  ( Body (NormalB),
    Clause (Clause),
    Dec (FunD, InstanceD),
    Exp (VarE),
    Kind,
    Name,
    Overlap (Incoherent),
    Pat (VarP, WildP),
    Pred,
    Q,
    Type (AppT, ArrowT, ConT, StarT, VarT),
    clause,
    conP,
    funD,
    nameBase,
    newName,
    normalB,
    varE,
    varP,
  )
import Language.Haskell.TH.Datatype
  ( ConstructorInfo (constructorFields, constructorName),
    TypeSubstitution (freeVariables),
    resolveTypeSynonyms,
  )

type FieldFunExp = M.Map Name Name -> Type -> Q Exp

-- | Default field transformation function.
defaultFieldFunExp :: [Name] -> FieldFunExp
defaultFieldFunExp :: [Name] -> FieldFunExp
defaultFieldFunExp [Name]
binaryOpFunNames Map Name Name
argToFunPat = Kind -> Q Exp
forall {m :: * -> *}. (MonadFail m, Quote m) => Kind -> m Exp
go
  where
    go :: Kind -> m Exp
go Kind
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 :: 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
      let fun0 :: m Exp
fun0 = Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ [Name] -> Name
forall a. HasCallStack => [a] -> a
head [Name]
binaryOpFunNames
          fun1 :: Kind -> m Exp
fun1 Kind
b = [|$(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ [Name]
binaryOpFunNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
1) $(Kind -> m Exp
go Kind
b)|]
          fun2 :: Kind -> Kind -> m Exp
fun2 Kind
b Kind
c = [|$(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ [Name]
binaryOpFunNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
2) $(Kind -> m Exp
go Kind
b) $(Kind -> m Exp
go Kind
c)|]
          fun3 :: Kind -> Kind -> Kind -> m Exp
fun3 Kind
b Kind
c Kind
d =
            [|$(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ [Name]
binaryOpFunNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
3) $(Kind -> m Exp
go Kind
b) $(Kind -> m Exp
go Kind
c) $(Kind -> m Exp
go Kind
d)|]
      case Kind
ty of
        AppT (AppT (AppT (VarT Name
_) Kind
b) Kind
c) Kind
d -> Kind -> Kind -> Kind -> m Exp
fun3 Kind
b Kind
c Kind
d
        AppT (AppT (VarT Name
_) Kind
b) Kind
c -> Kind -> Kind -> m Exp
fun2 Kind
b Kind
c
        AppT (VarT Name
_) Kind
b -> Kind -> m Exp
fun1 Kind
b
        Kind
_ | Kind -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Kind
ty -> m Exp
fun0
        AppT Kind
a Kind
b | Kind -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Kind
a -> Kind -> m Exp
fun1 Kind
b
        AppT (AppT Kind
a Kind
b) Kind
c | Kind -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Kind
a -> Kind -> Kind -> m Exp
fun2 Kind
b Kind
c
        AppT (AppT (AppT Kind
a Kind
b) Kind
c) Kind
d | Kind -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Kind
a -> Kind -> Kind -> Kind -> m Exp
fun3 Kind
b Kind
c Kind
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 -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pname
          Maybe Name
_ -> String -> m Exp
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Exp) -> String -> m Exp
forall a b. (a -> b) -> a -> b
$ String
"defaultFieldFunExp: unsupported type: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Kind -> String
forall a. Show a => a -> String
show Kind
ty
        Kind
_ -> String -> m Exp
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Exp) -> String -> m Exp
forall a b. (a -> b) -> a -> b
$ String
"defaultFieldFunExp: unsupported type: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Kind -> String
forall a. Show a => a -> String
show Kind
ty

funPatAndExps ::
  FieldFunExp ->
  [(Type, Kind)] ->
  [Type] ->
  Q ([Pat], [Exp])
funPatAndExps :: FieldFunExp -> [(Kind, Kind)] -> [Kind] -> Q ([Pat], [Exp])
funPatAndExps FieldFunExp
fieldFunExpGen [(Kind, Kind)]
argTypes [Kind]
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
$ [Kind] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [Kind]
fields
  [(Name, Maybe Name)]
args <-
    ((Kind, Kind) -> Q (Name, Maybe Name))
-> [(Kind, Kind)] -> 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
      ( \(Kind
ty, Kind
_) ->
          case Kind
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, 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 ('undefined, Maybe Name
forall a. Maybe a
Nothing)
            Kind
_ -> (Name, Maybe Name) -> Q (Name, Maybe Name)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ('undefined, Maybe Name
forall a. Maybe a
Nothing)
      )
      [(Kind, Kind)]
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
ty, 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
ty,) 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]
defaultFieldFunExps <- (Kind -> Q Exp) -> [Kind] -> 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) [Kind]
fields
  ([Pat], [Exp]) -> Q ([Pat], [Exp])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat]
funPats, [Exp]
defaultFieldFunExps)

tagPair ::
  DeriveConfig ->
  EvalModeTag ->
  [(Type, Kind)] ->
  [(Type, Kind)] ->
  [(Type, Type)]
tagPair :: DeriveConfig
-> EvalModeTag
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [(Kind, Kind)]
tagPair DeriveConfig
deriveConfig EvalModeTag
convertOpTarget [(Kind, Kind)]
lhsKeptVars [(Kind, Kind)]
rhsKeptVars =
  let conKeptVars :: [(Kind, Kind)]
conKeptVars =
        if EvalModeTag
convertOpTarget EvalModeTag -> EvalModeTag -> Bool
forall a. Eq a => a -> a -> Bool
== EvalModeTag
S then [(Kind, Kind)]
lhsKeptVars else [(Kind, Kind)]
rhsKeptVars
      symKeptVars :: [(Kind, Kind)]
symKeptVars =
        if EvalModeTag
convertOpTarget EvalModeTag -> EvalModeTag -> Bool
forall a. Eq a => a -> a -> Bool
== EvalModeTag
S then [(Kind, Kind)]
rhsKeptVars else [(Kind, Kind)]
lhsKeptVars
   in ((Int, EvalModeConfig) -> Maybe (Kind, Kind))
-> [(Int, EvalModeConfig)] -> [(Kind, Kind)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
        ( \case
            (Int
n, EvalModeConstraints [Name]
_)
              | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [(Kind, Kind)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Kind, Kind)]
conKeptVars Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 ->
                  (Kind, Kind) -> Maybe (Kind, Kind)
forall a. a -> Maybe a
Just ((Kind, Kind) -> Kind
forall a b. (a, b) -> a
fst ((Kind, Kind) -> Kind) -> (Kind, Kind) -> Kind
forall a b. (a -> b) -> a -> b
$ [(Kind, Kind)]
conKeptVars [(Kind, Kind)] -> Int -> (Kind, Kind)
forall a. HasCallStack => [a] -> Int -> a
!! Int
n, (Kind, Kind) -> Kind
forall a b. (a, b) -> a
fst ((Kind, Kind) -> Kind) -> (Kind, Kind) -> Kind
forall a b. (a -> b) -> a -> b
$ [(Kind, Kind)]
symKeptVars [(Kind, Kind)] -> Int -> (Kind, Kind)
forall a. HasCallStack => [a] -> Int -> a
!! Int
n)
            (Int, EvalModeConfig)
_ -> Maybe (Kind, Kind)
forall a. Maybe a
Nothing
        )
        (DeriveConfig -> [(Int, EvalModeConfig)]
evalModeConfig DeriveConfig
deriveConfig)

caseSplitTagPairs ::
  DeriveConfig ->
  EvalModeTag ->
  [(Type, Kind)] ->
  [(Type, Kind)] ->
  Exp ->
  Q Exp
caseSplitTagPairs :: DeriveConfig
-> EvalModeTag -> [(Kind, Kind)] -> [(Kind, Kind)] -> Exp -> Q Exp
caseSplitTagPairs DeriveConfig
deriveConfig EvalModeTag
convertOpTarget [(Kind, Kind)]
lhsKeptVars [(Kind, Kind)]
rhsKeptVars Exp
exp = do
  let tags :: [(Kind, Kind)]
tags = DeriveConfig
-> EvalModeTag
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [(Kind, Kind)]
tagPair DeriveConfig
deriveConfig EvalModeTag
convertOpTarget [(Kind, Kind)]
lhsKeptVars [(Kind, Kind)]
rhsKeptVars
  (Exp -> (Kind, Kind) -> Q Exp) -> Exp -> [(Kind, Kind)] -> Q Exp
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
    ( \Exp
exp (Kind
lty, Kind
rty) ->
        [|
          withModeConvertible'
            @($(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
lty))
            @($(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
rty))
            $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
exp)
            $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
exp)
            $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
exp)
          |]
    )
    Exp
exp
    [(Kind, Kind)]
tags

genConvertOpFieldClause ::
  DeriveConfig ->
  ConvertOpClassConfig ->
  [(Type, Kind)] ->
  [(Type, Kind)] ->
  [(Type, Kind)] ->
  [(Type, Kind)] ->
  ConstructorInfo ->
  Q Clause
genConvertOpFieldClause :: DeriveConfig
-> ConvertOpClassConfig
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> ConstructorInfo
-> Q Clause
genConvertOpFieldClause
  deriveConfig :: DeriveConfig
deriveConfig@DeriveConfig {Bool
[Int]
[(Int, Int)]
[(Int, EvalModeConfig)]
bitSizePositions :: DeriveConfig -> [Int]
evalModeConfig :: DeriveConfig -> [(Int, EvalModeConfig)]
fpBitSizePositions :: DeriveConfig -> [(Int, Int)]
needExtraMergeableUnderEvalMode :: DeriveConfig -> Bool
needExtraMergeableWithConcretizedEvalMode :: DeriveConfig -> Bool
unconstrainedPositions :: DeriveConfig -> [Int]
evalModeConfig :: [(Int, EvalModeConfig)]
bitSizePositions :: [Int]
fpBitSizePositions :: [(Int, Int)]
unconstrainedPositions :: [Int]
needExtraMergeableUnderEvalMode :: Bool
needExtraMergeableWithConcretizedEvalMode :: Bool
..}
  ConvertOpClassConfig {[Name]
EvalModeTag
Exp -> Exp -> Q Exp
Name -> [Exp] -> Q Exp
FieldFunExp
convertOpTarget :: EvalModeTag
convertOpInstanceNames :: [Name]
convertOpFunNames :: [Name]
convertFieldResFun :: Exp -> Exp -> Q Exp
convertFieldCombineFun :: Name -> [Exp] -> Q Exp
convertFieldFunExp :: FieldFunExp
convertFieldFunExp :: ConvertOpClassConfig -> FieldFunExp
convertFieldCombineFun :: ConvertOpClassConfig -> Name -> [Exp] -> Q Exp
convertFieldResFun :: ConvertOpClassConfig -> Exp -> Exp -> Q Exp
convertOpFunNames :: ConvertOpClassConfig -> [Name]
convertOpInstanceNames :: ConvertOpClassConfig -> [Name]
convertOpTarget :: ConvertOpClassConfig -> EvalModeTag
..}
  [(Kind, Kind)]
lhsKeptTypes
  [(Kind, Kind)]
rhsKeptTypes
  [(Kind, Kind)]
lhsArgTypes
  [(Kind, Kind)]
_rhsArgTypes
  ConstructorInfo
lhsConInfo = do
    [Kind]
fields <- (Kind -> Q Kind) -> [Kind] -> Q [Kind]
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 Kind -> Q Kind
resolveTypeSynonyms ([Kind] -> Q [Kind]) -> [Kind] -> Q [Kind]
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> [Kind]
constructorFields ConstructorInfo
lhsConInfo
    ([Pat]
funPats, [Exp]
defaultFieldFunExps) <- FieldFunExp -> [(Kind, Kind)] -> [Kind] -> Q ([Pat], [Exp])
funPatAndExps FieldFunExp
convertFieldFunExp [(Kind, Kind)]
lhsArgTypes [Kind]
fields
    [Name]
fieldsPatNames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([Kind] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
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"
    Pat
fieldPats <- Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (ConstructorInfo -> Name
constructorName ConstructorInfo
lhsConInfo) ((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]
fieldResExps <- (Exp -> Exp -> Q Exp) -> [Exp] -> [Exp] -> Q [Exp]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Exp -> Exp -> Q Exp
convertFieldResFun [Exp]
fieldPatExps [Exp]
defaultFieldFunExps
    Exp
resExp <- Name -> [Exp] -> Q Exp
convertFieldCombineFun (ConstructorInfo -> Name
constructorName ConstructorInfo
lhsConInfo) [Exp]
fieldResExps
    let resUsedNames :: Set Name
resUsedNames = Exp -> Set Name
allUsedNames Exp
resExp
    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
    Exp
resExpWithTags <-
      DeriveConfig
-> EvalModeTag -> [(Kind, Kind)] -> [(Kind, Kind)] -> Exp -> Q Exp
caseSplitTagPairs
        DeriveConfig
deriveConfig
        EvalModeTag
convertOpTarget
        [(Kind, Kind)]
lhsKeptTypes
        [(Kind, Kind)]
rhsKeptTypes
        Exp
resExp
    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]
funPats [Pat] -> [Pat] -> [Pat]
forall a. [a] -> [a] -> [a]
++ [Pat
fieldPats])
        (Exp -> Body
NormalB Exp
resExpWithTags)
        []

genConvertOpFun ::
  DeriveConfig ->
  ConvertOpClassConfig ->
  Int ->
  [(Type, Kind)] ->
  [(Type, Kind)] ->
  [(Type, Kind)] ->
  [(Type, Kind)] ->
  [ConstructorInfo] ->
  Q Dec
genConvertOpFun :: DeriveConfig
-> ConvertOpClassConfig
-> Int
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [ConstructorInfo]
-> Q Dec
genConvertOpFun DeriveConfig
_ ConvertOpClassConfig
convertOpClassConfig Int
n [(Kind, Kind)]
_ [(Kind, Kind)]
_ [(Kind, Kind)]
_ [(Kind, Kind)]
_ [] = do
  let instanceFunName :: Name
instanceFunName = (ConvertOpClassConfig -> [Name]
convertOpFunNames ConvertOpClassConfig
convertOpClassConfig) [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
n
  Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
instanceFunName [[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"|]) []]
genConvertOpFun
  DeriveConfig
deriveConfig
  ConvertOpClassConfig
convertOpClassConfig
  Int
n
  [(Kind, Kind)]
lhsKeptTypes
  [(Kind, Kind)]
rhsKeptTypes
  [(Kind, Kind)]
lhsArgTypes
  [(Kind, Kind)]
rhsArgTypes
  [ConstructorInfo]
lhsConstructors = do
    [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
        ( DeriveConfig
-> ConvertOpClassConfig
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> ConstructorInfo
-> Q Clause
genConvertOpFieldClause
            DeriveConfig
deriveConfig
            ConvertOpClassConfig
convertOpClassConfig
            [(Kind, Kind)]
lhsKeptTypes
            [(Kind, Kind)]
rhsKeptTypes
            [(Kind, Kind)]
lhsArgTypes
            [(Kind, Kind)]
rhsArgTypes
        )
        [ConstructorInfo]
lhsConstructors
    let instanceFunName :: Name
instanceFunName = (ConvertOpClassConfig -> [Name]
convertOpFunNames ConvertOpClassConfig
convertOpClassConfig) [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

-- | Configuration for a convert operation class.
data ConvertOpClassConfig = ConvertOpClassConfig
  { ConvertOpClassConfig -> EvalModeTag
convertOpTarget :: EvalModeTag,
    ConvertOpClassConfig -> [Name]
convertOpInstanceNames :: [Name],
    ConvertOpClassConfig -> [Name]
convertOpFunNames :: [Name],
    ConvertOpClassConfig -> Exp -> Exp -> Q Exp
convertFieldResFun :: Exp -> Exp -> Q Exp,
    ConvertOpClassConfig -> Name -> [Exp] -> Q Exp
convertFieldCombineFun :: Name -> [Exp] -> Q Exp,
    ConvertOpClassConfig -> FieldFunExp
convertFieldFunExp :: FieldFunExp
  }

convertCtxForVar :: [Type] -> Type -> Type -> Kind -> Q (Maybe Pred)
convertCtxForVar :: [Kind] -> Kind -> Kind -> Kind -> Q (Maybe Kind)
convertCtxForVar [Kind]
instanceExps Kind
lty Kind
rty Kind
knd = case Kind
knd of
  Kind
StarT ->
    Kind -> Maybe Kind
forall a. a -> Maybe a
Just
      (Kind -> Maybe Kind) -> Q Kind -> Q (Maybe Kind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|$(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> Q Kind) -> Kind -> Q Kind
forall a b. (a -> b) -> a -> b
$ [Kind] -> Kind
forall a. HasCallStack => [a] -> a
head [Kind]
instanceExps) $(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
lty) $(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
rty)|]
  AppT (AppT Kind
ArrowT Kind
StarT) Kind
StarT ->
    Kind -> Maybe Kind
forall a. a -> Maybe a
Just
      (Kind -> Maybe Kind) -> Q Kind -> Q (Maybe Kind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|$(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> Q Kind) -> Kind -> Q Kind
forall a b. (a -> b) -> a -> b
$ [Kind]
instanceExps [Kind] -> Int -> Kind
forall a. HasCallStack => [a] -> Int -> a
!! Int
1) $(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
lty) $(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
rty)|]
  AppT (AppT (AppT Kind
ArrowT Kind
StarT) Kind
StarT) Kind
StarT ->
    Kind -> Maybe Kind
forall a. a -> Maybe a
Just
      (Kind -> Maybe Kind) -> Q Kind -> Q (Maybe Kind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|$(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> Q Kind) -> Kind -> Q Kind
forall a b. (a -> b) -> a -> b
$ [Kind]
instanceExps [Kind] -> Int -> Kind
forall a. HasCallStack => [a] -> Int -> a
!! Int
2) $(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
lty) $(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
rty)|]
  AppT (AppT (AppT Kind
StarT Kind
StarT) Kind
StarT) Kind
_ ->
    String -> Q (Maybe Kind)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Maybe Kind)) -> String -> Q (Maybe Kind)
forall a b. (a -> b) -> a -> b
$ String
"Unsupported kind: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Kind -> String
forall a. Show a => a -> String
show Kind
knd
  Kind
_ -> Maybe Kind -> Q (Maybe Kind)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Kind
forall a. Maybe a
Nothing

-- | Generate extra constraints for a data type.
extraConstraintConvert ::
  DeriveConfig ->
  EvalModeTag ->
  Name ->
  Name ->
  [(Type, Kind)] ->
  [(Type, Kind)] ->
  [ConstructorInfo] ->
  Q [Pred]
extraConstraintConvert :: DeriveConfig
-> EvalModeTag
-> Name
-> Name
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [ConstructorInfo]
-> Q [Kind]
extraConstraintConvert
  deriveConfig :: DeriveConfig
deriveConfig@DeriveConfig {Bool
[Int]
[(Int, Int)]
[(Int, EvalModeConfig)]
bitSizePositions :: DeriveConfig -> [Int]
evalModeConfig :: DeriveConfig -> [(Int, EvalModeConfig)]
fpBitSizePositions :: DeriveConfig -> [(Int, Int)]
needExtraMergeableUnderEvalMode :: DeriveConfig -> Bool
needExtraMergeableWithConcretizedEvalMode :: DeriveConfig -> Bool
unconstrainedPositions :: DeriveConfig -> [Int]
evalModeConfig :: [(Int, EvalModeConfig)]
bitSizePositions :: [Int]
fpBitSizePositions :: [(Int, Int)]
unconstrainedPositions :: [Int]
needExtraMergeableUnderEvalMode :: Bool
needExtraMergeableWithConcretizedEvalMode :: Bool
..}
  EvalModeTag
convertOpTarget
  Name
tyName
  Name
instanceName
  [(Kind, Kind)]
lhsKeptArgs
  [(Kind, Kind)]
rhsKeptArgs
  [ConstructorInfo]
rhsConstructors = do
    let conKeptVars :: [(Kind, Kind)]
conKeptVars = if EvalModeTag
convertOpTarget EvalModeTag -> EvalModeTag -> Bool
forall a. Eq a => a -> a -> Bool
== EvalModeTag
S then [(Kind, Kind)]
lhsKeptArgs else [(Kind, Kind)]
rhsKeptArgs
    let symKeptVars :: [(Kind, Kind)]
symKeptVars = if EvalModeTag
convertOpTarget EvalModeTag -> EvalModeTag -> Bool
forall a. Eq a => a -> a -> Bool
== EvalModeTag
S then [(Kind, Kind)]
rhsKeptArgs else [(Kind, Kind)]
lhsKeptArgs

    [[Kind]]
rhsEvalModePreds <-
      if EvalModeTag
convertOpTarget EvalModeTag -> EvalModeTag -> Bool
forall a. Eq a => a -> a -> Bool
== EvalModeTag
S Bool -> Bool -> Bool
&& Bool
needExtraMergeableWithConcretizedEvalMode
        then
          ((Int, EvalModeConfig) -> Q [Kind])
-> [(Int, EvalModeConfig)] -> Q [[Kind]]
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 -> Name -> [(Kind, Kind)] -> (Int, EvalModeConfig) -> Q [Kind]
extraEvalModeConstraint Name
tyName Name
instanceName [(Kind, Kind)]
rhsKeptArgs)
            [(Int, EvalModeConfig)]
evalModeConfig
        else [[Kind]] -> Q [[Kind]]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    [[Kind]]
extraArgEvalModePreds <-
      ((Int, EvalModeConfig) -> Q [Kind])
-> [(Int, EvalModeConfig)] -> Q [[Kind]]
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
        ( \case
            (Int
n, EvalModeConstraints [Name]
_)
              | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [(Kind, Kind)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Kind, Kind)]
lhsKeptArgs Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 ->
                  (Kind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
: [])
                    (Kind -> [Kind]) -> Q Kind -> Q [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|
                      EvalModeConvertible
                        $(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> Q Kind) -> Kind -> Q Kind
forall a b. (a -> b) -> a -> b
$ (Kind, Kind) -> Kind
forall a b. (a, b) -> a
fst ((Kind, Kind) -> Kind) -> (Kind, Kind) -> Kind
forall a b. (a -> b) -> a -> b
$ [(Kind, Kind)]
conKeptVars [(Kind, Kind)] -> Int -> (Kind, Kind)
forall a. HasCallStack => [a] -> Int -> a
!! Int
n)
                        $(Kind -> Q Kind
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> Q Kind) -> Kind -> Q Kind
forall a b. (a -> b) -> a -> b
$ (Kind, Kind) -> Kind
forall a b. (a, b) -> a
fst ((Kind, Kind) -> Kind) -> (Kind, Kind) -> Kind
forall a b. (a -> b) -> a -> b
$ [(Kind, Kind)]
symKeptVars [(Kind, Kind)] -> Int -> (Kind, Kind)
forall a. HasCallStack => [a] -> Int -> a
!! Int
n)
                      |]
            (Int, EvalModeConfig)
_ -> [Kind] -> Q [Kind]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        )
        [(Int, EvalModeConfig)]
evalModeConfig
    [[Kind]]
bitSizePreds <-
      (Int -> Q [Kind]) -> [Int] -> Q [[Kind]]
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 -> Name -> [(Kind, Kind)] -> Int -> Q [Kind]
extraBitSizeConstraint Name
tyName Name
instanceName [(Kind, Kind)]
lhsKeptArgs)
        [Int]
bitSizePositions
    [[Kind]]
fpBitSizePreds <-
      ((Int, Int) -> Q [Kind]) -> [(Int, Int)] -> Q [[Kind]]
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 -> Name -> [(Kind, Kind)] -> (Int, Int) -> Q [Kind]
extraFpBitSizeConstraint Name
tyName Name
instanceName [(Kind, Kind)]
lhsKeptArgs)
        [(Int, Int)]
fpBitSizePositions
    [Kind]
extraMergeablePreds <-
      if EvalModeTag
convertOpTarget EvalModeTag -> EvalModeTag -> Bool
forall a. Eq a => a -> a -> Bool
== EvalModeTag
S
        Bool -> Bool -> Bool
&& ( ((Int, EvalModeConfig) -> Bool) -> [(Int, EvalModeConfig)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
               ( \case
                   (Int
_, EvalModeConstraints [Name]
_) -> Bool
True
                   (Int
_, EvalModeSpecified EvalModeTag
_) -> Bool
False
               )
               [(Int, EvalModeConfig)]
evalModeConfig
               Bool -> Bool -> Bool
|| Bool
needExtraMergeableWithConcretizedEvalMode
           )
        then DeriveConfig -> [ConstructorInfo] -> [(Kind, Kind)] -> Q [Kind]
extraExtraMergeableConstraint DeriveConfig
deriveConfig [ConstructorInfo]
rhsConstructors [(Kind, Kind)]
rhsKeptArgs
        else [Kind] -> Q [Kind]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    [Kind] -> Q [Kind]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Kind] -> Q [Kind]) -> [Kind] -> Q [Kind]
forall a b. (a -> b) -> a -> b
$
      [[Kind]] -> [Kind]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        ( [[Kind]]
rhsEvalModePreds
            [[Kind]] -> [[Kind]] -> [[Kind]]
forall a. [a] -> [a] -> [a]
++ [[Kind]]
extraArgEvalModePreds
            [[Kind]] -> [[Kind]] -> [[Kind]]
forall a. [a] -> [a] -> [a]
++ [[Kind]]
bitSizePreds
            [[Kind]] -> [[Kind]] -> [[Kind]]
forall a. [a] -> [a] -> [a]
++ [[Kind]]
fpBitSizePreds
            [[Kind]] -> [[Kind]] -> [[Kind]]
forall a. [a] -> [a] -> [a]
++ [[Kind]
extraMergeablePreds]
        )

-- | Generate a convert operation class instance.
genConvertOpClass ::
  DeriveConfig -> ConvertOpClassConfig -> Int -> Name -> Q [Dec]
genConvertOpClass :: DeriveConfig -> ConvertOpClassConfig -> Int -> Name -> Q [Dec]
genConvertOpClass DeriveConfig
deriveConfig (ConvertOpClassConfig {[Name]
EvalModeTag
Exp -> Exp -> Q Exp
Name -> [Exp] -> Q Exp
FieldFunExp
convertFieldFunExp :: ConvertOpClassConfig -> FieldFunExp
convertFieldCombineFun :: ConvertOpClassConfig -> Name -> [Exp] -> Q Exp
convertFieldResFun :: ConvertOpClassConfig -> Exp -> Exp -> Q Exp
convertOpFunNames :: ConvertOpClassConfig -> [Name]
convertOpInstanceNames :: ConvertOpClassConfig -> [Name]
convertOpTarget :: ConvertOpClassConfig -> EvalModeTag
convertOpTarget :: EvalModeTag
convertOpInstanceNames :: [Name]
convertOpFunNames :: [Name]
convertFieldResFun :: Exp -> Exp -> Q Exp
convertFieldCombineFun :: Name -> [Exp] -> Q Exp
convertFieldFunExp :: FieldFunExp
..}) Int
n Name
typName = do
  CheckArgsResult
oldLhsResult <-
    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]
convertOpInstanceNames)
        ([Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
convertOpInstanceNames Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        Name
typName
        Bool
False
        Int
n
  CheckArgsResult
oldRhsResult <- Bool -> CheckArgsResult -> Q CheckArgsResult
freshenCheckArgsResult Bool
False CheckArgsResult
oldLhsResult
  let lResult :: CheckArgsResult
lResult = CheckArgsResult
oldLhsResult
  let rResult :: CheckArgsResult
rResult = CheckArgsResult
oldRhsResult
  let instanceName :: Name
instanceName = [Name]
convertOpInstanceNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
n
  let lKeptVars :: [(Kind, Kind)]
lKeptVars = CheckArgsResult -> [(Kind, Kind)]
keptVars CheckArgsResult
lResult
  let rKeptVars :: [(Kind, Kind)]
rKeptVars = CheckArgsResult -> [(Kind, Kind)]
keptVars CheckArgsResult
rResult
  let lConstructors :: [ConstructorInfo]
lConstructors = CheckArgsResult -> [ConstructorInfo]
constructors CheckArgsResult
lResult
  let rConstructors :: [ConstructorInfo]
rConstructors = CheckArgsResult -> [ConstructorInfo]
constructors CheckArgsResult
rResult
  let lKeptType :: Kind
lKeptType = (Kind -> Kind -> Kind) -> Kind -> [Kind] -> Kind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
typName) ([Kind] -> Kind) -> [Kind] -> Kind
forall a b. (a -> b) -> a -> b
$ ((Kind, Kind) -> Kind) -> [(Kind, Kind)] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Kind, Kind) -> Kind
forall a b. (a, b) -> a
fst [(Kind, Kind)]
lKeptVars
  let rKeptType :: Kind
rKeptType = (Kind -> Kind -> Kind) -> Kind -> [Kind] -> Kind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
typName) ([Kind] -> Kind) -> [Kind] -> Kind
forall a b. (a -> b) -> a -> b
$ ((Kind, Kind) -> Kind) -> [(Kind, Kind)] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Kind, Kind) -> Kind
forall a b. (a, b) -> a
fst [(Kind, Kind)]
rKeptVars
  [Kind]
extraPreds <-
    DeriveConfig
-> EvalModeTag
-> Name
-> Name
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [ConstructorInfo]
-> Q [Kind]
extraConstraintConvert
      DeriveConfig
deriveConfig
      EvalModeTag
convertOpTarget
      Name
typName
      Name
instanceName
      [(Kind, Kind)]
lKeptVars
      [(Kind, Kind)]
rKeptVars
      [ConstructorInfo]
rConstructors
  [Kind]
unionExtraPreds <-
    DeriveConfig
-> EvalModeTag
-> Name
-> Name
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [ConstructorInfo]
-> Q [Kind]
extraConstraintConvert
      DeriveConfig
deriveConfig {needExtraMergeableWithConcretizedEvalMode = True}
      EvalModeTag
convertOpTarget
      Name
typName
      Name
instanceName
      [(Kind, Kind)]
lKeptVars
      [(Kind, Kind)]
rKeptVars
      [ConstructorInfo]
rConstructors

  let instanceType :: Kind
instanceType = Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
instanceName) Kind
lKeptType) Kind
rKeptType
  let isTypeUsedInFields :: Kind -> Bool
isTypeUsedInFields (VarT Name
nm) = CheckArgsResult -> Name -> Bool
isVarUsedInFields CheckArgsResult
lResult Name
nm
      isTypeUsedInFields Kind
_ = Bool
False
  [Maybe Kind]
ctxs <-
    ((Int, ((Kind, Kind), (Kind, Kind))) -> Q (Maybe Kind))
-> [(Int, ((Kind, Kind), (Kind, Kind)))] -> Q [Maybe Kind]
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
      ( \(Int
position, ((Kind
lty, Kind
knd), (Kind
rty, Kind
_))) ->
          if Int
position 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
            then Maybe Kind -> Q (Maybe Kind)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Kind
forall a. Maybe a
Nothing
            else [Kind] -> Kind -> Kind -> Kind -> Q (Maybe Kind)
convertCtxForVar (Name -> Kind
ConT (Name -> Kind) -> [Name] -> [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
convertOpInstanceNames) Kind
lty Kind
rty Kind
knd
      )
      ([(Int, ((Kind, Kind), (Kind, Kind)))] -> Q [Maybe Kind])
-> [(Int, ((Kind, Kind), (Kind, Kind)))] -> Q [Maybe Kind]
forall a b. (a -> b) -> a -> b
$ ((Int, ((Kind, Kind), (Kind, Kind))) -> Bool)
-> [(Int, ((Kind, Kind), (Kind, Kind)))]
-> [(Int, ((Kind, Kind), (Kind, Kind)))]
forall a. (a -> Bool) -> [a] -> [a]
filter (Kind -> Bool
isTypeUsedInFields (Kind -> Bool)
-> ((Int, ((Kind, Kind), (Kind, Kind))) -> Kind)
-> (Int, ((Kind, Kind), (Kind, Kind)))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Kind, Kind) -> Kind
forall a b. (a, b) -> a
fst ((Kind, Kind) -> Kind)
-> ((Int, ((Kind, Kind), (Kind, Kind))) -> (Kind, Kind))
-> (Int, ((Kind, Kind), (Kind, Kind)))
-> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Kind, Kind), (Kind, Kind)) -> (Kind, Kind)
forall a b. (a, b) -> a
fst (((Kind, Kind), (Kind, Kind)) -> (Kind, Kind))
-> ((Int, ((Kind, Kind), (Kind, Kind)))
    -> ((Kind, Kind), (Kind, Kind)))
-> (Int, ((Kind, Kind), (Kind, Kind)))
-> (Kind, Kind)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, ((Kind, Kind), (Kind, Kind))) -> ((Kind, Kind), (Kind, Kind))
forall a b. (a, b) -> b
snd)
      ([(Int, ((Kind, Kind), (Kind, Kind)))]
 -> [(Int, ((Kind, Kind), (Kind, Kind)))])
-> [(Int, ((Kind, Kind), (Kind, Kind)))]
-> [(Int, ((Kind, Kind), (Kind, Kind)))]
forall a b. (a -> b) -> a -> b
$ [Int]
-> [((Kind, Kind), (Kind, Kind))]
-> [(Int, ((Kind, Kind), (Kind, Kind)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..]
      ([((Kind, Kind), (Kind, Kind))]
 -> [(Int, ((Kind, Kind), (Kind, Kind)))])
-> [((Kind, Kind), (Kind, Kind))]
-> [(Int, ((Kind, Kind), (Kind, Kind)))]
forall a b. (a -> b) -> a -> b
$ [(Kind, Kind)] -> [(Kind, Kind)] -> [((Kind, Kind), (Kind, Kind))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Kind, Kind)]
lKeptVars [(Kind, Kind)]
rKeptVars

  Dec
instanceFun <-
    DeriveConfig
-> ConvertOpClassConfig
-> Int
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [ConstructorInfo]
-> Q Dec
genConvertOpFun
      DeriveConfig
deriveConfig
      (ConvertOpClassConfig {[Name]
EvalModeTag
Exp -> Exp -> Q Exp
Name -> [Exp] -> Q Exp
FieldFunExp
convertFieldFunExp :: FieldFunExp
convertFieldCombineFun :: Name -> [Exp] -> Q Exp
convertFieldResFun :: Exp -> Exp -> Q Exp
convertOpFunNames :: [Name]
convertOpInstanceNames :: [Name]
convertOpTarget :: EvalModeTag
convertOpTarget :: EvalModeTag
convertOpInstanceNames :: [Name]
convertOpFunNames :: [Name]
convertFieldResFun :: Exp -> Exp -> Q Exp
convertFieldCombineFun :: Name -> [Exp] -> Q Exp
convertFieldFunExp :: FieldFunExp
..})
      Int
n
      (CheckArgsResult -> [(Kind, Kind)]
keptVars CheckArgsResult
lResult)
      (CheckArgsResult -> [(Kind, Kind)]
keptVars CheckArgsResult
rResult)
      (CheckArgsResult -> [(Kind, Kind)]
argVars CheckArgsResult
lResult)
      (CheckArgsResult -> [(Kind, Kind)]
argVars CheckArgsResult
rResult)
      [ConstructorInfo]
lConstructors

  let instanceUnionType :: Kind
instanceUnionType =
        case EvalModeTag
convertOpTarget of
          EvalModeTag
S ->
            Kind -> Kind -> Kind
AppT
              (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
instanceName) Kind
lKeptType)
              (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT ''Union) Kind
rKeptType)
          EvalModeTag
C ->
            Kind -> Kind -> Kind
AppT
              (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
instanceName) (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT ''Union) Kind
lKeptType))
              Kind
rKeptType
  Dec
instanceUnionFun <- do
    Exp
resExp <-
      if EvalModeTag
convertOpTarget EvalModeTag -> EvalModeTag -> Bool
forall a. Eq a => a -> a -> Bool
== EvalModeTag
S
        then Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'toUnionSym
        else Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'unionToCon
    Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ([Name] -> Name
forall a. HasCallStack => [a] -> a
head [Name]
convertOpFunNames) [[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 (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
resExp) []]

  [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
$
    Maybe Overlap -> [Kind] -> Kind -> [Dec] -> Dec
InstanceD
      (Overlap -> Maybe Overlap
forall a. a -> Maybe a
Just Overlap
Incoherent)
      ([Kind]
extraPreds [Kind] -> [Kind] -> [Kind]
forall a. [a] -> [a] -> [a]
++ if [ConstructorInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CheckArgsResult -> [ConstructorInfo]
constructors CheckArgsResult
lResult) then [] else [Maybe Kind] -> [Kind]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Kind]
ctxs)
      Kind
instanceType
      [Dec
instanceFun]
      Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: ( [ Maybe Overlap -> [Kind] -> Kind -> [Dec] -> Dec
InstanceD
              (Overlap -> Maybe Overlap
forall a. a -> Maybe a
Just Overlap
Incoherent)
              ( [Kind]
unionExtraPreds
                  [Kind] -> [Kind] -> [Kind]
forall a. [a] -> [a] -> [a]
++ if [ConstructorInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CheckArgsResult -> [ConstructorInfo]
constructors CheckArgsResult
lResult)
                    then []
                    else [Maybe Kind] -> [Kind]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Kind]
ctxs
              )
              Kind
instanceUnionType
              [Dec
instanceUnionFun]
          | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
          ]
        )