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

-- |
-- Module      :   Grisette.Internal.TH.Derivation.ConvertOpCommon
-- Copyright   :   (c) Sirui Lu 2024
-- License     :   BSD-3-Clause (see the LICENSE file)
--
-- Maintainer  :   siruilu@cs.washington.edu
-- Stability   :   Experimental
-- Portability :   GHC only
module Grisette.Internal.TH.Derivation.ConvertOpCommon
  ( genConvertOpClass,
    ConvertOpClassConfig (..),
    defaultFieldFunExp,
  )
where

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

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

-- | Default field transformation function.
defaultFieldFunExp :: [Name] -> FieldFunExp
defaultFieldFunExp :: [Name] -> FieldFunExp
defaultFieldFunExp [Name]
binaryOpFunNames Map Name Name
argToFunPat = Kind -> Q Exp
forall {m :: * -> *}. (MonadFail m, Quote m) => Kind -> m Exp
go
  where
    go :: Kind -> m Exp
go Kind
ty = do
      let allArgNames :: Set Name
allArgNames = Map Name Name -> Set Name
forall k a. Map k a -> Set k
M.keysSet Map Name Name
argToFunPat
      let typeHasNoArg :: a -> Bool
typeHasNoArg a
ty =
            [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [a
ty])
              Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` Set Name
allArgNames
              Set Name -> Set Name -> Bool
forall a. Eq a => a -> a -> Bool
== Set Name
forall a. Set a
S.empty
      let fun0 :: m Exp
fun0 = Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ [Name] -> Name
forall a. HasCallStack => [a] -> a
head [Name]
binaryOpFunNames
          fun1 :: Kind -> m Exp
fun1 Kind
b = [|$(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ [Name]
binaryOpFunNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
1) $(Kind -> m Exp
go Kind
b)|]
          fun2 :: Kind -> Kind -> m Exp
fun2 Kind
b Kind
c = [|$(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ [Name]
binaryOpFunNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
2) $(Kind -> m Exp
go Kind
b) $(Kind -> m Exp
go Kind
c)|]
          fun3 :: Kind -> Kind -> Kind -> m Exp
fun3 Kind
b Kind
c Kind
d =
            [|$(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ [Name]
binaryOpFunNames [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
3) $(Kind -> m Exp
go Kind
b) $(Kind -> m Exp
go Kind
c) $(Kind -> m Exp
go Kind
d)|]
      case Kind
ty of
        AppT (AppT (AppT (VarT Name
_) Kind
b) Kind
c) Kind
d -> Kind -> Kind -> Kind -> m Exp
fun3 Kind
b Kind
c Kind
d
        AppT (AppT (VarT Name
_) Kind
b) Kind
c -> Kind -> Kind -> m Exp
fun2 Kind
b Kind
c
        AppT (VarT Name
_) Kind
b -> Kind -> m Exp
fun1 Kind
b
        Kind
_ | Kind -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Kind
ty -> m Exp
fun0
        AppT Kind
a Kind
b | Kind -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Kind
a -> Kind -> m Exp
fun1 Kind
b
        AppT (AppT Kind
a Kind
b) Kind
c | Kind -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Kind
a -> Kind -> Kind -> m Exp
fun2 Kind
b Kind
c
        AppT (AppT (AppT Kind
a Kind
b) Kind
c) Kind
d | Kind -> Bool
forall {a}. TypeSubstitution a => a -> Bool
typeHasNoArg Kind
a -> Kind -> Kind -> Kind -> m Exp
fun3 Kind
b Kind
c Kind
d
        VarT Name
nm -> case Name -> Map Name Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
nm Map Name Name
argToFunPat of
          Just Name
pname -> Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
pname
          Maybe Name
_ -> String -> m Exp
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Exp) -> String -> m Exp
forall a b. (a -> b) -> a -> b
$ String
"defaultFieldFunExp: unsupported type: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Kind -> String
forall a. Show a => a -> String
show Kind
ty
        Kind
_ -> String -> m Exp
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Exp) -> String -> m Exp
forall a b. (a -> b) -> a -> b
$ String
"defaultFieldFunExp: unsupported type: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Kind -> String
forall a. Show a => a -> String
show Kind
ty

funPatAndExps ::
  FieldFunExp ->
  [(Type, Kind)] ->
  [Type] ->
  Q ([Pat], [Exp])
funPatAndExps :: FieldFunExp -> [(Kind, Kind)] -> [Kind] -> Q ([Pat], [Exp])
funPatAndExps FieldFunExp
fieldFunExpGen [(Kind, Kind)]
argTypes [Kind]
fields = do
  let usedArgs :: Set Name
usedArgs = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList ([Name] -> Set Name) -> [Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ [Kind] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [Kind]
fields
  args <-
    ((Kind, Kind) -> Q (Name, Maybe Name))
-> [(Kind, Kind)] -> Q [(Name, Maybe Name)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
      ( \(Kind
ty, Kind
_) ->
          case Kind
ty of
            VarT Name
nm ->
              if Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Name
nm Set Name
usedArgs
                then do
                  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)
            Kind
_ -> (Name, Maybe Name) -> Q (Name, Maybe Name)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ('undefined, Maybe Name
forall a. Maybe a
Nothing)
      )
      [(Kind, Kind)]
argTypes
  let argToFunPat =
        [(Name, Name)] -> Map Name Name
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, Name)] -> Map Name Name)
-> [(Name, Name)] -> Map Name Name
forall a b. (a -> b) -> a -> b
$ ((Name, Maybe Name) -> Maybe (Name, Name))
-> [(Name, Maybe Name)] -> [(Name, Name)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Name
ty, Maybe Name
mpat) -> (Name -> (Name, Name)) -> Maybe Name -> Maybe (Name, Name)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name
ty,) Maybe Name
mpat) [(Name, Maybe Name)]
args
  let funPats = ((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
  defaultFieldFunExps <- traverse (fieldFunExpGen argToFunPat) fields
  return (funPats, defaultFieldFunExps)

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

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

genConvertOpFieldClause ::
  DeriveConfig ->
  ConvertOpClassConfig ->
  [(Type, Kind)] ->
  [(Type, Kind)] ->
  [(Type, Kind)] ->
  [(Type, Kind)] ->
  ConstructorInfo ->
  Q Clause
genConvertOpFieldClause :: DeriveConfig
-> ConvertOpClassConfig
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> ConstructorInfo
-> Q Clause
genConvertOpFieldClause
  deriveConfig :: DeriveConfig
deriveConfig@DeriveConfig {Bool
[Int]
[(Int, Int)]
[(Int, EvalModeConfig)]
bitSizePositions :: DeriveConfig -> [Int]
evalModeConfig :: DeriveConfig -> [(Int, EvalModeConfig)]
fpBitSizePositions :: DeriveConfig -> [(Int, Int)]
needExtraMergeableUnderEvalMode :: DeriveConfig -> Bool
needExtraMergeableWithConcretizedEvalMode :: DeriveConfig -> Bool
unconstrainedPositions :: DeriveConfig -> [Int]
evalModeConfig :: [(Int, EvalModeConfig)]
bitSizePositions :: [Int]
fpBitSizePositions :: [(Int, Int)]
unconstrainedPositions :: [Int]
needExtraMergeableUnderEvalMode :: Bool
needExtraMergeableWithConcretizedEvalMode :: Bool
..}
  ConvertOpClassConfig {[Name]
EvalModeTag
Exp -> Exp -> Q Exp
Name -> [Exp] -> Q Exp
FieldFunExp
convertOpTarget :: EvalModeTag
convertOpInstanceNames :: [Name]
convertOpFunNames :: [Name]
convertFieldResFun :: Exp -> Exp -> Q Exp
convertFieldCombineFun :: Name -> [Exp] -> Q Exp
convertFieldFunExp :: FieldFunExp
convertFieldFunExp :: ConvertOpClassConfig -> FieldFunExp
convertFieldCombineFun :: ConvertOpClassConfig -> Name -> [Exp] -> Q Exp
convertFieldResFun :: ConvertOpClassConfig -> Exp -> Exp -> Q Exp
convertOpFunNames :: ConvertOpClassConfig -> [Name]
convertOpInstanceNames :: ConvertOpClassConfig -> [Name]
convertOpTarget :: ConvertOpClassConfig -> EvalModeTag
..}
  [(Kind, Kind)]
lhsKeptTypes
  [(Kind, Kind)]
rhsKeptTypes
  [(Kind, Kind)]
lhsArgTypes
  [(Kind, Kind)]
_rhsArgTypes
  ConstructorInfo
lhsConInfo = do
    fields <- (Kind -> Q Kind) -> [Kind] -> Q [Kind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Kind -> Q Kind
resolveTypeSynonyms ([Kind] -> Q [Kind]) -> [Kind] -> Q [Kind]
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> [Kind]
constructorFields ConstructorInfo
lhsConInfo
    (funPats, defaultFieldFunExps) <- funPatAndExps convertFieldFunExp lhsArgTypes fields
    fieldsPatNames <- replicateM (length fields) $ newName "field"
    fieldPats <- conP (constructorName lhsConInfo) (fmap varP fieldsPatNames)
    let fieldPatExps = (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Exp
VarE [Name]
fieldsPatNames
    fieldResExps <- zipWithM convertFieldResFun fieldPatExps defaultFieldFunExps
    resExp <- convertFieldCombineFun (constructorName lhsConInfo) fieldResExps
    let resUsedNames = Exp -> Set Name
allUsedNames Exp
resExp
    let transformPat (VarP Name
nm) =
          if Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Name
nm Set Name
resUsedNames then Name -> Pat
VarP Name
nm else Pat
WildP
        transformPat Pat
p = Pat
p
    resExpWithTags <-
      caseSplitTagPairs
        deriveConfig
        convertOpTarget
        lhsKeptTypes
        rhsKeptTypes
        resExp
    return $
      Clause
        (fmap transformPat $ funPats ++ [fieldPats])
        (NormalB resExpWithTags)
        []

genConvertOpFun ::
  DeriveConfig ->
  ConvertOpClassConfig ->
  Int ->
  [(Type, Kind)] ->
  [(Type, Kind)] ->
  [(Type, Kind)] ->
  [(Type, Kind)] ->
  [ConstructorInfo] ->
  Q Dec
genConvertOpFun :: DeriveConfig
-> ConvertOpClassConfig
-> Int
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [ConstructorInfo]
-> Q Dec
genConvertOpFun DeriveConfig
_ ConvertOpClassConfig
convertOpClassConfig Int
n [(Kind, Kind)]
_ [(Kind, Kind)]
_ [(Kind, Kind)]
_ [(Kind, Kind)]
_ [] = do
  let instanceFunName :: Name
instanceFunName = (ConvertOpClassConfig -> [Name]
convertOpFunNames ConvertOpClassConfig
convertOpClassConfig) [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
n
  Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
instanceFunName [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|error "impossible"|]) []]
genConvertOpFun
  DeriveConfig
deriveConfig
  ConvertOpClassConfig
convertOpClassConfig
  Int
n
  [(Kind, Kind)]
lhsKeptTypes
  [(Kind, Kind)]
rhsKeptTypes
  [(Kind, Kind)]
lhsArgTypes
  [(Kind, Kind)]
rhsArgTypes
  [ConstructorInfo]
lhsConstructors = do
    clauses <-
      (ConstructorInfo -> Q Clause) -> [ConstructorInfo] -> Q [Clause]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
        ( DeriveConfig
-> ConvertOpClassConfig
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> [(Kind, Kind)]
-> ConstructorInfo
-> Q Clause
genConvertOpFieldClause
            DeriveConfig
deriveConfig
            ConvertOpClassConfig
convertOpClassConfig
            [(Kind, Kind)]
lhsKeptTypes
            [(Kind, Kind)]
rhsKeptTypes
            [(Kind, Kind)]
lhsArgTypes
            [(Kind, Kind)]
rhsArgTypes
        )
        [ConstructorInfo]
lhsConstructors
    let instanceFunName = (ConvertOpClassConfig -> [Name]
convertOpFunNames ConvertOpClassConfig
convertOpClassConfig) [Name] -> Int -> Name
forall a. HasCallStack => [a] -> Int -> a
!! Int
n
    return $ FunD instanceFunName clauses

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

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

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

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

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

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

  instanceFun <-
    genConvertOpFun
      deriveConfig
      (ConvertOpClassConfig {..})
      n
      (keptVars lResult)
      (keptVars rResult)
      (argVars lResult)
      (argVars rResult)
      lConstructors

  let instanceUnionType =
        case EvalModeTag
convertOpTarget of
          EvalModeTag
S ->
            Kind -> Kind -> Kind
AppT
              (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
instanceName) Kind
lKeptType)
              (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT ''Union) Kind
rKeptType)
          EvalModeTag
C ->
            Kind -> Kind -> Kind
AppT
              (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
instanceName) (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT ''Union) Kind
lKeptType))
              Kind
rKeptType
  instanceUnionFun <- do
    resExp <-
      if convertOpTarget == S
        then varE 'toUnionSym
        else varE 'unionToCon
    funD (head convertOpFunNames) [clause [] (normalB $ return resExp) []]

  return $
    InstanceD
      (Just Incoherent)
      (extraPreds ++ if null (constructors lResult) then [] else catMaybes ctxs)
      instanceType
      [instanceFun]
      : ( [ InstanceD
              (Just Incoherent)
              ( unionExtraPreds
                  ++ if null (constructors lResult)
                    then []
                    else catMaybes ctxs
              )
              instanceUnionType
              [instanceUnionFun]
          | n == 0
          ]
        )