{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Comp.Derive.DeepSeq
-- Copyright   :  (c) 2011 Patrick Bahr
-- License     :  BSD3
-- Maintainer  :  Patrick Bahr <paba@diku.dk>
-- Stability   :  experimental
-- Portability :  non-portable (GHC Extensions)
--
-- Automatically derive instances of @DeepSeq@.
--
--------------------------------------------------------------------------------

module Data.Comp.Derive.DeepSeq
    (
     NFDataF(..),
     makeNFDataF
    ) where


import Control.DeepSeq
import Data.Comp.Derive.Utils
import Language.Haskell.TH

{-| Signature normal form. An instance @NFDataF f@ gives rise to an instance
  @NFData (Term f)@. -}
class NFDataF f where
    rnfF :: NFData a => f a -> ()

{-| Derive an instance of 'NFDataF' for a type constructor of any first-order
  kind taking at least one argument. -}
makeNFDataF :: Name -> Q [Dec]
makeNFDataF :: Name -> Q [Dec]
makeNFDataF Name
fname = do
  Just (DataInfo Cxt
_cxt Name
name [TyVarBndr flag]
args [Con]
constrs [DerivClause]
_deriving) <- Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
  let argNames :: Cxt
argNames = forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {flag}. TyVarBndr flag -> Name
tyVarBndrName) (forall a. [a] -> [a]
init [TyVarBndr flag]
args)
      complType :: Type
complType = 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 = forall a b. (a -> b) -> [a] -> [b]
map (Name -> Cxt -> Type
mkClassP ''NFData forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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' <- 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 <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'rnfF (forall {a} {c}. [(Name, [a], c)] -> [Q Clause]
rnfFClauses [(Name, Cxt, Maybe Type)]
constrs')
  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)] -> [Q Clause]
rnfFClauses = forall a b. (a -> b) -> [a] -> [b]
map forall {t :: * -> *} {a} {c}.
Foldable t =>
(Name, t a, c) -> Q Clause
genRnfFClause
            genRnfFClause :: (Name, t a, c) -> Q Clause
genRnfFClause (Name
constr, t a
args,c
_) = do
              let n :: Int
n = 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 -> Cxt -> [Pat] -> Pat
ConP Name
constr [] forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varNs
                  allVars :: [Q Exp]
allVars = forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
varNs
              Exp
body <- forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ Q Exp
x Q Exp
y -> [|rnf $x `seq` $y|]) [| () |] [Q Exp]
allVars
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] (Exp -> Body
NormalB Exp
body) []