{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      :   Grisette.Internal.TH.Derivation.DeriveMergeable
-- 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.DeriveMergeable
  ( deriveMergeable,
    deriveMergeable1,
    deriveMergeable2,
    deriveMergeable3,
    genMergeableAndGetMergingInfoResult,
    genMergeable,
    genMergeable',
    genMergeableNoExistential,
    genMergeableNoStrategy,
    genMergeableList,
  )
where

import Control.Monad (foldM, replicateM, zipWithM)
import qualified Data.Map as M
import Data.Maybe (catMaybes, isJust, mapMaybe)
import qualified Data.Set as S
import Data.Word (Word16, Word32, Word64, Word8)
import Grisette.Internal.Internal.Decl.Core.Data.Class.Mergeable
  ( Mergeable (rootStrategy),
    Mergeable1 (liftRootStrategy),
    Mergeable2 (liftRootStrategy2),
    Mergeable3 (liftRootStrategy3),
    MergingStrategy (NoStrategy, SimpleStrategy, SortedStrategy),
    product2Strategy,
    wrapStrategy,
  )
import Grisette.Internal.TH.Derivation.Common
  ( CheckArgsResult
      ( CheckArgsResult,
        argVars,
        constructors,
        keptVars
      ),
    DeriveConfig (unconstrainedPositions, useNoStrategy),
    checkArgs,
    evalModeSpecializeList,
    extraConstraint,
    isVarUsedInFields,
    specializeResult,
  )
import Grisette.Internal.TH.Derivation.UnaryOpCommon
  ( FieldFunExp,
    UnaryOpClassConfig
      ( UnaryOpClassConfig,
        unaryOpAllowExistential,
        unaryOpConfigs,
        unaryOpContextNames,
        unaryOpExtraVars,
        unaryOpInstanceNames,
        unaryOpInstanceTypeFromConfig
      ),
    UnaryOpConfig (UnaryOpConfig),
    UnaryOpFunConfig (genUnaryOpFun),
    defaultUnaryOpInstanceTypeFromConfig,
    genUnaryOpClass,
  )
import Grisette.Internal.TH.Util (dataTypeHasExistential, integerE, mangleName)
import Language.Haskell.TH
  ( Bang (Bang),
    Body (NormalB),
    Clause (Clause),
    Con (ForallC, GadtC),
    Dec (DataD, FunD, InstanceD, PragmaD, SigD),
    Exp (AppE, ConE, VarE),
    Inline (Inline),
    Kind,
    Name,
    Pat (SigP, VarP, WildP),
    Phases (AllPhases),
    Pragma (InlineP),
    Pred,
    Q,
    RuleMatch (FunLike),
    SourceStrictness (NoSourceStrictness),
    SourceUnpackedness (NoSourceUnpackedness),
    Type (AppT, ArrowT, ConT, ForallT, StarT, VarT),
    appE,
    caseE,
    conE,
    conT,
    integerL,
    lamE,
    litP,
    lookupTypeName,
    mkName,
    nameBase,
    newName,
    normalB,
    recP,
    sigP,
    tupP,
    varE,
    varP,
    varT,
    wildP,
  )
import Language.Haskell.TH.Datatype
  ( ConstructorInfo
      ( constructorContext,
        constructorFields,
        constructorName,
        constructorVars
      ),
    DatatypeInfo (datatypeCons, datatypeName, datatypeVars),
    TypeSubstitution (applySubstitution, freeVariables),
    reifyDatatype,
    resolveTypeSynonyms,
    tvName,
  )
import Language.Haskell.TH.Datatype.TyVarBndr
  ( TyVarBndrUnit,
    kindedTVSpecified,
    plainTVFlag,
    specifiedSpec,
  )
import Language.Haskell.TH.Lib (clause, conP, litE, match, stringL)
import Type.Reflection (SomeTypeRep (SomeTypeRep), TypeRep, typeRep)
import Unsafe.Coerce (unsafeCoerce)

genMergingInfoCon ::
  [TyVarBndrUnit] ->
  Name ->
  Bool ->
  ConstructorInfo ->
  Q (Con, Name, [Clause], [Clause], [Clause])
genMergingInfoCon :: [TyVarBndrUnit]
-> Name
-> Bool
-> ConstructorInfo
-> Q (Con, Name, [Clause], [Clause], [Clause])
genMergingInfoCon [TyVarBndrUnit]
dataTypeVars Name
tyName Bool
isLast ConstructorInfo
con = do
  let conName :: String
conName = Name -> String
mangleName (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> Name
constructorName ConstructorInfo
con
  let newConName :: Name
newConName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
conName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"MergingInfo"
  let oriVars :: [TyVarBndrUnit]
oriVars = [TyVarBndrUnit]
dataTypeVars [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a] -> [a]
++ ConstructorInfo -> [TyVarBndrUnit]
constructorVars ConstructorInfo
con
  [Name]
newDataTypeVars <- (TyVarBndrUnit -> Q Name) -> [TyVarBndrUnit] -> 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 -> Q Name)
-> (TyVarBndrUnit -> String) -> TyVarBndrUnit -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase (Name -> String)
-> (TyVarBndrUnit -> Name) -> TyVarBndrUnit -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName) [TyVarBndrUnit]
dataTypeVars
  [Name]
newConstructorVars <-
    (TyVarBndrUnit -> Q Name) -> [TyVarBndrUnit] -> 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 -> Q Name)
-> (TyVarBndrUnit -> String) -> TyVarBndrUnit -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase (Name -> String)
-> (TyVarBndrUnit -> Name) -> TyVarBndrUnit -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName) ([TyVarBndrUnit] -> Q [Name]) -> [TyVarBndrUnit] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> [TyVarBndrUnit]
constructorVars ConstructorInfo
con
  let newNames :: [Name]
newNames = [Name]
newDataTypeVars [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
newConstructorVars
  -- newNames <- traverse (newName . nameBase . tvName) oriVars
  let newVars :: [Type]
newVars = (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]
newNames
  let substMap :: Map Name Type
substMap = [(Name, Type)] -> Map Name Type
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, Type)] -> Map Name Type)
-> [(Name, Type)] -> Map Name Type
forall a b. (a -> b) -> a -> b
$ [Name] -> [Type] -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip (TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName (TyVarBndrUnit -> Name) -> [TyVarBndrUnit] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndrUnit]
oriVars) [Type]
newVars
  let fields :: [(Integer, Type)]
fields =
        [Integer] -> [Type] -> [(Integer, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0 ..] ([Type] -> [(Integer, Type)]) -> [Type] -> [(Integer, Type)]
forall a b. (a -> b) -> a -> b
$
          Map Name Type -> [Type] -> [Type]
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
substMap ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$
            ConstructorInfo -> [Type]
constructorFields ConstructorInfo
con
  let tyFields :: [Type]
tyFields =
        Type -> Type -> Type
AppT (Name -> Type
ConT ''TypeRep)
          (Type -> Type) -> [Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name Type -> [Type] -> [Type]
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution
            Map Name Type
substMap
            ((Name -> Type
VarT (Name -> Type) -> (TyVarBndrUnit -> Name) -> TyVarBndrUnit -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName) (TyVarBndrUnit -> Type) -> [TyVarBndrUnit] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConstructorInfo -> [TyVarBndrUnit]
constructorVars ConstructorInfo
con)
  let strategyFields :: [Type]
strategyFields = ((Integer, Type) -> Type) -> [(Integer, 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
AppT (Name -> Type
ConT ''MergingStrategy) (Type -> Type)
-> ((Integer, Type) -> Type) -> (Integer, Type) -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer, Type) -> Type
forall a b. (a, b) -> b
snd) [(Integer, Type)]
fields
  [Name]
tyFieldNamesL <- (Type -> Q Name) -> [Type] -> 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 (Q Name -> Type -> Q Name
forall a b. a -> b -> a
const (Q Name -> Type -> Q Name) -> Q Name -> Type -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"p") [Type]
tyFields
  [Name]
tyFieldNamesR <- (Type -> Q Name) -> [Type] -> 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 (Q Name -> Type -> Q Name
forall a b. a -> b -> a
const (Q Name -> Type -> Q Name) -> Q Name -> Type -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"p") [Type]
tyFields
  let tyFieldPatsL :: [Q Pat]
tyFieldPatsL = (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]
tyFieldNamesL
  let tyFieldPatsR :: [Q Pat]
tyFieldPatsR = (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]
tyFieldNamesR
  let tyFieldVarsL :: [Q Exp]
tyFieldVarsL = (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
tyFieldNamesL
  let tyFieldVarsR :: [Q Exp]
tyFieldVarsR = (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
tyFieldNamesR
  let strategyFieldPats :: [Q Pat]
strategyFieldPats = Int -> Q Pat -> [Q Pat]
forall a. Int -> a -> [a]
replicate ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
strategyFields) Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP
  let patsL :: [Q Pat]
patsL = [Q Pat]
tyFieldPatsL [Q Pat] -> [Q Pat] -> [Q Pat]
forall a. [a] -> [a] -> [a]
++ [Q Pat]
strategyFieldPats
  let patsR :: [Q Pat]
patsR = [Q Pat]
tyFieldPatsR [Q Pat] -> [Q Pat] -> [Q Pat]
forall a. [a] -> [a] -> [a]
++ [Q Pat]
strategyFieldPats
  let allWildcards :: [Q Pat]
allWildcards = (Q Pat -> Q Pat) -> [Q Pat] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Q Pat -> Q Pat -> Q Pat
forall a b. a -> b -> a
const Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP) ([Q Pat] -> [Q Pat]) -> [Q Pat] -> [Q Pat]
forall a b. (a -> b) -> a -> b
$ [Q Pat]
tyFieldPatsL [Q Pat] -> [Q Pat] -> [Q Pat]
forall a. [a] -> [a] -> [a]
++ [Q Pat]
strategyFieldPats
  let eqCont :: m Exp -> m Exp -> m Exp -> m Exp
eqCont m Exp
l m Exp
r m Exp
cont =
        [|
          SomeTypeRep $m Exp
l == SomeTypeRep $m Exp
r
            && $m Exp
cont
          |]
  let eqExp :: Q Exp
eqExp =
        (Q Exp -> (Q Exp, Q Exp) -> Q Exp)
-> Q Exp -> [(Q Exp, Q 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
cont (Q Exp
l, Q Exp
r) -> Q Exp -> Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp -> m Exp
eqCont Q Exp
l Q Exp
r Q Exp
cont) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'True) ([(Q Exp, Q Exp)] -> Q Exp) -> [(Q Exp, Q Exp)] -> Q Exp
forall a b. (a -> b) -> a -> b
$
          [Q Exp] -> [Q Exp] -> [(Q Exp, Q Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Q Exp]
tyFieldVarsL [Q Exp]
tyFieldVarsR
  Clause
eqClause <-
    [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
      [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
newConName [Q Pat]
patsL, Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
newConName [Q Pat]
patsR]
      (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
eqExp)
      []
  let cmpCont :: m Exp -> m Exp -> m Exp -> m Exp
cmpCont m Exp
l m Exp
r m Exp
cont =
        [|
          case SomeTypeRep $m Exp
l `compare` SomeTypeRep $m Exp
r of
            EQ -> $m Exp
cont
            x -> x
          |]
  let cmpExp :: Q Exp
cmpExp =
        (Q Exp -> (Q Exp, Q Exp) -> Q Exp)
-> Q Exp -> [(Q Exp, Q 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
cont (Q Exp
l, Q Exp
r) -> Q Exp -> Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp -> m Exp
cmpCont Q Exp
l Q Exp
r Q Exp
cont) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'EQ) ([(Q Exp, Q Exp)] -> Q Exp) -> [(Q Exp, Q Exp)] -> Q Exp
forall a b. (a -> b) -> a -> b
$
          [Q Exp] -> [Q Exp] -> [(Q Exp, Q Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Q Exp]
tyFieldVarsL [Q Exp]
tyFieldVarsR
  Clause
cmpClause0 <-
    [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
      [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
newConName [Q Pat]
patsL, Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
newConName [Q Pat]
patsR]
      (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
cmpExp)
      []
  Clause
cmpClause1 <-
    [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
      [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
newConName [Q Pat]
allWildcards, Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP]
      (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
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'LT)
      []
  Clause
cmpClause2 <-
    [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
      [Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP, Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
newConName [Q Pat]
allWildcards]
      (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
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'GT)
      []
  let cmpClauses :: [Clause]
cmpClauses =
        if Bool
isLast
          then [Clause
cmpClause0]
          else [Clause
cmpClause0, Clause
cmpClause1, Clause
cmpClause2]
  let showCont :: m Exp -> m Exp -> m Exp
showCont m Exp
t m Exp
cont =
        [|$m Exp
cont <> " " <> show $m Exp
t|]
  let showExp :: Q Exp
showExp = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q 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 -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp
forall a b c. (a -> b -> c) -> b -> a -> c
flip Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
showCont) (Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL String
conName) [Q Exp]
tyFieldVarsL
  Clause
showClause <-
    [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
      [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
newConName [Q Pat]
patsL]
      (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
showExp)
      []
  let ctx :: [Type]
ctx = Map Name Type -> [Type] -> [Type]
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
substMap ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> [Type]
constructorContext ConstructorInfo
con
  let ctxAndGadtUsedVars :: Set Name
ctxAndGadtUsedVars =
        [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList ([Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type]
ctx)
          Set Name -> Set Name -> Set Name
forall a. Semigroup a => a -> a -> a
<> [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList ([Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type]
tyFields)
          Set Name -> Set Name -> Set Name
forall a. Semigroup a => a -> a -> a
<> [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList ([Type] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [Type]
strategyFields)
  let isCtxAndGadtUsedVar :: Name -> Bool
isCtxAndGadtUsedVar Name
nm = Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Name
nm Set Name
ctxAndGadtUsedVars
  (Con, Name, [Clause], [Clause], [Clause])
-> Q (Con, Name, [Clause], [Clause], [Clause])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( [TyVarBndr Specificity] -> [Type] -> Con -> Con
ForallC
        ( (Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr_ flag
`plainTVFlag` Specificity
specifiedSpec)
            (Name -> TyVarBndr Specificity)
-> [Name] -> [TyVarBndr Specificity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter Name -> Bool
isCtxAndGadtUsedVar [Name]
newDataTypeVars [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
newConstructorVars
        )
        [Type]
ctx
        (Con -> Con) -> Con -> Con
forall a b. (a -> b) -> a -> b
$ [Name] -> [BangType] -> Type -> Con
GadtC
          [Name
newConName]
          ( (SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness,)
              (Type -> BangType) -> [Type] -> [BangType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
tyFields [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
strategyFields
          )
          (Name -> Type
ConT Name
tyName),
      Name
newConName,
      [Clause
eqClause],
      [Clause]
cmpClauses,
      [Clause
showClause]
    )

data MergingInfoResult = MergingInfoResult
  { MergingInfoResult -> Name
_infoName :: Name,
    MergingInfoResult -> [Name]
_conInfoNames :: [Name]
  }

genMergingInfo :: Name -> Q (MergingInfoResult, [Dec])
genMergingInfo :: Name -> Q (MergingInfoResult, [Dec])
genMergingInfo Name
typName = do
  DatatypeInfo
d <- Name -> Q DatatypeInfo
reifyDatatype Name
typName
  let originalName :: String
originalName = Name -> String
mangleName (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> Name
datatypeName DatatypeInfo
d
  let newName :: String
newName = String
originalName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"MergingInfo"
  Maybe Name
found <- String -> Q (Maybe Name)
lookupTypeName String
newName
  let constructors :: [ConstructorInfo]
constructors = DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
d
  let name :: Name
name = String -> Name
mkName String
newName
  [(Con, Name, [Clause], [Clause], [Clause])]
r <-
    if [ConstructorInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConstructorInfo]
constructors
      then [(Con, Name, [Clause], [Clause], [Clause])]
-> Q [(Con, Name, [Clause], [Clause], [Clause])]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
      else do
        [(Con, Name, [Clause], [Clause], [Clause])]
cons0 <-
          (ConstructorInfo -> Q (Con, Name, [Clause], [Clause], [Clause]))
-> [ConstructorInfo]
-> Q [(Con, Name, [Clause], [Clause], [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 ([TyVarBndrUnit]
-> Name
-> Bool
-> ConstructorInfo
-> Q (Con, Name, [Clause], [Clause], [Clause])
genMergingInfoCon (DatatypeInfo -> [TyVarBndrUnit]
datatypeVars DatatypeInfo
d) Name
name Bool
False) ([ConstructorInfo]
 -> Q [(Con, Name, [Clause], [Clause], [Clause])])
-> [ConstructorInfo]
-> Q [(Con, Name, [Clause], [Clause], [Clause])]
forall a b. (a -> b) -> a -> b
$
            [ConstructorInfo] -> [ConstructorInfo]
forall a. HasCallStack => [a] -> [a]
init [ConstructorInfo]
constructors
        (Con, Name, [Clause], [Clause], [Clause])
consLast <-
          [TyVarBndrUnit]
-> Name
-> Bool
-> ConstructorInfo
-> Q (Con, Name, [Clause], [Clause], [Clause])
genMergingInfoCon (DatatypeInfo -> [TyVarBndrUnit]
datatypeVars DatatypeInfo
d) Name
name Bool
True (ConstructorInfo -> Q (Con, Name, [Clause], [Clause], [Clause]))
-> ConstructorInfo -> Q (Con, Name, [Clause], [Clause], [Clause])
forall a b. (a -> b) -> a -> b
$
            [ConstructorInfo] -> ConstructorInfo
forall a. HasCallStack => [a] -> a
last [ConstructorInfo]
constructors
        [(Con, Name, [Clause], [Clause], [Clause])]
-> Q [(Con, Name, [Clause], [Clause], [Clause])]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Con, Name, [Clause], [Clause], [Clause])]
 -> Q [(Con, Name, [Clause], [Clause], [Clause])])
-> [(Con, Name, [Clause], [Clause], [Clause])]
-> Q [(Con, Name, [Clause], [Clause], [Clause])]
forall a b. (a -> b) -> a -> b
$ [(Con, Name, [Clause], [Clause], [Clause])]
cons0 [(Con, Name, [Clause], [Clause], [Clause])]
-> [(Con, Name, [Clause], [Clause], [Clause])]
-> [(Con, Name, [Clause], [Clause], [Clause])]
forall a. [a] -> [a] -> [a]
++ [(Con, Name, [Clause], [Clause], [Clause])
consLast]
  let cons :: [Con]
cons = ((Con, Name, [Clause], [Clause], [Clause]) -> Con)
-> [(Con, Name, [Clause], [Clause], [Clause])] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Con
a, Name
_, [Clause]
_, [Clause]
_, [Clause]
_) -> Con
a) [(Con, Name, [Clause], [Clause], [Clause])]
r
  let eqClauses :: [Clause]
eqClauses =
        ((Con, Name, [Clause], [Clause], [Clause]) -> [Clause])
-> [(Con, Name, [Clause], [Clause], [Clause])] -> [Clause]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Con
_, Name
_, [Clause]
a, [Clause]
_, [Clause]
_) -> [Clause]
a) [(Con, Name, [Clause], [Clause], [Clause])]
r
          [Clause] -> [Clause] -> [Clause]
forall a. [a] -> [a] -> [a]
++ [ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP, Pat
WildP] (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE 'False) []
             | [ConstructorInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
constructors Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
             ]
  let cmpClauses :: [Clause]
cmpClauses = ((Con, Name, [Clause], [Clause], [Clause]) -> [Clause])
-> [(Con, Name, [Clause], [Clause], [Clause])] -> [Clause]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Con
_, Name
_, [Clause]
_, [Clause]
a, [Clause]
_) -> [Clause]
a) [(Con, Name, [Clause], [Clause], [Clause])]
r
  let showClauses :: [Clause]
showClauses = ((Con, Name, [Clause], [Clause], [Clause]) -> [Clause])
-> [(Con, Name, [Clause], [Clause], [Clause])] -> [Clause]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Con
_, Name
_, [Clause]
_, [Clause]
_, [Clause]
a) -> [Clause]
a) [(Con, Name, [Clause], [Clause], [Clause])]
r
  (MergingInfoResult, [Dec]) -> Q (MergingInfoResult, [Dec])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( Name -> [Name] -> MergingInfoResult
MergingInfoResult
        Name
name
        (((Con, Name, [Clause], [Clause], [Clause]) -> Name)
-> [(Con, Name, [Clause], [Clause], [Clause])] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Con
_, Name
a, [Clause]
_, [Clause]
_, [Clause]
_) -> Name
a) [(Con, Name, [Clause], [Clause], [Clause])]
r),
      if Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust Maybe Name
found
        then []
        else
          [ [Type]
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
name [] Maybe Type
forall a. Maybe a
Nothing [Con]
cons [],
            Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD
              Maybe Overlap
forall a. Maybe a
Nothing
              []
              (Name -> Type
ConT ''Eq Type -> Type -> Type
`AppT` Name -> Type
ConT Name
name)
              [Name -> [Clause] -> Dec
FunD '(==) [Clause]
eqClauses],
            Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD
              Maybe Overlap
forall a. Maybe a
Nothing
              []
              (Name -> Type
ConT ''Ord Type -> Type -> Type
`AppT` Name -> Type
ConT Name
name)
              [Name -> [Clause] -> Dec
FunD 'compare [Clause]
cmpClauses],
            Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD
              Maybe Overlap
forall a. Maybe a
Nothing
              []
              (Name -> Type
ConT ''Show Type -> Type -> Type
`AppT` Name -> Type
ConT Name
name)
              [Name -> [Clause] -> Dec
FunD 'show [Clause]
showClauses]
          ]
    )

-- | Generate 'Mergeable' instance and merging information for a data type.
genMergeableAndGetMergingInfoResult ::
  DeriveConfig -> Name -> Int -> Q (MergingInfoResult, [Dec])
genMergeableAndGetMergingInfoResult :: DeriveConfig -> Name -> Int -> Q (MergingInfoResult, [Dec])
genMergeableAndGetMergingInfoResult DeriveConfig
deriveConfig Name
typName Int
n = do
  (MergingInfoResult
infoResult, [Dec]
infoDec) <- Name -> Q (MergingInfoResult, [Dec])
genMergingInfo Name
typName
  (Name
_, [Dec]
decs) <- DeriveConfig -> MergingInfoResult -> Name -> Int -> Q (Name, [Dec])
genMergeable' DeriveConfig
deriveConfig MergingInfoResult
infoResult Name
typName Int
n
  (MergingInfoResult, [Dec]) -> Q (MergingInfoResult, [Dec])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (MergingInfoResult
infoResult, [Dec]
infoDec [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
decs)

constructMergingStrategyExp :: ConstructorInfo -> [Exp] -> Q Exp
constructMergingStrategyExp :: ConstructorInfo -> [Exp] -> Q Exp
constructMergingStrategyExp ConstructorInfo
_ [] = [|SimpleStrategy $ \_ t _ -> t|]
constructMergingStrategyExp ConstructorInfo
conInfo [Exp
x] = do
  Name
upname <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
  let unwrapPat :: Q Pat
unwrapPat = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (ConstructorInfo -> Name
constructorName ConstructorInfo
conInfo) [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
upname]
  let unwrapFun :: Q Exp
unwrapFun = [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Q Pat
unwrapPat] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'unsafeCoerce) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
upname)
  [|
    wrapStrategy
      $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x)
      (unsafeCoerce . $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> Name
constructorName ConstructorInfo
conInfo))
      $Q Exp
unwrapFun
    |]
constructMergingStrategyExp ConstructorInfo
conInfo [Exp]
l = do
  let takeHalf :: [a] -> [a]
takeHalf [a]
l = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [a]
l
  let dropHalf :: [a] -> [a]
dropHalf [a]
l = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [a]
l
  let num :: Int
num = [Exp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp]
l
  [Name]
upnames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
num (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
"a"
  let wrapPat1 :: [Name] -> m Pat
wrapPat1 [] = String -> m Pat
forall a. HasCallStack => String -> a
error String
"Should not happen"
      wrapPat1 [Name
x] = Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x
      wrapPat1 [Name]
l = [m Pat] -> m Pat
forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [[Name] -> m Pat
wrapPat1 ([Name] -> [Name]
forall {a}. [a] -> [a]
takeHalf [Name]
l), [Name] -> m Pat
wrapPat1 ([Name] -> [Name]
forall {a}. [a] -> [a]
dropHalf [Name]
l)]
  let wrapped :: Exp
wrapped = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> Name
constructorName ConstructorInfo
conInfo) ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (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]
upnames
  let wrapFun :: Q Exp
wrapFun =
        [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE
          [[Name] -> Q Pat
forall {m :: * -> *}. Quote m => [Name] -> m Pat
wrapPat1 ([Name] -> [Name]
forall {a}. [a] -> [a]
takeHalf [Name]
upnames), [Name] -> Q Pat
forall {m :: * -> *}. Quote m => [Name] -> m Pat
wrapPat1 ([Name] -> [Name]
forall {a}. [a] -> [a]
dropHalf [Name]
upnames)]
          [|unsafeCoerce ($(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
wrapped))|]
  let unwrapPat :: Q Pat
unwrapPat = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (ConstructorInfo -> Name
constructorName ConstructorInfo
conInfo) ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (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]
upnames
  let unwrapExp1 :: [Name] -> m Exp
unwrapExp1 [] = String -> m Exp
forall a. HasCallStack => String -> a
error String
"Should not happen"
      unwrapExp1 [Name
x] = [|(unsafeCoerce $(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x))|]
      unwrapExp1 [Name]
l = [|($([Name] -> m Exp
unwrapExp1 ([Name] -> [Name]
forall {a}. [a] -> [a]
takeHalf [Name]
l)), $([Name] -> m Exp
unwrapExp1 ([Name] -> [Name]
forall {a}. [a] -> [a]
dropHalf [Name]
l)))|]
  let unwrapFun :: Q Exp
unwrapFun = [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Q Pat
unwrapPat] ([Name] -> Q Exp
forall {m :: * -> *}. Quote m => [Name] -> m Exp
unwrapExp1 [Name]
upnames)
  let strategyx :: [Exp] -> m Exp
strategyx [] = String -> m Exp
forall a. HasCallStack => String -> a
error String
"Should not happen"
      strategyx [Exp
x] = Exp -> m Exp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x
      strategyx [Exp]
l =
        [|product2Strategy (,) id $([Exp] -> m Exp
strategyx ([Exp] -> [Exp]
forall {a}. [a] -> [a]
takeHalf [Exp]
l)) $([Exp] -> m Exp
strategyx ([Exp] -> [Exp]
forall {a}. [a] -> [a]
dropHalf [Exp]
l))|]
  [|
    product2Strategy
      $Q Exp
wrapFun
      $Q Exp
unwrapFun
      $([Exp] -> Q Exp
forall {m :: * -> *}. Quote m => [Exp] -> m Exp
strategyx ([Exp] -> Q Exp) -> [Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> [Exp]
forall {a}. [a] -> [a]
takeHalf [Exp]
l)
      $([Exp] -> Q Exp
forall {m :: * -> *}. Quote m => [Exp] -> m Exp
strategyx ([Exp] -> Q Exp) -> [Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> [Exp]
forall {a}. [a] -> [a]
dropHalf [Exp]
l)
    |]

genMergeFunClause' :: Name -> ConstructorInfo -> Q Clause
genMergeFunClause' :: Name -> ConstructorInfo -> Q Clause
genMergeFunClause' Name
conInfoName ConstructorInfo
con = do
  let numExistential :: Int
numExistential = [TyVarBndrUnit] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TyVarBndrUnit] -> Int) -> [TyVarBndrUnit] -> Int
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> [TyVarBndrUnit]
constructorVars ConstructorInfo
con
  let numFields :: Int
numFields = [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Type] -> Int) -> [Type] -> Int
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> [Type]
constructorFields ConstructorInfo
con
  let argWildCards :: [Q Pat]
argWildCards = Int -> Q Pat -> [Q Pat]
forall a. Int -> a -> [a]
replicate Int
numExistential Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP :: [Q Pat]

  [Name]
pnames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
numFields (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
"s"
  [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
    ([Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conInfoName ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ [Q Pat]
argWildCards [Q Pat] -> [Q Pat] -> [Q Pat]
forall a. [a] -> [a] -> [a]
++ (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]
pnames])
    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (ConstructorInfo -> [Exp] -> Q Exp
constructMergingStrategyExp ConstructorInfo
con ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
pnames)))
    []

constructVarPats :: ConstructorInfo -> Q Pat
constructVarPats :: ConstructorInfo -> Q Pat
constructVarPats ConstructorInfo
conInfo = do
  let fields :: [Type]
fields = ConstructorInfo -> [Type]
constructorFields ConstructorInfo
conInfo
      capture :: Int -> m Pat
capture Int
n = Pat -> m Pat
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat -> m Pat) -> Pat -> m Pat
forall a b. (a -> b) -> a -> b
$ Pat -> Type -> Pat
SigP Pat
WildP (Type -> Pat) -> Type -> Pat
forall a b. (a -> b) -> a -> b
$ [Type]
fields [Type] -> Int -> Type
forall a. HasCallStack => [a] -> Int -> a
!! Int
n
  Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (ConstructorInfo -> Name
constructorName ConstructorInfo
conInfo) ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ Int -> Q Pat
forall {m :: * -> *}. Monad m => Int -> m Pat
capture (Int -> Q Pat) -> [Int] -> [Q Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
0 .. [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
fields Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]

genMergingInfoFunClause' ::
  [(Type, Kind)] -> Name -> ConstructorInfo -> Q Clause
genMergingInfoFunClause' :: [(Type, Type)] -> Name -> ConstructorInfo -> Q Clause
genMergingInfoFunClause' [(Type, Type)]
argTypes Name
conInfoName ConstructorInfo
con = do
  let conVars :: [TyVarBndrUnit]
conVars = ConstructorInfo -> [TyVarBndrUnit]
constructorVars ConstructorInfo
con
  [Exp]
capturedVarTyReps <-
    (TyVarBndrUnit -> Q Exp) -> [TyVarBndrUnit] -> 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 (\TyVarBndrUnit
bndr -> [|typeRep @($(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndrUnit
bndr))|]) [TyVarBndrUnit]
conVars
  Pat
varPat <- ConstructorInfo -> Q Pat
constructVarPats ConstructorInfo
con
  let infoExpWithTypeReps :: Exp
infoExpWithTypeReps = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
conInfoName) [Exp]
capturedVarTyReps

  let fields :: [Type]
fields = ConstructorInfo -> [Type]
constructorFields ConstructorInfo
con
  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)]
strategyNames <-
    ((Type, Type) -> Q (Name, Maybe Name))
-> [(Type, Type)] -> 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
      ( \(Type
ty, Type
_) ->
          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, 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)
            Type
_ -> (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)
      )
      [(Type, Type)]
argTypes
  let argToStrategyPat :: [(Name, Name)]
argToStrategyPat =
        ((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)]
strategyNames
  let strategyPats :: [Pat]
strategyPats = ((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)]
strategyNames

  let argNameSet :: Set Name
argNameSet =
        [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, Type) -> Maybe Name) -> [(Type, Type)] -> [Name]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
            ( \(Type
ty, Type
_) -> case Type
ty of
                VarT Name
nm -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
nm
                Type
_ -> Maybe Name
forall a. Maybe a
Nothing
            )
            [(Type, Type)]
argTypes
  let containsArg :: Type -> Bool
      containsArg :: Type -> Bool
containsArg Type
ty =
        Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
S.intersection Set Name
argNameSet ([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 -> Bool
forall a. Eq a => a -> a -> Bool
/= Set Name
forall a. Set a
S.empty
  let typeHasNoArg :: Type -> Bool
typeHasNoArg = Bool -> Bool
not (Bool -> Bool) -> (Type -> Bool) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Bool
containsArg

  let fieldStrategyExp :: Type -> m Exp
fieldStrategyExp Type
ty =
        if Bool -> Bool
not (Type -> Bool
containsArg Type
ty)
          then [|rootStrategy :: MergingStrategy $(Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)|]
          else case Type
ty of
            Type
_
              | Type -> Bool
typeHasNoArg Type
ty ->
                  [|rootStrategy :: MergingStrategy $(Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)|]
            AppT Type
a Type
b
              | Type -> Bool
typeHasNoArg Type
a ->
                  [|
                    liftRootStrategy
                      $(Type -> m Exp
fieldStrategyExp Type
b) ::
                      MergingStrategy $(Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)
                    |]
            AppT (AppT Type
a Type
b) Type
c
              | Type -> Bool
typeHasNoArg Type
a ->
                  [|
                    liftRootStrategy2
                      $(Type -> m Exp
fieldStrategyExp Type
b)
                      $(Type -> m Exp
fieldStrategyExp Type
c) ::
                      MergingStrategy $(Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)
                    |]
            AppT (AppT (AppT Type
a Type
b) Type
c) Type
d
              | Type -> Bool
typeHasNoArg Type
a ->
                  [|
                    liftRootStrategy3
                      $(Type -> m Exp
fieldStrategyExp Type
b)
                      $(Type -> m Exp
fieldStrategyExp Type
c)
                      $(Type -> m Exp
fieldStrategyExp Type
d) ::
                      MergingStrategy $(Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)
                    |]
            VarT Name
nm -> do
              case Name -> [(Name, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
nm [(Name, Name)]
argToStrategyPat 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
"BUG: fieldStrategyExp"
            Type
_ -> 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
"fieldStrategyExp: unsupported type: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
ty
  [Exp]
fieldStrategyExps <- (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 Type -> Q Exp
forall {m :: * -> *}. (Quote m, MonadFail m) => Type -> m Exp
fieldStrategyExp [Type]
fields
  let infoExp :: Exp
infoExp = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE Exp
infoExpWithTypeReps [Exp]
fieldStrategyExps
  -- fail $ show infoExp
  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]
strategyPats [Pat] -> [Pat] -> [Pat]
forall a. [a] -> [a] -> [a]
++ [Pat
varPat]) (Exp -> Body
NormalB Exp
infoExp) []

mergeableFieldFunExp :: [Name] -> FieldFunExp
mergeableFieldFunExp :: [Name] -> FieldFunExp
mergeableFieldFunExp [Name]
unaryOpFunNames Map Name Name
argToFunPat Map Name [Name]
_ = Type -> Q Exp
forall {m :: * -> *}. (MonadFail m, Quote m) => Type -> m Exp
go
  where
    go :: Type -> m 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 :: 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 fun0a :: Type -> m Exp
fun0a Type
a = [|$(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]
unaryOpFunNames) @($(Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
a))|]
          fun1a :: Type -> Type -> m Exp
fun1a Type
a Type
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]
unaryOpFunNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
1) @($(Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
a)) $(Type -> m Exp
go Type
b)|]
          fun2a :: Type -> Type -> Type -> m Exp
fun2a Type
a Type
b Type
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]
unaryOpFunNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
2)
                @($(Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
a))
                $(Type -> m Exp
go Type
b)
                $(Type -> m Exp
go Type
c)
              |]
          fun3a :: Type -> Type -> Type -> Type -> m Exp
fun3a Type
a Type
b Type
c Type
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]
unaryOpFunNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
3)
                @($(Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
a))
                $(Type -> m Exp
go Type
b)
                $(Type -> m Exp
go Type
c)
                $(Type -> m Exp
go Type
d)
              |]

      case Type
ty of
        AppT (AppT (AppT a :: Type
a@(VarT Name
_) Type
b) Type
c) Type
d -> Type -> Type -> Type -> Type -> m Exp
fun3a Type
a Type
b Type
c Type
d
        AppT (AppT a :: Type
a@(VarT Name
_) Type
b) Type
c -> Type -> Type -> Type -> m Exp
fun2a Type
a Type
b Type
c
        AppT a :: Type
a@(VarT Name
_) Type
b -> Type -> Type -> m Exp
fun1a Type
a Type
b
        Type
_ | Type -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Type
ty -> Type -> m Exp
forall {m :: * -> *}. Quote m => Type -> m Exp
fun0a Type
ty
        AppT Type
a Type
b | Type -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Type
a -> Type -> Type -> m Exp
fun1a Type
a Type
b
        AppT (AppT Type
a Type
b) Type
c | Type -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Type
a -> Type -> Type -> Type -> m Exp
fun2a Type
a Type
b Type
c
        AppT (AppT (AppT Type
a Type
b) Type
c) Type
d | Type -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Type
a -> Type -> Type -> Type -> Type -> m Exp
fun3a Type
a 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 -> 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
<> Type -> String
forall a. Show a => a -> String
show Type
ty
        Type
_ -> 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
<> Type -> String
forall a. Show a => a -> String
show Type
ty

mergeableInstanceNames :: [Name]
mergeableInstanceNames :: [Name]
mergeableInstanceNames =
  [ ''Mergeable,
    ''Mergeable1,
    ''Mergeable2,
    ''Mergeable3
  ]

getMergeableInstanceName :: Int -> Name
getMergeableInstanceName :: Int -> Name
getMergeableInstanceName Int
n = [Name]
mergeableInstanceNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
n

rootStrategyFunNames :: [Name]
rootStrategyFunNames :: [Name]
rootStrategyFunNames =
  [ 'rootStrategy,
    'liftRootStrategy,
    'liftRootStrategy2,
    'liftRootStrategy3
  ]

getMergeableFunName :: Int -> Name
getMergeableFunName :: Int -> Name
getMergeableFunName Int
n = [Name]
rootStrategyFunNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
n

mergeableNoExistentialConfig :: UnaryOpClassConfig
mergeableNoExistentialConfig :: UnaryOpClassConfig
mergeableNoExistentialConfig =
  UnaryOpClassConfig
    { unaryOpConfigs :: [UnaryOpConfig]
unaryOpConfigs =
        [ MergeableNoExistentialConfig -> [Name] -> UnaryOpConfig
forall config.
UnaryOpFunConfig config =>
config -> [Name] -> UnaryOpConfig
UnaryOpConfig
            MergeableNoExistentialConfig
              { mergeableNoExistentialFun :: FieldFunExp
mergeableNoExistentialFun =
                  [Name] -> FieldFunExp
mergeableFieldFunExp [Name]
rootStrategyFunNames
              }
            [Name]
rootStrategyFunNames
        ],
      unaryOpInstanceNames :: [Name]
unaryOpInstanceNames =
        [''Mergeable, ''Mergeable1, ''Mergeable2, ''Mergeable3],
      unaryOpExtraVars :: DeriveConfig -> Q [(Type, Type)]
unaryOpExtraVars = Q [(Type, Type)] -> DeriveConfig -> Q [(Type, Type)]
forall a b. a -> b -> a
const (Q [(Type, Type)] -> DeriveConfig -> Q [(Type, Type)])
-> Q [(Type, Type)] -> DeriveConfig -> Q [(Type, Type)]
forall a b. (a -> b) -> a -> b
$ [(Type, Type)] -> Q [(Type, Type)]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [],
      unaryOpInstanceTypeFromConfig :: DeriveConfig -> [(Type, Type)] -> [(Type, Type)] -> Name -> Q Type
unaryOpInstanceTypeFromConfig = DeriveConfig -> [(Type, Type)] -> [(Type, Type)] -> Name -> Q Type
defaultUnaryOpInstanceTypeFromConfig,
      unaryOpAllowExistential :: Bool
unaryOpAllowExistential = Bool
False,
      unaryOpContextNames :: Maybe [Name]
unaryOpContextNames = Maybe [Name]
forall a. Maybe a
Nothing
    }

newtype MergeableNoExistentialConfig = MergeableNoExistentialConfig
  { MergeableNoExistentialConfig -> FieldFunExp
mergeableNoExistentialFun :: FieldFunExp
  }

instance UnaryOpFunConfig MergeableNoExistentialConfig where
  genUnaryOpFun :: DeriveConfig
-> MergeableNoExistentialConfig
-> [Name]
-> Int
-> [(Type, Type)]
-> [(Type, Type)]
-> [(Type, Type)]
-> (Name -> Bool)
-> [ConstructorInfo]
-> Q Dec
genUnaryOpFun
    DeriveConfig
_
    MergeableNoExistentialConfig {FieldFunExp
mergeableNoExistentialFun :: MergeableNoExistentialConfig -> FieldFunExp
mergeableNoExistentialFun :: FieldFunExp
..}
    [Name]
funNames
    Int
n
    [(Type, Type)]
_
    [(Type, Type)]
_
    [(Type, Type)]
argTypes
    Name -> Bool
_
    [ConstructorInfo]
constructors = do
      [Type]
allFields <-
        (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]) -> [ConstructorInfo] -> [Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConstructorInfo -> [Type]
constructorFields [ConstructorInfo]
constructors
      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]
allFields
      [(Name, Maybe Name)]
args <-
        ((Type, Type) -> Q (Name, Maybe Name))
-> [(Type, Type)] -> 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
          ( \(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, 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)
                Type
_ -> (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)
          )
          [(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) -> 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
      let genAuxFunExp :: ConstructorInfo -> Q Exp
genAuxFunExp 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
            [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
mergeableNoExistentialFun Map Name Name
argToFunPat Map Name [Name]
forall k a. Map k a
M.empty)
                [Type]
fields
            ConstructorInfo -> [Exp] -> Q Exp
constructMergingStrategyExp ConstructorInfo
conInfo [Exp]
defaultFieldFunExps
      [Exp]
auxExps <- (ConstructorInfo -> Q Exp) -> [ConstructorInfo] -> Q [Exp]
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 ConstructorInfo -> Q Exp
genAuxFunExp [ConstructorInfo]
constructors
      Exp
funExp <- case [Exp]
auxExps of
        [] -> [|NoStrategy|]
        [Exp
singleExp] -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
singleExp
        [Exp]
_ -> do
          Name
p <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"p"
          let numConstructors :: Int
numConstructors = [ConstructorInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
constructors
          let getIdx :: a -> Q Exp
getIdx a
i =
                if Int
numConstructors Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2
                  then if a
i a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 then [|False|] else [|True|]
                  else a -> Q Exp
forall a. Integral a => a -> Q Exp
integerE a
i
          let getIdxPat :: Integer -> m Pat
getIdxPat Integer
i =
                if Int
numConstructors Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2
                  then Name -> [m Pat] -> m Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (if Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 then 'False else 'True) []
                  else do
                    let w8Bound :: Int
w8Bound = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound @Word8)
                    let w16Bound :: Int
w16Bound = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound @Word16)
                    let w32Bound :: Int
w32Bound = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound @Word32)
                    let w64Bound :: Int
w64Bound = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound @Word64)
                    m Pat -> m Type -> m Pat
forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP
                      (Lit -> m Pat
forall (m :: * -> *). Quote m => Lit -> m Pat
litP (Integer -> Lit
integerL Integer
i))
                      ( Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> m Type) -> Name -> m Type
forall a b. (a -> b) -> a -> b
$
                          if
                            | Int
numConstructors Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
w8Bound Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 -> ''Word8
                            | Int
numConstructors Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
w16Bound Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 -> ''Word16
                            | Int
numConstructors Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
w32Bound Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 -> ''Word32
                            | Int
numConstructors Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
w64Bound Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 -> ''Word64
                            | Bool
otherwise -> ''Integer
                      )
          let idxFun :: Q Exp
idxFun =
                [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
p] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
                  Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE
                    (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
p)
                    ( (Integer -> ConstructorInfo -> Q Match)
-> [Integer] -> [ConstructorInfo] -> [Q Match]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                        ( \Integer
conIdx ConstructorInfo
conInfo -> do
                            Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
                              (Name -> [Q FieldPat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP (ConstructorInfo -> Name
constructorName ConstructorInfo
conInfo) [])
                              (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Integer -> Q Exp
forall a. Integral a => a -> Q Exp
getIdx Integer
conIdx))
                              []
                        )
                        [Integer
0 ..]
                        [ConstructorInfo]
constructors
                    )
          let auxFun :: Q Exp
auxFun =
                [Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
p] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
                  Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE
                    (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
p)
                    ( (Integer -> Exp -> Q Match) -> [Integer] -> [Exp] -> [Q Match]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                        ( \Integer
conIdx Exp
exp -> do
                            Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
                              (Integer -> Q Pat
forall {m :: * -> *}. Quote m => Integer -> m Pat
getIdxPat Integer
conIdx)
                              (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
exp))
                              []
                        )
                        [Integer
0 ..]
                        [Exp]
auxExps
                        [Q Match] -> [Q Match] -> [Q Match]
forall a. [a] -> [a] -> [a]
++ [Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|undefined|]) []]
                    )
          [|
            SortedStrategy $Q Exp
idxFun $Q Exp
auxFun
            |]
      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
          [ [Pat] -> Body -> [Dec] -> Clause
Clause
              [Pat]
funPats
              (Exp -> Body
NormalB Exp
funExp)
              []
          ]

-- | Generate 'Mergeable' instance for a data type, using a given merging info
-- result.
genMergeable' ::
  DeriveConfig -> MergingInfoResult -> Name -> Int -> Q (Name, [Dec])
genMergeable' :: DeriveConfig -> MergingInfoResult -> Name -> Int -> Q (Name, [Dec])
genMergeable' DeriveConfig
deriveConfig (MergingInfoResult Name
infoName [Name]
conInfoNames) Name
typName Int
n = 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
=<< String -> Int -> Name -> Bool -> Int -> Q CheckArgsResult
checkArgs String
"Mergeable" Int
3 Name
typName Bool
True Int
n

  DatatypeInfo
d <- Name -> Q DatatypeInfo
reifyDatatype Name
typName
  let ctxForVar :: (Type, Kind) -> Q (Maybe Pred)
      ctxForVar :: (Type, Type) -> Q (Maybe Type)
ctxForVar (Type
ty, Type
kind) = case Type
kind 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|Mergeable $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)|]
        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|Mergeable1 $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)|]
        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|Mergeable2 $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)|]
        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|Mergeable3 $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)|]
        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 Type
kind
        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
  let isTypeUsedInFields :: Type -> Bool
isTypeUsedInFields (VarT Name
nm) = CheckArgsResult -> Name -> Bool
isVarUsedInFields CheckArgsResult
result Name
nm
      isTypeUsedInFields Type
_ = Bool
False
  [Maybe Type]
mergeableContexts <-
    ((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)
ctxForVar ([(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 instanceName :: Name
instanceName = Int -> Name
getMergeableInstanceName Int
n
  let instanceHead :: Type
instanceHead = Name -> Type
ConT Name
instanceName
  [Type]
extraPreds <-
    DeriveConfig
-> Name
-> Name
-> [(Type, Type)]
-> [(Type, Type)]
-> [ConstructorInfo]
-> Q [Type]
extraConstraint
      DeriveConfig
deriveConfig
      Name
typName
      Name
instanceName
      []
      [(Type, Type)]
keptVars
      [ConstructorInfo]
constructors

  let targetType :: Type
targetType =
        (Type -> (Type, 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
ty (Type
var, Type
_) -> Type -> Type -> Type
AppT Type
ty Type
var)
          (Name -> Type
ConT Name
typName)
          ([(Type, Type)]
keptVars [(Type, Type)] -> [(Type, Type)] -> [(Type, Type)]
forall a. [a] -> [a] -> [a]
++ [(Type, Type)]
argVars)
  let infoType :: Type
infoType = Name -> Type
ConT Name
infoName
  let mergingInfoFunFinalType :: Type
mergingInfoFunFinalType = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
ArrowT Type
targetType) Type
infoType

  let mergingInfoFunTypeWithoutCtx :: Type
mergingInfoFunTypeWithoutCtx =
        ((Type, Type) -> Type -> Type) -> Type -> [(Type, Type)] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
          (((Type -> Type -> Type
AppT (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
ArrowT) (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT (Name -> Type
ConT ''MergingStrategy)) (Type -> Type -> Type)
-> ((Type, Type) -> Type) -> (Type, Type) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type, Type) -> Type
forall a b. (a, b) -> a
fst)
          Type
mergingInfoFunFinalType
          [(Type, Type)]
argVars

  let mergingInfoFunType :: Type
mergingInfoFunType =
        [TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT
          ( ((Type, Type) -> Maybe (TyVarBndr Specificity))
-> [(Type, Type)] -> [TyVarBndr Specificity]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
              ( \(Type
ty, Type
knd) -> case Type
ty of
                  VarT Name
nm -> TyVarBndr Specificity -> Maybe (TyVarBndr Specificity)
forall a. a -> Maybe a
Just (TyVarBndr Specificity -> Maybe (TyVarBndr Specificity))
-> TyVarBndr Specificity -> Maybe (TyVarBndr Specificity)
forall a b. (a -> b) -> a -> b
$ Name -> Type -> TyVarBndr Specificity
kindedTVSpecified Name
nm Type
knd
                  Type
_ -> Maybe (TyVarBndr Specificity)
forall a. Maybe a
Nothing
              )
              ([(Type, Type)] -> [TyVarBndr Specificity])
-> [(Type, Type)] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> a -> b
$ [(Type, Type)]
keptVars [(Type, Type)] -> [(Type, Type)] -> [(Type, Type)]
forall a. [a] -> [a] -> [a]
++ [(Type, Type)]
argVars
          )
          ([Type]
extraPreds [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Maybe Type] -> [Type]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Type]
mergeableContexts)
          Type
mergingInfoFunTypeWithoutCtx
  let mangledName :: String
mangledName = Name -> String
mangleName (DatatypeInfo -> Name
datatypeName DatatypeInfo
d)
  let mergingInfoFunName :: Name
mergingInfoFunName =
        String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$
          String
"mergingInfo"
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 then Int -> String
forall a. Show a => a -> String
show Int
n else String
"")
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
mangledName
  let mergingInfoFunSigD :: Dec
mergingInfoFunSigD = Name -> Type -> Dec
SigD Name
mergingInfoFunName Type
mergingInfoFunType
  [Clause]
clauses <-
    ((Name, ConstructorInfo) -> Q Clause)
-> [(Name, 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 -> ConstructorInfo -> Q Clause)
-> (Name, ConstructorInfo) -> Q Clause
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ([(Type, Type)] -> Name -> ConstructorInfo -> Q Clause
genMergingInfoFunClause' [(Type, Type)]
argVars)) ([(Name, ConstructorInfo)] -> Q [Clause])
-> [(Name, ConstructorInfo)] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$
      [Name] -> [ConstructorInfo] -> [(Name, ConstructorInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
conInfoNames [ConstructorInfo]
constructors
  let mergingInfoFunDec :: Dec
mergingInfoFunDec = Name -> [Clause] -> Dec
FunD Name
mergingInfoFunName [Clause]
clauses

  let mergeFunType :: Type
mergeFunType =
        Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
ArrowT Type
infoType) (Type -> Type -> Type
AppT (Name -> Type
ConT ''MergingStrategy) Type
targetType)
  let mergeFunName :: Name
mergeFunName =
        String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$
          String
"merge"
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 then Int -> String
forall a. Show a => a -> String
show Int
n else String
"")
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
mangledName
  let mergeFunSigD :: Dec
mergeFunSigD = Name -> Type -> Dec
SigD Name
mergeFunName Type
mergeFunType
  [Clause]
mergeFunClauses <- (Name -> ConstructorInfo -> Q Clause)
-> [Name] -> [ConstructorInfo] -> Q [Clause]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Name -> ConstructorInfo -> Q Clause
genMergeFunClause' [Name]
conInfoNames [ConstructorInfo]
constructors
  let mergeFunDec :: Dec
mergeFunDec = Name -> [Clause] -> Dec
FunD Name
mergeFunName [Clause]
mergeFunClauses

  let instanceType :: Type
instanceType =
        Type -> Type -> Type
AppT
          Type
instanceHead
          ((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)

  let mergeInstanceFunName :: Name
mergeInstanceFunName = Int -> Name
getMergeableFunName Int
n
  [Name]
mergeInstanceFunPatNames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (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
"rootStrategy"
  let mergeInstanceFunPats :: [Pat]
mergeInstanceFunPats = Name -> Pat
VarP (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
mergeInstanceFunPatNames

  Exp
mergeInstanceFunBody <-
    [|
      SortedStrategy
        $( (Exp -> Name -> Q Exp) -> Exp -> [Name] -> Q Exp
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
             (\Exp
exp Name
name -> Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
appE (Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
exp) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
name)
             (Name -> Exp
VarE Name
mergingInfoFunName)
             [Name]
mergeInstanceFunPatNames
         )
        $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
mergeFunName)
      |]

  let mergeInstanceFunClause :: Clause
mergeInstanceFunClause =
        [Pat] -> Body -> [Dec] -> Clause
Clause [Pat]
mergeInstanceFunPats (Exp -> Body
NormalB Exp
mergeInstanceFunBody) []

  (Name, [Dec]) -> Q (Name, [Dec])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( Name
mergingInfoFunName,
      [ Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
mergingInfoFunName Inline
Inline RuleMatch
FunLike Phases
AllPhases),
        Dec
mergingInfoFunSigD,
        Dec
mergingInfoFunDec,
        Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
mergeFunName Inline
Inline RuleMatch
FunLike Phases
AllPhases),
        Dec
mergeFunSigD,
        Dec
mergeFunDec,
        Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD
          Maybe Overlap
forall a. Maybe a
Nothing
          ([Type]
extraPreds [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Maybe Type] -> [Type]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Type]
mergeableContexts)
          Type
instanceType
          [Name -> [Clause] -> Dec
FunD Name
mergeInstanceFunName [Clause
mergeInstanceFunClause]]
      ]
    )

-- | Generate 'Mergeable' instance for a data type without existential variables.
genMergeableNoExistential :: DeriveConfig -> Name -> Int -> Q [Dec]
genMergeableNoExistential :: DeriveConfig -> Name -> Int -> Q [Dec]
genMergeableNoExistential DeriveConfig
deriveConfig Name
typName Int
n = do
  DeriveConfig -> UnaryOpClassConfig -> Int -> Name -> Q [Dec]
genUnaryOpClass DeriveConfig
deriveConfig UnaryOpClassConfig
mergeableNoExistentialConfig Int
n Name
typName

-- | Generate 'Mergeable' instance for a data type, using 'NoStrategy'.
genMergeableNoStrategy :: DeriveConfig -> Name -> Int -> Q [Dec]
genMergeableNoStrategy :: DeriveConfig -> Name -> Int -> Q [Dec]
genMergeableNoStrategy DeriveConfig
deriveConfig Name
typName Int
n = do
  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
=<< String -> Int -> Name -> Bool -> Int -> Q CheckArgsResult
checkArgs String
"Mergeable" Int
3 Name
typName Bool
True Int
n
  let instanceName :: Name
instanceName = Int -> Name
getMergeableInstanceName Int
n
  let instanceHead :: Type
instanceHead = Name -> Type
ConT Name
instanceName
  let instanceType :: Type
instanceType =
        Type -> Type -> Type
AppT
          Type
instanceHead
          ((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)
  let mergeInstanceFunName :: Name
mergeInstanceFunName = Int -> Name
getMergeableFunName Int
n

  let mergeInstanceFunClause :: Clause
mergeInstanceFunClause =
        [Pat] -> Body -> [Dec] -> Clause
Clause (Int -> Pat -> [Pat]
forall a. Int -> a -> [a]
replicate Int
n Pat
WildP) (Exp -> Body
NormalB (Name -> Exp
ConE 'NoStrategy)) []
  [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
instanceType
        [Name -> [Clause] -> Dec
FunD Name
mergeInstanceFunName [Clause
mergeInstanceFunClause]]
    ]

-- | Generate 'Mergeable' instance for a data type.
genMergeable :: DeriveConfig -> Name -> Int -> Q [Dec]
genMergeable :: DeriveConfig -> Name -> Int -> Q [Dec]
genMergeable DeriveConfig
deriveConfig Name
typName Int
n = do
  Bool
hasExistential <- Name -> Q Bool
dataTypeHasExistential Name
typName
  if
    | DeriveConfig -> Bool
useNoStrategy DeriveConfig
deriveConfig ->
        DeriveConfig -> Name -> Int -> Q [Dec]
genMergeableNoStrategy DeriveConfig
deriveConfig Name
typName Int
n
    | Bool
hasExistential -> do
        (MergingInfoResult
infoResult, [Dec]
infoDec) <- Name -> Q (MergingInfoResult, [Dec])
genMergingInfo Name
typName
        (Name
_, [Dec]
decs) <- DeriveConfig -> MergingInfoResult -> Name -> Int -> Q (Name, [Dec])
genMergeable' DeriveConfig
deriveConfig MergingInfoResult
infoResult Name
typName 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
$ [Dec]
infoDec [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
decs
    | Bool
otherwise -> DeriveConfig -> Name -> Int -> Q [Dec]
genMergeableNoExistential DeriveConfig
deriveConfig Name
typName Int
n

-- | Generate multiple 'Mergeable' instances for a data type.
genMergeableList :: DeriveConfig -> Name -> [Int] -> Q [Dec]
genMergeableList :: DeriveConfig -> Name -> [Int] -> Q [Dec]
genMergeableList DeriveConfig
_ Name
_ [] = [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
genMergeableList DeriveConfig
deriveConfig Name
typName [Int
n] = DeriveConfig -> Name -> Int -> Q [Dec]
genMergeable DeriveConfig
deriveConfig Name
typName Int
n
genMergeableList DeriveConfig
deriveConfig Name
typName l :: [Int]
l@(Int
n : [Int]
ns) = do
  Bool
hasExistential <- Name -> Q Bool
dataTypeHasExistential Name
typName
  if
    | DeriveConfig -> Bool
useNoStrategy DeriveConfig
deriveConfig ->
        [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Q [Dec]) -> [Int] -> 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 (DeriveConfig -> Name -> Int -> Q [Dec]
genMergeableNoStrategy DeriveConfig
deriveConfig Name
typName) [Int]
l
    | Bool
hasExistential -> do
        (MergingInfoResult
info, [Dec]
dn) <-
          DeriveConfig -> Name -> Int -> Q (MergingInfoResult, [Dec])
genMergeableAndGetMergingInfoResult
            DeriveConfig
deriveConfig
            Name
typName
            Int
n
        [(Name, [Dec])]
dns <-
          (Int -> Q (Name, [Dec])) -> [Int] -> Q [(Name, [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 (DeriveConfig -> MergingInfoResult -> Name -> Int -> Q (Name, [Dec])
genMergeable' DeriveConfig
deriveConfig MergingInfoResult
info Name
typName) [Int]
ns
        [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
$ [Dec]
dn [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ ((Name, [Dec]) -> [Dec]) -> [(Name, [Dec])] -> [Dec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name, [Dec]) -> [Dec]
forall a b. (a, b) -> b
snd [(Name, [Dec])]
dns
    | Bool
otherwise ->
        [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Q [Dec]) -> [Int] -> 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 (DeriveConfig -> Name -> Int -> Q [Dec]
genMergeableNoExistential DeriveConfig
deriveConfig Name
typName) [Int]
l

-- | Derive 'Mergeable' instance for GADT.
deriveMergeable :: DeriveConfig -> Name -> Q [Dec]
deriveMergeable :: DeriveConfig -> Name -> Q [Dec]
deriveMergeable DeriveConfig
deriveConfig Name
nm = DeriveConfig -> Name -> Int -> Q [Dec]
genMergeable DeriveConfig
deriveConfig Name
nm Int
0

-- | Derive 'Mergeable1' instance for GADT.
deriveMergeable1 :: DeriveConfig -> Name -> Q [Dec]
deriveMergeable1 :: DeriveConfig -> Name -> Q [Dec]
deriveMergeable1 DeriveConfig
deriveConfig Name
nm = DeriveConfig -> Name -> Int -> Q [Dec]
genMergeable DeriveConfig
deriveConfig Name
nm Int
1

-- | Derive 'Mergeable2' instance for GADT.
deriveMergeable2 :: DeriveConfig -> Name -> Q [Dec]
deriveMergeable2 :: DeriveConfig -> Name -> Q [Dec]
deriveMergeable2 DeriveConfig
deriveConfig Name
nm = DeriveConfig -> Name -> Int -> Q [Dec]
genMergeable DeriveConfig
deriveConfig Name
nm Int
2

-- | Derive 'Mergeable3' instance for GADT.
deriveMergeable3 :: DeriveConfig -> Name -> Q [Dec]
deriveMergeable3 :: DeriveConfig -> Name -> Q [Dec]
deriveMergeable3 DeriveConfig
deriveConfig Name
nm = DeriveConfig -> Name -> Int -> Q [Dec]
genMergeable DeriveConfig
deriveConfig Name
nm Int
3