-- editorconfig-checker-disable-file
{-# 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
    -- (==) i -> True
    ixMatchPat :: PatQ
ixMatchPat = [p| ((PlutusTx.==) (conIx :: Integer) -> True) |]
    -- [unsafeFromBuiltinData -> arg1, ...]
    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

-- TODO: safe match for the whole thing? not needed atm

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
    -- (==) i -> True
    ixMatchPat :: PatQ
ixMatchPat = [p| ((PlutusTx.==) (conIx :: Integer) -> True) |]
    -- [unsafeFromBuiltinData -> arg1, ...]
    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"

    -- Build the constructor application, assuming that all the arguments are in scope
    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"
    -- Call the clause for each constructor, falling through to the next one, until we get to the end in which case we call 'error'
    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 =
          [|
            -- See Note [Bang patterns in TH quotes]
            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"

    -- Build the constructor application, assuming that all the arguments are in scope
    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"
    -- Call the clause for each constructor, falling through to the next one, until we get to the end in which case we call 'error'
    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 =
          [|
            -- See Note [Bang patterns in TH quotes]
            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..]

-- | Generate a 'FromData' and a 'ToData' instance for a type.
-- This may not be stable in the face of constructor additions,
-- renamings, etc. Use 'makeIsDataIndexed' if you need stability.
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

-- | Generate a 'ToData', 'FromData and a 'UnsafeFromData' instances for a type,
-- using an explicit mapping of constructor names to indices.
-- Use this for types where you need to keep the representation stable.
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

{- Note [indexMatchCase and fallthrough]
`indexMatchCase` and `fallthrough` need to be non-strict, because (1) at most one of them
needs to be evaluated; (2) evaluating `indexMatchCase` when it shouldn't be evaluated
can lead to `BI.head []` (e.g., in the `UnsafeFromData (Maybe a)` instance); (3) evaluating
`fallthrough` when it shouldn't be evaluated can lead to PT1 (reconstructCaseError).
-}

{- Note [Bang patterns in TH quotes]
Bang patterns in TH quotes do not work before GHC 9.8.1. See
https://gitlab.haskell.org/ghc/ghc/-/issues/23036.

For the time being, we need to use `TH.bangP`.
-}