deepseq-bounded-0.5.0: src/Control/DeepSeq/Bounded/Generics/GNFDataN.hs
-------------------------------------------------------------------------------
{- LANGUAGE CPP #-}
#define USE_TRACE 1
-------------------------------------------------------------------------------
#if USE_SOP
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GADTs #-} -- for GHC 7.6.3
#else
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{- LANGUAGE MultiParamTypeClasses #-}
{- LANGUAGE Rank2Types #-}
#endif
-------------------------------------------------------------------------------
-- |
-- Module : Control.DeepSeq.Bounded.Generics.GNFDataN
-- Copyright : (c) 2014, Andrew G. Seniuk
-- License : BSD-style (see the LICENSE file)
--
-- Maintainer : Andrew Seniuk <rasfar@gmail.com>
-- Stability : provisional
-- Portability : GHC
--
-- Support for generic deriving (via "Generics.SOP") of 'NFDataN' instances.
--
-- 'NFDataN' does not have any superclasses.
--
-- It is also possible to derive instances using 'GHC.Generics', which
-- avoids SOP and TH, but if you plan to use 'NFDataP' then SOP is required.
-- (SOP can be used without TH if necessary; the interested reader is
-- referred to SOP documentation.)
--
-- This metaboilerplate is standard for using the generic deriving
-- facilities of GHC.Generics and Generics.SOP. Consider
-- <http://hackage.haskell.org/package/seqaid seqaid> for
-- a turnkey solution.
--
-- > {-# LANGUAGE TemplateHaskell #-}
-- > {-# LANGUAGE DataKinds #-}
-- > {-# LANGUAGE TypeFamilies #-}
-- > {-# LANGUAGE DeriveGeneric #-}
-- >
-- > import Generics.SOP.TH
-- > import Control.DeepSeq.Bounded ( NFDataN(..), grnfn )
-- > import GHC.Generics ( Generic )
-- >
-- > import Control.DeepSeq.Bounded ( forcen )
-- >
-- > data TA = A1 TB TA | A2 deriving ( Generic )
-- > instance NFDataN TA where rnfn = grnfn
-- >
-- > data TB = B1 Int | B2 TA deriving ( Generic )
-- > instance NFDataN TB where rnfn = grnfn
-- >
-- > deriveGeneric ''TA
-- > deriveGeneric ''TB
-- >
-- > main = return $! forcen 3 (A1 (B2 undefined) A2)
-------------------------------------------------------------------------------
module Control.DeepSeq.Bounded.Generics.GNFDataN
#if USE_SOP
(
grnfn
#else
(
genericRnfn
-- , genericRnfnV1
#endif
#if 0
-- * "Control.DeepSeq" re-exports
, deepseq
, force
, NFData(rnf)
, ($!!)
#endif
) where
-------------------------------------------------------------------------------
import Control.DeepSeq.Bounded.NFDataN
#if USE_SOP
import Generics.SOP
--import Generics.SOP.TH -- not here, but rather in the module needing to generically derive an NFDataN instance
#else
import GHC.Generics
#endif
#if 0
-- actually can be used in the SOP implementation (and is in the
-- example in the paper as well as the API docs), not that we nec.
-- want this; but there's no n=infinity rnfn, so I don't see how
-- else to manage it... after the "collapse"...
import Control.DeepSeq ( NFData, deepseq )
--import Control.DeepSeq ( rnf ) -- actually can be used in the SOP implementation, not that we necessarily want this; but there's no n=infinity rnfn, so I don't see how else to manage it... after the "collapse"...
#if 0
import Control.DeepSeq -- needed?
#endif
#endif
import Debug.Trace ( trace )
-------------------------------------------------------------------------------
#if USE_SOP
#if 1
grnfn :: (Generic a, All2 NFDataN (Code a)) => Int -> a -> ()
grnfn n x = grnfnS n (from x)
grnfnS :: (All2 NFDataN xss) => Int -> SOP I xss -> ()
grnfnS n (SOP (Z xs)) = grnfnP (-1+n) xs
grnfnS n (SOP (S xss)) = grnfnS n (SOP xss)
grnfnP :: (All NFDataN xs) => Int -> NP I xs -> ()
grnfnP n Nil = ()
grnfnP n (I x :* xs)
| n <= 0 = ()
| otherwise = rnfn n x `seq` grnfnP n xs
#else
-- XXX NOPE! This causes decrementing as traverse ctor args!
-- However, the above explicit recursive version works!
grnfn :: (Generic a, All2 NFDataN (Code a)) => Int -> a -> ()
-- Ah-hah!
grnfn n = rnfn n . hcollapse . hcliftA p (K . (if n <= 0 then const () else rnfn (-1+n)) . unI) . from
-- This doesn't help:
--grnfn n = let n_ = (-1+n) in
-- rnfn n . hcollapse . hcliftA p (K . rnfn n_ . unI) . from
-- So this is the closest I have so far, but it's broken b/c it
-- seems to add to the requisite depth, the index of the (leftmost?)
-- sibling bearing "undefined".
--grnfn n = rnfn n . hcollapse . hcliftA p (K . rnfn (-1+n) . unI) . from
-- This just delays everything by one more.
--grnfn n = rnfn (-1+n) . hcollapse . hcliftA p (K . rnfn (-1+n) . unI) . from
-- I don't think this was my problem anyhow, as arities aren't
-- high enough to expect it to affect depth of n [??...]
-- (And it doesn't work anyhow -- way too much stuff gets forced!)
--grnfn n = rnf . hcollapse . hcliftA p (K . rnfn (-1+n) . unI) . from
where p = Proxy :: Proxy NFDataN
-- From the SOP paper:
-- grnfn :: (Generic a, All2 NFDataN (Code a)) => a -> ()
-- grnfn = rnfn . hcollapse . hcliftA p (K . rnf . unI) . from
-- where p = Proxy :: Proxy NFDataN
-- "We can understand this function by tracking the types. First
-- we use from to translate from a to the generic representation
-- SOP I (Code a). We then map rnf (modulo newtype wrapping and
-- unwrapping) across this sum of products to get a value of type
-- SOP (K ()) (Code a), which we can collapse to a list of type [()].
-- Finally, we can reduce that list to a single unit value through one
-- more application of rnf. We use All2 in the type of grnf to require
-- that the types of the leaves must all satisfy NFData."
#endif
-------------------------------------------------------------------------------
#else
genericRnfn :: (Generic a, GNFDataN (Rep a)) => Int -> a -> ()
genericRnfn n = grnfn_ n . from
--genericRnfn n = grnfn_ (-1+n) . from
{-# INLINE genericRnfn #-}
-- Hidden internal type-class
--
-- Note: the 'V1' instance is not provided for 'GNFDataN' in order to
-- trigger a compile-time error; see 'GNFDataNV1' which defers this to
-- a runtime error.
class GNFDataN f where
grnfn_ :: Int -> f a -> ()
#if 1 || USE_TRACE
grnfn_ n x = trace "HH-0" $ () -- never seen, so far...
#else
grnfn_ n x = ()
#endif
-- grnfn_ n x = rnfn n $ to x
-- grnfn_ n x = rnfn n x
instance GNFDataN U1 where
#if USE_TRACE
grnfn_ _ !U1 = trace "HH-U1" $ ()
#else
grnfn_ _ !U1 = ()
#endif
{-# INLINE grnfn_ #-}
instance NFDataN a => GNFDataN (K1 i a) where
#if USE_TRACE
#if 1
grnfn_ n k@(K1 x) | n <= 0 = trace "()-K1" $ ()
-- | otherwise = trace "HH-K1" $ k `seq` rnfn (-1+n) x
-- | otherwise = trace "HH-K1" $ x `seq` rnfn (-1+n) x
| otherwise = trace "HH-K1" $ rnfn (-1+n) x
#else
grnfn_ n | n <= 0 = const ()
| otherwise = trace "HH-2" $ rnfn (-1+n) . unK1
#endif
#else
grnfn_ n (K1 x) | n <= 0 = ()
| otherwise = rnfn (-1+n) x
#endif
{-# INLINE grnfn_ #-}
instance GNFDataN a => GNFDataN (M1 i c a) where
#if USE_TRACE
#if 0
#elif 1
grnfn_ n (M1 x) | n <= 0 = trace "()-M1" $ () -- prob. unnec.
| otherwise = trace "HH-M1" $ grnfn_ n x
#elif 0
grnfn_ n (M1 x) | n <= 0 = trace "()-M1" $ ()
| otherwise = trace "HH-M1" $ grnfn_ (-1+n) x
#elif 0
grnfn_ n | n <= 0 = const ()
| otherwise = trace "HH-3" $ grnfn_ (-1+n) . unM1
#endif
#else
grnfn_ n (M1 x) | n <= 0 = () -- prob. unnec.
| otherwise = grnfn_ n x
#endif
{-# INLINE grnfn_ #-}
instance (GNFDataN a, GNFDataN b) => GNFDataN (a :*: b) where
#if USE_TRACE
#if 0
#elif 1
grnfn_ n (x :*: y) | n <= 0 = trace "()-:*:" $ () -- prob. unnec.
| otherwise = trace "HH-:*:" $ let n' = n in grnfn_ n' x `seq` grnfn_ n' y
#elif 0
grnfn_ n (x :*: y) | n <= 0 = trace "()-:*:" $ ()
| otherwise = trace "HH-:*:" $ let n' = -1+n in grnfn_ n' x `seq` grnfn_ n' y
#elif 0
grnfn_ n (x :*: y) | n <= 0 = ()
| otherwise = trace "HH-4" $ let n' = -1+n in grnfn_ n' x `seq` grnfn_ n' y
#endif
#else
grnfn_ n (x :*: y) | n <= 0 = () -- prob. unnec.
| otherwise = let n' = n in grnfn_ n' x `seq` grnfn_ n' y
#endif
{-# INLINE grnfn_ #-}
instance (GNFDataN a, GNFDataN b) => GNFDataN (a :+: b) where
#if USE_TRACE
#if 0
#elif 1
grnfn_ n (L1 x) | n <= 0 = trace "()-L1" $ () -- prob. unnec.
| otherwise = trace "HH-L1" $ grnfn_ n x
grnfn_ n (R1 x) | n <= 0 = trace "()-L2" $ () -- prob. unnec.
| otherwise = trace "HH-L2" $ grnfn_ n x
#elif 0
grnfn_ n (L1 x) | n <= 0 = trace "()-L1" $ ()
| otherwise = trace "HH-L1" $ grnfn_ (-1+n) x
grnfn_ n (R1 x) | n <= 0 = trace "()-L2" $ ()
| otherwise = trace "HH-L2" $ grnfn_ (-1+n) x
#elif 0
grnfn_ n (L1 x) | n <= 0 = ()
| otherwise = trace "HH-5L" $ grnfn_ (-1+n) x
grnfn_ n (R1 x) | n <= 0 = ()
| otherwise = trace "HH-5R" $ grnfn_ (-1+n) x
#endif
#else
grnfn_ n (L1 x) | n <= 0 = () -- prob. unnec.
| otherwise = grnfn_ n x
grnfn_ n (R1 x) | n <= 0 = () -- prob. unnec.
| otherwise = grnfn_ n x
#endif
{-# INLINE grnfn_ #-}
#endif
-------------------------------------------------------------------------------