{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
module Staged.GHC.Generics.TH (
deriveGeneric,
deriveGeneric1,
) where
import Control.Monad ((>=>), unless, when, forM)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Staged.GHC.Generics.TH.Names
import Staged.GHC.Generics.Internal (sapply)
import Language.Haskell.TH.Datatype
import Generics.Deriving.TH.Internal
import Generics.Deriving.TH.Post4_9
import Generics.Deriving.TH
(KindSigOptions, Options (..), RepOptions (..), defaultOptions)
import Language.Haskell.TH.Lift ()
import qualified Data.Map as Map (fromList)
deriveGeneric :: Name -> Q [Dec]
deriveGeneric :: Name -> Q [Dec]
deriveGeneric Name
n = do
Name
-> Name
-> GenericClass
-> Name
-> Name
-> Options
-> Name
-> Q [Dec]
deriveInstCommon Name
staged_genericTypeName Name
staged_repTypeName GenericClass
Generic Name
staged_fromValName Name
staged_toValName Options
defaultOptions Name
n
deriveGeneric1 :: Name -> Q [Dec]
deriveGeneric1 :: Name -> Q [Dec]
deriveGeneric1 Name
n = do
Name
-> Name
-> GenericClass
-> Name
-> Name
-> Options
-> Name
-> Q [Dec]
deriveInstCommon Name
staged_generic1TypeName Name
staged_rep1TypeName GenericClass
Generic1 Name
staged_fromVal1Name Name
staged_toVal1Name Options
defaultOptions Name
n
deriveInstCommon :: Name
-> Name
-> GenericClass
-> Name
-> Name
-> Options
-> Name
-> Q [Dec]
deriveInstCommon :: Name
-> Name
-> GenericClass
-> Name
-> Name
-> Options
-> Name
-> Q [Dec]
deriveInstCommon Name
genericName Name
repName GenericClass
gClass Name
fromName Name
toName Options
opts Name
n = do
Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
i <- Name
-> Q (Either
String (Name, [Type], [ConstructorInfo], DatatypeVariant_))
reifyDataInfo Name
n
let (Name
name, [Type]
instTys, [ConstructorInfo]
cons, DatatypeVariant_
dv) = (String -> (Name, [Type], [ConstructorInfo], DatatypeVariant_))
-> ((Name, [Type], [ConstructorInfo], DatatypeVariant_)
-> (Name, [Type], [ConstructorInfo], DatatypeVariant_))
-> Either
String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
-> (Name, [Type], [ConstructorInfo], DatatypeVariant_)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> (Name, [Type], [ConstructorInfo], DatatypeVariant_)
forall a. HasCallStack => String -> a
error (Name, [Type], [ConstructorInfo], DatatypeVariant_)
-> (Name, [Type], [ConstructorInfo], DatatypeVariant_)
forall a. a -> a
id Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)
i
useKindSigs :: KindSigOptions
useKindSigs = Options -> KindSigOptions
kindSigOptions Options
opts
!(Type
origTy, Type
origKind) <- GenericClass -> KindSigOptions -> Name -> [Type] -> Q (Type, Type)
buildTypeInstance GenericClass
gClass KindSigOptions
useKindSigs Name
name [Type]
instTys
Type
tyInsRHS <- if Options -> RepOptions
repOptions Options
opts RepOptions -> RepOptions -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== RepOptions
InlineRep
then GenericClass
-> DatatypeVariant_
-> Name
-> [Type]
-> [ConstructorInfo]
-> Type
-> Q Type
makeRepInline GenericClass
gClass DatatypeVariant_
dv Name
name [Type]
instTys [ConstructorInfo]
cons Type
origTy
else GenericClass -> DatatypeVariant_ -> Name -> Type -> Q Type
makeRepTySynApp GenericClass
gClass DatatypeVariant_
dv Name
name Type
origTy
let origSigTy :: Type
origSigTy = if KindSigOptions
useKindSigs
then Type -> Type -> Type
SigT Type
origTy Type
origKind
else Type
origTy
Dec
tyIns <- Name -> Maybe [Q TyVarBndrUnit] -> [Q Type] -> Q Type -> DecQ
tySynInstDCompat Name
repName
Maybe [Q TyVarBndrUnit]
forall a. Maybe a
Nothing
[Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
origSigTy] (Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
tyInsRHS)
let ecOptions :: KindSigOptions
ecOptions = Options -> KindSigOptions
emptyCaseOptions Options
opts
mkBody :: (GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match)
-> [Q Clause]
mkBody GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
maker = [[Q Pat] -> Q Body -> [DecQ] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$
GenericClass
-> KindSigOptions
-> Name
-> [Type]
-> [ConstructorInfo]
-> (GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match)
-> Q Exp
mkCaseExp GenericClass
gClass KindSigOptions
ecOptions Name
name [Type]
instTys [ConstructorInfo]
cons GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
maker) []]
tcs :: [Q Clause]
tcs = (GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match)
-> [Q Clause]
mkBody GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
mkTo
fcs' :: Q Exp
fcs' = do
Name
val <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"val"
Name
k <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"_kont"
[Q Pat] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
val, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
k] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
[| unsafeCodeCoerce |] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| caseE |]
[ [| unTypeCode |] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
val
, Q Exp
-> GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Exp
mkFrom (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
k) GenericClass
gClass KindSigOptions
ecOptions Int
1 Int
1 Name
name [Type]
instTys [ConstructorInfo]
cons
]
fcs :: [Q Clause]
fcs = [ [Q Pat] -> Q Body -> [DecQ] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
fcs') []]
(Dec -> [Dec]) -> DecQ -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (DecQ -> Q [Dec]) -> DecQ -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
Q [Type] -> Q Type -> [DecQ] -> DecQ
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt []) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
genericName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
origSigTy)
[Dec -> DecQ
forall (m :: * -> *) a. Monad m => a -> m a
return Dec
tyIns, Name -> [Q Clause] -> DecQ
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
fromName [Q Clause]
fcs, Name -> [Q Clause] -> DecQ
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
toName [Q Clause]
tcs]
buildTypeInstance :: GenericClass
-> KindSigOptions
-> Name
-> [Type]
-> Q (Type, Kind)
buildTypeInstance :: GenericClass -> KindSigOptions -> Name -> [Type] -> Q (Type, Type)
buildTypeInstance GenericClass
gClass KindSigOptions
useKindSigs Name
tyConName [Type]
varTysOrig = do
[Type]
varTysExp <- (Type -> Q Type) -> [Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
resolveTypeSynonyms [Type]
varTysOrig
let remainingLength :: Int
remainingLength :: Int
remainingLength = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
varTysOrig Int -> Int -> Int
forall a. Num a => a -> a -> a
- GenericClass -> Int
forall a. Enum a => a -> Int
fromEnum GenericClass
gClass
droppedTysExp :: [Type]
droppedTysExp :: [Type]
droppedTysExp = Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop Int
remainingLength [Type]
varTysExp
droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = (Type -> StarKindStatus) -> [Type] -> [StarKindStatus]
forall a b. (a -> b) -> [a] -> [b]
map Type -> StarKindStatus
canRealizeKindStar [Type]
droppedTysExp
KindSigOptions -> Q () -> Q ()
forall (f :: * -> *).
Applicative f =>
KindSigOptions -> f () -> f ()
when (Int
remainingLength Int -> Int -> KindSigOptions
forall a. Ord a => a -> a -> KindSigOptions
< Int
0 KindSigOptions -> KindSigOptions -> KindSigOptions
|| (StarKindStatus -> KindSigOptions)
-> [StarKindStatus] -> KindSigOptions
forall (t :: * -> *) a.
Foldable t =>
(a -> KindSigOptions) -> t a -> KindSigOptions
any (StarKindStatus -> StarKindStatus -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== StarKindStatus
NotKindStar) [StarKindStatus]
droppedStarKindStati) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
Name -> Q ()
forall a. Name -> Q a
derivingKindError Name
tyConName
let varTysExpSubst :: [Type]
#if MIN_VERSION_base(4,10,0)
varTysExpSubst :: [Type]
varTysExpSubst = [Type]
varTysExp
#else
varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp
droppedKindVarNames :: [Name]
droppedKindVarNames = catKindVarNames droppedStarKindStati
#endif
let remainingTysExpSubst, droppedTysExpSubst :: [Type]
([Type]
remainingTysExpSubst, [Type]
droppedTysExpSubst) =
Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
remainingLength [Type]
varTysExpSubst
#if !(MIN_VERSION_base(4,10,0))
unless (all hasKindStar droppedTysExpSubst) $
derivingKindError tyConName
#endif
let varTysOrigSubst :: [Type]
varTysOrigSubst :: [Type]
varTysOrigSubst =
#if MIN_VERSION_base(4,10,0)
[Type] -> [Type]
forall a. a -> a
id
#else
map (substNamesWithKindStar droppedKindVarNames)
#endif
([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ [Type]
varTysOrig
remainingTysOrigSubst, droppedTysOrigSubst :: [Type]
([Type]
remainingTysOrigSubst, [Type]
droppedTysOrigSubst) =
Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
remainingLength [Type]
varTysOrigSubst
remainingTysOrigSubst' :: [Type]
remainingTysOrigSubst' :: [Type]
remainingTysOrigSubst' =
if KindSigOptions
useKindSigs
then [Type]
remainingTysOrigSubst
else (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
unSigT [Type]
remainingTysOrigSubst
instanceType :: Type
instanceType :: Type
instanceType = Type -> [Type] -> Type
applyTyToTys (Name -> Type
ConT Name
tyConName) [Type]
remainingTysOrigSubst'
instanceKind :: Kind
instanceKind :: Type
instanceKind = [Type] -> Type -> Type
makeFunKind ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
typeKind [Type]
droppedTysOrigSubst) Type
starK
KindSigOptions -> Q () -> Q ()
forall (f :: * -> *).
Applicative f =>
KindSigOptions -> f () -> f ()
unless ([Type] -> [Type] -> KindSigOptions
canEtaReduce [Type]
remainingTysExpSubst [Type]
droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
Type -> Q ()
forall a. Type -> Q a
etaReductionError Type
instanceType
(Type, Type) -> Q (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
instanceType, Type
instanceKind)
makeRepInline :: GenericClass
-> DatatypeVariant_
-> Name
-> [Type]
-> [ConstructorInfo]
-> Type
-> Q Type
makeRepInline :: GenericClass
-> DatatypeVariant_
-> Name
-> [Type]
-> [ConstructorInfo]
-> Type
-> Q Type
makeRepInline GenericClass
gClass DatatypeVariant_
dv Name
name [Type]
instTys [ConstructorInfo]
cons Type
ty = do
let instVars :: [TyVarBndrUnit]
instVars = [Type] -> [TyVarBndrUnit]
freeVariablesWellScoped [Type
ty]
([TyVarBndrUnit]
tySynVars, GenericKind
gk) = GenericClass -> [Type] -> ([TyVarBndrUnit], GenericKind)
genericKind GenericClass
gClass [Type]
instTys
typeSubst :: TypeSubst
typeSubst :: TypeSubst
typeSubst = [(Name, Type)] -> TypeSubst
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Type)] -> TypeSubst) -> [(Name, Type)] -> TypeSubst
forall a b. (a -> b) -> a -> b
$
[Name] -> [Type] -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((TyVarBndrUnit -> Name) -> [TyVarBndrUnit] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndrUnit]
tySynVars)
((TyVarBndrUnit -> Type) -> [TyVarBndrUnit] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT (Name -> Type) -> (TyVarBndrUnit -> Name) -> TyVarBndrUnit -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndrUnit -> Name
forall flag. TyVarBndr_ flag -> Name
tvName) [TyVarBndrUnit]
instVars)
GenericKind
-> DatatypeVariant_
-> Name
-> TypeSubst
-> [ConstructorInfo]
-> Q Type
repType GenericKind
gk DatatypeVariant_
dv Name
name TypeSubst
typeSubst [ConstructorInfo]
cons
genRepName :: GenericClass -> DatatypeVariant_
-> Name -> Name
genRepName :: GenericClass -> DatatypeVariant_ -> Name -> Name
genRepName GenericClass
gClass DatatypeVariant_
dv Name
n
= String -> Name
mkName
(String -> Name) -> (String -> String) -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatatypeVariant_ -> String -> String
showsDatatypeVariant DatatypeVariant_
dv
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String
"Rep" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (GenericClass -> Int
forall a. Enum a => a -> Int
fromEnum GenericClass
gClass)) String -> String -> String
forall a. [a] -> [a] -> [a]
++)
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name -> String
showNameQual Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_") String -> String -> String
forall a. [a] -> [a] -> [a]
++)
(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
sanitizeName
(String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
n
repType :: GenericKind
-> DatatypeVariant_
-> Name
-> TypeSubst
-> [ConstructorInfo]
-> Q Type
repType :: GenericKind
-> DatatypeVariant_
-> Name
-> TypeSubst
-> [ConstructorInfo]
-> Q Type
repType GenericKind
gk DatatypeVariant_
dv Name
dt TypeSubst
typeSubst [ConstructorInfo]
cs =
Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
d2TypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` DatatypeVariant_ -> Name -> Q Type
mkMetaDataType DatatypeVariant_
dv Name
dt Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT`
(Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal Q Type -> Q Type -> Q Type
sum' (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
v2TypeName) ((ConstructorInfo -> Q Type) -> [ConstructorInfo] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (GenericKind
-> DatatypeVariant_
-> Name
-> TypeSubst
-> ConstructorInfo
-> Q Type
repCon GenericKind
gk DatatypeVariant_
dv Name
dt TypeSubst
typeSubst) [ConstructorInfo]
cs)
where
sum' :: Q Type -> Q Type -> Q Type
sum' :: Q Type -> Q Type -> Q Type
sum' Q Type
a Q Type
b = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
staged_sumTypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
a Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
b
repCon :: GenericKind
-> DatatypeVariant_
-> Name
-> TypeSubst
-> ConstructorInfo
-> Q Type
repCon :: GenericKind
-> DatatypeVariant_
-> Name
-> TypeSubst
-> ConstructorInfo
-> Q Type
repCon GenericKind
gk DatatypeVariant_
dv Name
dt TypeSubst
typeSubst
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
n
, constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
constructorVars = [TyVarBndrUnit]
vars
, constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
ctxt
, constructorStrictness :: ConstructorInfo -> [FieldStrictness]
constructorStrictness = [FieldStrictness]
bangs
, constructorFields :: ConstructorInfo -> [Type]
constructorFields = [Type]
ts
, constructorVariant :: ConstructorInfo -> ConstructorVariant
constructorVariant = ConstructorVariant
cv
}) = do
Name -> [TyVarBndrUnit] -> [Type] -> Q ()
checkExistentialContext Name
n [TyVarBndrUnit]
vars [Type]
ctxt
let mbSelNames :: Maybe [Name]
mbSelNames = case ConstructorVariant
cv of
ConstructorVariant
NormalConstructor -> Maybe [Name]
forall a. Maybe a
Nothing
ConstructorVariant
InfixConstructor -> Maybe [Name]
forall a. Maybe a
Nothing
RecordConstructor [Name]
selNames -> [Name] -> Maybe [Name]
forall a. a -> Maybe a
Just [Name]
selNames
isRecord :: KindSigOptions
isRecord = case ConstructorVariant
cv of
ConstructorVariant
NormalConstructor -> KindSigOptions
False
ConstructorVariant
InfixConstructor -> KindSigOptions
False
RecordConstructor [Name]
_ -> KindSigOptions
True
isInfix :: KindSigOptions
isInfix = case ConstructorVariant
cv of
ConstructorVariant
NormalConstructor -> KindSigOptions
False
ConstructorVariant
InfixConstructor -> KindSigOptions
True
RecordConstructor [Name]
_ -> KindSigOptions
False
[SelStrictInfo]
ssis <- Name -> [FieldStrictness] -> Q [SelStrictInfo]
reifySelStrictInfo Name
n [FieldStrictness]
bangs
GenericKind
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe [Name]
-> [SelStrictInfo]
-> [Type]
-> KindSigOptions
-> KindSigOptions
-> Q Type
repConWith GenericKind
gk DatatypeVariant_
dv Name
dt Name
n TypeSubst
typeSubst Maybe [Name]
mbSelNames [SelStrictInfo]
ssis [Type]
ts KindSigOptions
isRecord KindSigOptions
isInfix
repConWith :: GenericKind
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe [Name]
-> [SelStrictInfo]
-> [Type]
-> Bool
-> Bool
-> Q Type
repConWith :: GenericKind
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe [Name]
-> [SelStrictInfo]
-> [Type]
-> KindSigOptions
-> KindSigOptions
-> Q Type
repConWith GenericKind
gk DatatypeVariant_
dv Name
dt Name
n TypeSubst
typeSubst Maybe [Name]
mbSelNames [SelStrictInfo]
ssis [Type]
ts KindSigOptions
isRecord KindSigOptions
isInfix = do
let structureType :: Q Type
structureType :: Q Type
structureType = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal Q Type -> Q Type -> Q Type
prodT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
u2TypeName) [Q Type]
f
f :: [Q Type]
f :: [Q Type]
f = case Maybe [Name]
mbSelNames of
Just [Name]
selNames -> (Name -> SelStrictInfo -> Type -> Q Type)
-> [Name] -> [SelStrictInfo] -> [Type] -> [Q Type]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (GenericKind
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe Name
-> SelStrictInfo
-> Type
-> Q Type
repField GenericKind
gk DatatypeVariant_
dv Name
dt Name
n TypeSubst
typeSubst (Maybe Name -> SelStrictInfo -> Type -> Q Type)
-> (Name -> Maybe Name) -> Name -> SelStrictInfo -> Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Maybe Name
forall a. a -> Maybe a
Just)
[Name]
selNames [SelStrictInfo]
ssis [Type]
ts
Maybe [Name]
Nothing -> (SelStrictInfo -> Type -> Q Type)
-> [SelStrictInfo] -> [Type] -> [Q Type]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericKind
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe Name
-> SelStrictInfo
-> Type
-> Q Type
repField GenericKind
gk DatatypeVariant_
dv Name
dt Name
n TypeSubst
typeSubst Maybe Name
forall a. Maybe a
Nothing)
[SelStrictInfo]
ssis [Type]
ts
Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
c2TypeName
Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` DatatypeVariant_
-> Name -> Name -> KindSigOptions -> KindSigOptions -> Q Type
mkMetaConsType DatatypeVariant_
dv Name
dt Name
n KindSigOptions
isRecord KindSigOptions
isInfix
Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
structureType
prodT :: Q Type -> Q Type -> Q Type
prodT :: Q Type -> Q Type -> Q Type
prodT Q Type
a Q Type
b = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
staged_productTypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
a Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
b
repField :: GenericKind
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe Name
-> SelStrictInfo
-> Type
-> Q Type
repField :: GenericKind
-> DatatypeVariant_
-> Name
-> Name
-> TypeSubst
-> Maybe Name
-> SelStrictInfo
-> Type
-> Q Type
repField GenericKind
gk DatatypeVariant_
dv Name
dt Name
ns TypeSubst
typeSubst Maybe Name
mbF SelStrictInfo
ssi Type
t =
Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
s2TypeName
Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` DatatypeVariant_
-> Name -> Name -> Maybe Name -> SelStrictInfo -> Q Type
mkMetaSelType DatatypeVariant_
dv Name
dt Name
ns Maybe Name
mbF SelStrictInfo
ssi
Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (GenericKind -> KindSigOptions -> Type -> Q Type
repFieldArg GenericKind
gk KindSigOptions
False (Type -> Q Type) -> Q Type -> Q Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Q Type
resolveTypeSynonyms Type
t'')
where
t', t'' :: Type
t' :: Type
t' = case GenericKind
gk of
Gen1 Name
_ (Just Name
_kvName) ->
#if MIN_VERSION_base(4,10,0)
Type
t
#else
substNameWithKind _kvName starK t
#endif
GenericKind
_ -> Type
t
t'' :: Type
t'' = TypeSubst -> Type -> Type
forall a. TypeSubstitution a => TypeSubst -> a -> a
applySubstitution TypeSubst
typeSubst Type
t'
repFieldArg :: GenericKind -> Bool -> Type -> Q Type
repFieldArg :: GenericKind -> KindSigOptions -> Type -> Q Type
repFieldArg GenericKind
_ KindSigOptions
_ ForallT{} = Q Type
forall a. a
rankNError
repFieldArg GenericKind
gk KindSigOptions
inPar (SigT Type
t Type
_) = GenericKind -> KindSigOptions -> Type -> Q Type
repFieldArg GenericKind
gk KindSigOptions
inPar Type
t
repFieldArg GenericKind
Gen0 KindSigOptions
_ Type
t = Type -> Q Type
boxT Type
t
repFieldArg (Gen1 Name
name Maybe Name
_) KindSigOptions
_ (VarT Name
t) | Name
t Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
par2TypeName
repFieldArg gk :: GenericKind
gk@(Gen1 Name
name Maybe Name
_) KindSigOptions
inPar Type
t = do
let Type
tyHead:[Type]
tyArgs = Type -> [Type]
unapplyTy Type
t
numLastArgs :: Int
numLastArgs = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs
([Type]
lhsArgs, [Type]
rhsArgs) = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLastArgs) [Type]
tyArgs
k2Type :: Q Type
k2Type = Type -> Q Type
boxT Type
t
phiType :: Q Type
phiType = Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Type -> [Type] -> Type
applyTyToTys Type
tyHead [Type]
lhsArgs
let inspectTy :: Type -> Q Type
inspectTy :: Type -> Q Type
inspectTy (VarT Name
a)
| Name
a Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name
= if KindSigOptions
inPar
then Q Type
phiType
else Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
staged_appTypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
par2TypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
phiType
inspectTy (SigT Type
ty Type
_) = Type -> Q Type
inspectTy Type
ty
inspectTy Type
beta
| KindSigOptions -> KindSigOptions
not (Type -> Name -> KindSigOptions
ground Type
beta Name
name)
= Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
staged_appTypeName
Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
staged_appTypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
par2TypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
phiType)
Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` GenericKind -> KindSigOptions -> Type -> Q Type
repFieldArg GenericKind
gk KindSigOptions
True Type
beta
inspectTy Type
_ = Q Type
k2Type
KindSigOptions
itf <- Type -> Q KindSigOptions
isTyFamily Type
tyHead
if (Type -> KindSigOptions) -> [Type] -> KindSigOptions
forall (t :: * -> *) a.
Foldable t =>
(a -> KindSigOptions) -> t a -> KindSigOptions
any (KindSigOptions -> KindSigOptions
not (KindSigOptions -> KindSigOptions)
-> (Type -> KindSigOptions) -> Type -> KindSigOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Name -> KindSigOptions
`ground` Name
name)) [Type]
lhsArgs
KindSigOptions -> KindSigOptions -> KindSigOptions
|| (Type -> KindSigOptions) -> [Type] -> KindSigOptions
forall (t :: * -> *) a.
Foldable t =>
(a -> KindSigOptions) -> t a -> KindSigOptions
any (KindSigOptions -> KindSigOptions
not (KindSigOptions -> KindSigOptions)
-> (Type -> KindSigOptions) -> Type -> KindSigOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Name -> KindSigOptions
`ground` Name
name)) [Type]
tyArgs KindSigOptions -> KindSigOptions -> KindSigOptions
&& KindSigOptions
itf
then Q Type
forall a. Q a
outOfPlaceTyVarError
else case [Type]
rhsArgs of
[] -> Q Type
k2Type
Type
ty:[Type]
_ -> Type -> Q Type
inspectTy Type
ty
boxT :: Type -> Q Type
boxT :: Type -> Q Type
boxT Type
ty = case Type -> Maybe (Name, Name, Name)
unboxedRepNames Type
ty of
Just (Name
boxTyName, Name
_, Name
_) -> Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
boxTyName
Maybe (Name, Name, Name)
Nothing -> Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
k2TypeName Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
unboxedRepNames :: Type -> Maybe (Name, Name, Name)
unboxedRepNames :: Type -> Maybe (Name, Name, Name)
unboxedRepNames Type
ty
| Type
ty Type -> Type -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name -> Type
ConT Name
addrHashTypeName = (Name, Name, Name) -> Maybe (Name, Name, Name)
forall a. a -> Maybe a
Just (Name
uAddrTypeName, Name
uAddrDataName, Name
uAddrHashValName)
| Type
ty Type -> Type -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name -> Type
ConT Name
charHashTypeName = (Name, Name, Name) -> Maybe (Name, Name, Name)
forall a. a -> Maybe a
Just (Name
uCharTypeName, Name
uCharDataName, Name
uCharHashValName)
| Type
ty Type -> Type -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name -> Type
ConT Name
doubleHashTypeName = (Name, Name, Name) -> Maybe (Name, Name, Name)
forall a. a -> Maybe a
Just (Name
uDoubleTypeName, Name
uDoubleDataName, Name
uDoubleHashValName)
| Type
ty Type -> Type -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name -> Type
ConT Name
floatHashTypeName = (Name, Name, Name) -> Maybe (Name, Name, Name)
forall a. a -> Maybe a
Just (Name
uFloatTypeName, Name
uFloatDataName, Name
uFloatHashValName)
| Type
ty Type -> Type -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name -> Type
ConT Name
intHashTypeName = (Name, Name, Name) -> Maybe (Name, Name, Name)
forall a. a -> Maybe a
Just (Name
uIntTypeName, Name
uIntDataName, Name
uIntHashValName)
| Type
ty Type -> Type -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name -> Type
ConT Name
wordHashTypeName = (Name, Name, Name) -> Maybe (Name, Name, Name)
forall a. a -> Maybe a
Just (Name
uWordTypeName, Name
uWordDataName, Name
uWordHashValName)
| KindSigOptions
otherwise = Maybe (Name, Name, Name)
forall a. Maybe a
Nothing
makeRepTySynApp :: GenericClass -> DatatypeVariant_ -> Name
-> Type -> Q Type
makeRepTySynApp :: GenericClass -> DatatypeVariant_ -> Name -> Type -> Q Type
makeRepTySynApp GenericClass
gClass DatatypeVariant_
dv Name
name Type
ty =
let instTvbs :: [TyVarBndrUnit]
instTvbs = (TyVarBndrUnit -> TyVarBndrUnit)
-> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> TyVarBndrUnit
unKindedTV ([TyVarBndrUnit] -> [TyVarBndrUnit])
-> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$ [Type] -> [TyVarBndrUnit]
freeVariablesWellScoped [Type
ty]
in Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> [TyVarBndrUnit] -> Type
forall spec. Name -> [TyVarBndr_ spec] -> Type
applyTyToTvbs (GenericClass -> DatatypeVariant_ -> Name -> Name
genRepName GenericClass
gClass DatatypeVariant_
dv Name
name) [TyVarBndrUnit]
instTvbs
mkCaseExp
:: GenericClass -> EmptyCaseOptions -> Name -> [Type] -> [ConstructorInfo]
-> (GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]
-> [ConstructorInfo] -> Q Match)
-> Q Exp
mkCaseExp :: GenericClass
-> KindSigOptions
-> Name
-> [Type]
-> [ConstructorInfo]
-> (GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match)
-> Q Exp
mkCaseExp GenericClass
gClass KindSigOptions
ecOptions Name
dt [Type]
instTys [ConstructorInfo]
cs GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
matchmaker = do
Name
val <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"val"
Q Pat -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
val) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
val) [GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
matchmaker GenericClass
gClass KindSigOptions
ecOptions Int
1 Int
1 Name
dt [Type]
instTys [ConstructorInfo]
cs]
type EmptyCaseOptions = Bool
mkTo :: GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]
-> [ConstructorInfo] -> Q Match
mkTo :: GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Match
mkTo GenericClass
gClass KindSigOptions
ecOptions Int
m Int
i Name
dt [Type]
instTys [ConstructorInfo]
cs = do
Name
y <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"y"
Q Pat -> Q Body -> [DecQ] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
m2DataName [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y])
(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) [Q Match]
cases)
[]
where
cases :: [Q Match]
cases = case [ConstructorInfo]
cs of
[] -> KindSigOptions -> Name -> [Q Match]
errorTo KindSigOptions
ecOptions Name
dt
[ConstructorInfo]
_ -> (Int -> ConstructorInfo -> Q Match)
-> [Int] -> [ConstructorInfo] -> [Q Match]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericKind
-> (Q Pat -> Q Pat) -> Int -> Int -> ConstructorInfo -> Q Match
toCon GenericKind
gk Q Pat -> Q Pat
wrapP ([ConstructorInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cs)) [Int
1..] [ConstructorInfo]
cs
wrapP :: Q Pat -> Q Pat
wrapP Q Pat
p = Int -> Int -> Q Pat -> Q Pat
lrP Int
i Int
m Q Pat
p
([TyVarBndrUnit]
_, GenericKind
gk) = GenericClass -> [Type] -> ([TyVarBndrUnit], GenericKind)
genericKind GenericClass
gClass [Type]
instTys
toCon :: GenericKind -> (Q Pat -> Q Pat) -> Int -> Int
-> ConstructorInfo -> Q Match
toCon :: GenericKind
-> (Q Pat -> Q Pat) -> Int -> Int -> ConstructorInfo -> Q Match
toCon GenericKind
gk Q Pat -> Q Pat
wrap Int
m Int
i
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
cn
, constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
constructorVars = [TyVarBndrUnit]
vars
, constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
ctxt
, constructorFields :: ConstructorInfo -> [Type]
constructorFields = [Type]
ts
}) = do
Name -> [TyVarBndrUnit] -> [Type] -> Q ()
checkExistentialContext Name
cn [TyVarBndrUnit]
vars [Type]
ctxt
[Name]
fNames <- String -> Int -> Q [Name]
newNameList String
"f" (Int -> Q [Name]) -> Int -> Q [Name]
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts
Q Pat -> Q Body -> [DecQ] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Q Pat -> Q Pat
wrap (Q Pat -> Q Pat) -> Q Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Q Pat -> Q Pat
lrP Int
i Int
m (Q Pat -> Q Pat) -> Q Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
m2DataName
[(Q Pat -> Q Pat -> Q Pat) -> Q Pat -> [Q Pat] -> Q Pat
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal Q Pat -> Q Pat -> Q Pat
forall {m :: * -> *}. Quote m => m Pat -> m Pat -> m Pat
prod (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
u2DataName []) ((Name -> Type -> Q Pat) -> [Name] -> [Type] -> [Q Pat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericKind -> Name -> Type -> Q Pat
toField GenericKind
gk) [Name]
fNames [Type]
ts)])
(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
(\Q Exp
f Q Exp
x -> [| sapply $f $x |])
([| unsafeCodeCoerce |] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ([| conE |] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift Name
cn))
((Name -> Type -> Q Exp) -> [Name] -> [Type] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
nr -> Type -> Q Type
resolveTypeSynonyms (Type -> Q Type) -> (Type -> Q Exp) -> Type -> Q Exp
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> GenericKind -> Name -> Type -> Q Exp
toConUnwC GenericKind
gk Name
nr)
[Name]
fNames [Type]
ts)) []
where prod :: m Pat -> m Pat -> m Pat
prod m Pat
x m Pat
y = Name -> [m Pat] -> m Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
staged_productDataName [m Pat
x,m Pat
y]
toConUnwC :: GenericKind -> Name -> Type -> Q Exp
toConUnwC :: GenericKind -> Name -> Type -> Q Exp
toConUnwC GenericKind
Gen0 Name
nr Type
_ = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
nr
toConUnwC (Gen1 Name
name Maybe Name
_) Name
nr Type
t = Type -> KindSigOptions -> Name -> Name -> Q Exp
unwC Type
t KindSigOptions
False Name
name Name
nr
toField :: GenericKind -> Name -> Type -> Q Pat
toField :: GenericKind -> Name -> Type -> Q Pat
toField GenericKind
gk Name
nr Type
t = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
m2DataName [GenericKind -> Name -> Type -> Q Pat
toFieldWrap GenericKind
gk Name
nr Type
t]
toFieldWrap :: GenericKind -> Name -> Type -> Q Pat
toFieldWrap :: GenericKind -> Name -> Type -> Q Pat
toFieldWrap GenericKind
Gen0 Name
nr Type
t = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (Type -> Name
boxRepName Type
t) [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
nr]
toFieldWrap Gen1{} Name
nr Type
_ = Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
nr
unwC :: Type -> Bool -> Name -> Name -> Q Exp
unwC :: Type -> KindSigOptions -> Name -> Name -> Q Exp
unwC (SigT Type
t Type
_) KindSigOptions
inPar Name
name Name
nr = Type -> KindSigOptions -> Name -> Name -> Q Exp
unwC Type
t KindSigOptions
inPar Name
name Name
nr
unwC (VarT Name
t) KindSigOptions
_inPar Name
name Name
nr | Name
t Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unPar2ValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
nr
unwC Type
t KindSigOptions
inPar Name
name Name
nr
| Type -> Name -> KindSigOptions
ground Type
t Name
name = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Type -> Name
unboxRepName Type
t) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
nr
| KindSigOptions
otherwise = do
let Type
tyHead:[Type]
tyArgs = Type -> [Type]
unapplyTy Type
t
numLastArgs :: Int
numLastArgs = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs
([Type]
lhsArgs, [Type]
rhsArgs) = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLastArgs) [Type]
tyArgs
inspectTy :: Type -> Q Exp
inspectTy :: Type -> Q Exp
inspectTy ForallT{} = Q Exp
forall a. a
rankNError
inspectTy (SigT Type
ty Type
_) = Type -> Q Exp
inspectTy Type
ty
inspectTy (VarT Name
a)
| Name
a Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name
= if KindSigOptions
inPar
then Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unAppValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
nr
else Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unPar2ValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unAppValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
nr)
inspectTy Type
beta
= Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unPar2ValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
unAppValName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Type -> KindSigOptions -> Name -> Name -> Q Exp
unwC Type
beta KindSigOptions
True Name
name Name
nr)
KindSigOptions
itf <- Type -> Q KindSigOptions
isTyFamily Type
tyHead
if (Type -> KindSigOptions) -> [Type] -> KindSigOptions
forall (t :: * -> *) a.
Foldable t =>
(a -> KindSigOptions) -> t a -> KindSigOptions
any (KindSigOptions -> KindSigOptions
not (KindSigOptions -> KindSigOptions)
-> (Type -> KindSigOptions) -> Type -> KindSigOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Name -> KindSigOptions
`ground` Name
name)) [Type]
lhsArgs
KindSigOptions -> KindSigOptions -> KindSigOptions
|| (Type -> KindSigOptions) -> [Type] -> KindSigOptions
forall (t :: * -> *) a.
Foldable t =>
(a -> KindSigOptions) -> t a -> KindSigOptions
any (KindSigOptions -> KindSigOptions
not (KindSigOptions -> KindSigOptions)
-> (Type -> KindSigOptions) -> Type -> KindSigOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Name -> KindSigOptions
`ground` Name
name)) [Type]
tyArgs KindSigOptions -> KindSigOptions -> KindSigOptions
&& KindSigOptions
itf
then Q Exp
forall a. Q a
outOfPlaceTyVarError
else case [Type]
rhsArgs of
[] -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Type -> Name
unboxRepName Type
t) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
nr
Type
ty:[Type]
_ -> Type -> Q Exp
inspectTy Type
ty
unboxRepName :: Type -> Name
unboxRepName :: Type -> Name
unboxRepName = Name
-> ((Name, Name, Name) -> Name) -> Maybe (Name, Name, Name) -> Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Name
unK2ValName (Name, Name, Name) -> Name
forall a b c. (a, b, c) -> c
trd3 (Maybe (Name, Name, Name) -> Name)
-> (Type -> Maybe (Name, Name, Name)) -> Type -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe (Name, Name, Name)
unboxedRepNames
boxRepName :: Type -> Name
boxRepName :: Type -> Name
boxRepName = Name
-> ((Name, Name, Name) -> Name) -> Maybe (Name, Name, Name) -> Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Name
k2DataName (Name, Name, Name) -> Name
forall a b c. (a, b, c) -> b
snd3 (Maybe (Name, Name, Name) -> Name)
-> (Type -> Maybe (Name, Name, Name)) -> Type -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe (Name, Name, Name)
unboxedRepNames
mkFrom :: Q Exp
-> GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]
-> [ConstructorInfo] -> Q Exp
mkFrom :: Q Exp
-> GenericClass
-> KindSigOptions
-> Int
-> Int
-> Name
-> [Type]
-> [ConstructorInfo]
-> Q Exp
mkFrom Q Exp
kont GenericClass
gClass KindSigOptions
ecOptions Int
m Int
i Name
dt [Type]
instTys [ConstructorInfo]
cs = do
[Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [Q Exp]
cases
where
cases :: [ExpQ]
cases :: [Q Exp]
cases = case [ConstructorInfo]
cs of
[] -> KindSigOptions -> Name -> [Q Exp]
errorFrom KindSigOptions
ecOptions Name
dt
[ConstructorInfo]
_ -> (Int -> ConstructorInfo -> Q Exp)
-> [Int] -> [ConstructorInfo] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Q Exp
-> GenericKind
-> (Q Exp -> Q Exp)
-> Int
-> Int
-> ConstructorInfo
-> Q Exp
fromCon Q Exp
kont GenericKind
gk Q Exp -> Q Exp
wrapE ([ConstructorInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cs)) [Int
1..] [ConstructorInfo]
cs
wrapE :: Q Exp -> Q Exp
wrapE Q Exp
e = Int -> Int -> Q Exp -> Q Exp
lrE Int
i Int
m Q Exp
e
([TyVarBndrUnit]
_, GenericKind
gk) = GenericClass -> [Type] -> ([TyVarBndrUnit], GenericKind)
genericKind GenericClass
gClass [Type]
instTys
errorFrom :: EmptyCaseOptions -> Name -> [ExpQ]
errorFrom :: KindSigOptions -> Name -> [Q Exp]
errorFrom KindSigOptions
_useEmptyCase Name
_dt = []
fromCon :: Q Exp
-> GenericKind -> (Q Exp -> Q Exp) -> Int -> Int
-> ConstructorInfo -> Q Exp
fromCon :: Q Exp
-> GenericKind
-> (Q Exp -> Q Exp)
-> Int
-> Int
-> ConstructorInfo
-> Q Exp
fromCon Q Exp
kont GenericKind
gk Q Exp -> Q Exp
wrap Int
m Int
i
(ConstructorInfo { constructorName :: ConstructorInfo -> Name
constructorName = Name
cn
, constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
constructorVars = [TyVarBndrUnit]
vars
, constructorContext :: ConstructorInfo -> [Type]
constructorContext = [Type]
ctxt
, constructorFields :: ConstructorInfo -> [Type]
constructorFields = [Type]
ts
}) = do
Name -> [TyVarBndrUnit] -> [Type] -> Q ()
checkExistentialContext Name
cn [TyVarBndrUnit]
vars [Type]
ctxt
[(Name, String)]
fNames <- String -> Int -> Q [(Name, String)]
newNameList' String
"f" (Int -> Q [(Name, String)]) -> Int -> Q [(Name, String)]
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts
let fNameExps :: [ExpQ]
fNameExps :: [Q Exp]
fNameExps =
[ [| unsafeCodeCoerce (varE $(varE fName)) |]
| (Name
fName, String
_) <- [(Name, String)]
fNames
]
let kontArg :: ExpQ
kontArg :: Q Exp
kontArg = Q Exp -> Q Exp
wrap (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Q Exp -> Q Exp
lrE Int
i Int
m (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
m2DataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
(Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> a -> [a] -> a
foldBal Q Exp -> Q Exp -> Q Exp
prodE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
u2DataName) ((Q Exp -> Type -> Q Exp) -> [Q Exp] -> [Type] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericKind -> Q Exp -> Type -> Q Exp
fromField GenericKind
gk) [Q Exp]
fNameExps [Type]
ts)
let bindNewNames :: [Q Stmt]
bindNewNames = [ Q Pat -> Q Exp -> Q Stmt
forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
bindS (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
v) [| newName $(stringE s) |] | (Name
v, String
s) <- [(Name, String)]
fNames ]
[Q Stmt] -> Q Exp
forall (m :: * -> *). Quote m => [m Stmt] -> m Exp
doE ([Q Stmt] -> Q Exp) -> [Q Stmt] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Q Stmt]
bindNewNames [Q Stmt] -> [Q Stmt] -> [Q Stmt]
forall a. [a] -> [a] -> [a]
++
[ Q Exp -> Q Stmt
forall (m :: * -> *). Quote m => m Exp -> m Stmt
noBindS (Q Exp -> Q Stmt) -> Q Exp -> Q Stmt
forall a b. (a -> b) -> a -> b
$ (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| match |]
[ (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| conP |]
[ Name -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift Name
cn
, [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [ [| varP |] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fName | (Name
fName, String
_) <- [(Name, String)]
fNames ]
]
, [| normalB (unTypeCode ($kont $(conE m2DataName `appE` kontArg))) |]
, [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE []
]
]
newNameList' :: String -> Int -> Q [(Name, String)]
newNameList' :: String -> Int -> Q [(Name, String)]
newNameList' String
prefix Int
n = [Int] -> (Int -> Q (Name, String)) -> Q [(Name, String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
1..Int
n] ((Int -> Q (Name, String)) -> Q [(Name, String)])
-> (Int -> Q (Name, String)) -> Q [(Name, String)]
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
let s :: String
s = String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
Name
n' <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
s
(Name, String) -> Q (Name, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n', String
s)
prodE :: Q Exp -> Q Exp -> Q Exp
prodE :: Q Exp -> Q Exp -> Q Exp
prodE Q Exp
x Q Exp
y = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
staged_productDataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
x Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
y
fromField :: GenericKind -> Q Exp -> Type -> Q Exp
fromField :: GenericKind -> Q Exp -> Type -> Q Exp
fromField GenericKind
gk Q Exp
nr Type
t = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
m2DataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (GenericKind -> Q Exp -> Type -> Q Exp
fromFieldWrap GenericKind
gk Q Exp
nr (Type -> Q Exp) -> Q Type -> Q Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> Q Type
resolveTypeSynonyms Type
t)
fromFieldWrap :: GenericKind -> Q Exp -> Type -> Q Exp
fromFieldWrap :: GenericKind -> Q Exp -> Type -> Q Exp
fromFieldWrap GenericKind
_ Q Exp
_ ForallT{} = Q Exp
forall a. a
rankNError
fromFieldWrap GenericKind
gk Q Exp
nr (SigT Type
t Type
_) = GenericKind -> Q Exp -> Type -> Q Exp
fromFieldWrap GenericKind
gk Q Exp
nr Type
t
fromFieldWrap GenericKind
Gen0 Q Exp
nr Type
t = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Type -> Name
boxRepName Type
t) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
nr
fromFieldWrap (Gen1 Name
name Maybe Name
_) Q Exp
nr Type
t = Type -> Name -> Q Exp -> Q Exp
wC Type
t Name
name Q Exp
nr
wC :: Type -> Name -> Q Exp -> Q Exp
wC :: Type -> Name -> Q Exp -> Q Exp
wC (VarT Name
t) Name
name Q Exp
nr | Name
t Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
par2DataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
nr
wC Type
t Name
name Q Exp
nr
| Type -> Name -> KindSigOptions
ground Type
t Name
name = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Type -> Name
boxRepName Type
t) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
nr
| KindSigOptions
otherwise = do
let Type
tyHead:[Type]
tyArgs = Type -> [Type]
unapplyTy Type
t
numLastArgs :: Int
numLastArgs = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs
([Type]
lhsArgs, [Type]
rhsArgs) = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tyArgs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numLastArgs) [Type]
tyArgs
inspectTy :: Type -> Q Exp
inspectTy :: Type -> Q Exp
inspectTy ForallT{} = Q Exp
forall a. a
rankNError
inspectTy (SigT Type
ty Type
_) = Type -> Q Exp
inspectTy Type
ty
inspectTy (VarT Name
a)
| Name
a Name -> Name -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Name
name
= Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
appDataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
par2DataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
nr)
inspectTy Type
beta =
Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
appDataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Type -> Name -> Q Exp -> Q Exp
wC Type
beta Name
name Q Exp
nr
KindSigOptions
itf <- Type -> Q KindSigOptions
isTyFamily Type
tyHead
if (Type -> KindSigOptions) -> [Type] -> KindSigOptions
forall (t :: * -> *) a.
Foldable t =>
(a -> KindSigOptions) -> t a -> KindSigOptions
any (KindSigOptions -> KindSigOptions
not (KindSigOptions -> KindSigOptions)
-> (Type -> KindSigOptions) -> Type -> KindSigOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Name -> KindSigOptions
`ground` Name
name)) [Type]
lhsArgs
KindSigOptions -> KindSigOptions -> KindSigOptions
|| (Type -> KindSigOptions) -> [Type] -> KindSigOptions
forall (t :: * -> *) a.
Foldable t =>
(a -> KindSigOptions) -> t a -> KindSigOptions
any (KindSigOptions -> KindSigOptions
not (KindSigOptions -> KindSigOptions)
-> (Type -> KindSigOptions) -> Type -> KindSigOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Name -> KindSigOptions
`ground` Name
name)) [Type]
tyArgs KindSigOptions -> KindSigOptions -> KindSigOptions
&& KindSigOptions
itf
then Q Exp
forall a. Q a
outOfPlaceTyVarError
else case [Type]
rhsArgs of
[] -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Type -> Name
boxRepName Type
t) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
nr
Type
ty:[Type]
_ -> Type -> Q Exp
inspectTy Type
ty
errorTo :: EmptyCaseOptions -> Name -> [Q Match]
errorTo :: KindSigOptions -> Name -> [Q Match]
errorTo KindSigOptions
useEmptyCase Name
dt
| KindSigOptions
useEmptyCase
= []
| KindSigOptions
otherwise
= [do Name
z <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"z"
Q Pat -> Q Body -> [DecQ] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
z)
(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$
Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
seqValName) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z) Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
errorValName)
(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"No values for empty datatype " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
dt))
[]]
lrP :: Int -> Int -> (Q Pat -> Q Pat)
lrP :: Int -> Int -> Q Pat -> Q Pat
lrP Int
i Int
n Q Pat
p
| Int
n Int -> Int -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Int
0 = String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lrP: impossible"
| Int
n Int -> Int -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Int
1 = Q Pat
p
| Int
i Int -> Int -> KindSigOptions
forall a. Ord a => a -> a -> KindSigOptions
<= Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2 = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
l2DataName [Int -> Int -> Q Pat -> Q Pat
lrP Int
i (Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2) Q Pat
p]
| KindSigOptions
otherwise = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
r2DataName [Int -> Int -> Q Pat -> Q Pat
lrP (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m) Q Pat
p]
where m :: Int
m = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2
lrE :: Int -> Int -> (Q Exp -> Q Exp)
lrE :: Int -> Int -> Q Exp -> Q Exp
lrE Int
i Int
n Q Exp
e
| Int
n Int -> Int -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Int
0 = String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lrE: impossible"
| Int
n Int -> Int -> KindSigOptions
forall a. Eq a => a -> a -> KindSigOptions
== Int
1 = Q Exp
e
| Int
i Int -> Int -> KindSigOptions
forall a. Ord a => a -> a -> KindSigOptions
<= Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2 = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
l2DataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Int -> Q Exp -> Q Exp
lrE Int
i (Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2) Q Exp
e
| KindSigOptions
otherwise = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
r2DataName Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Int -> Q Exp -> Q Exp
lrE (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m) Q Exp
e
where m :: Int
m = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2