grisette-0.12.0.0: src/Grisette/Internal/TH/Derivation/DeriveMergeable.hs
{-# 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 dataTypeVars tyName isLast con = do
let conName = mangleName $ constructorName con
let newConName = mkName $ conName <> "MergingInfo"
let oriVars = dataTypeVars ++ constructorVars con
newDataTypeVars <- traverse (newName . nameBase . tvName) dataTypeVars
newConstructorVars <-
traverse (newName . nameBase . tvName) $ constructorVars con
let newNames = newDataTypeVars ++ newConstructorVars
-- newNames <- traverse (newName . nameBase . tvName) oriVars
let newVars = fmap VarT newNames
let substMap = M.fromList $ zip (tvName <$> oriVars) newVars
let fields =
zip [0 ..] $
applySubstitution substMap $
constructorFields con
let tyFields =
AppT (ConT ''TypeRep)
<$> applySubstitution
substMap
((VarT . tvName) <$> constructorVars con)
let strategyFields = fmap (AppT (ConT ''MergingStrategy) . snd) fields
tyFieldNamesL <- traverse (const $ newName "p") tyFields
tyFieldNamesR <- traverse (const $ newName "p") tyFields
let tyFieldPatsL = fmap varP tyFieldNamesL
let tyFieldPatsR = fmap varP tyFieldNamesR
let tyFieldVarsL = fmap varE tyFieldNamesL
let tyFieldVarsR = fmap varE tyFieldNamesR
let strategyFieldPats = replicate (length strategyFields) wildP
let patsL = tyFieldPatsL ++ strategyFieldPats
let patsR = tyFieldPatsR ++ strategyFieldPats
let allWildcards = fmap (const wildP) $ tyFieldPatsL ++ strategyFieldPats
let eqCont l r cont =
[|
SomeTypeRep $l == SomeTypeRep $r
&& $cont
|]
let eqExp =
foldl (\cont (l, r) -> eqCont l r cont) (conE 'True) $
zip tyFieldVarsL tyFieldVarsR
eqClause <-
clause
[conP newConName patsL, conP newConName patsR]
(normalB eqExp)
[]
let cmpCont l r cont =
[|
case SomeTypeRep $l `compare` SomeTypeRep $r of
EQ -> $cont
x -> x
|]
let cmpExp =
foldl (\cont (l, r) -> cmpCont l r cont) (conE 'EQ) $
zip tyFieldVarsL 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 isLast
then [cmpClause0]
else [cmpClause0, cmpClause1, cmpClause2]
let showCont t cont =
[|$cont <> " " <> show $t|]
let showExp = foldl (flip showCont) (litE $ stringL conName) tyFieldVarsL
showClause <-
clause
[conP newConName patsL]
(normalB showExp)
[]
let ctx = applySubstitution substMap $ constructorContext con
let ctxAndGadtUsedVars =
S.fromList (freeVariables ctx)
<> S.fromList (freeVariables tyFields)
<> S.fromList (freeVariables strategyFields)
let isCtxAndGadtUsedVar nm = S.member nm 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
{ _infoName :: Name,
_conInfoNames :: [Name]
}
genMergingInfo :: Name -> Q (MergingInfoResult, [Dec])
genMergingInfo typName = do
d <- reifyDatatype typName
let originalName = mangleName $ datatypeName d
let newName = originalName <> "MergingInfo"
found <- lookupTypeName newName
let constructors = datatypeCons d
let name = mkName 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 = fmap (\(a, _, _, _, _) -> a) r
let eqClauses =
concatMap (\(_, _, a, _, _) -> a) r
++ [ Clause [WildP, WildP] (NormalB $ ConE 'False) []
| length constructors > 1
]
let cmpClauses = concatMap (\(_, _, _, a, _) -> a) r
let showClauses = concatMap (\(_, _, _, _, a) -> a) r
return
( MergingInfoResult
name
(fmap (\(_, a, _, _, _) -> 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 typName n = do
(infoResult, infoDec) <- genMergingInfo typName
(_, decs) <- genMergeable' deriveConfig infoResult typName n
return (infoResult, infoDec ++ decs)
constructMergingStrategyExp :: ConstructorInfo -> [Exp] -> Q Exp
constructMergingStrategyExp _ [] = [|SimpleStrategy $ \_ t _ -> t|]
constructMergingStrategyExp conInfo [x] = do
upname <- newName "a"
let unwrapPat = conP (constructorName conInfo) [varP upname]
let unwrapFun = lamE [unwrapPat] $ appE (varE 'unsafeCoerce) (varE upname)
[|
wrapStrategy
$(return x)
(unsafeCoerce . $(conE $ constructorName conInfo))
$unwrapFun
|]
constructMergingStrategyExp conInfo l = do
let takeHalf l = take (length l `div` 2) l
let dropHalf l = drop (length l `div` 2) l
let num = length l
upnames <- replicateM num $ newName "a"
let wrapPat1 [] = error "Should not happen"
wrapPat1 [x] = varP x
wrapPat1 l = tupP [wrapPat1 (takeHalf l), wrapPat1 (dropHalf l)]
let wrapped = foldl AppE (ConE $ constructorName conInfo) $ fmap VarE upnames
let wrapFun =
lamE
[wrapPat1 (takeHalf upnames), wrapPat1 (dropHalf upnames)]
[|unsafeCoerce ($(return wrapped))|]
let unwrapPat = conP (constructorName conInfo) $ fmap varP upnames
let unwrapExp1 [] = error "Should not happen"
unwrapExp1 [x] = [|(unsafeCoerce $(varE x))|]
unwrapExp1 l = [|($(unwrapExp1 (takeHalf l)), $(unwrapExp1 (dropHalf l)))|]
let unwrapFun = lamE [unwrapPat] (unwrapExp1 upnames)
let strategyx [] = error "Should not happen"
strategyx [x] = return x
strategyx l =
[|product2Strategy (,) id $(strategyx (takeHalf l)) $(strategyx (dropHalf l))|]
[|
product2Strategy
$wrapFun
$unwrapFun
$(strategyx $ takeHalf l)
$(strategyx $ dropHalf l)
|]
genMergeFunClause' :: Name -> ConstructorInfo -> Q Clause
genMergeFunClause' conInfoName con = do
let numExistential = length $ constructorVars con
let numFields = length $ constructorFields con
let argWildCards = replicate numExistential wildP :: [Q Pat]
pnames <- replicateM numFields $ newName "s"
clause
([conP conInfoName $ argWildCards ++ fmap varP pnames])
(normalB (constructMergingStrategyExp con (map VarE pnames)))
[]
constructVarPats :: ConstructorInfo -> Q Pat
constructVarPats conInfo = do
let fields = constructorFields conInfo
capture n = return $ SigP WildP $ fields !! n
conP (constructorName conInfo) $ capture <$> [0 .. length fields - 1]
genMergingInfoFunClause' ::
[(Type, Kind)] -> Name -> ConstructorInfo -> Q Clause
genMergingInfoFunClause' argTypes conInfoName con = do
let conVars = constructorVars con
capturedVarTyReps <-
traverse (\bndr -> [|typeRep @($(varT $ tvName bndr))|]) conVars
varPat <- constructVarPats con
let infoExpWithTypeReps = foldl AppE (ConE conInfoName) capturedVarTyReps
let fields = constructorFields con
let usedArgs = S.fromList $ freeVariables fields
strategyNames <-
traverse
( \(ty, _) ->
case ty of
VarT nm ->
if S.member nm usedArgs
then do
pname <- newName "p"
return (nm, Just pname)
else return ('undefined, Nothing)
_ -> return ('undefined, Nothing)
)
argTypes
let argToStrategyPat =
mapMaybe (\(nm, mpat) -> fmap (nm,) mpat) strategyNames
let strategyPats = fmap (maybe WildP VarP . snd) strategyNames
let argNameSet =
S.fromList $
mapMaybe
( \(ty, _) -> case ty of
VarT nm -> Just nm
_ -> Nothing
)
argTypes
let containsArg :: Type -> Bool
containsArg ty =
S.intersection argNameSet (S.fromList (freeVariables [ty])) /= S.empty
let typeHasNoArg = not . containsArg
let fieldStrategyExp ty =
if not (containsArg ty)
then [|rootStrategy :: MergingStrategy $(return ty)|]
else case ty of
_
| typeHasNoArg ty ->
[|rootStrategy :: MergingStrategy $(return ty)|]
AppT a b
| typeHasNoArg a ->
[|
liftRootStrategy
$(fieldStrategyExp b) ::
MergingStrategy $(return ty)
|]
AppT (AppT a b) c
| typeHasNoArg a ->
[|
liftRootStrategy2
$(fieldStrategyExp b)
$(fieldStrategyExp c) ::
MergingStrategy $(return ty)
|]
AppT (AppT (AppT a b) c) d
| typeHasNoArg a ->
[|
liftRootStrategy3
$(fieldStrategyExp b)
$(fieldStrategyExp c)
$(fieldStrategyExp d) ::
MergingStrategy $(return ty)
|]
VarT nm -> do
case lookup nm argToStrategyPat of
Just pname -> varE pname
_ -> fail "BUG: fieldStrategyExp"
_ -> fail $ "fieldStrategyExp: unsupported type: " <> show ty
fieldStrategyExps <- traverse fieldStrategyExp fields
let infoExp = foldl AppE infoExpWithTypeReps fieldStrategyExps
-- fail $ show infoExp
return $ Clause (strategyPats ++ [varPat]) (NormalB infoExp) []
mergeableFieldFunExp :: [Name] -> FieldFunExp
mergeableFieldFunExp unaryOpFunNames argToFunPat _ = go
where
go ty = do
let allArgNames = M.keysSet argToFunPat
let typeHasNoArg ty =
S.fromList (freeVariables [ty])
`S.intersection` allArgNames
== S.empty
let fun0a a = [|$(varE $ head unaryOpFunNames) @($(return a))|]
fun1a a b = [|$(varE $ unaryOpFunNames !! 1) @($(return a)) $(go b)|]
fun2a a b c =
[|
$(varE $ unaryOpFunNames !! 2)
@($(return a))
$(go b)
$(go c)
|]
fun3a a b c d =
[|
$(varE $ unaryOpFunNames !! 3)
@($(return a))
$(go b)
$(go c)
$(go d)
|]
case ty of
AppT (AppT (AppT a@(VarT _) b) c) d -> fun3a a b c d
AppT (AppT a@(VarT _) b) c -> fun2a a b c
AppT a@(VarT _) b -> fun1a a b
_ | typeHasNoArg ty -> fun0a ty
AppT a b | typeHasNoArg a -> fun1a a b
AppT (AppT a b) c | typeHasNoArg a -> fun2a a b c
AppT (AppT (AppT a b) c) d | typeHasNoArg a -> fun3a a b c d
VarT nm -> case M.lookup nm argToFunPat of
Just pname -> varE pname
_ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty
_ -> fail $ "defaultFieldFunExp: unsupported type: " <> show ty
mergeableInstanceNames :: [Name]
mergeableInstanceNames =
[ ''Mergeable,
''Mergeable1,
''Mergeable2,
''Mergeable3
]
getMergeableInstanceName :: Int -> Name
getMergeableInstanceName n = mergeableInstanceNames !! n
rootStrategyFunNames :: [Name]
rootStrategyFunNames =
[ 'rootStrategy,
'liftRootStrategy,
'liftRootStrategy2,
'liftRootStrategy3
]
getMergeableFunName :: Int -> Name
getMergeableFunName n = rootStrategyFunNames !! n
mergeableNoExistentialConfig :: UnaryOpClassConfig
mergeableNoExistentialConfig =
UnaryOpClassConfig
{ unaryOpConfigs =
[ UnaryOpConfig
MergeableNoExistentialConfig
{ mergeableNoExistentialFun =
mergeableFieldFunExp rootStrategyFunNames
}
rootStrategyFunNames
],
unaryOpInstanceNames =
[''Mergeable, ''Mergeable1, ''Mergeable2, ''Mergeable3],
unaryOpExtraVars = const $ return [],
unaryOpInstanceTypeFromConfig = defaultUnaryOpInstanceTypeFromConfig,
unaryOpAllowExistential = False,
unaryOpContextNames = Nothing
}
newtype MergeableNoExistentialConfig = MergeableNoExistentialConfig
{ mergeableNoExistentialFun :: FieldFunExp
}
instance UnaryOpFunConfig MergeableNoExistentialConfig where
genUnaryOpFun
_
MergeableNoExistentialConfig {..}
funNames
n
_
_
argTypes
_
constructors = do
allFields <-
mapM resolveTypeSynonyms $
concatMap constructorFields constructors
let usedArgs = S.fromList $ freeVariables allFields
args <-
traverse
( \(ty, _) -> do
case ty of
VarT nm ->
if S.member nm usedArgs
then do
pname <- newName "p"
return (nm, Just pname)
else return ('undefined, Nothing)
_ -> return ('undefined, Nothing)
)
argTypes
let argToFunPat =
M.fromList $ mapMaybe (\(nm, mpat) -> fmap (nm,) mpat) args
let funPats = fmap (maybe WildP VarP . snd) args
let genAuxFunExp conInfo = do
fields <- mapM resolveTypeSynonyms $ constructorFields conInfo
defaultFieldFunExps <-
traverse
(mergeableNoExistentialFun argToFunPat M.empty)
fields
constructMergingStrategyExp conInfo defaultFieldFunExps
auxExps <- mapM genAuxFunExp constructors
funExp <- case auxExps of
[] -> [|NoStrategy|]
[singleExp] -> return singleExp
_ -> do
p <- newName "p"
let numConstructors = length constructors
let getIdx i =
if numConstructors <= 2
then if i == 0 then [|False|] else [|True|]
else integerE i
let getIdxPat i =
if numConstructors <= 2
then conP (if i == 0 then 'False else 'True) []
else do
let w8Bound = fromIntegral (maxBound @Word8)
let w16Bound = fromIntegral (maxBound @Word16)
let w32Bound = fromIntegral (maxBound @Word32)
let w64Bound = fromIntegral (maxBound @Word64)
sigP
(litP (integerL i))
( conT $
if
| numConstructors <= w8Bound + 1 -> ''Word8
| numConstructors <= w16Bound + 1 -> ''Word16
| numConstructors <= w32Bound + 1 -> ''Word32
| numConstructors <= w64Bound + 1 -> ''Word64
| otherwise -> ''Integer
)
let idxFun =
lamE [varP p] $
caseE
(varE p)
( zipWith
( \conIdx conInfo -> do
match
(recP (constructorName conInfo) [])
(normalB (getIdx conIdx))
[]
)
[0 ..]
constructors
)
let auxFun =
lamE [varP p] $
caseE
(varE p)
( zipWith
( \conIdx exp -> do
match
(getIdxPat conIdx)
(normalB (return exp))
[]
)
[0 ..]
auxExps
++ [match wildP (normalB [|undefined|]) []]
)
[|
SortedStrategy $idxFun $auxFun
|]
let instanceFunName = funNames !! 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 infoName conInfoNames) typName n = do
result@CheckArgsResult {..} <-
specializeResult (evalModeSpecializeList deriveConfig)
=<< checkArgs "Mergeable" 3 typName True n
d <- reifyDatatype typName
let ctxForVar :: (Type, Kind) -> Q (Maybe Pred)
ctxForVar (ty, kind) = case kind of
StarT -> Just <$> [t|Mergeable $(return ty)|]
AppT (AppT ArrowT StarT) StarT ->
Just <$> [t|Mergeable1 $(return ty)|]
AppT (AppT (AppT ArrowT StarT) StarT) StarT ->
Just <$> [t|Mergeable2 $(return ty)|]
AppT (AppT (AppT (AppT ArrowT StarT) StarT) StarT) StarT ->
Just <$> [t|Mergeable3 $(return ty)|]
AppT (AppT (AppT (AppT ArrowT StarT) StarT) StarT) _ ->
fail $ "Unsupported kind: " <> show kind
_ -> return Nothing
let isTypeUsedInFields (VarT nm) = isVarUsedInFields result nm
isTypeUsedInFields _ = False
mergeableContexts <-
traverse ctxForVar $
filter (isTypeUsedInFields . fst) $
fmap snd $
filter (not . (`elem` unconstrainedPositions deriveConfig) . fst) $
zip [0 ..] keptVars
let instanceName = getMergeableInstanceName n
let instanceHead = ConT instanceName
extraPreds <-
extraConstraint
deriveConfig
typName
instanceName
[]
keptVars
constructors
let targetType =
foldl
(\ty (var, _) -> AppT ty var)
(ConT typName)
(keptVars ++ argVars)
let infoType = ConT infoName
let mergingInfoFunFinalType = AppT (AppT ArrowT targetType) infoType
let mergingInfoFunTypeWithoutCtx =
foldr
(((AppT . AppT ArrowT) . AppT (ConT ''MergingStrategy)) . fst)
mergingInfoFunFinalType
argVars
let mergingInfoFunType =
ForallT
( mapMaybe
( \(ty, knd) -> case ty of
VarT nm -> Just $ kindedTVSpecified nm knd
_ -> Nothing
)
$ keptVars ++ argVars
)
(extraPreds ++ catMaybes mergeableContexts)
mergingInfoFunTypeWithoutCtx
let mangledName = mangleName (datatypeName d)
let mergingInfoFunName =
mkName $
"mergingInfo"
<> (if n /= 0 then show n else "")
<> mangledName
let mergingInfoFunSigD = SigD mergingInfoFunName mergingInfoFunType
clauses <-
traverse (uncurry (genMergingInfoFunClause' argVars)) $
zip conInfoNames constructors
let mergingInfoFunDec = FunD mergingInfoFunName clauses
let mergeFunType =
AppT (AppT ArrowT infoType) (AppT (ConT ''MergingStrategy) targetType)
let mergeFunName =
mkName $
"merge"
<> (if n /= 0 then show n else "")
<> mangledName
let mergeFunSigD = SigD mergeFunName mergeFunType
mergeFunClauses <- zipWithM genMergeFunClause' conInfoNames constructors
let mergeFunDec = FunD mergeFunName mergeFunClauses
let instanceType =
AppT
instanceHead
(foldl AppT (ConT typName) $ fmap fst keptVars)
let mergeInstanceFunName = getMergeableFunName n
mergeInstanceFunPatNames <- replicateM n $ newName "rootStrategy"
let mergeInstanceFunPats = VarP <$> mergeInstanceFunPatNames
mergeInstanceFunBody <-
[|
SortedStrategy
$( foldM
(\exp name -> appE (return exp) $ varE name)
(VarE mergingInfoFunName)
mergeInstanceFunPatNames
)
$(varE mergeFunName)
|]
let mergeInstanceFunClause =
Clause mergeInstanceFunPats (NormalB 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 typName n = do
genUnaryOpClass deriveConfig mergeableNoExistentialConfig n typName
-- | Generate 'Mergeable' instance for a data type, using 'NoStrategy'.
genMergeableNoStrategy :: DeriveConfig -> Name -> Int -> Q [Dec]
genMergeableNoStrategy deriveConfig typName n = do
CheckArgsResult {..} <-
specializeResult (evalModeSpecializeList deriveConfig)
=<< checkArgs "Mergeable" 3 typName True n
let instanceName = getMergeableInstanceName n
let instanceHead = ConT instanceName
let instanceType =
AppT
instanceHead
(foldl AppT (ConT typName) $ fmap fst keptVars)
let mergeInstanceFunName = getMergeableFunName n
let mergeInstanceFunClause =
Clause (replicate n WildP) (NormalB (ConE 'NoStrategy)) []
return
[ InstanceD
Nothing
[]
instanceType
[FunD mergeInstanceFunName [mergeInstanceFunClause]]
]
-- | Generate 'Mergeable' instance for a data type.
genMergeable :: DeriveConfig -> Name -> Int -> Q [Dec]
genMergeable deriveConfig typName n = do
hasExistential <- dataTypeHasExistential 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 _ _ [] = return []
genMergeableList deriveConfig typName [n] = genMergeable deriveConfig typName n
genMergeableList deriveConfig typName l@(n : ns) = do
hasExistential <- dataTypeHasExistential 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 nm = genMergeable deriveConfig nm 0
-- | Derive 'Mergeable1' instance for GADT.
deriveMergeable1 :: DeriveConfig -> Name -> Q [Dec]
deriveMergeable1 deriveConfig nm = genMergeable deriveConfig nm 1
-- | Derive 'Mergeable2' instance for GADT.
deriveMergeable2 :: DeriveConfig -> Name -> Q [Dec]
deriveMergeable2 deriveConfig nm = genMergeable deriveConfig nm 2
-- | Derive 'Mergeable3' instance for GADT.
deriveMergeable3 :: DeriveConfig -> Name -> Q [Dec]
deriveMergeable3 deriveConfig nm = genMergeable deriveConfig nm 3