content: {-# 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 fname = do
    Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
    let argNames = map (VarT . tyVarBndrName) (init args)
        complType = foldl AppT (ConT name) argNames
        preCond = map (mkClassP ''NFData . (: [])) argNames
        classType = AppT (ConT ''NFDataF) complType
    constrs' <- mapM normalConExp constrs
    rnfFDecl <- funD 'rnfF (rnfFClauses constrs')
    return [mkInstanceD preCond classType [rnfFDecl]]
        where rnfFClauses = map genRnfFClause
              genRnfFClause (constr, args,_) = do
                let n = length args
                varNs <- newNames n "x"
                let pat = ConP constr [] $ map VarP varNs
                    allVars = map varE varNs
                body <- foldr (\ x y -> [|rnf $x `seq` $y|]) [| () |] allVars
                return $ Clause [pat] (NormalB body) []
  