deepseq-bounded-0.6.0.0: src/Control/DeepSeq/Bounded/NFDataPDyn.hs
-------------------------------------------------------------------------------
{- LANGUAGE CPP #-}
#define DO_TRACE 0
#define WARN_IGNORED_SUBPATTERNS 1
#define NEVER_IGNORE_SUBPATTERNS 0
#define USE_GENERICQ 0
-- Now specified via --flag=[-]USE_WWW_DEEPSEQ
--- #define USE_WW_DEEPSEQ 1
-------------------------------------------------------------------------------
#if USE_SOP
-- XXX and what happened to DataKinds??... (only when also TemplateHaskell?)
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
#if __GLASGOW_HASKELL__ < 708
{-# LANGUAGE GADTs #-}
#endif
#endif
{-# LANGUAGE Rank2Types #-}
{- LANGUAGE ScopedTypeVariables #-}
-- For tracing only:
{- LANGUAGE BangPatterns #-}
-------------------------------------------------------------------------------
-- |
-- Module : Control.DeepSeq.Bounded.NFDataPDyn
-- Copyright : Andrew G. Seniuk 2014-2015
-- 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 USE_GENERICQ
import Data.Generics ( GenericQ )
#endif
#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 :: forall a b. (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)
#if USE_GENERICQ
) => GenericQ PatNode -> a -> b -> b
#else
) => (forall c. Data c => c -> PatNode) -> a -> b -> b
#endif
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'' :: forall a b. (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' :: forall a b. (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 :: forall a. (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)
#if USE_GENERICQ
) => GenericQ PatNode -> a -> a
#else
) => (forall c. Data c => c -> PatNode) -> a -> a
#endif
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'' :: forall a. (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' :: forall a. (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 a 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 emptyPatNodeAttrs
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
#if USE_GENERICQ
GenericQ PatNode
#else
( forall c. (
#if 1
Data c
#else
Generic c
-- , All2 Show (Code c)
#endif
) => c -> PatNode
)
#endif
-> 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
#if USE_GENERICQ
GenericQ PatNode
#else
( forall c. (
Data c
) => c -> PatNode
)
#endif
-> 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
#if USE_GENERICQ
GenericQ PatNode
#else
( forall c. (
Data c
) => c -> PatNode
)
#endif
-> 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 emptyPatNodeAttrs
#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 emptyPatNodeAttrs
-- 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
-- XXX I guess, at the very least, you'll need
-- syb-with-class if you want to implement this...
#error Cannot use NFDataPDyn without flag USE_SOP being True (at least at this time).
#endif
-------------------------------------------------------------------------------