{-# 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
  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
  newConstructorVars <-
    traverse (newName . nameBase . tvName) $ constructorVars con
  let newNames = [Name]
newDataTypeVars [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
newConstructorVars
  -- newNames <- traverse (newName . nameBase . tvName) oriVars
  let 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 = [(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] -> [(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 -> 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 = ((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
  tyFieldNamesL <- traverse (const $ newName "p") tyFields
  tyFieldNamesR <- traverse (const $ newName "p") tyFields
  let 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 = (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 = (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 = (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 = 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]
tyFieldPatsL [Q Pat] -> [Q Pat] -> [Q Pat]
forall a. [a] -> [a] -> [a]
++ [Q Pat]
strategyFieldPats
  let patsR = [Q Pat]
tyFieldPatsR [Q Pat] -> [Q Pat] -> [Q Pat]
forall a. [a] -> [a] -> [a]
++ [Q Pat]
strategyFieldPats
  let 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
l m Exp
r m Exp
cont =
        [|
          SomeTypeRep $m Exp
l == SomeTypeRep $m Exp
r
            && $m Exp
cont
          |]
  let 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
  eqClause <-
    clause
      [conP newConName patsL, conP newConName patsR]
      (normalB eqExp)
      []
  let 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 -> (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
  cmpClause0 <-
    clause
      [conP newConName patsL, conP newConName patsR]
      (normalB cmpExp)
      []
  cmpClause1 <-
    clause
      [conP newConName allWildcards, wildP]
      (normalB $ conE 'LT)
      []
  cmpClause2 <-
    clause
      [wildP, conP newConName allWildcards]
      (normalB $ conE 'GT)
      []
  let cmpClauses =
        if Bool
isLast
          then [Clause
cmpClause0]
          else [Clause
cmpClause0, Clause
cmpClause1, Clause
cmpClause2]
  let showCont m Exp
t m Exp
cont =
        [|$m Exp
cont <> " " <> show $m Exp
t|]
  let 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
  showClause <-
    clause
      [conP newConName patsL]
      (normalB showExp)
      []
  let 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 =
        [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
nm = Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Name
nm Set Name
ctxAndGadtUsedVars
  return
    ( ForallC
        ( (`plainTVFlag` specifiedSpec)
            <$> filter isCtxAndGadtUsedVar newDataTypeVars ++ newConstructorVars
        )
        ctx
        $ GadtC
          [newConName]
          ( (Bang NoSourceUnpackedness NoSourceStrictness,)
              <$> tyFields ++ strategyFields
          )
          (ConT tyName),
      newConName,
      [eqClause],
      cmpClauses,
      [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
  d <- Name -> Q DatatypeInfo
reifyDatatype Name
typName
  let originalName = Name -> String
mangleName (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> Name
datatypeName DatatypeInfo
d
  let newName = String
originalName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"MergingInfo"
  found <- lookupTypeName newName
  let constructors = DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
d
  let name = String -> Name
mkName String
newName
  r <-
    if null constructors
      then return []
      else do
        cons0 <-
          traverse (genMergingInfoCon (datatypeVars d) name False) $
            init constructors
        consLast <-
          genMergingInfoCon (datatypeVars d) name True $
            last constructors
        return $ cons0 ++ [consLast]
  let 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 =
        ((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 = ((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 = ((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
  return
    ( MergingInfoResult
        name
        (fmap (\(Con
_, Name
a, [Clause]
_, [Clause]
_, [Clause]
_) -> Name
a) r),
      if isJust found
        then []
        else
          [ DataD [] name [] Nothing cons [],
            InstanceD
              Nothing
              []
              (ConT ''Eq `AppT` ConT name)
              [FunD '(==) eqClauses],
            InstanceD
              Nothing
              []
              (ConT ''Ord `AppT` ConT name)
              [FunD 'compare cmpClauses],
            InstanceD
              Nothing
              []
              (ConT ''Show `AppT` ConT name)
              [FunD 'show 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
  (infoResult, infoDec) <- Name -> Q (MergingInfoResult, [Dec])
genMergingInfo Name
typName
  (_, decs) <- genMergeable' deriveConfig infoResult typName n
  return (infoResult, infoDec ++ decs)

constructMergingStrategyExp :: ConstructorInfo -> [Exp] -> Q Exp
constructMergingStrategyExp :: ConstructorInfo -> [Exp] -> Q Exp
constructMergingStrategyExp ConstructorInfo
_ [] = [|SimpleStrategy $ \_ t _ -> t|]
constructMergingStrategyExp ConstructorInfo
conInfo [Exp
x] = do
  upname <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
  let 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 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
      $(return x)
      (unsafeCoerce . $(conE $ constructorName conInfo))
      $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
  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 [] = 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 -> 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 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 = 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 [] = 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 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 [] = 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
      $wrapFun
      $unwrapFun
      $(strategyx $ takeHalf l)
      $(strategyx $ dropHalf 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]

  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"
  clause
    ([conP conInfoName $ argWildCards ++ fmap varP pnames])
    (normalB (constructMergingStrategyExp con (map VarE 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
  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
  varPat <- constructVarPats con
  let 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 = ConstructorInfo -> [Type]
constructorFields ConstructorInfo
con
  let 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

  strategyNames <-
    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
                  pname <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"p"
                  return (nm, Just 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)
      )
      argTypes
  let 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 = ((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 =
        [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
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 = 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
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
  fieldStrategyExps <- traverse fieldStrategyExp fields
  let 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
  return $ Clause (strategyPats ++ [varPat]) (NormalB 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
      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 = [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
      args <-
        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
                      pname <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"p"
                      return (nm, Just 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)
          )
          argTypes
      let 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 = ((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
conInfo = do
            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
            defaultFieldFunExps <-
              traverse
                (mergeableNoExistentialFun argToFunPat M.empty)
                fields
            constructMergingStrategyExp conInfo defaultFieldFunExps
      auxExps <- mapM genAuxFunExp constructors
      funExp <- case 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
          p <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"p"
          let numConstructors = [ConstructorInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
constructors
          let 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
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 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 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 $idxFun $auxFun
            |]
      let instanceFunName = [Name]
funNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
n
      return $
        FunD
          instanceFunName
          [ Clause
              funPats
              (NormalB 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 {..} <-
    [(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

  d <- reifyDatatype typName
  let ctxForVar :: (Type, Kind) -> Q (Maybe Pred)
      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 (VarT Name
nm) = CheckArgsResult -> Name -> Bool
isVarUsedInFields CheckArgsResult
result Name
nm
      isTypeUsedInFields Type
_ = Bool
False
  mergeableContexts <-
    traverse ctxForVar $
      filter (isTypeUsedInFields . fst) $
        fmap snd $
          filter (not . (`elem` unconstrainedPositions deriveConfig) . fst) $
            zip [0 ..] keptVars

  let instanceName = Int -> Name
getMergeableInstanceName Int
n
  let instanceHead = Name -> Type
ConT Name
instanceName
  extraPreds <-
    extraConstraint
      deriveConfig
      typName
      instanceName
      []
      keptVars
      constructors

  let 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 = Name -> Type
ConT Name
infoName
  let mergingInfoFunFinalType = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
ArrowT Type
targetType) Type
infoType

  let 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 =
        [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 = Name -> String
mangleName (DatatypeInfo -> Name
datatypeName DatatypeInfo
d)
  let 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 = Name -> Type -> Dec
SigD Name
mergingInfoFunName Type
mergingInfoFunType
  clauses <-
    traverse (uncurry (genMergingInfoFunClause' argVars)) $
      zip conInfoNames constructors
  let mergingInfoFunDec = Name -> [Clause] -> Dec
FunD Name
mergingInfoFunName [Clause]
clauses

  let 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 =
        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 = Name -> Type -> Dec
SigD Name
mergeFunName Type
mergeFunType
  mergeFunClauses <- zipWithM genMergeFunClause' conInfoNames constructors
  let mergeFunDec = Name -> [Clause] -> Dec
FunD Name
mergeFunName [Clause]
mergeFunClauses

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

  mergeInstanceFunBody <-
    [|
      SortedStrategy
        $( 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)
             (VarE mergingInfoFunName)
             mergeInstanceFunPatNames
         )
        $(varE mergeFunName)
      |]

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

  return
    ( mergingInfoFunName,
      [ PragmaD (InlineP mergingInfoFunName Inline FunLike AllPhases),
        mergingInfoFunSigD,
        mergingInfoFunDec,
        PragmaD (InlineP mergeFunName Inline FunLike AllPhases),
        mergeFunSigD,
        mergeFunDec,
        InstanceD
          Nothing
          (extraPreds ++ catMaybes mergeableContexts)
          instanceType
          [FunD mergeInstanceFunName [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 {..} <-
    [(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 = Int -> Name
getMergeableInstanceName Int
n
  let instanceHead = Name -> Type
ConT Name
instanceName
  let 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 = Int -> Name
getMergeableFunName Int
n

  let 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)) []
  return
    [ InstanceD
        Nothing
        []
        instanceType
        [FunD mergeInstanceFunName [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
  hasExistential <- Name -> Q Bool
dataTypeHasExistential Name
typName
  if
    | useNoStrategy deriveConfig ->
        genMergeableNoStrategy deriveConfig typName n
    | hasExistential -> do
        (infoResult, infoDec) <- genMergingInfo typName
        (_, decs) <- genMergeable' deriveConfig infoResult typName n
        return $ infoDec ++ decs
    | otherwise -> genMergeableNoExistential deriveConfig typName 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
  hasExistential <- Name -> Q Bool
dataTypeHasExistential Name
typName
  if
    | useNoStrategy deriveConfig ->
        concat <$> traverse (genMergeableNoStrategy deriveConfig typName) l
    | hasExistential -> do
        (info, dn) <-
          genMergeableAndGetMergingInfoResult
            deriveConfig
            typName
            n
        dns <-
          traverse (genMergeable' deriveConfig info typName) ns
        return $ dn ++ concatMap snd dns
    | otherwise ->
        concat <$> traverse (genMergeableNoExistential deriveConfig typName) 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