deepseq-bounded-0.5.0: src/Control/DeepSeq/Bounded/NFDataPDyn.hs
-------------------------------------------------------------------------------
{- LANGUAGE CPP #-}
#define DO_TRACE 0
#define WARN_IGNORED_SUBPATTERNS 1
#define NEVER_IGNORE_SUBPATTERNS 0
-- Now specified via --flag=[-]USE_WWW_DEEPSEQ
--- #define USE_WW_DEEPSEQ 1
-------------------------------------------------------------------------------
#if USE_SOP
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-} -- for GHC 7.6.3
#endif
{-# LANGUAGE Rank2Types #-}
{- LANGUAGE ScopedTypeVariables #-}
-- For tracing only:
{- LANGUAGE BangPatterns #-}
-------------------------------------------------------------------------------
-- |
-- Module : Control.DeepSeq.Bounded.NFDataPDyn
-- Copyright : (c) 2014, Andrew G. Seniuk
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : Andrew Seniuk <rasfar@gmail.com>
-- Stability : experimental
-- Portability : GHC
--
-------------------------------------------------------------------------------
module Control.DeepSeq.Bounded.NFDataPDyn
(
-- * Dynamic pattern-directed forcing
-- | These functions are concerned with extending the forcing pattern
-- dynamically, depending on the types of the nodes encountered while
-- generically traversing a term.
--
-- (Work in progress...).
rnfpDyn
, deepseqpDyn
, forcepDyn
, rnfpDyn'
, deepseqpDyn'
, forcepDyn'
, rnfpDyn''
, deepseqpDyn''
, forcepDyn''
-- * Re-exported for convenience
, module Control.DeepSeq.Bounded.NFDataP
)
where
-------------------------------------------------------------------------------
import Control.DeepSeq.Bounded.NFDataP
import Control.DeepSeq.Bounded.NFDataN -- finally used ("*3" etc.)
#if USE_WW_DEEPSEQ
import Control.DeepSeq ( NFData )
--import Control.DeepSeq ( rnf )
#endif
import Data.Data ( Data )
#if 1
import Data.Typeable ( Typeable )
import Data.Typeable ( typeOf )
#else
-- XXX These are NOT interchangeable!
#if __GLASGOW_HASKELL__ >= 781
import Data.Typeable ( typeRep )
#else
import Data.Typeable ( typeOf )
#endif
#endif
import Debug.Trace ( trace )
#if USE_SOP
import Generics.SOP hiding ( Shape )
#endif
-------------------------------------------------------------------------------
#if DO_TRACE
mytrace = trace
#else
mytrace _ = id
#endif
-------------------------------------------------------------------------------
-- | SOP/SYB hybrid dynamic 'deepseqp'.
deepseqpDyn :: (Show a, NFDataP a, Generic a, Data a
, All2 Show (Code a)
, All2 NFData (Code a)
, All2 NFDataN (Code a)
, All2 NFDataP (Code a)
, All2 Data (Code a)
) => (forall c. Data c => c -> PatNode) -> a -> b -> b
deepseqpDyn fg a b = rnfpDyn fg a `seq` b
-- XXX Partially-applied; is that okay in GHC RULES?
{- RULES
"deepseqpDyn/composition" forall fg1 fg2 x. (.) (deepseqpDyn fg2) (deepseqpDyn fg1) x = deepseqpDyn (gcombQ fg1 fg2) x
#-}
-- | SOP/Typeable hybrid dynamic 'deepseqp'.
deepseqpDyn'' :: (Show a, NFDataP a, Generic a, Data a
, All2 Show (Code a)
, All2 NFData (Code a)
, All2 NFDataN (Code a)
, All2 NFDataP (Code a)
-- , All2 Data (Code a)
) => (forall c. Typeable c => c -> PatNode) -> a -> b -> b
deepseqpDyn'' fg a b = rnfpDyn'' fg a `seq` b
-- XXX Partially-applied; is that okay in GHC RULES?
{- RULES
"deepseqpDyn''/composition" forall fg1 fg2 x. (.) (deepseqpDyn'' fg2) (deepseqpDyn'' fg1) x = deepseqpDyn'' (gcombQ fg1 fg2) x
#-}
-- | SOP-only dynamic 'deepseqp'.
deepseqpDyn' :: (Show a, NFDataP a, Generic a, Data a
, All2 Generic (Code a)
, All2 Show (Code a)
, All2 NFData (Code a)
, All2 NFDataN (Code a)
, All2 NFDataP (Code a)
) => (forall c. Generic c => c -> PatNode) -> a -> b -> b
deepseqpDyn' fg a b = rnfpDyn' fg a `seq` b
-------------------------------------------------------------------------------
-- | SOP/SYB hybrid dynamic 'forcep'.
forcepDyn :: (Show a, NFDataP a, Generic a, Data a
, All2 Show (Code a)
, All2 NFData (Code a)
, All2 NFDataN (Code a)
, All2 NFDataP (Code a)
, All2 Data (Code a)
) => (forall c. Data c => c -> PatNode) -> a -> a
forcepDyn fg x = deepseqpDyn fg x x
{- RULES
"forcepDyn/composition" forall fg1 fg2 x. (.) (forcepDyn fg2) (forcepDyn fg1) x = forcepDyn (gcombQ fg1 fg2) x
#-}
-- | SOP/Typeable hybrid dynamic 'forcep'.
forcepDyn'' :: (Show a, NFDataP a, Generic a, Data a
, All2 Show (Code a)
, All2 NFData (Code a)
, All2 NFDataN (Code a)
, All2 NFDataP (Code a)
-- , All2 Data (Code a)
) => (forall c. Typeable c => c -> PatNode) -> a -> a
forcepDyn'' fg x = deepseqpDyn'' fg x x
{- RULES
"forcepDyn''/composition" forall fg1 fg2 x. (.) (forcepDyn'' fg2) (forcepDyn'' fg1) x = forcepDyn'' (gcombQ fg1 fg2) x
#-}
-- | SOP-only dynamic 'forcep'.
forcepDyn' :: (Show a, NFDataP a, Generic a, Data a
, All2 Generic (Code a)
, All2 Show (Code a)
, All2 NFData (Code a)
, All2 NFDataN (Code a)
, All2 NFDataP (Code a)
) => (forall c. Generic c => c -> PatNode) -> a -> a
forcepDyn' fg x = deepseqpDyn' fg x x
-------------------------------------------------------------------------------
#if USE_SOP
-------------------------------------------------------------------------------
#if 1
-------------------------------------------------------------------------------
-- This one, trying for a SOP (not SYB) based generic stop function arg.
-- This should be straightforward. We have adequate precedent in GNFDataP.
-- | SOP-only dynamic 'rnfp'.
-- Takes an SOP generic function yielding 'PatNode', which extends
-- the pattern dynamically, depending on the type of the value node.
rnfpDyn' :: forall a. (
Generic a
, All2 Generic (Code a)
, All2 Show (Code a)
, All2 NFData (Code a)
, All2 NFDataN (Code a)
, All2 NFDataP (Code a)
-- , NFData a
-- , NFDataN a
-- , NFDataP a
) =>
( forall c. (
Generic c
-- , All2 Show (Code c)
) => c -> PatNode
)
-> a
-> ()
rnfpDyn' fg d = rnfpDynS' fg (from d)
rnfpDynS' :: forall xss. (
All2 Generic xss
, All2 Show xss
, All2 NFData xss
, All2 NFDataN xss
, All2 NFDataP xss
-- , NFData xss
-- , NFDataN xss
-- , NFDataP xss
) =>
( forall c. (
Generic c
-- , All2 Show (Code c)
) => c -> PatNode
)
-> SOP I xss
-> ()
rnfpDynS' fg (SOP (Z xs)) = rnfpDynP' fg xs
rnfpDynS' fg (SOP (S xss)) = rnfpDynS' fg (SOP xss)
rnfpDynP' :: forall xs. (
All Generic xs
, All Show xs
, All NFData xs
, All NFDataN xs
, All NFDataP xs
-- , NFData xs
-- , NFDataN xs
-- , NFDataP xs
) =>
( forall c. (
Generic c
-- , All2 Show (Code c)
) => c -> PatNode
)
-> NP I xs
-> ()
rnfpDynP' fg Nil = ()
rnfpDynP' fg (I x :* xs)
| trace (show $ typeOf x) False = undefined
| WI <- pn = trace ("Boo A " ) $ rnfpDynP' fg xs `seq` ()
| otherwise = trace ("Boo B "++show x) $ rnfpDynP' fg xs `seq` x `seq` ()
where
-- pn = WR
pn = fg x {-:: PatNode-}
pat = Node pn [] {-:: Pattern-}
-------------------------------------------------------------------------------
-- Trying explicit SOP recursion, since it seems then Proxy isn't needed?
-- | SOP/SYB hybrid dynamic 'rnfp'.
-- Takes a SYB 'GenericQ' 'PatNode' argument, which extends the pattern
-- dynamically, depending on the type of the value node.
---rnfpDyn :: (Generic a, All2 NFData (Code a)) => a -> ()
rnfpDyn :: forall a. (
Generic a
, All2 Show (Code a)
, All2 NFData (Code a)
, All2 NFDataN (Code a)
, All2 NFDataP (Code a)
, All2 Data (Code a)
-- , NFData a
-- , NFDataN a
-- , NFDataP a
) =>
#if 0
a
#else
( forall c. (
#if 1
Data c
#else
Generic c
-- , All2 Show (Code c)
#endif
) => c -> PatNode
)
-> a
#endif
-> ()
#if 0
rnfpDyn d = ()
#else
rnfpDyn fg d = rnfpDynS fg (from d)
--rnfpDyn fg d = ()
#endif
--rnfpDynS :: (All2 NFData xss) => SOP I xss -> ()
rnfpDynS :: forall xss. (
All2 Show xss
, All2 NFData xss
, All2 NFDataN xss
, All2 NFDataP xss
, All2 Data xss
-- , NFData xss
-- , NFDataN xss
-- , NFDataP xss
) =>
#if 0
SOP I xss
#else
( forall c. (
Data c
) => c -> PatNode
)
-> SOP I xss
#endif
-> ()
rnfpDynS fg (SOP (Z xs)) = rnfpDynP fg xs
rnfpDynS fg (SOP (S xss)) = rnfpDynS fg (SOP xss)
--rnfpDynP :: (All NFData xs) => NP I xs -> ()
rnfpDynP :: forall xs. (
All Show xs
, All NFData xs
, All NFDataN xs
, All NFDataP xs
, All Data xs
-- , NFData xs
-- , NFDataN xs
-- , NFDataP xs
) =>
#if 0
NP I xs
#else
( forall c. (
Data c
) => c -> PatNode
)
-> NP I xs
#endif
-> ()
rnfpDynP fg Nil = ()
--rnfpDynP fg (I x :* xs) = rnfpDynP fg xs `seq` x `seq` ()
rnfpDynP fg (I x :* xs)
| trace (show $ typeOf x) False = undefined
--- | trace (show $ typeOf x) $! False = undefined
#if 0
| WI <- pn = trace ("AAA "++show x) $ ()
| otherwise = trace ("BBB "++show x) $ ()
#else
| WI <- pn = trace ("AAA " ) $ rnfpDynP fg xs `seq` ()
--- | WI <- pn = trace ("AAA "++show x) $ rnfpDynP fg xs `seq` ()
--- | WI <- pn = trace ("AAA "++show x) $ ()
--- | otherwise = trace ("BBB "++show x) $ rnfpDynP fg xs `seq` rnfp pat x `seq` ()
---- | otherwise = trace ("BBB "++show x) $ rnfpDynP fg xs `seq` rnfpDyn fg x `seq` ()
| otherwise = trace ("BBB "++show x) $ rnfpDynP fg xs `seq` x `seq` ()
#endif
where
#if 0
pn = WR
#else
pn = trace (show $ fg x) $ fg x {-:: PatNode-}
-- pn = fg x {-:: PatNode-}
#endif
pat = Node pn [] {-:: Pattern-}
#if 0
proxy_a = Proxy :: Proxy a
-- proxy_a = Proxy (Proxy :: Proxy a, Proxy :: Proxy b)
#endif
--rnfpDynP (I x :* xs) = x `deepseq` (rnfpDynP xs)
-------------------------------------------------------------------------------
-- | SOP/Typeable hybrid dynamic 'rnfp'.
-- Takes a SYB 'GenericQ' 'PatNode' argument, which extends the pattern
-- dynamically, depending on the type of the value node.
rnfpDyn'' :: forall a. (
Generic a
, All2 Show (Code a)
, All2 NFData (Code a)
, All2 NFDataN (Code a)
, All2 NFDataP (Code a)
-- , All2 Data (Code a)
) =>
( forall c. (
Typeable c
) => c -> PatNode
)
-> a
-> ()
rnfpDyn'' fg d = rnfpDyn''S fg (from d)
rnfpDyn''S :: forall xss. (
All2 Show xss
, All2 NFData xss
, All2 NFDataN xss
, All2 NFDataP xss
-- , All2 Data xss
) =>
( forall c. (
Typeable c
) => c -> PatNode
)
-> SOP I xss
-> ()
rnfpDyn''S fg (SOP (Z xs)) = rnfpDyn''P fg xs
rnfpDyn''S fg (SOP (S xss)) = rnfpDyn''S fg (SOP xss)
rnfpDyn''P :: forall xs. (
All Show xs
, All NFData xs
, All NFDataN xs
, All NFDataP xs
-- , All Data xs
) =>
( forall c. (
Typeable c
) => c -> PatNode
)
-> NP I xs
-> ()
rnfpDyn''P fg Nil = ()
rnfpDyn''P fg (I x :* xs)
| trace (show $ typeOf x) False = undefined
| WI <- pn = trace ("AAA " ) $ rnfpDyn''P fg xs `seq` ()
| otherwise = trace ("BBB "++show x) $ rnfpDyn''P fg xs `seq` x `seq` ()
where
pn = trace (show $ fg x) $ fg x {-:: PatNode-}
-- pn = fg x {-:: PatNode-}
pat = Node pn [] {-:: Pattern-}
-------------------------------------------------------------------------------
#else
#if 0
Generic a
, HasDatatypeInfo a
-- , All Show (Map ConstructorInfo (Code a))
, All2 NFDataP (Code a)
, All2 Show (Code a)
, Typeable a
, NFDataN a
, NFDataP a
#endif
rnfpDyn :: forall a. (
Generic a
, All2 Show (Code a)
, All2 NFDataP (Code a)
, All2 NFData (Code a)
, NFDataP a
, NFData a
) =>
#if 1
a
#else
( forall b. (
Generic b
, All2 Show (Code b)
) => b -> PatNode
)
-> a
#endif
-> ()
--rnfpDyn fg d = ()
#if 1
rnfpDyn d
#else
rnfpDyn fg d
#endif
-- This appears to work from the bottom-up which is not
-- what's wanted ... but I must be mistaken? Well, not "must"...
-- The question is whether hcollapse makes a head available
-- without having to finish recursions completely.
#if 1
= (rnfp pat . hcollapse . hcliftA (Proxy :: Proxy a) (\ (I x) -> K (rnfpDyn x)) . from) d
-- = (rnfp pat . hcollapse . hcliftA (Proxy :: Proxy NFDataP) (\ (I x) -> K (rnfpDyn x)) . from) d
#else
= (rnfp pat . hcollapse . hcliftA (Proxy :: Proxy NFDataP) (\ (I x) -> K (rnfpDyn fg x)) . from) d
#endif
-- = (rnfp pat . hcollapse . hcliftA (Proxy :: Proxy a) (\ (I x) -> K (rnfpDyn fg x)) . from) d
-- = (rnfp pat . hcollapse . hcliftA proxy_a (\ (I x) -> K (rnfpDyn fg x)) . from) d
-- = rnfp pat x `seq` map (rnfpDyn fg) x `seq` ()
where
#if 1
pn = WR
#else
pn = fg d {-:: PatNode-}
#endif
pat = Node pn [] {-:: Pattern-}
proxy_a = Proxy :: Proxy a
-- proxy_a = Proxy (Proxy :: Proxy a, Proxy :: Proxy b)
#endif
-------------------------------------------------------------------------------
#else
-------------------------------------------------------------------------------
#if 0
-- XXX This was written to try to get rid of type errors, b/c
-- I have definitely seen SYB refuse to compile until things
-- are USED. (No joy yet.)
blah :: (Show a, NFData a, NFDataP a, Data a) => a -> ()
blah x = rnfpDynG (mkQ WI f :: GenericQ PatNode) x
where
f :: (Int,Bool) -> PatNode
f (n,b) | n < 3 || not b = WI
| otherwise = WS
#endif
-------------------------------------------------------------------------------
#if 0
-- Well Fuck.
#if 0
rnfpDynG :: (Show d,NFDataP d,NFData d,Data d) => d -> ()
--rnfpDynG :: (Typeable d,Show d,NFDataP d,NFData d,Data d) => d -> ()
--rnfpDynG :: (Typeable d,Show d,NFDataP d,NFData d) => d -> ()
--rnfpDynG :: Data d => d -> ()
rnfpDynG x = rnfpDynG' f x
where
f :: (Int,Bool) -> PatNode
f (n,b) | n < 3 || not b = WI
| otherwise = WS
rnfpDynG' :: forall e. Data e => ((Int,Bool) -> PatNode) -> e -> ()
-- rnfpDynG' :: ((Int,Bool) -> PatNode) -> d -> ()
-- rnfpDynG' :: (Show d,NFDataP d,NFData d,Data d) => ((Int,Bool) -> PatNode) -> d -> ()
rnfpDynG' f x
= (gmapQ (rnfpDynG' f) x) `seq` ()
where
pn = fg x :: PatNode
pat = Node pn [] {-:: Pattern-}
fg = mkQ WI f
-- fg = ( mkQ WI f :: d -> PatNode )
-- fg = mkQ WI ( f :: (Int,Bool) -> PatNode )
#else
-- Note that (rnfpDynG fg) is itself a GenericQ ().
rnfpDynG :: forall d. (Show d,NFDataP d,NFData d,Data d) => (forall e. (Show e,NFDataP e,NFData e,Data e) => e -> PatNode) -> d -> ()
--rnfpDynG :: forall d. (Show d,NFDataP d,NFData d,Data d) => (d -> PatNode) -> d -> ()
--rnfpDynG :: forall d. (Typeable d,Show d,NFDataP d,NFData d,Data d) => (d -> PatNode) -> d -> ()
--rnfpDynG :: forall d. (Typeable d,Show d,NFDataP d,NFData d,Data d) => (forall e. (NFDataP e,NFData e,Data e) => e -> PatNode) -> d -> ()
--rnfpDynG :: (Typeable d,Show d,NFDataP d,NFData d,Data d) => (forall e. (NFDataP e,NFData e,Data e) => e -> PatNode) -> d -> ()
--rnfpDynG :: (Typeable d,Show d,NFDataP d,NFData d,Data d) => GenericQ PatNode -> d -> ()
--rnfpDynG :: forall d. (Show d, NFDataP d, Data d) => (forall d. Data d => d -> PatNode) -> d -> ()
--rnfpDynG :: GenericQ PatNode -> GenericQ ()
--rnfpDynG :: forall d a. (Show d, NFDataP d, Data d, Show a, NFDataP a, Data a) => GenericQ PatNode -> a -> ()
--rnfpDynG :: forall d. (Show d, NFDataP d, NFData d, Data d) => (d -> PatNode) -> d -> ()
--rnfpDynG :: forall d. (Show d, NFDataP d, NFData d, Data d) => GenericQ PatNode -> d -> ()
--rnfpDynG :: forall d. (Show d, NFDataP d, Data d) => GenericQ PatNode -> d -> ()
--rnfpDynG :: forall d. (Show d, NFDataP d, Data d) => GenericQ PatNode -> d -> ()
rnfpDynG fg x
#if 0
-- = (rnfp pat x) `seq` ()
-- = (gmapQ ((rnfpDynG fg)::GenericQ ()) x) `seq` ()
-- = (gmapQ ((rnfpDynG fg)::d->()) x) `seq` ()
-- = (gmapQ ((rnfpDynG fg)::NFDataP d => d->()) x) `seq` ()
-- = ((gmapQ (rnfpDynG fg) x)::[()]) `seq` ()
= (gmapQ (rnfpDynG fg) x) `seq` ()
-- = (rnfp pat x) `seq` (gmapQ (rnfpDynG fg) x) `seq` ()
#else
| WI <- pn = ()
| otherwise = (rnfp pat x) `seq` (gmapQ ((rnfpDynG (fg::forall b. (Show b,NFDataP b,NFData b,Data b) => b -> PatNode)) :: forall c. (Show c,NFDataP c,NFData c,Data c) => c -> ()) x) `seq` ()
--- | otherwise = (rnfp pat x) `seq` (gmapQ ((rnfpDynG fg) :: forall e. (Show e,NFDataP e,NFData e,Data e) => e -> ()) x) `seq` ()
--- | otherwise = (rnfp pat x) `seq` (gmapQ ((rnfpDynG fg) :: forall e. Data e => e -> ()) x) `seq` ()
--- | otherwise = (rnfp pat x) `seq` (gmapQ (rnfpDynG fg) x) `seq` ()
--- | otherwise = (rnfp pat x) `seq` () -- this is fine
--- | otherwise = rnfp pat x `seq` gmapQ (rnfpDynG fg) x `seq` ()
--- | otherwise = rnfp pat x `seq` gmapQ ((rnfpDynG fg) :: GenericQ ()) x `seq` ()
--- | otherwise = ( ( rnfp pat ) :: d -> () ) d `seq` gmapQ (rnfpDynG fg) d `seq` ()
#endif
where
pn = fg x {-:: PatNode-}
pat = Node pn [] {-:: Pattern-}
#endif
#endif
-------------------------------------------------------------------------------
#endif
-------------------------------------------------------------------------------