{-# LANGUAGE TemplateHaskell #-}
module Generics.SOP.TH
( deriveGeneric
, deriveGenericOnly
, deriveGenericSubst
, deriveGenericOnlySubst
, deriveGenericFunctions
, deriveMetadataValue
, deriveMetadataType
) where
import Control.Monad (join, replicateM, unless)
import Data.List (foldl')
import Data.Maybe (fromMaybe)
import Data.Proxy
import Language.Haskell.TH.Datatype.TyVarBndr
import Language.Haskell.TH
import Language.Haskell.TH.Datatype as TH
import Generics.SOP.BasicFunctors
import qualified Generics.SOP.Metadata as SOP
import qualified Generics.SOP.Type.Metadata as SOP.T
import Generics.SOP.NP
import Generics.SOP.NS
import Generics.SOP.Universe
deriveGeneric :: Name -> Q [Dec]
deriveGeneric :: Name -> Q [Dec]
deriveGeneric n :: Name
n =
Name -> (Name -> Q Type) -> Q [Dec]
deriveGenericSubst Name
n Name -> Q Type
varT
deriveGenericOnly :: Name -> Q [Dec]
deriveGenericOnly :: Name -> Q [Dec]
deriveGenericOnly n :: Name
n =
Name -> (Name -> Q Type) -> Q [Dec]
deriveGenericOnlySubst Name
n Name -> Q Type
varT
deriveGenericSubst :: Name -> (Name -> Q Type) -> Q [Dec]
deriveGenericSubst :: Name -> (Name -> Q Type) -> Q [Dec]
deriveGenericSubst n :: Name
n f :: Name -> Q Type
f = do
DatatypeInfo
dec <- Name -> Q DatatypeInfo
reifyDatatype Name
n
[Dec]
ds1 <- DatatypeInfo
-> (DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec])
-> Q [Dec]
forall a.
DatatypeInfo
-> (DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q a)
-> Q a
withDataDec DatatypeInfo
dec ((Name -> Q Type)
-> DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec]
deriveGenericForDataDec Name -> Q Type
f)
[Dec]
ds2 <- DatatypeInfo
-> (DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec])
-> Q [Dec]
forall a.
DatatypeInfo
-> (DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q a)
-> Q a
withDataDec DatatypeInfo
dec ((Name -> Q Type)
-> DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec]
deriveMetadataForDataDec Name -> Q Type
f)
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
ds1 [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
ds2)
deriveGenericOnlySubst :: Name -> (Name -> Q Type) -> Q [Dec]
deriveGenericOnlySubst :: Name -> (Name -> Q Type) -> Q [Dec]
deriveGenericOnlySubst n :: Name
n f :: Name -> Q Type
f = do
DatatypeInfo
dec <- Name -> Q DatatypeInfo
reifyDatatype Name
n
DatatypeInfo
-> (DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec])
-> Q [Dec]
forall a.
DatatypeInfo
-> (DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q a)
-> Q a
withDataDec DatatypeInfo
dec ((Name -> Q Type)
-> DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec]
deriveGenericForDataDec Name -> Q Type
f)
deriveGenericFunctions :: Name -> String -> String -> String -> Q [Dec]
deriveGenericFunctions :: Name -> String -> String -> String -> Q [Dec]
deriveGenericFunctions n :: Name
n codeName :: String
codeName fromName :: String
fromName toName :: String
toName = do
let codeName' :: Name
codeName' = String -> Name
mkName String
codeName
let fromName' :: Name
fromName' = String -> Name
mkName String
fromName
let toName' :: Name
toName' = String -> Name
mkName String
toName
DatatypeInfo
dec <- Name -> Q DatatypeInfo
reifyDatatype Name
n
DatatypeInfo
-> (DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec])
-> Q [Dec]
forall a.
DatatypeInfo
-> (DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q a)
-> Q a
withDataDec DatatypeInfo
dec ((DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec])
-> Q [Dec])
-> (DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec])
-> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \_variant :: DatatypeVariant
_variant _cxt :: Cxt
_cxt name :: Name
name bndrs :: [TyVarBndrUnit]
bndrs instTys :: Cxt
instTys cons :: [ConstructorInfo]
cons -> do
let codeType :: Q Type
codeType = (Name -> Q Type) -> [ConstructorInfo] -> Q Type
codeFor Name -> Q Type
varT [ConstructorInfo]
cons
let origType :: Q Type
origType = (Name -> Q Type) -> Name -> Cxt -> Q Type
appTysSubst Name -> Q Type
varT Name
name Cxt
instTys
let repType :: Q Type
repType = [t| SOP I $(appTyVars varT codeName' bndrs) |]
[Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ Name -> [TyVarBndrUnit] -> Q Type -> Q Dec
tySynD Name
codeName' [TyVarBndrUnit]
bndrs Q Type
codeType
, Name -> Q Type -> Q Dec
sigD Name
fromName' [t| $origType -> $repType |]
, Name -> [ConstructorInfo] -> Q Dec
embedding Name
fromName' [ConstructorInfo]
cons
, Name -> Q Type -> Q Dec
sigD Name
toName' [t| $repType -> $origType |]
, Name -> [ConstructorInfo] -> Q Dec
projection Name
toName' [ConstructorInfo]
cons
]
deriveMetadataValue :: Name -> String -> String -> Q [Dec]
deriveMetadataValue :: Name -> String -> String -> Q [Dec]
deriveMetadataValue n :: Name
n codeName :: String
codeName datatypeInfoName :: String
datatypeInfoName = do
let codeName' :: Name
codeName' = String -> Name
mkName String
codeName
let datatypeInfoName' :: Name
datatypeInfoName' = String -> Name
mkName String
datatypeInfoName
DatatypeInfo
dec <- Name -> Q DatatypeInfo
reifyDatatype Name
n
DatatypeInfo
-> (DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec])
-> Q [Dec]
forall a.
DatatypeInfo
-> (DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q a)
-> Q a
withDataDec DatatypeInfo
dec ((DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec])
-> Q [Dec])
-> (DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec])
-> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \variant :: DatatypeVariant
variant _cxt :: Cxt
_cxt name :: Name
name bndrs :: [TyVarBndrUnit]
bndrs _instTys :: Cxt
_instTys cons :: [ConstructorInfo]
cons -> do
[Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Name -> Q Type -> Q Dec
sigD Name
datatypeInfoName' [t| SOP.DatatypeInfo $(appTyVars varT codeName' bndrs) |]
, Name -> [ClauseQ] -> Q Dec
funD Name
datatypeInfoName' [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ DatatypeVariant -> Name -> [ConstructorInfo] -> ExpQ
metadata' DatatypeVariant
variant Name
name [ConstructorInfo]
cons) []]
]
{-# DEPRECATED deriveMetadataValue "Use 'deriveMetadataType' and 'demoteDatatypeInfo' instead." #-}
deriveMetadataType :: Name -> String -> Q [Dec]
deriveMetadataType :: Name -> String -> Q [Dec]
deriveMetadataType n :: Name
n datatypeInfoName :: String
datatypeInfoName = do
let datatypeInfoName' :: Name
datatypeInfoName' = String -> Name
mkName String
datatypeInfoName
DatatypeInfo
dec <- Name -> Q DatatypeInfo
reifyDatatype Name
n
DatatypeInfo
-> (DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec])
-> Q [Dec]
forall a.
DatatypeInfo
-> (DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q a)
-> Q a
withDataDec DatatypeInfo
dec ((DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec])
-> Q [Dec])
-> (DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec])
-> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \ variant :: DatatypeVariant
variant _ctx :: Cxt
_ctx name :: Name
name _bndrs :: [TyVarBndrUnit]
_bndrs _instTys :: Cxt
_instTys cons :: [ConstructorInfo]
cons ->
[Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ Name -> [TyVarBndrUnit] -> Q Type -> Q Dec
tySynD Name
datatypeInfoName' [] (DatatypeVariant -> Name -> [ConstructorInfo] -> Q Type
metadataType' DatatypeVariant
variant Name
name [ConstructorInfo]
cons) ]
deriveGenericForDataDec ::
(Name -> Q Type) -> DatatypeVariant -> Cxt -> Name -> [TyVarBndrUnit] -> [Type] -> [TH.ConstructorInfo] -> Q [Dec]
deriveGenericForDataDec :: (Name -> Q Type)
-> DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec]
deriveGenericForDataDec f :: Name -> Q Type
f _variant :: DatatypeVariant
_variant _cxt :: Cxt
_cxt name :: Name
name _bndrs :: [TyVarBndrUnit]
_bndrs instTys :: Cxt
instTys cons :: [ConstructorInfo]
cons = do
let typ :: Q Type
typ = (Name -> Q Type) -> Name -> Cxt -> Q Type
appTysSubst Name -> Q Type
f Name
name Cxt
instTys
(Name -> Q Type) -> Q Type -> [ConstructorInfo] -> Q [Dec]
deriveGenericForDataType Name -> Q Type
f Q Type
typ [ConstructorInfo]
cons
deriveGenericForDataType :: (Name -> Q Type) -> Q Type -> [TH.ConstructorInfo] -> Q [Dec]
deriveGenericForDataType :: (Name -> Q Type) -> Q Type -> [ConstructorInfo] -> Q [Dec]
deriveGenericForDataType f :: Name -> Q Type
f typ :: Q Type
typ cons :: [ConstructorInfo]
cons = do
let codeSyn :: Q Dec
codeSyn = Name -> Maybe [Q TyVarBndrUnit] -> [Q Type] -> Q Type -> Q Dec
tySynInstDCompat ''Generics.SOP.Universe.Code Maybe [Q TyVarBndrUnit]
forall a. Maybe a
Nothing [Q Type
typ] ((Name -> Q Type) -> [ConstructorInfo] -> Q Type
codeFor Name -> Q Type
f [ConstructorInfo]
cons)
Dec
inst <- CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD
([Q Type] -> CxtQ
cxt [])
[t| Generic $typ |]
[Q Dec
codeSyn, Name -> [ConstructorInfo] -> Q Dec
embedding 'from [ConstructorInfo]
cons, Name -> [ConstructorInfo] -> Q Dec
projection 'to [ConstructorInfo]
cons]
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
inst]
deriveMetadataForDataDec ::
(Name -> Q Type) -> DatatypeVariant -> Cxt -> Name -> [TyVarBndrUnit] -> [Type] -> [TH.ConstructorInfo] -> Q [Dec]
deriveMetadataForDataDec :: (Name -> Q Type)
-> DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q [Dec]
deriveMetadataForDataDec f :: Name -> Q Type
f variant :: DatatypeVariant
variant _cxt :: Cxt
_cxt name :: Name
name _bndrs :: [TyVarBndrUnit]
_bndrs instTys :: Cxt
instTys cons :: [ConstructorInfo]
cons = do
let typ :: Q Type
typ = (Name -> Q Type) -> Name -> Cxt -> Q Type
appTysSubst Name -> Q Type
f Name
name Cxt
instTys
DatatypeVariant -> Name -> Q Type -> [ConstructorInfo] -> Q [Dec]
deriveMetadataForDataType DatatypeVariant
variant Name
name Q Type
typ [ConstructorInfo]
cons
deriveMetadataForDataType :: DatatypeVariant -> Name -> Q Type -> [TH.ConstructorInfo] -> Q [Dec]
deriveMetadataForDataType :: DatatypeVariant -> Name -> Q Type -> [ConstructorInfo] -> Q [Dec]
deriveMetadataForDataType variant :: DatatypeVariant
variant name :: Name
name typ :: Q Type
typ cons :: [ConstructorInfo]
cons = do
Dec
md <- CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD ([Q Type] -> CxtQ
cxt [])
[t| HasDatatypeInfo $typ |]
[ Q Type -> DatatypeVariant -> Name -> [ConstructorInfo] -> Q Dec
metadataType Q Type
typ DatatypeVariant
variant Name
name [ConstructorInfo]
cons
, Name -> [ClauseQ] -> Q Dec
funD 'datatypeInfo
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP]
(ExpQ -> BodyQ
normalB [| SOP.T.demoteDatatypeInfo (Proxy :: Proxy (DatatypeInfoOf $typ)) |])
[]
]
]
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
md]
codeFor :: (Name -> Q Type) -> [TH.ConstructorInfo] -> Q Type
codeFor :: (Name -> Q Type) -> [ConstructorInfo] -> Q Type
codeFor f :: Name -> Q Type
f = [Q Type] -> Q Type
promotedTypeList ([Q Type] -> Q Type)
-> ([ConstructorInfo] -> [Q Type]) -> [ConstructorInfo] -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConstructorInfo -> Q Type) -> [ConstructorInfo] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> Q Type
go
where
go :: TH.ConstructorInfo -> Q Type
go :: ConstructorInfo -> Q Type
go c :: ConstructorInfo
c = do (_, ts :: [Q Type]
ts) <- ConstructorInfo -> Q (Name, [Q Type])
conInfo ConstructorInfo
c
(Name -> Q Type) -> [Q Type] -> Q Type
promotedTypeListSubst Name -> Q Type
f [Q Type]
ts
embedding :: Name -> [TH.ConstructorInfo] -> Q Dec
embedding :: Name -> [ConstructorInfo] -> Q Dec
embedding fromName :: Name
fromName = Name -> [ClauseQ] -> Q Dec
funD Name
fromName ([ClauseQ] -> Q Dec)
-> ([ConstructorInfo] -> [ClauseQ]) -> [ConstructorInfo] -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExpQ -> ExpQ) -> [ConstructorInfo] -> [ClauseQ]
go' (\e :: ExpQ
e -> [| Z $e |])
where
go' :: (Q Exp -> Q Exp) -> [TH.ConstructorInfo] -> [Q Clause]
go' :: (ExpQ -> ExpQ) -> [ConstructorInfo] -> [ClauseQ]
go' _ [] = (ClauseQ -> [ClauseQ] -> [ClauseQ]
forall a. a -> [a] -> [a]
:[]) (ClauseQ -> [ClauseQ]) -> ClauseQ -> [ClauseQ]
forall a b. (a -> b) -> a -> b
$ do
Name
x <- String -> Q Name
newName "x"
[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
x] (ExpQ -> BodyQ
normalB (ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
x) [])) []
go' br :: ExpQ -> ExpQ
br cs :: [ConstructorInfo]
cs = (ExpQ -> ExpQ) -> [ConstructorInfo] -> [ClauseQ]
go ExpQ -> ExpQ
br [ConstructorInfo]
cs
go :: (Q Exp -> Q Exp) -> [TH.ConstructorInfo] -> [Q Clause]
go :: (ExpQ -> ExpQ) -> [ConstructorInfo] -> [ClauseQ]
go _ [] = []
go br :: ExpQ -> ExpQ
br (c :: ConstructorInfo
c:cs :: [ConstructorInfo]
cs) = (ExpQ -> ExpQ) -> ConstructorInfo -> ClauseQ
mkClause ExpQ -> ExpQ
br ConstructorInfo
c ClauseQ -> [ClauseQ] -> [ClauseQ]
forall a. a -> [a] -> [a]
: (ExpQ -> ExpQ) -> [ConstructorInfo] -> [ClauseQ]
go (\e :: ExpQ
e -> [| S $(br e) |]) [ConstructorInfo]
cs
mkClause :: (Q Exp -> Q Exp) -> TH.ConstructorInfo -> Q Clause
mkClause :: (ExpQ -> ExpQ) -> ConstructorInfo -> ClauseQ
mkClause br :: ExpQ -> ExpQ
br c :: ConstructorInfo
c = do
(n :: Name
n, ts :: [Q Type]
ts) <- ConstructorInfo -> Q (Name, [Q Type])
conInfo ConstructorInfo
c
[Name]
vars <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([Q Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Type]
ts) (String -> Q Name
newName "x")
[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP Name
n ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
vars)]
(ExpQ -> BodyQ
normalB [| SOP $(br . npE . map (appE (conE 'I) . varE) $ vars) |])
[]
projection :: Name -> [TH.ConstructorInfo] -> Q Dec
projection :: Name -> [ConstructorInfo] -> Q Dec
projection toName :: Name
toName = Name -> [ClauseQ] -> Q Dec
funD Name
toName ([ClauseQ] -> Q Dec)
-> ([ConstructorInfo] -> [ClauseQ]) -> [ConstructorInfo] -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ConstructorInfo] -> [ClauseQ]
go'
where
go' :: [TH.ConstructorInfo] -> [Q Clause]
go' :: [ConstructorInfo] -> [ClauseQ]
go' [] = (ClauseQ -> [ClauseQ] -> [ClauseQ]
forall a. a -> [a] -> [a]
:[]) (ClauseQ -> [ClauseQ]) -> ClauseQ -> [ClauseQ]
forall a b. (a -> b) -> a -> b
$ do
Name
x <- String -> Q Name
newName "x"
[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
x] (ExpQ -> BodyQ
normalB (ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
x) [])) []
go' cs :: [ConstructorInfo]
cs = (PatQ -> PatQ) -> [ConstructorInfo] -> [ClauseQ]
go PatQ -> PatQ
forall a. a -> a
id [ConstructorInfo]
cs
go :: (Q Pat -> Q Pat) -> [TH.ConstructorInfo] -> [Q Clause]
go :: (PatQ -> PatQ) -> [ConstructorInfo] -> [ClauseQ]
go br :: PatQ -> PatQ
br [] = [(PatQ -> PatQ) -> ClauseQ
mkUnreachableClause PatQ -> PatQ
br]
go br :: PatQ -> PatQ
br (c :: ConstructorInfo
c:cs :: [ConstructorInfo]
cs) = (PatQ -> PatQ) -> ConstructorInfo -> ClauseQ
mkClause PatQ -> PatQ
br ConstructorInfo
c ClauseQ -> [ClauseQ] -> [ClauseQ]
forall a. a -> [a] -> [a]
: (PatQ -> PatQ) -> [ConstructorInfo] -> [ClauseQ]
go (\p :: PatQ
p -> Name -> [PatQ] -> PatQ
conP 'S [PatQ -> PatQ
br PatQ
p]) [ConstructorInfo]
cs
mkUnreachableClause :: (Q Pat -> Q Pat) -> Q Clause
mkUnreachableClause :: (PatQ -> PatQ) -> ClauseQ
mkUnreachableClause br :: PatQ -> PatQ
br = do
Name
var <- String -> Q Name
newName "x"
[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP 'SOP [PatQ -> PatQ
br (Name -> PatQ
varP Name
var)]]
(ExpQ -> BodyQ
normalB [| $(varE var) `seq` error "inaccessible" |])
[]
mkClause :: (Q Pat -> Q Pat) -> TH.ConstructorInfo -> Q Clause
mkClause :: (PatQ -> PatQ) -> ConstructorInfo -> ClauseQ
mkClause br :: PatQ -> PatQ
br c :: ConstructorInfo
c = do
(n :: Name
n, ts :: [Q Type]
ts) <- ConstructorInfo -> Q (Name, [Q Type])
conInfo ConstructorInfo
c
[Name]
vars <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([Q Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Type]
ts) (String -> Q Name
newName "x")
[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP 'SOP [PatQ -> PatQ
br (PatQ -> PatQ) -> ([Name] -> PatQ) -> [Name] -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [PatQ] -> PatQ
conP 'Z ([PatQ] -> PatQ) -> ([Name] -> [PatQ]) -> [Name] -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
:[]) (PatQ -> [PatQ]) -> ([Name] -> PatQ) -> [Name] -> [PatQ]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PatQ] -> PatQ
npP ([PatQ] -> PatQ) -> ([Name] -> [PatQ]) -> [Name] -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map (\v :: Name
v -> Name -> [PatQ] -> PatQ
conP 'I [Name -> PatQ
varP Name
v]) ([Name] -> PatQ) -> [Name] -> PatQ
forall a b. (a -> b) -> a -> b
$ [Name]
vars]]
(ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ([ExpQ] -> ExpQ) -> [ExpQ] -> BodyQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ExpQ] -> ExpQ
appsE ([ExpQ] -> BodyQ) -> [ExpQ] -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
conE Name
n ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
: (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
vars)
[]
metadataType :: Q Type -> DatatypeVariant -> Name -> [TH.ConstructorInfo] -> Q Dec
metadataType :: Q Type -> DatatypeVariant -> Name -> [ConstructorInfo] -> Q Dec
metadataType typ :: Q Type
typ variant :: DatatypeVariant
variant typeName :: Name
typeName cs :: [ConstructorInfo]
cs =
Name -> Maybe [Q TyVarBndrUnit] -> [Q Type] -> Q Type -> Q Dec
tySynInstDCompat ''DatatypeInfoOf Maybe [Q TyVarBndrUnit]
forall a. Maybe a
Nothing [Q Type
typ] (DatatypeVariant -> Name -> [ConstructorInfo] -> Q Type
metadataType' DatatypeVariant
variant Name
typeName [ConstructorInfo]
cs)
metadata' :: DatatypeVariant -> Name -> [TH.ConstructorInfo] -> Q Exp
metadata' :: DatatypeVariant -> Name -> [ConstructorInfo] -> ExpQ
metadata' dataVariant :: DatatypeVariant
dataVariant typeName :: Name
typeName cs :: [ConstructorInfo]
cs = ExpQ
md
where
md :: Q Exp
md :: ExpQ
md | DatatypeVariant -> Bool
isNewtypeVariant DatatypeVariant
dataVariant
= [| SOP.Newtype $(stringE (nameModule' typeName))
$(stringE (nameBase typeName))
$(mdCon (head cs))
|]
| Bool
otherwise
= [| SOP.ADT $(stringE (nameModule' typeName))
$(stringE (nameBase typeName))
$(npE $ map mdCon cs)
$(popE $ map mdStrictness cs)
|]
mdStrictness :: TH.ConstructorInfo -> Q [Q Exp]
mdStrictness :: ConstructorInfo -> Q [ExpQ]
mdStrictness ci :: ConstructorInfo
ci@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
n
, constructorStrictness :: ConstructorInfo -> [FieldStrictness]
constructorStrictness = [FieldStrictness]
bs }) =
ConstructorInfo -> Q [ExpQ] -> Q [ExpQ]
forall a. ConstructorInfo -> Q a -> Q a
checkForGADTs ConstructorInfo
ci (Q [ExpQ] -> Q [ExpQ]) -> Q [ExpQ] -> Q [ExpQ]
forall a b. (a -> b) -> a -> b
$ Name -> [FieldStrictness] -> Q [ExpQ]
mdConStrictness Name
n [FieldStrictness]
bs
mdConStrictness :: Name -> [FieldStrictness] -> Q [Q Exp]
mdConStrictness :: Name -> [FieldStrictness] -> Q [ExpQ]
mdConStrictness n :: Name
n bs :: [FieldStrictness]
bs = do
[DecidedStrictness]
dss <- Name -> Q [DecidedStrictness]
reifyConStrictness Name
n
[ExpQ] -> Q [ExpQ]
forall (m :: * -> *) a. Monad m => a -> m a
return ((FieldStrictness -> DecidedStrictness -> ExpQ)
-> [FieldStrictness] -> [DecidedStrictness] -> [ExpQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ (FieldStrictness su :: Unpackedness
su ss :: Strictness
ss) ds :: DecidedStrictness
ds ->
[| SOP.StrictnessInfo
$(mdTHUnpackedness su)
$(mdTHStrictness ss)
$(mdDecidedStrictness ds)
|]) [FieldStrictness]
bs [DecidedStrictness]
dss)
mdCon :: TH.ConstructorInfo -> Q Exp
mdCon :: ConstructorInfo -> ExpQ
mdCon ci :: ConstructorInfo
ci@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
n
, constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
conVariant }) =
ConstructorInfo -> ExpQ -> ExpQ
forall a. ConstructorInfo -> Q a -> Q a
checkForGADTs ConstructorInfo
ci (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$
case ConstructorVariant
conVariant of
NormalConstructor -> [| SOP.Constructor $(stringE (nameBase n)) |]
RecordConstructor ts :: [Name]
ts -> [| SOP.Record $(stringE (nameBase n))
$(npE (map mdField ts))
|]
InfixConstructor -> do
Maybe Fixity
fixity <- Name -> Q (Maybe Fixity)
reifyFixity Name
n
case Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity Maybe Fixity
fixity of
Fixity f :: Int
f a :: FixityDirection
a -> [| SOP.Infix $(stringE (nameBase n))
$(mdAssociativity a)
f
|]
mdField :: Name -> Q Exp
mdField :: Name -> ExpQ
mdField n :: Name
n = [| SOP.FieldInfo $(stringE (nameBase n)) |]
mdTHUnpackedness :: TH.Unpackedness -> Q Exp
mdTHUnpackedness :: Unpackedness -> ExpQ
mdTHUnpackedness UnspecifiedUnpackedness = [| SOP.NoSourceUnpackedness |]
mdTHUnpackedness NoUnpack = [| SOP.SourceNoUnpack |]
mdTHUnpackedness Unpack = [| SOP.SourceUnpack |]
mdTHStrictness :: TH.Strictness -> Q Exp
mdTHStrictness :: Strictness -> ExpQ
mdTHStrictness UnspecifiedStrictness = [| SOP.NoSourceStrictness |]
mdTHStrictness Lazy = [| SOP.SourceLazy |]
mdTHStrictness TH.Strict = [| SOP.SourceStrict |]
mdDecidedStrictness :: DecidedStrictness -> Q Exp
mdDecidedStrictness :: DecidedStrictness -> ExpQ
mdDecidedStrictness DecidedLazy = [| SOP.DecidedLazy |]
mdDecidedStrictness DecidedStrict = [| SOP.DecidedStrict |]
mdDecidedStrictness DecidedUnpack = [| SOP.DecidedUnpack |]
mdAssociativity :: FixityDirection -> Q Exp
mdAssociativity :: FixityDirection -> ExpQ
mdAssociativity InfixL = [| SOP.LeftAssociative |]
mdAssociativity InfixR = [| SOP.RightAssociative |]
mdAssociativity InfixN = [| SOP.NotAssociative |]
metadataType' :: DatatypeVariant -> Name -> [TH.ConstructorInfo] -> Q Type
metadataType' :: DatatypeVariant -> Name -> [ConstructorInfo] -> Q Type
metadataType' dataVariant :: DatatypeVariant
dataVariant typeName :: Name
typeName cs :: [ConstructorInfo]
cs = Q Type
md
where
md :: Q Type
md :: Q Type
md | DatatypeVariant -> Bool
isNewtypeVariant DatatypeVariant
dataVariant
= [t| 'SOP.T.Newtype $(stringT (nameModule' typeName))
$(stringT (nameBase typeName))
$(mdCon (head cs))
|]
| Bool
otherwise
= [t| 'SOP.T.ADT $(stringT (nameModule' typeName))
$(stringT (nameBase typeName))
$(promotedTypeList $ map mdCon cs)
$(promotedTypeListOfList $ map mdStrictness cs)
|]
mdStrictness :: TH.ConstructorInfo -> Q [Q Type]
mdStrictness :: ConstructorInfo -> Q [Q Type]
mdStrictness ci :: ConstructorInfo
ci@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
n
, constructorStrictness :: ConstructorInfo -> [FieldStrictness]
constructorStrictness = [FieldStrictness]
bs }) =
ConstructorInfo -> Q [Q Type] -> Q [Q Type]
forall a. ConstructorInfo -> Q a -> Q a
checkForGADTs ConstructorInfo
ci (Q [Q Type] -> Q [Q Type]) -> Q [Q Type] -> Q [Q Type]
forall a b. (a -> b) -> a -> b
$ Name -> [FieldStrictness] -> Q [Q Type]
mdConStrictness Name
n [FieldStrictness]
bs
mdConStrictness :: Name -> [FieldStrictness] -> Q [Q Type]
mdConStrictness :: Name -> [FieldStrictness] -> Q [Q Type]
mdConStrictness n :: Name
n bs :: [FieldStrictness]
bs = do
[DecidedStrictness]
dss <- Name -> Q [DecidedStrictness]
reifyConStrictness Name
n
[Q Type] -> Q [Q Type]
forall (m :: * -> *) a. Monad m => a -> m a
return ((FieldStrictness -> DecidedStrictness -> Q Type)
-> [FieldStrictness] -> [DecidedStrictness] -> [Q Type]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ (FieldStrictness su :: Unpackedness
su ss :: Strictness
ss) ds :: DecidedStrictness
ds ->
[t| 'SOP.T.StrictnessInfo
$(mdTHUnpackedness su)
$(mdTHStrictness ss)
$(mdDecidedStrictness ds)
|]) [FieldStrictness]
bs [DecidedStrictness]
dss)
mdCon :: TH.ConstructorInfo -> Q Type
mdCon :: ConstructorInfo -> Q Type
mdCon ci :: ConstructorInfo
ci@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
n
, constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
conVariant }) =
ConstructorInfo -> Q Type -> Q Type
forall a. ConstructorInfo -> Q a -> Q a
checkForGADTs ConstructorInfo
ci (Q Type -> Q Type) -> Q Type -> Q Type
forall a b. (a -> b) -> a -> b
$
case ConstructorVariant
conVariant of
NormalConstructor -> [t| 'SOP.T.Constructor $(stringT (nameBase n)) |]
RecordConstructor ts :: [Name]
ts -> [t| 'SOP.T.Record $(stringT (nameBase n))
$(promotedTypeList (map mdField ts))
|]
InfixConstructor -> do
Maybe Fixity
fixity <- Name -> Q (Maybe Fixity)
reifyFixity Name
n
case Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity Maybe Fixity
fixity of
Fixity f :: Int
f a :: FixityDirection
a -> [t| 'SOP.T.Infix $(stringT (nameBase n))
$(mdAssociativity a)
$(natT f)
|]
mdField :: Name -> Q Type
mdField :: Name -> Q Type
mdField n :: Name
n = [t| 'SOP.T.FieldInfo $(stringT (nameBase n)) |]
mdTHUnpackedness :: TH.Unpackedness -> Q Type
mdTHUnpackedness :: Unpackedness -> Q Type
mdTHUnpackedness UnspecifiedUnpackedness = [t| 'SOP.NoSourceUnpackedness |]
mdTHUnpackedness NoUnpack = [t| 'SOP.SourceNoUnpack |]
mdTHUnpackedness Unpack = [t| 'SOP.SourceUnpack |]
mdTHStrictness :: TH.Strictness -> Q Type
mdTHStrictness :: Strictness -> Q Type
mdTHStrictness UnspecifiedStrictness = [t| 'SOP.NoSourceStrictness |]
mdTHStrictness Lazy = [t| 'SOP.SourceLazy |]
mdTHStrictness TH.Strict = [t| 'SOP.SourceStrict |]
mdDecidedStrictness :: DecidedStrictness -> Q Type
mdDecidedStrictness :: DecidedStrictness -> Q Type
mdDecidedStrictness DecidedLazy = [t| 'SOP.DecidedLazy |]
mdDecidedStrictness DecidedStrict = [t| 'SOP.DecidedStrict |]
mdDecidedStrictness DecidedUnpack = [t| 'SOP.DecidedUnpack |]
mdAssociativity :: FixityDirection -> Q Type
mdAssociativity :: FixityDirection -> Q Type
mdAssociativity InfixL = [t| 'SOP.T.LeftAssociative |]
mdAssociativity InfixR = [t| 'SOP.T.RightAssociative |]
mdAssociativity InfixN = [t| 'SOP.T.NotAssociative |]
nameModule' :: Name -> String
nameModule' :: Name -> String
nameModule' = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe String -> String)
-> (Name -> Maybe String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Maybe String
nameModule
npE :: [Q Exp] -> Q Exp
npE :: [ExpQ] -> ExpQ
npE [] = [| Nil |]
npE (e :: ExpQ
e:es :: [ExpQ]
es) = [| $e :* $(npE es) |]
popE :: [Q [Q Exp]] -> Q Exp
popE :: [Q [ExpQ]] -> ExpQ
popE ess :: [Q [ExpQ]]
ess =
[| POP $(npE (map (join . fmap npE) ess)) |]
npP :: [Q Pat] -> Q Pat
npP :: [PatQ] -> PatQ
npP [] = Name -> [PatQ] -> PatQ
conP 'Nil []
npP (p :: PatQ
p:ps :: [PatQ]
ps) = Name -> [PatQ] -> PatQ
conP '(:*) [PatQ
p, [PatQ] -> PatQ
npP [PatQ]
ps]
conInfo :: TH.ConstructorInfo -> Q (Name, [Q Type])
conInfo :: ConstructorInfo -> Q (Name, [Q Type])
conInfo ci :: ConstructorInfo
ci@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
n
, constructorFields :: ConstructorInfo -> Cxt
constructorFields = Cxt
ts }) =
ConstructorInfo -> Q (Name, [Q Type]) -> Q (Name, [Q Type])
forall a. ConstructorInfo -> Q a -> Q a
checkForGADTs ConstructorInfo
ci (Q (Name, [Q Type]) -> Q (Name, [Q Type]))
-> Q (Name, [Q Type]) -> Q (Name, [Q Type])
forall a b. (a -> b) -> a -> b
$ (Name, [Q Type]) -> Q (Name, [Q Type])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, (Type -> Q Type) -> Cxt -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
ts)
stringT :: String -> Q Type
stringT :: String -> Q Type
stringT = TyLitQ -> Q Type
litT (TyLitQ -> Q Type) -> (String -> TyLitQ) -> String -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TyLitQ
strTyLit
natT :: Int -> Q Type
natT :: Int -> Q Type
natT = TyLitQ -> Q Type
litT (TyLitQ -> Q Type) -> (Int -> TyLitQ) -> Int -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> TyLitQ
numTyLit (Integer -> TyLitQ) -> (Int -> Integer) -> Int -> TyLitQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral
promotedTypeList :: [Q Type] -> Q Type
promotedTypeList :: [Q Type] -> Q Type
promotedTypeList [] = Q Type
promotedNilT
promotedTypeList (t :: Q Type
t:ts :: [Q Type]
ts) = [t| $promotedConsT $t $(promotedTypeList ts) |]
promotedTypeListOfList :: [Q [Q Type]] -> Q Type
promotedTypeListOfList :: [Q [Q Type]] -> Q Type
promotedTypeListOfList =
[Q Type] -> Q Type
promotedTypeList ([Q Type] -> Q Type)
-> ([Q [Q Type]] -> [Q Type]) -> [Q [Q Type]] -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q [Q Type] -> Q Type) -> [Q [Q Type]] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (Q (Q Type) -> Q Type
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Q (Q Type) -> Q Type)
-> (Q [Q Type] -> Q (Q Type)) -> Q [Q Type] -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Q Type] -> Q Type) -> Q [Q Type] -> Q (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Q Type] -> Q Type
promotedTypeList)
promotedTypeListSubst :: (Name -> Q Type) -> [Q Type] -> Q Type
promotedTypeListSubst :: (Name -> Q Type) -> [Q Type] -> Q Type
promotedTypeListSubst _ [] = Q Type
promotedNilT
promotedTypeListSubst f :: Name -> Q Type
f (t :: Q Type
t:ts :: [Q Type]
ts) = [t| $promotedConsT $(t >>= substType f) $(promotedTypeListSubst f ts) |]
appsT :: Name -> [Q Type] -> Q Type
appsT :: Name -> [Q Type] -> Q Type
appsT n :: Name
n = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT Name
n)
appTyVars :: (Name -> Q Type) -> Name -> [TyVarBndrUnit] -> Q Type
appTyVars :: (Name -> Q Type) -> Name -> [TyVarBndrUnit] -> Q Type
appTyVars f :: Name -> Q Type
f n :: Name
n bndrs :: [TyVarBndrUnit]
bndrs =
Name -> [Q Type] -> Q Type
appsT Name
n ((TyVarBndrUnit -> Q Type) -> [TyVarBndrUnit] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Q Type
f (Name -> Q Type)
-> (TyVarBndrUnit -> Name) -> TyVarBndrUnit -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndrUnit -> Name
forall flag. TyVarBndrUnit -> Name
tvName) [TyVarBndrUnit]
bndrs)
appTysSubst :: (Name -> Q Type) -> Name -> [Type] -> Q Type
appTysSubst :: (Name -> Q Type) -> Name -> Cxt -> Q Type
appTysSubst f :: Name -> Q Type
f n :: Name
n args :: Cxt
args =
Name -> [Q Type] -> Q Type
appsT Name
n ((Type -> Q Type) -> Cxt -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> Q Type) -> Type -> Q Type
substType Name -> Q Type
f (Type -> Q Type) -> (Type -> Type) -> Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
unSigType) Cxt
args)
unSigType :: Type -> Type
unSigType :: Type -> Type
unSigType (SigT t :: Type
t _) = Type
t
unSigType t :: Type
t = Type
t
substType :: (Name -> Q Type) -> Type -> Q Type
substType :: (Name -> Q Type) -> Type -> Q Type
substType f :: Name -> Q Type
f = Type -> Q Type
go
where
go :: Type -> Q Type
go (VarT n :: Name
n) = Name -> Q Type
f Name
n
go (AppT t1 :: Type
t1 t2 :: Type
t2) = Type -> Type -> Type
AppT (Type -> Type -> Type) -> Q Type -> Q (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Type
go Type
t1 Q (Type -> Type) -> Q Type -> Q Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Q Type
go Type
t2
go ListT = Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ListT
go (ConT n :: Name
n) = Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
ConT Name
n)
go ArrowT = Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ArrowT
go (TupleT i :: Int
i) = Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Type
TupleT Int
i)
go t :: Type
t = Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
withDataDec :: TH.DatatypeInfo
-> (DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> [Type]
-> [TH.ConstructorInfo]
-> Q a)
-> Q a
withDataDec :: DatatypeInfo
-> (DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q a)
-> Q a
withDataDec (TH.DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
name
, datatypeVars :: DatatypeInfo -> [TyVarBndrUnit]
datatypeVars = [TyVarBndrUnit]
bndrs
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTypes
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons }) f :: DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q a
f =
DatatypeVariant
-> Cxt
-> Name
-> [TyVarBndrUnit]
-> Cxt
-> [ConstructorInfo]
-> Q a
f DatatypeVariant
variant Cxt
ctxt Name
name [TyVarBndrUnit]
bndrs Cxt
instTypes [ConstructorInfo]
cons
checkForGADTs :: TH.ConstructorInfo -> Q a -> Q a
checkForGADTs :: ConstructorInfo -> Q a -> Q a
checkForGADTs (ConstructorInfo { constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
constructorVars = [TyVarBndrUnit]
exVars
, constructorContext :: ConstructorInfo -> Cxt
constructorContext = Cxt
exCxt }) q :: Q a
q = do
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([TyVarBndrUnit] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndrUnit]
exVars) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Existentials not supported"
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Cxt -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
exCxt) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "GADTs not supported"
Q a
q
isNewtypeVariant :: DatatypeVariant -> Bool
isNewtypeVariant :: DatatypeVariant -> Bool
isNewtypeVariant Datatype = Bool
False
isNewtypeVariant DataInstance = Bool
False
isNewtypeVariant Newtype = Bool
True
isNewtypeVariant NewtypeInstance = Bool
True