deepseq-th 0.0.0.0 → 0.1.0.0

raw patch · 2 files changed

+117/−27 lines, 2 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Control/DeepSeq/TH.hs +112/−22
• deepseq-th.cabal +5/−5

@@ -1,9 +1,19 @@ {-# LANGUAGE TemplateHaskell #-} +-- |Module providing Template Haskell based 'NFData' instance+-- generators and WHNF=NF type inspectors.+--+-- To use this module enable the @TemplateHaskell@ extension and+-- import "Control.DeepSeq.TH":+--+-- > {-# LANGUAGE TemplateHaskell #-}+-- > import Control.DeepSeq.TH+-- module Control.DeepSeq.TH     ( deriveNFData     , deriveNFDatas-    , whnfIsNf+    , typeWhnfIsNf+    , decWhnfIsNf     ) where  import Control.DeepSeq     (NFData(rnf),deepseq)@@ -12,26 +22,86 @@ import Data.Maybe          (fromMaybe, isJust, catMaybes) import Language.Haskell.TH --- |Try to infer whether type has the property that WHNF=NF for its+-- |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+-- This function has currently a rather limited knowledge and returns+-- @Nothing@ most of the time except for some primitive types and+-- other simple cases.+--+-- See also 'decWhnfIsNf'+typeWhnfIsNf :: Type -> Q (Maybe Bool)+typeWhnfIsNf = typeWhnfIsNf2 [] --- Wrapper for 'whnfIsNf' defaulting to 'False'-whnfIsNf' :: Type -> Bool-whnfIsNf' = fromMaybe False . whnfIsNf+typeWhnfIsNf2 :: [Name] -> Type -> Q (Maybe Bool)+typeWhnfIsNf2 seen (ConT x)+    | x `elem` [''Int, ''Double, ''Float, ''Char, ''Bool, ''()] = return $ Just True+    | x `elem` seen = return $ Just True  -- FIXME: check whether this correct+                      -- e.g. it might break with parametrized types (which we don't handle yet anyway)+    | otherwise = do+        t <- reify x+        case t of+            TyConI dec -> decWhnfIsNf2 (x:seen) dec+            _          -> return Nothing +typeWhnfIsNf2 _ (AppT (AppT ArrowT _) _) = return $ Just True -- a -> b+typeWhnfIsNf2 _ (AppT ListT _)           = return $ Just False -- [a]+typeWhnfIsNf2 _ (AppT (TupleT _) _)      = return $ Just False -- (a,b,...)+typeWhnfIsNf2 _ _                        = return  Nothing++-- |Try to infer whether a 'Dec' which defines a type which has the+-- property that WHNF=NF for its values. This property is derived+-- statically via the following simple rules:+--+--  * @newtype@s are WHNF=NF if the wrapped type is WHNF=NF+--+--  * @type@s are WHNF=NF if the aliased type is WHNF=NF+--+--  * Types defined by @data@ are WHNF=NF if all constructors contain+--    only strict fields with WHNF=NF types+--+-- Known limitations:+--+--  * Doesn't work properly with parametrized declarations (in which+--    case @Nothing@ is returned) or existential types+--+-- See also 'typeWhnfIsNf'+decWhnfIsNf :: Dec -> Q (Maybe Bool)+decWhnfIsNf = decWhnfIsNf2 []++decWhnfIsNf2 :: [Name] -> Dec -> Q (Maybe Bool)+decWhnfIsNf2 seen (NewtypeD _ _ _ (NormalC _ [(NotStrict, t)]) _) = typeWhnfIsNf2 seen t+decWhnfIsNf2 seen (NewtypeD _ _ _ (RecC  _ [(_,NotStrict, t)]) _) = typeWhnfIsNf2 seen t+decWhnfIsNf2 seen (TySynD _ _ t)                                  = typeWhnfIsNf2 seen t+decWhnfIsNf2 _    (DataD _ _ _ [] _)                              = return Nothing+decWhnfIsNf2 seen (DataD _ _ _ cons _)                            = reduce `liftM` mapM conWhnfIsNf cons+  where+    conWhnfIsNf :: Con -> Q (Maybe Bool)+    conWhnfIsNf con+        | allStrict  = do+            ms <- mapM (typeWhnfIsNf2 seen) fTypes+            return $ reduce ms+        | otherwise  = return $ Just False+      where+        allStrict = all (== IsStrict) fStricts+        (fStricts, fTypes) = unzip $ con2types con++    con2types (NormalC _ ts)   = ts+    con2types (RecC _ vts)     = [ (tst,tt) | (_,tst,tt) <- vts ]+    con2types (InfixC tl _ tr) = [tl,tr]+    con2types (ForallC {})     = [] -- FIXME++    reduce :: [Maybe Bool] -> Maybe Bool+    reduce ms | all (==Just True)  ms  = Just True+              | any (==Just False) ms  = Just False+              | otherwise              = Nothing++decWhnfIsNf2 _    _                                               = return Nothing+ -- | Derive 'NFData' instance for simple @Data@-declarations -- -- Example usage for deriving 'NFData' instance for the type @TypeName@:@@ -39,14 +109,19 @@ -- > $(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@:+-- types have the WHNF=NF property (see also 'typeWhnfIsNf' and+-- 'decWhnfIsNf'). For instance, consider the following types @Foo@+-- and @Bar@: -- -- > data Foo a = Foo1 -- >            | Foo2 !Int !String -- >            | Foo3 (Foo a) -- >            | Foo4 { fX :: Int, fY :: Char }+-- >            | Foo5 !Bar+-- >            | Foo6 !(String -> Int) -- >            | Foo a :--: !Bool+-- >+-- > data Bar = Bar0 | Bar1 !Char | Bar2 !Int !Int | Bar3 !Bar -- -- By invoking @$(deriveNFData ''Foo)@ the generated 'NFData' instance -- will be equivalent to:@@ -56,8 +131,15 @@ -- >     rnf (Foo2 _ x) = x `deepseq` () -- >     rnf (Foo3 x)   = x `deepseq` () -- >     rnf (Foo4 x y) = x `deepseq` y `deepseq` ()+-- >     rnf (Foo5 _)   = ()+-- >     rnf (Foo6 _)   = () -- >     rnf (x :--: _) = x `deepseq` () --+-- Whereas @$(deriveNFData ''Bar)@ generates the following default+-- 'NFData' instance since @Bar@ is inferred as a WHNF=NF type:+--+-- > instance NFData Bar+-- -- Known issues/limitations: -- --  * @TypeName@ must be a proper @data@ typename (use the@@ -75,15 +157,19 @@     dec <- reify tn      case dec of-        TyConI (DataD _ctx _tn tvs ctors _) -> do+        TyConI idec@(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] ]+            isWhnfEqNf <- decWhnfIsNf idec +            return $ case isWhnfEqNf of -- short-cut if data-type is strict as a whole+                Just True -> [ InstanceD ctxt (AppT (ConT ''NFData) ity) [] ] -- default NFData instance+                _         -> [ 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"@@ -112,11 +198,15 @@     -- 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)-+        ts' <- mapM hlp ts+        let vns = concatMap getFreeTyVars $ catMaybes ts'+        vars <- tys2vars ts'+        return (Clause [ConP n vars] (NormalB $ mkDeepSeqExpr [ n' | VarP n' <- vars ]) [], vns)+      where+        hlp (NotStrict, fieldType) = return $ Just fieldType+        hlp (IsStrict, fieldType) = do+            tmp <- typeWhnfIsNf fieldType+            return $ if fromMaybe False tmp then Nothing else Just fieldType  -- |Plural version of 'deriveNFData' --

@@ -1,15 +1,15 @@ name:         deepseq-th-version:      0.0.0.0+version:      0.1.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+synopsis:     Template Haskell based deriver for optimised 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.+    This package provides a Template Haskell based mechanism for+    deriving optimised NFData instances for custom data types. See+    documentation in "Control.DeepSeq.TH" for more information.     . build-type:     Simple cabal-version:  >=1.10