deepseq-th (empty) → 0.0.0.0

raw patch · 4 files changed

+214/−0 lines, 4 filesdep +basedep +deepseqdep +template-haskellsetup-changed

Dependencies added: base, deepseq, template-haskell

Files

• Control/DeepSeq/TH.hs +148/−0
• LICENSE +30/−0
• Setup.hs +6/−0
• deepseq-th.cabal +30/−0

@@ -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

@@ -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 <COPYRIGHT+HOLDER> 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.

@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain

@@ -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+}