-- editorconfig-checker-disable-file
{-# 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
    -- Do not change this to raw integer pattern matching.
    -- GHC may inline `integerEq` and do integer equality by matching
    -- them structurally, which the plugin does not know how to handle.
    -- (==) 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

mkListPartsMatchPattern :: [TH.Name] -> TH.PatQ
mkListPartsMatchPattern :: [Name] -> PatQ
mkListPartsMatchPattern [Name]
extractFieldNames =
  let
    -- [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))|]
    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)|]

{-| If generating pattern synonyms for a product type declared with 'asData',
we can avoid the index match, as we know that the type only has one constructor.
-}
data AsDataProdType
  = IsAsDataProdType
  | IsNotAsDataProdType

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

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
    -- (==) 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|(wrapUnsafeUncons -> ($m Pat
x, $([m Pat] -> m Pat
go [m Pat]
xs)))|]
    pat :: PatQ
pat =
      -- We can safely omit the index match if we know that the type is a product type
      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"

  -- 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) []

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"
  -- 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
    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 =
        [|
          -- 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
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"

  -- 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
    (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"

  -- 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
    (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"
  -- 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) []

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"
  -- 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
    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 =
        [|
          -- 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
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 ..]

{-| 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

{-| Generates `FromData` and `ToData` instances for a type.
Requires the type to have exactly one constructor,
since instances created by `deriveIsDataAsList` use a list encoding
instead of `Constr` and thus cannot represent constructor indices.
-}
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


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