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

-- |
-- Module      :   Grisette.Internal.TH.GADT.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.GADT.DeriveMergeable
  ( deriveGADTMergeable,
    deriveGADTMergeable1,
    deriveGADTMergeable2,
    deriveGADTMergeable3,
    genMergeableAndGetMergingInfoResult,
    genMergeable,
    genMergeable',
  )
where

import Control.Monad (foldM, replicateM, zipWithM)
import qualified Data.Map as M
import Data.Maybe (catMaybes, isJust, mapMaybe)
import Data.Proxy (Proxy (Proxy))
import qualified Data.Set as S
import Grisette.Internal.Core.Data.Class.Mergeable
  ( Mergeable (rootStrategy),
    Mergeable1 (liftRootStrategy),
    Mergeable2 (liftRootStrategy2),
    Mergeable3 (liftRootStrategy3),
    MergingStrategy (SimpleStrategy, SortedStrategy),
    product2Strategy,
    wrapStrategy,
  )
import Grisette.Internal.TH.GADT.Common
  ( CheckArgsResult
      ( CheckArgsResult,
        argNewNames,
        argNewVars,
        constructors,
        isVarUsedInFields,
        keptNewNames,
        keptNewVars
      ),
    checkArgs,
  )
import Grisette.Internal.TH.Util (occName)
import Language.Haskell.TH
  ( Bang (Bang),
    Body (NormalB),
    Clause (Clause),
    Con (ForallC, GadtC),
    Dec (DataD, FunD, InstanceD, SigD),
    Exp (AppE, ConE, VarE),
    Name,
    Pat (SigP, VarP, WildP),
    Pred,
    Q,
    SourceStrictness (NoSourceStrictness),
    SourceUnpackedness (NoSourceUnpackedness),
    Type (AppT, ArrowT, ConT, ForallT, StarT, VarT),
    appE,
    conE,
    conT,
    lamE,
    lookupTypeName,
    mkName,
    newName,
    normalB,
    tupP,
    varE,
    varP,
    varT,
    wildP,
  )
import Language.Haskell.TH.Datatype
  ( ConstructorInfo
      ( constructorContext,
        constructorFields,
        constructorName,
        constructorVars
      ),
    DatatypeInfo (datatypeCons, datatypeName, datatypeVars),
    TypeSubstitution (applySubstitution, freeVariables),
    reifyDatatype,
    tvName,
  )
import Language.Haskell.TH.Datatype.TyVarBndr
  ( TyVarBndrUnit,
    TyVarBndr_,
    mapTVFlag,
    plainTVFlag,
    specifiedSpec,
    tvKind,
  )
import Language.Haskell.TH.Lib (clause, conP, litE, stringL)
import Type.Reflection (SomeTypeRep (SomeTypeRep), TypeRep, typeRep)
import Unsafe.Coerce (unsafeCoerce)

genMergingInfoCon ::
  [TyVarBndrUnit] ->
  Name ->
  Bool ->
  ConstructorInfo ->
  Q (Con, Name, S.Set Int, [Clause], [Clause], [Clause])
genMergingInfoCon :: [TyVarBndrUnit]
-> Name
-> Bool
-> ConstructorInfo
-> Q (Con, Name, Set Int, [Clause], [Clause], [Clause])
genMergingInfoCon [TyVarBndrUnit]
dataTypeVars Name
tyName Bool
isLast ConstructorInfo
con = do
  let conName :: String
conName = Name -> String
occName (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"
  if [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ConstructorInfo -> [Type]
constructorFields ConstructorInfo
con) Bool -> Bool -> Bool
&& [TyVarBndrUnit] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndrUnit]
dataTypeVars
    then do
      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 [], Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
newConName []]
          (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 'True)
          []
      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 [], Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
newConName []]
          (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 'EQ)
          []
      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
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 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 nameLit :: Q Exp
nameLit = 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
      let showExp :: Q Exp
showExp = [|$Q Exp
nameLit <> " " <> show (Proxy @($(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tyName)))|]
      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 Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
showExp)
          []
      (Con, Name, Set Int, [Clause], [Clause], [Clause])
-> Q (Con, Name, Set Int, [Clause], [Clause], [Clause])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( [Name] -> [BangType] -> Type -> Con
GadtC [Name
newConName] [] (Name -> Type
ConT Name
tyName),
          Name
newConName,
          [Int] -> Set Int
forall a. Ord a => [a] -> Set a
S.fromList [],
          [Clause
eqClause],
          [Clause]
cmpClauses,
          [Clause
showClause]
        )
    else do
      let oriVars :: [TyVarBndrUnit]
oriVars = [TyVarBndrUnit]
dataTypeVars [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a] -> [a]
++ ConstructorInfo -> [TyVarBndrUnit]
constructorVars ConstructorInfo
con
      [Name]
newNames <- (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
occName (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]
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, Set Int, [Clause], [Clause], [Clause])
-> Q (Con, Name, Set Int, [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]
newNames
            )
            [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,
          [Int] -> Set Int
forall a. Ord a => [a] -> Set a
S.fromList [Int
0 .. [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyFields Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1],
          -- S.fromList $ fst <$> dedupedFields,
          [Clause
eqClause],
          [Clause]
cmpClauses,
          [Clause
showClause]
        )

data MergingInfoResult = MergingInfoResult
  { MergingInfoResult -> Name
_infoName :: Name,
    MergingInfoResult -> [Name]
_conInfoNames :: [Name],
    MergingInfoResult -> [Set Int]
_pos :: [S.Set Int]
  }

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
occName (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, Set Int, [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, Set Int, [Clause], [Clause], [Clause])]
-> Q [(Con, Name, Set Int, [Clause], [Clause], [Clause])]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
      else do
        [(Con, Name, Set Int, [Clause], [Clause], [Clause])]
cons0 <-
          (ConstructorInfo
 -> Q (Con, Name, Set Int, [Clause], [Clause], [Clause]))
-> [ConstructorInfo]
-> Q [(Con, Name, Set Int, [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, Set Int, [Clause], [Clause], [Clause])
genMergingInfoCon (DatatypeInfo -> [TyVarBndrUnit]
datatypeVars DatatypeInfo
d) Name
name Bool
False) ([ConstructorInfo]
 -> Q [(Con, Name, Set Int, [Clause], [Clause], [Clause])])
-> [ConstructorInfo]
-> Q [(Con, Name, Set Int, [Clause], [Clause], [Clause])]
forall a b. (a -> b) -> a -> b
$
            [ConstructorInfo] -> [ConstructorInfo]
forall a. HasCallStack => [a] -> [a]
init [ConstructorInfo]
constructors
        (Con, Name, Set Int, [Clause], [Clause], [Clause])
consLast <-
          [TyVarBndrUnit]
-> Name
-> Bool
-> ConstructorInfo
-> Q (Con, Name, Set Int, [Clause], [Clause], [Clause])
genMergingInfoCon (DatatypeInfo -> [TyVarBndrUnit]
datatypeVars DatatypeInfo
d) Name
name Bool
True (ConstructorInfo
 -> Q (Con, Name, Set Int, [Clause], [Clause], [Clause]))
-> ConstructorInfo
-> Q (Con, Name, Set Int, [Clause], [Clause], [Clause])
forall a b. (a -> b) -> a -> b
$
            [ConstructorInfo] -> ConstructorInfo
forall a. HasCallStack => [a] -> a
last [ConstructorInfo]
constructors
        [(Con, Name, Set Int, [Clause], [Clause], [Clause])]
-> Q [(Con, Name, Set Int, [Clause], [Clause], [Clause])]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Con, Name, Set Int, [Clause], [Clause], [Clause])]
 -> Q [(Con, Name, Set Int, [Clause], [Clause], [Clause])])
-> [(Con, Name, Set Int, [Clause], [Clause], [Clause])]
-> Q [(Con, Name, Set Int, [Clause], [Clause], [Clause])]
forall a b. (a -> b) -> a -> b
$ [(Con, Name, Set Int, [Clause], [Clause], [Clause])]
cons0 [(Con, Name, Set Int, [Clause], [Clause], [Clause])]
-> [(Con, Name, Set Int, [Clause], [Clause], [Clause])]
-> [(Con, Name, Set Int, [Clause], [Clause], [Clause])]
forall a. [a] -> [a] -> [a]
++ [(Con, Name, Set Int, [Clause], [Clause], [Clause])
consLast]
  let cons :: [Con]
cons = ((Con, Name, Set Int, [Clause], [Clause], [Clause]) -> Con)
-> [(Con, Name, Set Int, [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
_, Set Int
_, [Clause]
_, [Clause]
_, [Clause]
_) -> Con
a) [(Con, Name, Set Int, [Clause], [Clause], [Clause])]
r
  let eqClauses :: [Clause]
eqClauses =
        ((Con, Name, Set Int, [Clause], [Clause], [Clause]) -> [Clause])
-> [(Con, Name, Set Int, [Clause], [Clause], [Clause])] -> [Clause]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Con
_, Name
_, Set Int
_, [Clause]
a, [Clause]
_, [Clause]
_) -> [Clause]
a) [(Con, Name, Set Int, [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, Set Int, [Clause], [Clause], [Clause]) -> [Clause])
-> [(Con, Name, Set Int, [Clause], [Clause], [Clause])] -> [Clause]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Con
_, Name
_, Set Int
_, [Clause]
_, [Clause]
a, [Clause]
_) -> [Clause]
a) [(Con, Name, Set Int, [Clause], [Clause], [Clause])]
r
  let showClauses :: [Clause]
showClauses = ((Con, Name, Set Int, [Clause], [Clause], [Clause]) -> [Clause])
-> [(Con, Name, Set Int, [Clause], [Clause], [Clause])] -> [Clause]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Con
_, Name
_, Set Int
_, [Clause]
_, [Clause]
_, [Clause]
a) -> [Clause]
a) [(Con, Name, Set Int, [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] -> [Set Int] -> MergingInfoResult
MergingInfoResult
        Name
name
        (((Con, Name, Set Int, [Clause], [Clause], [Clause]) -> Name)
-> [(Con, Name, Set Int, [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, Set Int
_, [Clause]
_, [Clause]
_, [Clause]
_) -> Name
a) [(Con, Name, Set Int, [Clause], [Clause], [Clause])]
r)
        (((Con, Name, Set Int, [Clause], [Clause], [Clause]) -> Set Int)
-> [(Con, Name, Set Int, [Clause], [Clause], [Clause])]
-> [Set Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Con
_, Name
_, Set Int
a, [Clause]
_, [Clause]
_, [Clause]
_) -> Set Int
a) [(Con, Name, Set Int, [Clause], [Clause], [Clause])]
r),
      if Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust Maybe Name
found
        then []
        else
          [ [Type]
-> Name
-> [TyVarBndrUnit]
-> 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 GADT.
genMergeableAndGetMergingInfoResult ::
  Name -> Int -> Q (MergingInfoResult, [Dec])
genMergeableAndGetMergingInfoResult :: Name -> Int -> Q (MergingInfoResult, [Dec])
genMergeableAndGetMergingInfoResult Name
typName Int
n = do
  (MergingInfoResult
infoResult, [Dec]
infoDec) <- Name -> Q (MergingInfoResult, [Dec])
genMergingInfo Name
typName
  (Name
_, [Dec]
decs) <- MergingInfoResult -> Name -> Int -> Q (Name, [Dec])
genMergeable' 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)

-- | Generate 'Mergeable' instance for a GADT.
genMergeable :: Name -> Int -> Q [Dec]
genMergeable :: Name -> Int -> Q [Dec]
genMergeable Name
typName Int
n = do
  (MergingInfoResult
infoResult, [Dec]
infoDec) <- Name -> Q (MergingInfoResult, [Dec])
genMergingInfo Name
typName
  (Name
_, [Dec]
decs) <- MergingInfoResult -> Name -> Int -> Q (Name, [Dec])
genMergeable' 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

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
  case Int
numFields of
    Int
0 -> do
      let pat :: Q Pat
pat = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conInfoName []
      [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
        ([Q Pat]
argWildCards [Q Pat] -> [Q Pat] -> [Q Pat]
forall a. [a] -> [a] -> [a]
++ [Q Pat
pat])
        (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|SimpleStrategy $ \_ t _ -> t|])
        []
    Int
1 -> do
      Name
pname <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"s"
      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
con) [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)
      [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
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
pname]]
        ( Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
            [|
              wrapStrategy
                $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pname)
                (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
con))
                $Q Exp
unwrapFun
              |]
        )
        []
    Int
_ -> do
      -- fail $ show (argWildCards, conInfoName)
      [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"
      [Name]
upnames <- 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
"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
x : [Name]
xs) = [m Pat] -> m Pat
forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x, [Name] -> m Pat
wrapPat1 [Name]
xs]
      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
con) ([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
varP (Name -> Q Pat) -> Name -> Q Pat
forall a b. (a -> b) -> a -> b
$ [Name] -> Name
forall a. HasCallStack => [a] -> a
head [Name]
upnames, [Name] -> Q Pat
forall {m :: * -> *}. Quote m => [Name] -> m Pat
wrapPat1 ([Name] -> Q Pat) -> [Name] -> Q Pat
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. HasCallStack => [a] -> [a]
tail [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
con) ([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
_] = String -> m Exp
forall a. HasCallStack => String -> a
error String
"Should not happen"
          unwrapExp1 [Name
x, Name
y] =
            [|(unsafeCoerce $(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x), unsafeCoerce $(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y))|]
          unwrapExp1 (Name
x : [Name]
xs) = [|(unsafeCoerce $(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x), $([Name] -> m Exp
unwrapExp1 [Name]
xs))|]
      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 strategy1 :: [Name] -> m Exp
strategy1 [] = String -> m Exp
forall a. HasCallStack => String -> a
error String
"Should not happen"
          strategy1 [Name
x] = Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x
          strategy1 (Name
x : [Name]
xs) =
            [|
              product2Strategy
                ((,))
                (\(x, y) -> (x, y))
                $(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)
                $([Name] -> m Exp
strategy1 [Name]
xs)
              |]
      [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
            [|
              product2Strategy
                $Q Exp
wrapFun
                $Q Exp
unwrapFun
                $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Name] -> Name
forall a. HasCallStack => [a] -> a
head [Name]
pnames)
                $([Name] -> Q Exp
forall {m :: * -> *}. Quote m => [Name] -> m Exp
strategy1 ([Name] -> Q Exp) -> [Name] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. HasCallStack => [a] -> [a]
tail [Name]
pnames)
              |]
        )
        []

genMergingInfoFunClause' ::
  [Name] -> Name -> S.Set Int -> ConstructorInfo -> Q Clause
genMergingInfoFunClause' :: [Name] -> Name -> Set Int -> ConstructorInfo -> Q Clause
genMergingInfoFunClause' [Name]
argTypes Name
conInfoName Set Int
pos ConstructorInfo
oldCon = do
  let conName :: Name
conName = ConstructorInfo -> Name
constructorName ConstructorInfo
oldCon
  let oldConVars :: [TyVarBndrUnit]
oldConVars = ConstructorInfo -> [TyVarBndrUnit]
constructorVars ConstructorInfo
oldCon
  [Name]
newNames <- (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
occName (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]
oldConVars
  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]
oldConVars) (Name -> Type
VarT (Name -> Type) -> [Name] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
newNames)
  let con :: ConstructorInfo
con = Map Name Type -> ConstructorInfo -> ConstructorInfo
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
substMap ConstructorInfo
oldCon
  let conVars :: [TyVarBndrUnit]
conVars = ConstructorInfo -> [TyVarBndrUnit]
constructorVars ConstructorInfo
con
  let fields :: [Type]
fields = ConstructorInfo -> [Type]
constructorFields ConstructorInfo
con
  let capture :: Int -> m Pat
capture Int
n =
        if Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Int
n Set Int
pos
          then do
            Pat -> m Pat
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (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)
          else Pat -> m Pat
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat
WildP)
  [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 <- Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conName ([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 (ConstructorInfo -> [Type]
constructorFields ConstructorInfo
con) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
  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 <-
    (Name -> Q (Name, Maybe Name)) -> [Name] -> Q [(Name, Maybe Name)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
      ( \Name
nm ->
          if Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Name
nm Set Name
usedArgs
            then do
              Name
pname <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"p"
              (Name, Maybe Name) -> Q (Name, Maybe Name)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nm, Name -> Maybe Name
forall a. a -> Maybe a
Just Name
pname)
            else (Name, Maybe Name) -> Q (Name, Maybe Name)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nm, Maybe Name
forall a. Maybe a
Nothing)
      )
      [Name]
argTypes
  let 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 argTypeSet :: Set Name
argTypeSet = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList [Name]
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
argTypeSet ([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) []

-- | Generate 'Mergeable' instance for a GADT, using a given merging info
-- result.
genMergeable' :: MergingInfoResult -> Name -> Int -> Q (Name, [Dec])
genMergeable' :: MergingInfoResult -> Name -> Int -> Q (Name, [Dec])
genMergeable' (MergingInfoResult Name
infoName [Name]
conInfoNames [Set Int]
pos) Name
typName Int
n = do
  CheckArgsResult {[Name]
[ConstructorInfo]
[TyVarBndrUnit]
Name -> Bool
argNewNames :: CheckArgsResult -> [Name]
argNewVars :: CheckArgsResult -> [TyVarBndrUnit]
constructors :: CheckArgsResult -> [ConstructorInfo]
isVarUsedInFields :: CheckArgsResult -> Name -> Bool
keptNewNames :: CheckArgsResult -> [Name]
keptNewVars :: CheckArgsResult -> [TyVarBndrUnit]
constructors :: [ConstructorInfo]
keptNewNames :: [Name]
keptNewVars :: [TyVarBndrUnit]
argNewNames :: [Name]
argNewVars :: [TyVarBndrUnit]
isVarUsedInFields :: Name -> Bool
..} <- String -> Int -> Name -> Int -> Q CheckArgsResult
checkArgs String
"Mergeable" Int
3 Name
typName Int
n

  DatatypeInfo
d <- Name -> Q DatatypeInfo
reifyDatatype Name
typName
  let ctxForVar :: TyVarBndr_ flag -> Q (Maybe Pred)
      ctxForVar :: forall flag. TyVarBndr_ flag -> Q (Maybe Type)
ctxForVar TyVarBndr_ flag
var = case TyVarBndr_ flag -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind TyVarBndr_ flag
var of
        Type
StarT -> Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Q Type -> Q (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|Mergeable $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ TyVarBndr_ flag -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndr_ flag
var)|]
        AppT (AppT Type
ArrowT Type
StarT) Type
StarT ->
          Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Q Type -> Q (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|Mergeable1 $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ TyVarBndr_ flag -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndr_ flag
var)|]
        AppT (AppT (AppT Type
ArrowT Type
StarT) Type
StarT) Type
StarT ->
          Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Q Type -> Q (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|Mergeable2 $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ TyVarBndr_ flag -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndr_ flag
var)|]
        AppT (AppT (AppT (AppT Type
ArrowT Type
StarT) Type
StarT) Type
StarT) Type
StarT ->
          Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Q Type -> Q (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|Mergeable3 $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ TyVarBndr_ flag -> Name
forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndr_ flag
var)|]
        AppT (AppT (AppT (AppT Type
ArrowT Type
StarT) Type
StarT) Type
StarT) Type
_ ->
          String -> Q (Maybe Type)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Maybe Type)) -> String -> Q (Maybe Type)
forall a b. (a -> b) -> a -> b
$ String
"Unsupported kind: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show (TyVarBndr_ flag -> Type
forall flag. TyVarBndr_ flag -> Type
tvKind TyVarBndr_ flag
var)
        Type
_ -> Maybe Type -> Q (Maybe Type)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Type
forall a. Maybe a
Nothing
  [Maybe Type]
mergeableContexts <-
    (TyVarBndrUnit -> Q (Maybe Type))
-> [TyVarBndrUnit] -> 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 TyVarBndrUnit -> Q (Maybe Type)
forall flag. TyVarBndr_ flag -> Q (Maybe Type)
ctxForVar ([TyVarBndrUnit] -> Q [Maybe Type])
-> [TyVarBndrUnit] -> Q [Maybe Type]
forall a b. (a -> b) -> a -> b
$ (TyVarBndrUnit -> Bool) -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> Bool
isVarUsedInFields (Name -> Bool) -> (TyVarBndrUnit -> Name) -> TyVarBndrUnit -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName) [TyVarBndrUnit]
keptNewVars

  let targetType :: Type
targetType =
        (Type -> Name -> Type) -> Type -> [Name] -> 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 Name
nm -> Type -> Type -> Type
AppT Type
ty (Name -> Type
VarT Name
nm))
          (Name -> Type
ConT Name
typName)
          ([Name]
keptNewNames [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
argNewNames)
  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 =
        (Name -> Type -> Type) -> Type -> [Name] -> 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) -> (Name -> Type) -> Name -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT (Name -> Type
ConT ''MergingStrategy) (Type -> Type) -> (Name -> Type) -> Name -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
VarT)
          Type
mergingInfoFunFinalType
          [Name]
argNewNames

  let mergingInfoFunType :: Type
mergingInfoFunType =
        [TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT
          ((() -> Specificity) -> TyVarBndrUnit -> TyVarBndr Specificity
forall flag flag'.
(flag -> flag') -> TyVarBndr_ flag -> TyVarBndr_ flag'
mapTVFlag (Specificity -> () -> Specificity
forall a b. a -> b -> a
const Specificity
specifiedSpec) (TyVarBndrUnit -> TyVarBndr Specificity)
-> [TyVarBndrUnit] -> [TyVarBndr Specificity]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndrUnit]
keptNewVars [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a] -> [a]
++ [TyVarBndrUnit]
argNewVars)
          ([Maybe Type] -> [Type]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Type]
mergeableContexts)
          Type
mergingInfoFunTypeWithoutCtx
  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
<> Name -> String
occName (DatatypeInfo -> Name
datatypeName DatatypeInfo
d)
  let mergingInfoFunSigD :: Dec
mergingInfoFunSigD = Name -> Type -> Dec
SigD Name
mergingInfoFunName Type
mergingInfoFunType
  [Clause]
clauses <-
    ((Name, Set Int, ConstructorInfo) -> Q Clause)
-> [(Name, Set Int, 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
conInfoName, Set Int
pos, ConstructorInfo
con) ->
          [Name] -> Name -> Set Int -> ConstructorInfo -> Q Clause
genMergingInfoFunClause' (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]
argNewVars) Name
conInfoName Set Int
pos ConstructorInfo
con
      )
      ([(Name, Set Int, ConstructorInfo)] -> Q [Clause])
-> [(Name, Set Int, ConstructorInfo)] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ [Name]
-> [Set Int]
-> [ConstructorInfo]
-> [(Name, Set Int, ConstructorInfo)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Name]
conInfoNames [Set Int]
pos [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
<> Name -> String
occName (DatatypeInfo -> Name
datatypeName DatatypeInfo
d)
  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 instanceHead :: Type
instanceHead = case Int
n of
        Int
0 -> Name -> Type
ConT ''Mergeable
        Int
1 -> Name -> Type
ConT ''Mergeable1
        Int
2 -> Name -> Type
ConT ''Mergeable2
        Int
3 -> Name -> Type
ConT ''Mergeable3
        Int
_ -> String -> Type
forall a. HasCallStack => String -> a
error String
"Unsupported n"

  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
$ (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
VarT [Name]
keptNewNames)

  let mergeInstanceFunName :: Name
mergeInstanceFunName = case Int
n of
        Int
0 -> 'rootStrategy
        Int
1 -> 'liftRootStrategy
        Int
2 -> 'liftRootStrategy2
        Int
3 -> 'liftRootStrategy3
        Int
_ -> String -> Name
forall a. HasCallStack => String -> a
error String
"Unsupported 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,
      [ Dec
mergingInfoFunSigD,
        Dec
mergingInfoFunDec,
        Dec
mergeFunSigD,
        Dec
mergeFunDec,
        Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD
          Maybe Overlap
forall a. Maybe a
Nothing
          ([Maybe Type] -> [Type]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Type]
mergeableContexts)
          Type
instanceType
          [Name -> [Clause] -> Dec
FunD Name
mergeInstanceFunName [Clause
mergeInstanceFunClause]]
      ]
    )

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

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

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

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