{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module PlutusTx.IsData.TH (
unsafeFromDataClause,
unstableMakeIsData,
makeIsDataIndexed,
makeIsDataAsList,
mkConstrCreateExpr,
mkUnsafeConstrMatchPattern,
mkConstrPartsMatchPattern,
mkUnsafeConstrPartsMatchPattern,
AsDataProdType (..),
) 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.AsData.Internal (wrapUnsafeDataAsConstr, wrapUnsafeUncons)
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
mkListCreateExpr :: [TH.Name] -> TH.ExpQ
mkListCreateExpr :: [Name] -> ExpQ
mkListCreateExpr [Name]
createFieldNames =
(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
mkConstrCreateExpr :: Integer -> [TH.Name] -> TH.ExpQ
mkConstrCreateExpr :: Integer -> [Name] -> ExpQ
mkConstrCreateExpr Integer
conIx [Name]
createFieldNames =
[|BI.mkConstr (conIx :: Integer) $([Name] -> ExpQ
mkListCreateExpr [Name]
createFieldNames)|]
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
mkListPartsMatchPattern :: [TH.Name] -> TH.PatQ
mkListPartsMatchPattern :: [Name] -> PatQ
mkListPartsMatchPattern [Name]
extractFieldNames =
let
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))|]
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)))|]
in [p|$([PatQ] -> PatQ
forall {m :: * -> *}. Quote m => [m Pat] -> m Pat
go [PatQ]
extractArgPats)|]
data AsDataProdType
= IsAsDataProdType
| IsNotAsDataProdType
mkUnsafeConstrMatchPattern
:: AsDataProdType
-> Integer
-> [TH.Name]
-> TH.PatQ
mkUnsafeConstrMatchPattern :: AsDataProdType -> Integer -> [Name] -> PatQ
mkUnsafeConstrMatchPattern AsDataProdType
isProduct Integer
conIx [Name]
extractFieldNames =
case AsDataProdType
isProduct of
AsDataProdType
IsAsDataProdType ->
[p|
( wrapUnsafeDataAsConstr ->
( BI.snd ->
$(AsDataProdType -> Integer -> [Name] -> PatQ
mkUnsafeConstrPartsMatchPattern AsDataProdType
isProduct Integer
conIx [Name]
extractFieldNames)
)
)
|]
AsDataProdType
IsNotAsDataProdType ->
[p|
( wrapUnsafeDataAsConstr ->
( Builtins.pairToPair ->
$(AsDataProdType -> Integer -> [Name] -> PatQ
mkUnsafeConstrPartsMatchPattern AsDataProdType
isProduct Integer
conIx [Name]
extractFieldNames)
)
)
|]
mkUnsafeConstrPartsMatchPattern
:: AsDataProdType
-> Integer
-> [TH.Name]
-> TH.PatQ
mkUnsafeConstrPartsMatchPattern :: AsDataProdType -> Integer -> [Name] -> PatQ
mkUnsafeConstrPartsMatchPattern AsDataProdType
isProduct 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|(wrapUnsafeUncons -> ($m Pat
x, $([m Pat] -> m Pat
go [m Pat]
xs)))|]
pat :: PatQ
pat =
case AsDataProdType
isProduct of
AsDataProdType
IsAsDataProdType -> [p|$PatQ
extractArgsPat|]
AsDataProdType
IsNotAsDataProdType -> [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) []
toDataListClause :: TH.ConstructorInfo -> TH.Q TH.Clause
toDataListClause :: ConstructorInfo -> Q Clause
toDataListClause TH.ConstructorInfo{constructorName :: ConstructorInfo -> Name
TH.constructorName = Name
name, constructorFields :: ConstructorInfo -> [Type]
TH.constructorFields = [Type]
argTys} = 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 = [|BI.mkList $([Name] -> ExpQ
mkListCreateExpr [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) []
fromDataListClause :: TH.ConstructorInfo -> TH.Q TH.Clause
fromDataListClause :: ConstructorInfo -> Q Clause
fromDataListClause TH.ConstructorInfo{constructorName :: ConstructorInfo -> Name
TH.constructorName = Name
consName, constructorFields :: ConstructorInfo -> [Type]
TH.constructorFields = [Type]
argTys} = do
Name
dName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"d"
Name
argsName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"args"
let
singleCase :: TH.MatchQ
singleCase :: MatchQ
singleCase = do
[Name]
constructorArgs <- [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
"consArg"
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
consName) [Name]
constructorArgs
PatQ -> Q Body -> [Q Dec] -> MatchQ
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
TH.match ([Name] -> PatQ
mkListPartsMatchPattern [Name]
constructorArgs) (ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
TH.normalB [|Just $ExpQ
app|]) []
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
singleCase, 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
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
argsName) = $ExpQ
kase
in matchData'
$(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
dName)
(const $ const Nothing)
(const Nothing)
constrFun
(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
(AsDataProdType -> Integer -> [Name] -> PatQ
mkUnsafeConstrPartsMatchPattern AsDataProdType
IsNotAsDataProdType (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)
[]
unsafeReconstructListCase :: TH.ConstructorInfo -> TH.MatchQ
unsafeReconstructListCase :: ConstructorInfo -> MatchQ
unsafeReconstructListCase TH.ConstructorInfo{constructorName :: ConstructorInfo -> Name
TH.constructorName = Name
name, constructorFields :: ConstructorInfo -> [Type]
TH.constructorFields = [Type]
argTys} = 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
(AsDataProdType -> Integer -> [Name] -> PatQ
mkUnsafeConstrPartsMatchPattern AsDataProdType
IsAsDataProdType (-Integer
1) [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) []
unsafeFromDataListClause :: TH.ConstructorInfo -> TH.Q TH.Clause
unsafeFromDataListClause :: ConstructorInfo -> Q Clause
unsafeFromDataListClause ConstructorInfo
cons = do
Name
dName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"d"
Name
argsName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"args"
let
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 = [ConstructorInfo -> MatchQ
unsafeReconstructListCase ConstructorInfo
cons, 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
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
argsName) = BI.unsafeDataAsList $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
TH.varE Name
dName)
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
makeIsDataAsList :: TH.Name -> TH.Q [TH.Dec]
makeIsDataAsList :: Name -> Q [Dec]
makeIsDataAsList Name
dataTypeName = 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
cons <-
case DatatypeInfo -> [ConstructorInfo]
TH.datatypeCons DatatypeInfo
dataTypeInfo of
[ConstructorInfo
cons] -> ConstructorInfo -> Q ConstructorInfo
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstructorInfo
cons
[ConstructorInfo]
_ -> String -> Q ConstructorInfo
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Only data types with single constructor are eligible for 'makeIsDataAsList'"
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 -> Q Clause
toDataListClause ConstructorInfo
cons]
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 -> Q Clause
fromDataListClause ConstructorInfo
cons]
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 -> Q Clause
unsafeFromDataListClause ConstructorInfo
cons]
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