diff --git a/Control/DeepSeq/TH.hs b/Control/DeepSeq/TH.hs new file mode 100644 --- /dev/null +++ b/Control/DeepSeq/TH.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Control.DeepSeq.TH + ( deriveNFData + , deriveNFDatas + , whnfIsNf + ) where + +import Control.DeepSeq (NFData(rnf),deepseq) +import Control.Monad (mzero,liftM,mplus) +import Data.List +import Data.Maybe (fromMaybe, isJust, catMaybes) +import Language.Haskell.TH + +-- |Try to infer whether type has the property that WHNF=NF for its +-- values. +-- +-- A result of @Nothing@ means it is not known whether the +-- property holds for the given type. @Just True@ means that the +-- property holds. +-- +-- This function has currently a very limited knowledge and returns +-- @Nothing@ most of the time except for some primitive types. +whnfIsNf :: Type -> Maybe Bool +whnfIsNf (ConT x) + | x `elem` [''Int, ''Double, ''Float, ''Char, ''Bool, ''()] = Just True +whnfIsNf (AppT ListT _) = Just False -- [a] +whnfIsNf (AppT (TupleT _) _) = Just False -- [a] +whnfIsNf _ = Nothing + +-- Wrapper for 'whnfIsNf' defaulting to 'False' +whnfIsNf' :: Type -> Bool +whnfIsNf' = fromMaybe False . whnfIsNf + +-- | Derive 'NFData' instance for simple @Data@-declarations +-- +-- Example usage for deriving 'NFData' instance for the type @TypeName@: +-- +-- > $(deriveNFData ''TypeName) +-- +-- The derivation tries to avoid evaluation of strict fields whose +-- types have the WHNF=NF property (see also 'whnfIsNf'). For +-- instance, consider the following type @Foo@: +-- +-- > data Foo a = Foo1 +-- > | Foo2 !Int !String +-- > | Foo3 (Foo a) +-- > | Foo4 { fX :: Int, fY :: Char } +-- > | Foo a :--: !Bool +-- +-- By invoking @$(deriveNFData ''Foo)@ the generated 'NFData' instance +-- will be equivalent to: +-- +-- > instance NFData a => NFData (Foo a) where +-- > rnf Foo1 = () +-- > rnf (Foo2 _ x) = x `deepseq` () +-- > rnf (Foo3 x) = x `deepseq` () +-- > rnf (Foo4 x y) = x `deepseq` y `deepseq` () +-- > rnf (x :--: _) = x `deepseq` () +-- +-- Known issues/limitations: +-- +-- * @TypeName@ must be a proper @data@ typename (use the +-- @GeneralizedNewtypeDeriving@ extension for @newtype@ names) +-- +-- * Does not support existential types yet (i.e. use of the @forall@ +-- keyword) +-- +-- * Does not always detect phantom type variables (e.g. for @data +-- Foo a = Foo0 | Foo1 (Foo a)@) which causes those to require +-- 'NFData' instances. +-- +deriveNFData :: Name -> Q [Dec] +deriveNFData tn = do + dec <- reify tn + + case dec of + TyConI (DataD _ctx _tn tvs ctors _) -> do + clauses_names <- mapM con2rnf ctors + let clauses = map fst clauses_names + names = nub $ concat $ map snd clauses_names + ctxt = [ClassP ''NFData [VarT n] | n <- names ] + let ity = foldl (\t tvn -> AppT t (VarT tvn)) (ConT tn) $ map tyvarname tvs + + return [ InstanceD ctxt (AppT (ConT ''NFData) ity) [FunD 'rnf clauses] ] + + TyConI (NewtypeD {}) -> do + fail $ "deriveNFData ''" ++ show tn ++ ": please use GeneralizedNewtypeDeriving " ++ + "for deriving NFData instances for newtype" + + TyConI (TySynD {}) -> do + fail $ "deriveNFData ''" ++ show tn ++ ": cannot derive for type-alias" + + TyConI _ -> do + fail $ "deriveNFData ''" ++ show tn ++ ": argument must be a proper 'data'-type" + + _ -> do + fail $ "deriveNFData ''" ++ show tn ++ ": argument must be a type-level entity" + + where + tyvarname (PlainTV n) = n + tyvarname (KindedTV n _) = n + + tys2vars = mapM (\t -> if isJust t then liftM VarP (newName "x") else return WildP) + + con2rnf :: Con -> Q (Clause, [Name]) + con2rnf (NormalC n ts) = genCon2Rnf n ts + con2rnf (RecC n vts) = genCon2Rnf n [ (tst,tt) | (_,tst,tt) <- vts ] + con2rnf (InfixC tl n tr) = genCon2Rnf n [tl,tr] + con2rnf (ForallC {}) = fail "deriveNFData: 'forall' not supported in constructor declaration" + + -- generic per-constructor function generator + genCon2Rnf :: Name -> [(Strict,Type)] -> Q (Clause, [Name]) + genCon2Rnf n ts = do + let vns = concatMap getFreeTyVars $ catMaybes ts' + ts' = [ if tst == NotStrict || not (whnfIsNf' tt) then Just tt else Nothing | (tst,tt) <- ts ] + vars <- tys2vars ts' + return (Clause [ConP n vars] (NormalB $ mkDeepSeqExpr [ n' | VarP n' <- vars ]) [], vns) + + +-- |Plural version of 'deriveNFData' +-- +-- Convenience wrapper for 'deriveNFData' which allows to derive +-- multiple 'NFData' instances for a list of @TypeName@s, e.g.: +-- +-- > $(deriveNFData [''TypeName1, ''TypeName2, ''TypeName3]) +-- +deriveNFDatas :: [Name] -> Q [Dec] +deriveNFDatas = liftM concat . mapM deriveNFData + +-- FIXME: there should be a ready-to-use TH function which does this already +getFreeTyVars :: Type -> [Name] +getFreeTyVars (AppT t1 t2) = getFreeTyVars t1 `mplus` getFreeTyVars t2 +getFreeTyVars (ArrowT) = mzero +getFreeTyVars (ConT _) = mzero +getFreeTyVars (ForallT {}) = error "getFreeTyVars: ForallT not supported yet" +getFreeTyVars (ListT) = mzero +getFreeTyVars (SigT t1 _) = getFreeTyVars t1 +getFreeTyVars (TupleT _) = mzero +getFreeTyVars (UnboxedTupleT _) = mzero +getFreeTyVars (VarT n) = return n + +-- helper +mkDeepSeqExpr :: [Name] -> Exp +mkDeepSeqExpr = foldr deepSeqE (ConE '()) + where + deepSeqE :: Name -> Exp -> Exp + deepSeqE lhs rhs = AppE (AppE (VarE 'deepseq) (VarE lhs)) rhs diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2011, Herbert Valerio Riedel +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/deepseq-th.cabal b/deepseq-th.cabal new file mode 100644 --- /dev/null +++ b/deepseq-th.cabal @@ -0,0 +1,30 @@ +name: deepseq-th +version: 0.0.0.0 +license: BSD3 +license-file: LICENSE +maintainer: hvr@gnu.org +bug-reports: https://github.com/hvr/hs-deepseq-th/issues +synopsis: Provides Template Haskell deriver for NFData instances +category: Control +description: + Provides a Template Haskell based mechanism for deriving NFData + instances for custom data types. See documentation in + "Control.DeepSeq.TH" for more information. + . +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC>=7.2.1 + +source-repository head + type: git + location: http://github.com/hvr/hs-deepseq-th.git + +library { + default-language: Haskell2010 + exposed-modules: Control.DeepSeq.TH + build-depends: + base >= 4.4 && < 4.5, + deepseq >= 1.1 && < 1.2, + template-haskell >= 2.6 && < 2.7 + ghc-options: -Wall +}