{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
module Generics.Linear.TH (
deriveGeneric
, deriveGeneric1
, deriveGenericAnd1
) where
import Control.Monad ((>=>), unless, when)
import Generics.Linear.TH.Internal
import Generics.Linear.TH.MetaData
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Lib
import Language.Haskell.TH
import Generics.Linear.Class
hiding ( uAddr#, uChar#, uDouble#, uFloat#, uInt#, uWord#
, unM1, unK1, unPar1, unComp1)
import Generics.Linear.TH.Insertions
hiding ((.))
import qualified Generics.Linear.TH.Insertions as Ins
import GHC.Exts (Addr#, Char#, Int#, Word#, Double#, Float#)
deriveGeneric :: Name -> Q [Dec]
deriveGeneric :: Name -> Q [Dec]
deriveGeneric = Bool -> Bool -> Name -> Q [Dec]
deriveGenericCommon Bool
True Bool
False
deriveGeneric1 :: Name -> Q [Dec]
deriveGeneric1 :: Name -> Q [Dec]
deriveGeneric1 = Bool -> Bool -> Name -> Q [Dec]
deriveGenericCommon Bool
False Bool
True
deriveGenericAnd1 :: Name -> Q [Dec]
deriveGenericAnd1 :: Name -> Q [Dec]
deriveGenericAnd1 = Bool -> Bool -> Name -> Q [Dec]
deriveGenericCommon Bool
True Bool
True
deriveGenericCommon :: Bool -> Bool -> Name -> Q [Dec]
deriveGenericCommon :: Bool -> Bool -> Name -> Q [Dec]
deriveGenericCommon Bool
generic Bool
generic1 Name
n = do
[Dec]
b <- if Bool
generic
then GenericClass -> Name -> Q [Dec]
deriveInst GenericClass
Generic Name
n
else [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
[Dec]
c <- if Bool
generic1
then GenericClass -> Name -> Q [Dec]
deriveInst GenericClass
Generic1 Name
n
else [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
b [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
c)
deriveInst :: GenericClass -> Name -> Q [Dec]
deriveInst :: GenericClass -> Name -> Q [Dec]
deriveInst GenericClass
Generic = Name -> Name -> GenericClass -> Name -> Name -> Name -> Q [Dec]
deriveInstCommon ''Generic ''Rep GenericClass
Generic 'from 'to
deriveInst GenericClass
Generic1 = Name -> Name -> GenericClass -> Name -> Name -> Name -> Q [Dec]
deriveInstCommon ''Generic1 ''Rep1 GenericClass
Generic1 'from1 'to1
deriveInstCommon :: Name
-> Name
-> GenericClass
-> Name
-> Name
-> Name
-> Q [Dec]
deriveInstCommon :: Name -> Name -> GenericClass -> Name -> Name -> Name -> Q [Dec]
deriveInstCommon Name
genericName Name
repName GenericClass
gClass Name
fromName Name
toName Name
n = do
(Name
name, [Type]
instTys, [ConstructorInfo]
cons, DatatypeVariant_
dv) <- Name -> Q (Name, [Type], [ConstructorInfo], DatatypeVariant_)
reifyDataInfo Name
n
let gt :: GenericTvbs
gt = GenericClass -> [Type] -> GenericTvbs
mkGenericTvbs GenericClass
gClass [Type]
instTys
(Type
origTy, Type
origKind) <- GenericClass -> Name -> [Type] -> Q (Type, Type)
buildTypeInstance GenericClass
gClass Name
name [Type]
instTys
Type
tyInsRHS <- GenericTvbs
-> DatatypeVariant_ -> Name -> [ConstructorInfo] -> Q Type
repType GenericTvbs
gt DatatypeVariant_
dv Name
name [ConstructorInfo]
cons
let origSigTy :: Type
origSigTy = Type -> Type -> Type
SigT Type
origTy Type
origKind
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
mkBody :: (GenericTvbs -> [ConstructorInfo] -> Q Match) -> [Q Clause]
mkBody GenericTvbs -> [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
$ [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => [m Match] -> m Exp
lamCaseE [GenericTvbs -> [ConstructorInfo] -> Q Match
maker GenericTvbs
gt [ConstructorInfo]
cons]) []]
fcs :: [Q Clause]
fcs = (GenericTvbs -> [ConstructorInfo] -> Q Match) -> [Q Clause]
mkBody GenericTvbs -> [ConstructorInfo] -> Q Match
mkFrom
tcs :: [Q Clause]
tcs = (GenericTvbs -> [ConstructorInfo] -> Q Match) -> [Q Clause]
mkBody GenericTvbs -> [ConstructorInfo] -> Q Match
mkTo
(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]
repType :: GenericTvbs
-> DatatypeVariant_
-> Name
-> [ConstructorInfo]
-> Q Type
repType :: GenericTvbs
-> DatatypeVariant_ -> Name -> [ConstructorInfo] -> Q Type
repType GenericTvbs
gt DatatypeVariant_
dv Name
dt [ConstructorInfo]
cs =
Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''D1 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 ''V1) ((ConstructorInfo -> Q Type) -> [ConstructorInfo] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (GenericTvbs
-> DatatypeVariant_ -> Name -> ConstructorInfo -> Q Type
repCon GenericTvbs
gt DatatypeVariant_
dv Name
dt) [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 ''(:+:) 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 :: GenericTvbs
-> DatatypeVariant_
-> Name
-> ConstructorInfo
-> Q Type
repCon :: GenericTvbs
-> DatatypeVariant_ -> Name -> ConstructorInfo -> Q Type
repCon GenericTvbs
gt DatatypeVariant_
dv Name
dt
(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 :: Bool
isRecord = case ConstructorVariant
cv of
ConstructorVariant
NormalConstructor -> Bool
False
ConstructorVariant
InfixConstructor -> Bool
False
RecordConstructor [Name]
_ -> Bool
True
isInfix :: Bool
isInfix = case ConstructorVariant
cv of
ConstructorVariant
NormalConstructor -> Bool
False
ConstructorVariant
InfixConstructor -> Bool
True
RecordConstructor [Name]
_ -> Bool
False
[SelStrictInfo]
ssis <- Name -> [FieldStrictness] -> Q [SelStrictInfo]
reifySelStrictInfo Name
n [FieldStrictness]
bangs
GenericTvbs
-> DatatypeVariant_
-> Name
-> Name
-> Maybe [Name]
-> [SelStrictInfo]
-> [Type]
-> Bool
-> Bool
-> Q Type
repConWith GenericTvbs
gt DatatypeVariant_
dv Name
dt Name
n Maybe [Name]
mbSelNames [SelStrictInfo]
ssis [Type]
ts Bool
isRecord Bool
isInfix
repConWith :: GenericTvbs
-> DatatypeVariant_
-> Name
-> Name
-> Maybe [Name]
-> [SelStrictInfo]
-> [Type]
-> Bool
-> Bool
-> Q Type
repConWith :: GenericTvbs
-> DatatypeVariant_
-> Name
-> Name
-> Maybe [Name]
-> [SelStrictInfo]
-> [Type]
-> Bool
-> Bool
-> Q Type
repConWith GenericTvbs
gt DatatypeVariant_
dv Name
dt Name
n Maybe [Name]
mbSelNames [SelStrictInfo]
ssis [Type]
ts Bool
isRecord Bool
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 ''U1) [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 (GenericTvbs
-> DatatypeVariant_
-> Name
-> Name
-> Maybe Name
-> SelStrictInfo
-> Type
-> Q Type
repField GenericTvbs
gt DatatypeVariant_
dv Name
dt Name
n (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 (GenericTvbs
-> DatatypeVariant_
-> Name
-> Name
-> Maybe Name
-> SelStrictInfo
-> Type
-> Q Type
repField GenericTvbs
gt DatatypeVariant_
dv Name
dt Name
n Maybe Name
forall a. Maybe a
Nothing)
[SelStrictInfo]
ssis [Type]
ts
Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''C1
Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` DatatypeVariant_ -> Name -> Name -> Bool -> Bool -> Q Type
mkMetaConsType DatatypeVariant_
dv Name
dt Name
n Bool
isRecord Bool
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 ''(:*:) 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 :: GenericTvbs
-> DatatypeVariant_
-> Name
-> Name
-> Maybe Name
-> SelStrictInfo
-> Type
-> Q Type
repField :: GenericTvbs
-> DatatypeVariant_
-> Name
-> Name
-> Maybe Name
-> SelStrictInfo
-> Type
-> Q Type
repField GenericTvbs
gt DatatypeVariant_
dv Name
dt Name
ns Maybe Name
mbF SelStrictInfo
ssi Type
t =
Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''S1
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` (GenericTvbs -> Type -> Q Type
repFieldArg GenericTvbs
gt (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)
repFieldArg :: GenericTvbs -> Type -> Q Type
repFieldArg :: GenericTvbs -> Type -> Q Type
repFieldArg Gen0{} (Type -> Type
dustOff -> Type
t0) = Type -> Q Type
boxT Type
t0
repFieldArg (Gen1{gen1LastTvbName :: GenericTvbs -> Name
gen1LastTvbName = Name
name}) (Type -> Type
dustOff -> Type
t0) = Q Type -> Type -> Q Type
go (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Par1) Type
t0
where
go :: Q Type -> Type -> Q Type
go :: Q Type -> Type -> Q Type
go Q Type
_ ForallT{} = Q Type
forall a. Q a
rankNError
go Q Type
_ ForallVisT{} = Q Type
forall a. Q a
rankNError
go Q Type
macc (VarT Name
t) | Name
t Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name = Q Type
macc
go Q Type
macc (AppT Type
f Type
x) = do
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Type
f Type -> Name -> Bool
`ground` Name
name)) Q ()
forall a. Q a
outOfPlaceTyVarError
let
macc' :: Q Type
macc' = do
Bool
itf <- Type -> Q Bool
isUnsaturatedType Type
f
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
itf Q ()
forall a. Q a
typeFamilyApplicationError
Q Type -> Name -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> Name -> m Type -> m Type
infixT Q Type
macc ''(:.:) (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
f)
Q Type -> Type -> Q Type
go Q Type
macc' (Type -> Type
dustOff Type
x)
go Q Type
_ Type
_ = Type -> Q Type
boxT Type
t0
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 ''Rec0 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
mkFrom :: GenericTvbs -> [ConstructorInfo] -> Q Match
mkFrom :: GenericTvbs -> [ConstructorInfo] -> Q Match
mkFrom GenericTvbs
gt [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
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
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'M1 Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
tweakedCaseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) [Q Match]
cases)
[]
where
cases :: [Q Match]
cases = (Int -> ConstructorInfo -> Q Match)
-> [Int] -> [ConstructorInfo] -> [Q Match]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericTvbs
-> (Q Exp -> Q Exp) -> Int -> Int -> ConstructorInfo -> Q Match
fromCon GenericTvbs
gt Q Exp -> Q Exp
forall a. a -> a
id ([ConstructorInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cs)) [Int
1..] [ConstructorInfo]
cs
mkTo :: GenericTvbs -> [ConstructorInfo] -> Q Match
mkTo :: GenericTvbs -> [ConstructorInfo] -> Q Match
mkTo GenericTvbs
gt [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 'M1 [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
tweakedCaseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) [Q Match]
cases)
[]
where
cases :: [Q Match]
cases = (Int -> ConstructorInfo -> Q Match)
-> [Int] -> [ConstructorInfo] -> [Q Match]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericTvbs
-> (Q Pat -> Q Pat) -> Int -> Int -> ConstructorInfo -> Q Match
toCon GenericTvbs
gt Q Pat -> Q Pat
forall a. a -> a
id ([ConstructorInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cs)) [Int
1..] [ConstructorInfo]
cs
tweakedCaseE :: Quote m => m Exp -> [m Match] -> m Exp
#if __GLASGOW_HASKELL__ >= 901
tweakedCaseE = caseE
#else
tweakedCaseE :: forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
tweakedCaseE m Exp
scrut [m Match]
branches = [m Match] -> m Exp
forall (m :: * -> *). Quote m => [m Match] -> m Exp
lamCaseE [m Match]
branches m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` m Exp
scrut
#endif
fromCon :: GenericTvbs -> (Q Exp -> Q Exp) -> Int -> Int
-> ConstructorInfo -> Q Match
fromCon :: GenericTvbs
-> (Q Exp -> Q Exp) -> Int -> Int -> ConstructorInfo -> Q Match
fromCon GenericTvbs
gt 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]
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 (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
cn ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fNames))
(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
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 'M1 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 'U1) ((Name -> Type -> Q Exp) -> [Name] -> [Type] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericTvbs -> Name -> Type -> Q Exp
fromField GenericTvbs
gt) [Name]
fNames [Type]
ts)) []
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 '(:*:) 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 :: GenericTvbs -> Name -> Type -> Q Exp
fromField :: GenericTvbs -> Name -> Type -> Q Exp
fromField GenericTvbs
gt Name
nr Type
t = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'M1 Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (GenericTvbs -> Name -> Type -> Q Exp
fromFieldWrap GenericTvbs
gt Name
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 :: GenericTvbs -> Name -> Type -> Q Exp
fromFieldWrap :: GenericTvbs -> Name -> Type -> Q Exp
fromFieldWrap GenericTvbs
_ Name
_ ForallT{} = Q Exp
forall a. Q a
rankNError
fromFieldWrap GenericTvbs
gt Name
nr (SigT Type
t Type
_) = GenericTvbs -> Name -> Type -> Q Exp
fromFieldWrap GenericTvbs
gt Name
nr Type
t
fromFieldWrap Gen0{} Name
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` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
nr
fromFieldWrap (Gen1{gen1LastTvbName :: GenericTvbs -> Name
gen1LastTvbName = Name
name}) Name
nr Type
t = Type -> Name -> Q Exp
wC Type
t Name
name 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
wC :: Type -> Name -> Q Exp
wC :: Type -> Name -> Q Exp
wC (Type -> Type
dustOff -> Type
t0) Name
name = Exp -> Type -> Q Exp
go (Name -> Exp
ConE 'Par1) Type
t0
where
go :: Exp -> Type -> Q Exp
go :: Exp -> Type -> Q Exp
go !Exp
_ ForallT{} = Q Exp
forall a. Q a
rankNError
go Exp
_ ForallVisT{} = Q Exp
forall a. Q a
rankNError
go Exp
acc (VarT Name
t) | Name
t Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name = Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
acc
go Exp
acc (AppT Type
_f Type
x) =
let
acc' :: Exp
acc' =
Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Name -> Exp
ConE 'Comp1)) (Name -> Exp
VarE '(Ins..)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
acc)
in Exp -> Type -> Q Exp
go Exp
acc' (Type -> Type
dustOff Type
x)
go Exp
_ Type
_ = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Type -> Name
boxRepName Type
t0)
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 'K1 (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
toCon :: GenericTvbs -> (Q Pat -> Q Pat) -> Int -> Int
-> ConstructorInfo -> Q Match
toCon :: GenericTvbs
-> (Q Pat -> Q Pat) -> Int -> Int -> ConstructorInfo -> Q Match
toCon GenericTvbs
gt 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 'M1
[(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 'U1 []) ((Name -> Type -> Q Pat) -> [Name] -> [Type] -> [Q Pat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (GenericTvbs -> Name -> Type -> Q Pat
toField GenericTvbs
gt) [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 -> 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
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
>=> GenericTvbs -> Name -> Type -> Q Exp
toConUnwC GenericTvbs
gt 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 '(:*:) [m Pat
x,m Pat
y]
toConUnwC :: GenericTvbs -> Name -> Type -> Q Exp
toConUnwC :: GenericTvbs -> Name -> Type -> Q Exp
toConUnwC Gen0{} Name
nr Type
_ = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
nr
toConUnwC (Gen1{gen1LastTvbName :: GenericTvbs -> Name
gen1LastTvbName = Name
name}) Name
nr Type
t = Type -> Name -> Q Exp
unwC Type
t Name
name 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
toField :: GenericTvbs -> Name -> Type -> Q Pat
toField :: GenericTvbs -> Name -> Type -> Q Pat
toField GenericTvbs
gt Name
nr Type
t = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'M1 [GenericTvbs -> Name -> Type -> Q Pat
toFieldWrap GenericTvbs
gt Name
nr Type
t]
toFieldWrap :: GenericTvbs -> Name -> Type -> Q Pat
toFieldWrap :: GenericTvbs -> Name -> Type -> Q Pat
toFieldWrap 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 -> Name -> Q Exp
unwC :: Type -> Name -> Q Exp
unwC (Type -> Type
dustOff -> Type
t0) Name
name = Exp -> Type -> Q Exp
go (Name -> Exp
VarE 'unPar1) Type
t0
where
go :: Exp -> Type -> Q Exp
go :: Exp -> Type -> Q Exp
go !Exp
_ ForallT{} = Q Exp
forall a. Q a
rankNError
go Exp
_ ForallVisT{} = Q Exp
forall a. Q a
rankNError
go Exp
acc (VarT Name
t) | Name
t Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name = Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
acc
go Exp
acc (AppT Type
_f Type
x) =
let
acc' :: Exp
acc' =
Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
acc)
(Name -> Exp
VarE '(Ins..))
(Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Name -> Exp
VarE 'unComp1))
in
Exp -> Type -> Q Exp
go Exp
acc' (Type -> Type
dustOff Type
x)
go Exp
_ Type
_ = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Type -> Name
unboxRepName Type
t0)
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 'unK1 (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
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 -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = String -> Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lrP: impossible"
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Q Pat
p
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 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 'L1 [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]
| Bool
otherwise = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP 'R1 [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 -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lrE: impossible"
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Q Exp
e
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 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 'L1 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
| Bool
otherwise = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'R1 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
unboxedRepNames :: Type -> Maybe (Name, Name, Name)
unboxedRepNames :: Type -> Maybe (Name, Name, Name)
unboxedRepNames Type
ty
| Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''Addr# = (Name, Name, Name) -> Maybe (Name, Name, Name)
forall a. a -> Maybe a
Just (''UAddr, 'UAddr, 'uAddr#)
| Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''Char# = (Name, Name, Name) -> Maybe (Name, Name, Name)
forall a. a -> Maybe a
Just (''UChar, 'UChar, 'uChar#)
| Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''Double# = (Name, Name, Name) -> Maybe (Name, Name, Name)
forall a. a -> Maybe a
Just (''UDouble, 'UDouble, 'uDouble#)
| Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''Float# = (Name, Name, Name) -> Maybe (Name, Name, Name)
forall a. a -> Maybe a
Just (''UFloat, 'UFloat, 'uFloat#)
| Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''Int# = (Name, Name, Name) -> Maybe (Name, Name, Name)
forall a. a -> Maybe a
Just (''UInt, 'UInt, 'uInt#)
| Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
ConT ''Word# = (Name, Name, Name) -> Maybe (Name, Name, Name)
forall a. a -> Maybe a
Just (''UWord, 'UWord, 'uWord#)
| Bool
otherwise = Maybe (Name, Name, Name)
forall a. Maybe a
Nothing
buildTypeInstance :: GenericClass
-> Name
-> [Type]
-> Q (Type, Kind)
buildTypeInstance :: GenericClass -> Name -> [Type] -> Q (Type, Type)
buildTypeInstance GenericClass
gClass 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
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
remainingLength Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ Name -> Q ()
forall a. Name -> Q a
derivingKindError Name
tyConName
let varTysExpSubst :: [Type]
varTysExpSubst :: [Type]
varTysExpSubst = [Type]
varTysExp
let remainingTysExpSubst, droppedTysExpSubst :: [Type]
([Type]
remainingTysExpSubst, [Type]
droppedTysExpSubst) =
Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
remainingLength [Type]
varTysExpSubst
let
remainingTysOrigSubst, droppedTysOrigSubst :: [Type]
([Type]
remainingTysOrigSubst, [Type]
droppedTysOrigSubst) =
Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
remainingLength [Type]
varTysOrig
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
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Type] -> [Type] -> Bool
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)