-- editorconfig-checker-disable-file
{-# LANGUAGE BangPatterns    #-}
{-# LANGUAGE CPP             #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns    #-}
module PlutusTx.IsData.TH (
  unstableMakeIsData,
  makeIsDataIndexed,
  mkConstrCreateExpr,
  mkUnsafeConstrMatchPattern,
  mkConstrPartsMatchPattern,
  mkUnsafeConstrPartsMatchPattern,
  mkAsDataMatchingFunction,
) 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 hiding (drop)
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

-- | Generate a function that matches on a 'BuiltinData' value and decodes it as a product type.
mkAsDataMatchingFunction
  :: TH.Name
  -- ^ The name of the type
  -> [TH.Name]
  -- ^ Type variables of the type
  -> TH.Name
  -- ^ The name of the constructor
  -> [TH.Type]
  -- ^ Types of the fields
  -> [TH.Name]
  -- ^ The names of the fields
  -> TH.Q (TH.Dec, TH.Dec)
mkAsDataMatchingFunction :: Name -> [Name] -> Name -> [Type] -> [Name] -> Q (Dec, Dec)
mkAsDataMatchingFunction Name
name [Name]
typeVars Name
consName [Type]
fieldTypes [Name]
fields = do
  let numFields :: Int
numFields = [Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
fields
  Name
funcName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"matchOn" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
TH.nameBase Name
name
  Name
builtinData <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"builtinData"
  Name
asConstrN <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"asConstr"
  Name
constrArgsN <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"constrArgs"
  [Name]
restNs <- (Int -> Q Name) -> [Int] -> Q [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 (\Int
i -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"rest" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i) [Int
0 .. Int
numFields Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2]
  [Name]
fieldNs <- (Int -> Q Name) -> [Int] -> Q [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 (\Int
i -> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
TH.newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"field" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i) [Int
0 .. Int
numFields Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
  Pat
argPat <- Name -> [PatQ] -> PatQ
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
TH.conP Name
consName [Pat -> PatQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> PatQ) -> Pat -> PatQ
forall a b. (a -> b) -> a -> b
$ Name -> Pat
TH.VarP Name
builtinData]
  let restDecs :: [Dec]
restDecs =
        (((Name, Name) -> Dec) -> [(Name, Name)] -> [Dec])
-> [(Name, Name)] -> ((Name, Name) -> Dec) -> [Dec]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Name, Name) -> Dec) -> [(Name, Name)] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
restNs (Name
constrArgsN Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
restNs)) (((Name, Name) -> Dec) -> [Dec]) -> ((Name, Name) -> Dec) -> [Dec]
forall a b. (a -> b) -> a -> b
$ \(Name
resti, Name
restj) ->
          Pat -> Body -> [Dec] -> Dec
TH.ValD
            (Name -> Pat
TH.VarP Name
resti)
            (Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE 'BI.tail) (Name -> Exp
TH.VarE Name
restj))
            []
      fieldDecs :: [Dec]
fieldDecs =
          (((Name, Name) -> Dec) -> [(Name, Name)] -> [Dec])
-> [(Name, Name)] -> ((Name, Name) -> Dec) -> [Dec]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Name, Name) -> Dec) -> [(Name, Name)] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
fieldNs (Name
constrArgsN Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
restNs)) (((Name, Name) -> Dec) -> [Dec]) -> ((Name, Name) -> Dec) -> [Dec]
forall a b. (a -> b) -> a -> b
$ \(Name
fieldi, Name
restj) ->
              Pat -> Body -> [Dec] -> Dec
TH.ValD
                (Name -> Pat
TH.VarP Name
fieldi)
                (Exp -> Body
TH.NormalB
                  (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
TH.AppE
                      (Name -> Exp
TH.VarE 'unsafeFromBuiltinData)
                      (Exp -> Exp -> Exp
TH.AppE
                        (Name -> Exp
TH.VarE 'BI.head)
                        (Name -> Exp
TH.VarE Name
restj)
                      )
                )
                []
      decs :: [Dec]
decs =
        [ Pat -> Body -> [Dec] -> Dec
TH.ValD
            (Name -> Pat
TH.VarP Name
asConstrN)
            (Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE 'BI.unsafeDataAsConstr) (Name -> Exp
TH.VarE Name
builtinData))
            []
        , Pat -> Body -> [Dec] -> Dec
TH.ValD
            (Name -> Pat
TH.VarP Name
constrArgsN)
            (Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE 'BI.snd) (Name -> Exp
TH.VarE Name
asConstrN))
            []
        ]
        [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
fieldDecs
        [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
restDecs
      resultExpr :: Exp
resultExpr =
        [Maybe Exp] -> Exp
TH.TupE
        ([Maybe Exp] -> Exp) -> [Maybe Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> (Name -> Exp) -> Name -> Maybe Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
TH.VarE
        (Name -> Maybe Exp) -> [Name] -> [Maybe Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fieldNs
      body :: Body
body = Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ [Dec] -> Exp -> Exp
TH.LetE [Dec]
decs Exp
resultExpr
      clause :: Clause
clause = [Pat] -> Body -> [Dec] -> Clause
TH.Clause [Pat
argPat] Body
body []
      functionDef :: Dec
functionDef = Name -> [Clause] -> Dec
TH.FunD Name
funcName [Clause
clause]
      tupleType :: Type
tupleType = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
TH.AppT (Int -> Type
TH.TupleT Int
numFields) [Type]
fieldTypes
      tType :: Type
tType = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT Name
name) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
TH.VarT (Name -> Type) -> [Name] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
typeVars
      constraints :: [Type]
constraints = (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Name
ty -> Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT ''UnsafeFromData) (Name -> Type
TH.VarT Name
ty)) [Name]
typeVars
      typeBody :: Type
typeBody = Type -> Type -> Type
TH.AppT (Type -> Type -> Type
TH.AppT Type
TH.ArrowT Type
tType) Type
tupleType
      typeBodyWithQuantification :: Type
typeBodyWithQuantification = [TyVarBndr Specificity] -> [Type] -> Type -> Type
TH.ForallT [] [Type]
constraints Type
typeBody
      functionType :: Dec
functionType = Name -> Type -> Dec
TH.SigD Name
funcName Type
typeBodyWithQuantification
    in (Dec, Dec) -> Q (Dec, Dec)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
functionType, Dec
functionDef)

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`.
-}