{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module PlutusTx.IsData.TH (
unstableMakeIsData,
makeIsDataIndexed,
mkConstrCreateExpr,
mkUnsafeConstrMatchPattern,
mkConstrPartsMatchPattern,
mkUnsafeConstrPartsMatchPattern,
) where
import Data.Foldable as Foldable (foldl')
import Data.Functor ((<&>))
import Data.Traversable (for)
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Datatype qualified as TH
import PlutusTx.Builtins as Builtins
import PlutusTx.Builtins.Internal qualified as BI
import PlutusTx.Eq qualified as PlutusTx
import PlutusTx.ErrorCodes (reconstructCaseError)
import PlutusTx.IsData.Class (FromData (..), ToData (..), UnsafeFromData (..))
import PlutusTx.Trace (traceError)
import Prelude
mkConstrCreateExpr :: Integer -> [TH.Name] -> TH.ExpQ
mkConstrCreateExpr :: Integer -> [Name] -> ExpQ
mkConstrCreateExpr Integer
conIx [Name]
createFieldNames =
let
createArgsExpr :: TH.ExpQ
createArgsExpr :: ExpQ
createArgsExpr = (Name -> ExpQ -> ExpQ) -> ExpQ -> [Name] -> ExpQ
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
(\Name
v ExpQ
e -> [| BI.mkCons (toBuiltinData $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
v)) $ExpQ
e |])
[| BI.mkNilData BI.unitval |]
[Name]
createFieldNames
createExpr :: ExpQ
createExpr = [| BI.mkConstr (conIx :: Integer) $ExpQ
createArgsExpr |]
in ExpQ
createExpr
mkConstrPartsMatchPattern :: Integer -> [TH.Name] -> TH.PatQ
mkConstrPartsMatchPattern :: Integer -> [Name] -> PatQ
mkConstrPartsMatchPattern Integer
conIx [Name]
extractFieldNames =
let
ixMatchPat :: PatQ
ixMatchPat = [p| ((PlutusTx.==) (conIx :: Integer) -> True) |]
extractArgPats :: [PatQ]
extractArgPats = [Name]
extractFieldNames [Name] -> (Name -> PatQ) -> [PatQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Name
n ->
[p| (fromBuiltinData -> Just $(Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP Name
n)) |]
extractArgsPat :: PatQ
extractArgsPat = [PatQ] -> PatQ
forall {m :: * -> *}. Quote m => [m Pat] -> m Pat
go [PatQ]
extractArgPats
where
go :: [m Pat] -> m Pat
go [] = [p| _ |]
go [m Pat
x] = [p| (Builtins.headMaybe -> Just $m Pat
x) |]
go (m Pat
x:[m Pat]
xs) = [p| (Builtins.uncons -> Just ($m Pat
x, $([m Pat] -> m Pat
go [m Pat]
xs))) |]
pat :: PatQ
pat = [p| ($PatQ
ixMatchPat, $PatQ
extractArgsPat) |]
in PatQ
pat
mkUnsafeConstrMatchPattern :: Integer -> [TH.Name] -> TH.PatQ
mkUnsafeConstrMatchPattern :: Integer -> [Name] -> PatQ
mkUnsafeConstrMatchPattern Integer
conIx [Name]
extractFieldNames =
[p| (BI.unsafeDataAsConstr -> (Builtins.pairToPair -> $(Integer -> [Name] -> PatQ
mkUnsafeConstrPartsMatchPattern Integer
conIx [Name]
extractFieldNames))) |]
mkUnsafeConstrPartsMatchPattern :: Integer -> [TH.Name] -> TH.PatQ
mkUnsafeConstrPartsMatchPattern :: Integer -> [Name] -> PatQ
mkUnsafeConstrPartsMatchPattern Integer
conIx [Name]
extractFieldNames =
let
ixMatchPat :: PatQ
ixMatchPat = [p| ((PlutusTx.==) (conIx :: Integer) -> True) |]
extractArgPats :: [PatQ]
extractArgPats = [Name]
extractFieldNames [Name] -> (Name -> PatQ) -> [PatQ]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Name
n ->
[p| (unsafeFromBuiltinData -> $(Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP Name
n)) |]
extractArgsPat :: PatQ
extractArgsPat = [PatQ] -> PatQ
forall {m :: * -> *}. Quote m => [m Pat] -> m Pat
go [PatQ]
extractArgPats
where
go :: [m Pat] -> m Pat
go [] = [p| _ |]
go [m Pat
x] = [p| (BI.head -> $m Pat
x) |]
go (m Pat
x:[m Pat]
xs) = [p| (Builtins.unsafeUncons -> ($m Pat
x, $([m Pat] -> m Pat
go [m Pat]
xs))) |]
pat :: PatQ
pat = [p| ($PatQ
ixMatchPat, $PatQ
extractArgsPat) |]
in PatQ
pat
toDataClause :: (TH.ConstructorInfo, Int) -> TH.Q TH.Clause
toDataClause :: (ConstructorInfo, Int) -> Q Clause
toDataClause (TH.ConstructorInfo{constructorName :: ConstructorInfo -> Name
TH.constructorName=Name
name, constructorFields :: ConstructorInfo -> [Type]
TH.constructorFields=[Type]
argTys}, Int
index) = do
[Name]
argNames <- [Type] -> (Type -> Q Name) -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Type]
argTys ((Type -> Q Name) -> Q [Name]) -> (Type -> Q Name) -> Q [Name]
forall a b. (a -> b) -> a -> b
$ \Type
_ -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"arg"
let create :: ExpQ
create = Integer -> [Name] -> ExpQ
mkConstrCreateExpr (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
index) [Name]
argNames
[PatQ] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Name -> [PatQ] -> PatQ
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
TH.conP Name
name ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP [Name]
argNames)] (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB ExpQ
create) []
toDataClauses :: [(TH.ConstructorInfo, Int)] -> [TH.Q TH.Clause]
toDataClauses :: [(ConstructorInfo, Int)] -> [Q Clause]
toDataClauses [(ConstructorInfo, Int)]
indexedCons = (ConstructorInfo, Int) -> Q Clause
toDataClause ((ConstructorInfo, Int) -> Q Clause)
-> [(ConstructorInfo, Int)] -> [Q Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ConstructorInfo, Int)]
indexedCons
reconstructCase :: (TH.ConstructorInfo, Int) -> TH.MatchQ
reconstructCase :: (ConstructorInfo, Int) -> MatchQ
reconstructCase (TH.ConstructorInfo{constructorName :: ConstructorInfo -> Name
TH.constructorName=Name
name, constructorFields :: ConstructorInfo -> [Type]
TH.constructorFields=[Type]
argTys}, Int
index) = do
[Name]
argNames <- [Type] -> (Type -> Q Name) -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Type]
argTys ((Type -> Q Name) -> Q [Name]) -> (Type -> Q Name) -> Q [Name]
forall a b. (a -> b) -> a -> b
$ \Type
_ -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"arg"
let app :: ExpQ
app = (ExpQ -> Name -> ExpQ) -> ExpQ -> [Name] -> ExpQ
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' (\ExpQ
h Name
v -> [| $ExpQ
h $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
v) |]) (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
TH.conE Name
name) [Name]
argNames
PatQ -> Q Body -> [Q Dec] -> MatchQ
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
TH.match (Integer -> [Name] -> PatQ
mkConstrPartsMatchPattern (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
index) [Name]
argNames) (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB [| Just $ExpQ
app |]) []
fromDataClause :: [(TH.ConstructorInfo, Int)] -> TH.Q TH.Clause
fromDataClause :: [(ConstructorInfo, Int)] -> Q Clause
fromDataClause [(ConstructorInfo, Int)]
indexedCons = do
Name
dName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"d"
Name
indexName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"index"
Name
argsName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"args"
let
conCases :: [TH.MatchQ]
conCases :: [MatchQ]
conCases = (((ConstructorInfo, Int) -> MatchQ)
-> [(ConstructorInfo, Int)] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(ConstructorInfo, Int)
ixCon -> (ConstructorInfo, Int) -> MatchQ
reconstructCase (ConstructorInfo, Int)
ixCon) [(ConstructorInfo, Int)]
indexedCons)
finalCase :: TH.MatchQ
finalCase :: MatchQ
finalCase = PatQ -> Q Body -> [Q Dec] -> MatchQ
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
TH.match PatQ
forall (m :: * -> *). Quote m => m Pat
TH.wildP (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB [| Nothing |]) []
cases :: [MatchQ]
cases = [MatchQ]
conCases [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. [a] -> [a] -> [a]
++ [MatchQ
finalCase]
kase :: TH.ExpQ
kase :: ExpQ
kase = ExpQ -> [MatchQ] -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
TH.caseE [| ($(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
indexName), $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
argsName))|] [MatchQ]
cases
let body :: ExpQ
body =
[|
let constrFun $(PatQ -> PatQ
forall (m :: * -> *). Quote m => m Pat -> m Pat
TH.bangP (PatQ -> PatQ) -> PatQ -> PatQ
forall a b. (a -> b) -> a -> b
$ Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP Name
indexName) $(PatQ -> PatQ
forall (m :: * -> *). Quote m => m Pat -> m Pat
TH.bangP (PatQ -> PatQ) -> PatQ -> PatQ
forall a b. (a -> b) -> a -> b
$ Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP Name
argsName) = $ExpQ
kase
in matchData' $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
dName) constrFun (const Nothing) (const Nothing) (const Nothing) (const Nothing)
|]
[PatQ] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP Name
dName] (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB ExpQ
body) []
unsafeReconstructCase :: (TH.ConstructorInfo, Int) -> TH.MatchQ
unsafeReconstructCase :: (ConstructorInfo, Int) -> MatchQ
unsafeReconstructCase (TH.ConstructorInfo{constructorName :: ConstructorInfo -> Name
TH.constructorName=Name
name, constructorFields :: ConstructorInfo -> [Type]
TH.constructorFields=[Type]
argTys}, Int
index) = do
[Name]
argNames <- [Type] -> (Type -> Q Name) -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Type]
argTys ((Type -> Q Name) -> Q [Name]) -> (Type -> Q Name) -> Q [Name]
forall a b. (a -> b) -> a -> b
$ \Type
_ -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"arg"
let app :: ExpQ
app = (ExpQ -> Name -> ExpQ) -> ExpQ -> [Name] -> ExpQ
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ExpQ
h Name
v -> [| $ExpQ
h $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
v) |]) (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
TH.conE Name
name) [Name]
argNames
PatQ -> Q Body -> [Q Dec] -> MatchQ
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
TH.match (Integer -> [Name] -> PatQ
mkUnsafeConstrPartsMatchPattern (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
index) [Name]
argNames) (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB ExpQ
app) []
unsafeFromDataClause :: [(TH.ConstructorInfo, Int)] -> TH.Q TH.Clause
unsafeFromDataClause :: [(ConstructorInfo, Int)] -> Q Clause
unsafeFromDataClause [(ConstructorInfo, Int)]
indexedCons = do
Name
dName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"d"
Name
tupName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"tup"
Name
indexName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"index"
Name
argsName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"args"
let
conCases :: [TH.MatchQ]
conCases :: [MatchQ]
conCases = (((ConstructorInfo, Int) -> MatchQ)
-> [(ConstructorInfo, Int)] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(ConstructorInfo, Int)
ixCon -> (ConstructorInfo, Int) -> MatchQ
unsafeReconstructCase (ConstructorInfo, Int)
ixCon) [(ConstructorInfo, Int)]
indexedCons)
finalCase :: TH.MatchQ
finalCase :: MatchQ
finalCase = PatQ -> Q Body -> [Q Dec] -> MatchQ
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
TH.match PatQ
forall (m :: * -> *). Quote m => m Pat
TH.wildP (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB [| traceError reconstructCaseError |]) []
cases :: [MatchQ]
cases = [MatchQ]
conCases [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. [a] -> [a] -> [a]
++ [MatchQ
finalCase]
kase :: TH.ExpQ
kase :: ExpQ
kase = ExpQ -> [MatchQ] -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
TH.caseE [| ($(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
indexName), $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
argsName))|] [MatchQ]
cases
let body :: ExpQ
body =
[|
let $(PatQ -> PatQ
forall (m :: * -> *). Quote m => m Pat -> m Pat
TH.bangP (PatQ -> PatQ) -> PatQ -> PatQ
forall a b. (a -> b) -> a -> b
$ Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP Name
tupName) = BI.unsafeDataAsConstr $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
dName)
$(PatQ -> PatQ
forall (m :: * -> *). Quote m => m Pat -> m Pat
TH.bangP (PatQ -> PatQ) -> PatQ -> PatQ
forall a b. (a -> b) -> a -> b
$ Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP Name
indexName) = BI.fst $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
tupName)
$(PatQ -> PatQ
forall (m :: * -> *). Quote m => m Pat -> m Pat
TH.bangP (PatQ -> PatQ) -> PatQ -> PatQ
forall a b. (a -> b) -> a -> b
$ Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP Name
argsName) = BI.snd $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
tupName)
in $ExpQ
kase
|]
[PatQ] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Name -> PatQ
forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP Name
dName] (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB ExpQ
body) []
defaultIndex :: TH.Name -> TH.Q [(TH.Name, Int)]
defaultIndex :: Name -> Q [(Name, Int)]
defaultIndex Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
TH.reifyDatatype Name
name
[(Name, Int)] -> Q [(Name, Int)]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Name, Int)] -> Q [(Name, Int)])
-> [(Name, Int)] -> Q [(Name, Int)]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Int] -> [(Name, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (ConstructorInfo -> Name
TH.constructorName (ConstructorInfo -> Name) -> [ConstructorInfo] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatatypeInfo -> [ConstructorInfo]
TH.datatypeCons DatatypeInfo
info) [Int
0..]
unstableMakeIsData :: TH.Name -> TH.Q [TH.Dec]
unstableMakeIsData :: Name -> Q [Dec]
unstableMakeIsData Name
name = Name -> [(Name, Int)] -> Q [Dec]
makeIsDataIndexed Name
name ([(Name, Int)] -> Q [Dec]) -> Q [(Name, Int)] -> Q [Dec]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> Q [(Name, Int)]
defaultIndex Name
name
makeIsDataIndexed :: TH.Name -> [(TH.Name, Int)] -> TH.Q [TH.Dec]
makeIsDataIndexed :: Name -> [(Name, Int)] -> Q [Dec]
makeIsDataIndexed Name
dataTypeName [(Name, Int)]
indices = do
DatatypeInfo
dataTypeInfo <- Name -> Q DatatypeInfo
TH.reifyDatatype Name
dataTypeName
let appliedType :: Type
appliedType = DatatypeInfo -> Type
TH.datatypeType DatatypeInfo
dataTypeInfo
let nonOverlapInstance :: [Type] -> Type -> [Dec] -> Dec
nonOverlapInstance = Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
TH.InstanceD Maybe Overlap
forall a. Maybe a
Nothing
[(ConstructorInfo, Int)]
indexedCons <- [ConstructorInfo]
-> (ConstructorInfo -> Q (ConstructorInfo, Int))
-> Q [(ConstructorInfo, Int)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (DatatypeInfo -> [ConstructorInfo]
TH.datatypeCons DatatypeInfo
dataTypeInfo) ((ConstructorInfo -> Q (ConstructorInfo, Int))
-> Q [(ConstructorInfo, Int)])
-> (ConstructorInfo -> Q (ConstructorInfo, Int))
-> Q [(ConstructorInfo, Int)]
forall a b. (a -> b) -> a -> b
$ \ConstructorInfo
ctorInfo ->
case Name -> [(Name, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (ConstructorInfo -> Name
TH.constructorName ConstructorInfo
ctorInfo) [(Name, Int)]
indices of
Just Int
i -> (ConstructorInfo, Int) -> Q (ConstructorInfo, Int)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConstructorInfo
ctorInfo, Int
i)
Maybe Int
Nothing -> String -> Q (ConstructorInfo, Int)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (ConstructorInfo, Int))
-> String -> Q (ConstructorInfo, Int)
forall a b. (a -> b) -> a -> b
$ String
"No index given for constructor" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show (ConstructorInfo -> Name
TH.constructorName ConstructorInfo
ctorInfo)
Dec
toDataInst <- do
let constraints :: [Type]
constraints = DatatypeInfo -> [TyVarBndrUnit]
TH.datatypeVars DatatypeInfo
dataTypeInfo [TyVarBndrUnit] -> (TyVarBndrUnit -> Type) -> [Type]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \TyVarBndrUnit
tyVarBinder ->
Name -> [Type] -> Type
TH.classPred ''ToData [Name -> Type
TH.VarT (TyVarBndrUnit -> Name
forall {flag}. TyVarBndr flag -> Name
tyvarbndrName TyVarBndrUnit
tyVarBinder)]
Dec
toDataDecl <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
TH.funD 'toBuiltinData ([(ConstructorInfo, Int)] -> [Q Clause]
toDataClauses [(ConstructorInfo, Int)]
indexedCons)
Dec
toDataPrag <- Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
TH.pragInlD 'toBuiltinData Inline
TH.Inlinable RuleMatch
TH.FunLike Phases
TH.AllPhases
Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> [Dec] -> Dec
nonOverlapInstance
[Type]
constraints
(Name -> [Type] -> Type
TH.classPred ''ToData [Type
appliedType])
[Dec
toDataPrag, Dec
toDataDecl]
Dec
fromDataInst <- do
let constraints :: [Type]
constraints = DatatypeInfo -> [TyVarBndrUnit]
TH.datatypeVars DatatypeInfo
dataTypeInfo [TyVarBndrUnit] -> (TyVarBndrUnit -> Type) -> [Type]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \TyVarBndrUnit
tyVarBinder ->
Name -> [Type] -> Type
TH.classPred ''FromData [Name -> Type
TH.VarT (TyVarBndrUnit -> Name
forall {flag}. TyVarBndr flag -> Name
tyvarbndrName TyVarBndrUnit
tyVarBinder)]
Dec
fromDataDecl <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
TH.funD 'fromBuiltinData [[(ConstructorInfo, Int)] -> Q Clause
fromDataClause [(ConstructorInfo, Int)]
indexedCons]
Dec
fromDataPrag <- Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
TH.pragInlD 'fromBuiltinData Inline
TH.Inlinable RuleMatch
TH.FunLike Phases
TH.AllPhases
Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> [Dec] -> Dec
nonOverlapInstance
[Type]
constraints
(Name -> [Type] -> Type
TH.classPred ''FromData [Type
appliedType])
[Dec
fromDataPrag, Dec
fromDataDecl]
Dec
unsafeFromDataInst <- do
let constraints :: [Type]
constraints = DatatypeInfo -> [TyVarBndrUnit]
TH.datatypeVars DatatypeInfo
dataTypeInfo [TyVarBndrUnit] -> (TyVarBndrUnit -> Type) -> [Type]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \TyVarBndrUnit
tyVarBinder ->
Name -> [Type] -> Type
TH.classPred ''UnsafeFromData [Name -> Type
TH.VarT (TyVarBndrUnit -> Name
forall {flag}. TyVarBndr flag -> Name
tyvarbndrName TyVarBndrUnit
tyVarBinder)]
Dec
unsafeFromDataDecl <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
TH.funD 'unsafeFromBuiltinData [[(ConstructorInfo, Int)] -> Q Clause
unsafeFromDataClause [(ConstructorInfo, Int)]
indexedCons]
Dec
unsafeFromDataPrag <- Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
TH.pragInlD 'unsafeFromBuiltinData Inline
TH.Inlinable RuleMatch
TH.FunLike Phases
TH.AllPhases
Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> [Dec] -> Dec
nonOverlapInstance
[Type]
constraints
(Name -> [Type] -> Type
TH.classPred ''UnsafeFromData [Type
appliedType])
[Dec
unsafeFromDataPrag, Dec
unsafeFromDataDecl]
[Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
toDataInst, Dec
fromDataInst, Dec
unsafeFromDataInst]
where
#if MIN_VERSION_template_haskell(2,17,0)
tyvarbndrName :: TyVarBndr flag -> Name
tyvarbndrName (TH.PlainTV Name
n flag
_) = Name
n
tyvarbndrName (TH.KindedTV Name
n flag
_ Type
_) = Name
n
#else
tyvarbndrName (TH.PlainTV n) = n
tyvarbndrName (TH.KindedTV n _) = n
#endif