{-# LANGUAGE TemplateHaskell #-}
module Data.Comp.Derive.DeepSeq
(
NFDataF(..),
makeNFDataF
) where
import Control.DeepSeq
import Data.Comp.Derive.Utils
import Language.Haskell.TH
class NFDataF f where
rnfF :: NFData a => f a -> ()
makeNFDataF :: Name -> Q [Dec]
makeNFDataF :: Name -> Q [Dec]
makeNFDataF Name
fname = do
Just (DataInfo Cxt
_cxt Name
name [TyVarBndr]
args [Con]
constrs [DerivClause]
_deriving) <- Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ (Q Info -> Q (Maybe DataInfo)) -> Q Info -> Q (Maybe DataInfo)
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
let argNames :: Cxt
argNames = (TyVarBndr -> Type) -> [TyVarBndr] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT (Name -> Type) -> (TyVarBndr -> Name) -> TyVarBndr -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Name
tyVarBndrName) ([TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a]
init [TyVarBndr]
args)
complType :: Type
complType = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) Cxt
argNames
preCond :: Cxt
preCond = (Type -> Type) -> Cxt -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Cxt -> Type
mkClassP ''NFData (Cxt -> Type) -> (Type -> Cxt) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Cxt -> Cxt
forall a. a -> [a] -> [a]
: [])) Cxt
argNames
classType :: Type
classType = Type -> Type -> Type
AppT (Name -> Type
ConT ''NFDataF) Type
complType
[(Name, Cxt, Maybe Type)]
constrs' <- (Con -> Q (Name, Cxt, Maybe Type))
-> [Con] -> Q [(Name, Cxt, Maybe Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> Q (Name, Cxt, Maybe Type)
normalConExp [Con]
constrs
Dec
rnfFDecl <- Name -> [ClauseQ] -> DecQ
funD 'rnfF ([(Name, Cxt, Maybe Type)] -> [ClauseQ]
forall a c. [(Name, [a], c)] -> [ClauseQ]
rnfFClauses [(Name, Cxt, Maybe Type)]
constrs')
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Cxt -> Type -> [Dec] -> Dec
mkInstanceD Cxt
preCond Type
classType [Dec
rnfFDecl]]
where rnfFClauses :: [(Name, [a], c)] -> [ClauseQ]
rnfFClauses = ((Name, [a], c) -> ClauseQ) -> [(Name, [a], c)] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [a], c) -> ClauseQ
forall (t :: * -> *) a c. Foldable t => (Name, t a, c) -> ClauseQ
genRnfFClause
genRnfFClause :: (Name, t a, c) -> ClauseQ
genRnfFClause (Name
constr, t a
args,c
_) = do
let n :: Int
n = t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
args
[Name]
varNs <- Int -> String -> Q [Name]
newNames Int
n String
"x"
let pat :: Pat
pat = Name -> [Pat] -> Pat
ConP Name
constr ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varNs
allVars :: [ExpQ]
allVars = (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
varNs
Exp
body <- (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ ExpQ
x ExpQ
y -> [|rnf $x `seq` $y|]) [| () |] [ExpQ]
allVars
Clause -> ClauseQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> ClauseQ) -> Clause -> ClauseQ
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] (Exp -> Body
NormalB Exp
body) []