{-# LANGUAGE CPP, DeriveDataTypeable #-}
{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing -fwarn-unused-imports #-}

-- | This module defines the 'AList' type, a list that supports
-- constant-time append, and is therefore ideal for building the
-- result of tree-shaped parallel computations.

module Control.Monad.Par.AList 
{-# DEPRECATED "This structure does not perform well, and will be removed in future versions" #-}
 (
  -- * The 'AList' type and operations
  AList(..),
  empty, singleton, cons, head, tail, length, null, append,
  toList, fromList, fromListBalanced, 

  -- * Regular (non-parallel) Combinators
  filter, map, partition,

  -- * Operations to build 'AList's in the 'Par' monad
  parBuildThresh, parBuildThreshM,
  parBuild, parBuildM,

  -- * Inspect and modify the internal structure of an AList tree 
  depth, balance
 )
where 

import Control.DeepSeq
import Prelude hiding (length,head,tail,null,map,filter)
import qualified Prelude as P
import qualified Data.List as L
import qualified Control.Monad.Par.Combinator as C
import Control.Monad.Par.Class
import Data.Typeable
import qualified Data.Serialize as S

----------------------------------------------------------------------------------------------------

-- | List that support constant-time append (sometimes called
-- join-lists).
data AList a = ANil | ASing a | Append (AList a) (AList a) | AList [a]
 deriving (Typeable)

-- TODO -- Add vectors.

instance NFData a => NFData (AList a) where
 rnf :: AList a -> ()
rnf AList a
ANil         = ()
 rnf (ASing a
a)    = a -> ()
forall a. NFData a => a -> ()
rnf a
a 
 rnf (Append AList a
l AList a
r) = AList a -> ()
forall a. NFData a => a -> ()
rnf AList a
l () -> () -> ()
forall a b. a -> b -> b
`seq` AList a -> ()
forall a. NFData a => a -> ()
rnf AList a
r
 rnf (AList  [a]
l)   = [a] -> ()
forall a. NFData a => a -> ()
rnf [a]
l

instance Show a => Show (AList a) where 
  show :: AList a -> String
show AList a
al = String
"fromList "String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => a -> String
show (AList a -> [a]
forall a. AList a -> [a]
toList AList a
al)

-- TODO: Better Serialization
instance S.Serialize a => S.Serialize (AList a) where
  put :: Putter (AList a)
put AList a
al = Putter [a]
forall t. Serialize t => Putter t
S.put (AList a -> [a]
forall a. AList a -> [a]
toList AList a
al)
  get :: Get (AList a)
get = do [a]
x <- Get [a]
forall t. Serialize t => Get t
S.get 
	   AList a -> Get (AList a)
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> AList a
forall a. [a] -> AList a
fromList [a]
x)



----------------------------------------------------------------------------------------------------

{-# INLINE append #-}
-- | /O(1)/ Append two 'AList's
append :: AList a -> AList a -> AList a
append :: forall a. AList a -> AList a -> AList a
append AList a
ANil AList a
r = AList a
r
append AList a
l AList a
ANil = AList a
l
append AList a
l AList a
r    = AList a -> AList a -> AList a
forall a. AList a -> AList a -> AList a
Append AList a
l AList a
r

{-# INLINE empty #-}
-- | /O(1)/ an empty 'AList'
empty :: AList a
empty :: forall a. AList a
empty = AList a
forall a. AList a
ANil

{-# INLINE singleton #-}
-- | /O(1)/ a singleton 'AList'
singleton :: a -> AList a
singleton :: forall a. a -> AList a
singleton = a -> AList a
forall a. a -> AList a
ASing

{-# INLINE fromList #-}
-- | /O(1)/ convert an ordinary list to an 'AList'
fromList :: [a] -> AList a
fromList :: forall a. [a] -> AList a
fromList  = [a] -> AList a
forall a. [a] -> AList a
AList

-- | Convert an ordinary list, but do so using 'Append' and
-- 'ASing' rather than 'AList'
fromListBalanced :: [a] -> AList a
fromListBalanced :: forall a. [a] -> AList a
fromListBalanced [a]
xs = [a] -> Int -> AList a
forall {a}. [a] -> Int -> AList a
go [a]
xs ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
P.length [a]
xs)
  where 
   go :: [a] -> Int -> AList a
go [a]
_  Int
0 = AList a
forall a. AList a
ANil
   go [a]
ls Int
1 = case [a]
ls of 
	       (a
h:[a]
_) -> a -> AList a
forall a. a -> AList a
ASing a
h
	       []    -> String -> AList a
forall a. HasCallStack => String -> a
error String
"the impossible happened"
   go [a]
ls Int
n = 
     let (Int
q,Int
r) = Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
quotRem Int
n Int
2 in
     AList a -> AList a -> AList a
forall a. AList a -> AList a -> AList a
Append ([a] -> Int -> AList a
go [a]
ls Int
q)
            ([a] -> Int -> AList a
go (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
q [a]
ls) (Int
qInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
r))


-- | Balance the tree representation of an AList.  
balance :: AList a -> AList a
balance :: forall a. AList a -> AList a
balance = [a] -> AList a
forall a. [a] -> AList a
fromListBalanced ([a] -> AList a) -> (AList a -> [a]) -> AList a -> AList a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AList a -> [a]
forall a. AList a -> [a]
toList
-- This would be much better if ALists tracked their size.

{-# INLINE cons #-}
-- | /O(1)/ prepend an element
cons :: a -> AList a -> AList a
cons :: forall a. a -> AList a -> AList a
cons a
x AList a
ANil = a -> AList a
forall a. a -> AList a
ASing a
x
cons a
x AList a
al   = AList a -> AList a -> AList a
forall a. AList a -> AList a -> AList a
Append (a -> AList a
forall a. a -> AList a
ASing a
x) AList a
al
-- If we tracked length perhaps this could make an effort at balance.

-- | /O(n)/ take the head element of an 'AList'
--
-- NB. linear-time, because the list might look like this:
--
-- > (((... `append` a) `append` b) `append` c)
--
head :: AList a -> a
head :: forall a. AList a -> a
head AList a
al = 
  case AList a -> Maybe a
forall {a}. AList a -> Maybe a
loop AList a
al of
    Just a
x -> a
x 
    Maybe a
Nothing -> String -> a
forall a. HasCallStack => String -> a
error String
"cannot take head of an empty AList"
 where 
  -- Alas there are an infinite number of representations for null:
  loop :: AList a -> Maybe a
loop AList a
al =
   case AList a
al of 
     Append AList a
l AList a
r -> case AList a -> Maybe a
loop AList a
l of 
		     x :: Maybe a
x@(Just a
_) -> Maybe a
x
		     Maybe a
Nothing    -> AList a -> Maybe a
loop AList a
r
     ASing a
x     -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
     AList (a
h:[a]
_) -> a -> Maybe a
forall a. a -> Maybe a
Just a
h
     AList []    -> Maybe a
forall a. Maybe a
Nothing
     AList a
ANil        -> Maybe a
forall a. Maybe a
Nothing

-- | /O(n)/ take the tail element of an 'AList'
tail :: AList a -> AList a
tail :: forall a. AList a -> AList a
tail AList a
al = 
  case AList a -> Maybe (AList a)
forall {a}. AList a -> Maybe (AList a)
loop AList a
al of
    Just AList a
x -> AList a
x 
    Maybe (AList a)
Nothing -> String -> AList a
forall a. HasCallStack => String -> a
error String
"cannot take tail of an empty AList"
 where 
  loop :: AList a -> Maybe (AList a)
loop AList a
al =
   case AList a
al of 
     Append AList a
l AList a
r -> case AList a -> Maybe (AList a)
loop AList a
l of 
		     (Just AList a
x) -> AList a -> Maybe (AList a)
forall a. a -> Maybe a
Just (AList a -> AList a -> AList a
forall a. AList a -> AList a -> AList a
Append AList a
x AList a
r)
		     Maybe (AList a)
Nothing  -> AList a -> Maybe (AList a)
loop AList a
r

     ASing a
_     -> AList a -> Maybe (AList a)
forall a. a -> Maybe a
Just AList a
forall a. AList a
ANil
     AList (a
_:[a]
t) -> AList a -> Maybe (AList a)
forall a. a -> Maybe a
Just ([a] -> AList a
forall a. [a] -> AList a
AList [a]
t)
     AList []    -> Maybe (AList a)
forall a. Maybe a
Nothing
     AList a
ANil        -> Maybe (AList a)
forall a. Maybe a
Nothing

-- | /O(n)/ find the length of an 'AList'
length :: AList a -> Int
length :: forall a. AList a -> Int
length AList a
ANil         = Int
0
length (ASing a
_)    = Int
1
length (Append AList a
l AList a
r) = AList a -> Int
forall a. AList a -> Int
length AList a
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ AList a -> Int
forall a. AList a -> Int
length AList a
r
length (AList  [a]
l)   = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
P.length [a]
l 

{-# INLINE null #-}
-- | /O(n)/ returns 'True' if the 'AList' is empty
null :: AList a -> Bool
null :: forall a. AList a -> Bool
null = (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0) (Int -> Bool) -> (AList a -> Int) -> AList a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AList a -> Int
forall a. AList a -> Int
length 

-- | /O(n)/ converts an 'AList' to an ordinary list
toList :: AList a -> [a]
toList :: forall a. AList a -> [a]
toList AList a
a = AList a -> [a] -> [a]
forall {a}. AList a -> [a] -> [a]
go AList a
a []
 where go :: AList a -> [a] -> [a]
go AList a
ANil         [a]
rest = [a]
rest
       go (ASing a
a)    [a]
rest = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
rest
       go (Append AList a
l AList a
r) [a]
rest = AList a -> [a] -> [a]
go AList a
l ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$! AList a -> [a] -> [a]
go AList a
r [a]
rest
       go (AList [a]
xs)   [a]
rest = [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
rest

partition :: (a -> Bool) -> AList a -> (AList a, AList a)
partition :: forall a. (a -> Bool) -> AList a -> (AList a, AList a)
partition a -> Bool
p AList a
a = AList a -> (AList a, AList a) -> (AList a, AList a)
go AList a
a (AList a
forall a. AList a
ANil, AList a
forall a. AList a
ANil)
  where go :: AList a -> (AList a, AList a) -> (AList a, AList a)
go AList a
ANil      (AList a, AList a)
acc = (AList a, AList a)
acc
        go (ASing a
a) (AList a
ys, AList a
ns) | a -> Bool
p a
a = (a
a a -> AList a -> AList a
forall a. a -> AList a -> AList a
`cons` AList a
ys, AList a
ns)
        go (ASing a
a) (AList a
ys, AList a
ns) | Bool
otherwise = (AList a
ys, a
a a -> AList a -> AList a
forall a. a -> AList a -> AList a
`cons` AList a
ns)
        go (Append AList a
l AList a
r) (AList a, AList a)
acc = AList a -> (AList a, AList a) -> (AList a, AList a)
go AList a
l ((AList a, AList a) -> (AList a, AList a))
-> (AList a, AList a) -> (AList a, AList a)
forall a b. (a -> b) -> a -> b
$! AList a -> (AList a, AList a) -> (AList a, AList a)
go AList a
r (AList a, AList a)
acc
        go (AList [a]
xs) (AList a
ys, AList a
ns) = ([a] -> AList a
forall a. [a] -> AList a
AList [a]
ys' AList a -> AList a -> AList a
forall a. AList a -> AList a -> AList a
`append` AList a
ys, [a] -> AList a
forall a. [a] -> AList a
AList [a]
ns' AList a -> AList a -> AList a
forall a. AList a -> AList a -> AList a
`append` AList a
ns)
          where
            ([a]
ys', [a]
ns') = (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition a -> Bool
p [a]
xs

depth :: AList a -> Int
depth :: forall a. AList a -> Int
depth AList a
ANil      = Int
0
depth (ASing a
_) = Int
1
depth (AList [a]
_) = Int
1
depth (Append AList a
l AList a
r) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (AList a -> Int
forall a. AList a -> Int
depth AList a
l) (AList a -> Int
forall a. AList a -> Int
depth AList a
r)


-- The filter operation compacts dead space in the tree that would be
-- left by ANil nodes.
filter :: (a -> Bool) -> AList a -> AList a
filter :: forall a. (a -> Bool) -> AList a -> AList a
filter a -> Bool
p AList a
l = AList a -> AList a
loop AList a
l 
 where 
  loop :: AList a -> AList a
loop AList a
ANil         = AList a
forall a. AList a
ANil
  loop o :: AList a
o@(ASing a
x)  = if a -> Bool
p a
x then AList a
o else AList a
forall a. AList a
ANil
  loop   (AList [a]
ls) = [a] -> AList a
forall a. [a] -> AList a
AList([a] -> AList a) -> [a] -> AList a
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
P.filter a -> Bool
p [a]
ls
  loop (Append AList a
x AList a
y) = 
     let l :: AList a
l = AList a -> AList a
loop AList a
x
	 r :: AList a
r = AList a -> AList a
loop AList a
y in
     case (AList a
l,AList a
r) of 
       (AList a
ANil,AList a
ANil) -> AList a
forall a. AList a
ANil
       (AList a
ANil,AList a
y)    -> AList a
y
       (AList a
x,AList a
ANil)    -> AList a
x
       (AList a
x,AList a
y)       -> AList a -> AList a -> AList a
forall a. AList a -> AList a -> AList a
Append AList a
x AList a
y

-- | The usual `map` operation.
map :: (a -> b) -> AList a -> AList b
map :: forall a b. (a -> b) -> AList a -> AList b
map a -> b
_  AList a
ANil = AList b
forall a. AList a
ANil 
map a -> b
f (ASing a
x) = b -> AList b
forall a. a -> AList a
ASing (a -> b
f a
x)
map a -> b
f (AList [a]
l) = [b] -> AList b
forall a. [a] -> AList a
AList ((a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
P.map a -> b
f [a]
l)
map a -> b
f (Append AList a
x AList a
y) = AList b -> AList b -> AList b
forall a. AList a -> AList a -> AList a
Append ((a -> b) -> AList a -> AList b
forall a b. (a -> b) -> AList a -> AList b
map a -> b
f AList a
x) ((a -> b) -> AList a -> AList b
forall a b. (a -> b) -> AList a -> AList b
map a -> b
f AList a
y)


--------------------------------------------------------------------------------
-- * Combinators built on top of a Par monad.

-- | A parMap over an AList can result in more balanced parallelism than
--   the default parMap over Traversable data types.
-- parMap :: NFData b => (a -> b) -> AList a -> Par (AList b)

-- | Build a balanced 'AList' in parallel, constructing each element as a
--   function of its index.  The threshold argument provides control
--   over the degree of parallelism.  It indicates under what number
--   of elements the build process should switch from parallel to
--   serial.
parBuildThresh :: (NFData a, ParFuture f p) => Int -> C.InclusiveRange -> (Int -> a) -> p (AList a)
parBuildThresh :: forall a (f :: * -> *) (p :: * -> *).
(NFData a, ParFuture f p) =>
Int -> InclusiveRange -> (Int -> a) -> p (AList a)
parBuildThresh Int
threshold InclusiveRange
range Int -> a
fn =
  Int
-> InclusiveRange
-> (Int -> p (AList a))
-> (AList a -> AList a -> p (AList a))
-> AList a
-> p (AList a)
forall a (iv :: * -> *) (p :: * -> *).
(NFData a, ParFuture iv p) =>
Int
-> InclusiveRange -> (Int -> p a) -> (a -> a -> p a) -> a -> p a
C.parMapReduceRangeThresh Int
threshold InclusiveRange
range
			  (AList a -> p (AList a)
forall a. a -> p a
forall (m :: * -> *) a. Monad m => a -> m a
return (AList a -> p (AList a)) -> (Int -> AList a) -> Int -> p (AList a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> AList a
forall a. a -> AList a
singleton (a -> AList a) -> (Int -> a) -> Int -> AList a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a
fn) AList a -> AList a -> p (AList a)
forall (f :: * -> *) (p :: * -> *) a.
ParFuture f p =>
AList a -> AList a -> p (AList a)
appendM AList a
forall a. AList a
empty

-- | Variant of 'parBuildThresh' in which the element-construction function is itself a 'Par' computation.
parBuildThreshM :: (NFData a, ParFuture f p) => Int -> C.InclusiveRange -> (Int -> p a) -> p (AList a)
parBuildThreshM :: forall a (f :: * -> *) (p :: * -> *).
(NFData a, ParFuture f p) =>
Int -> InclusiveRange -> (Int -> p a) -> p (AList a)
parBuildThreshM Int
threshold InclusiveRange
range Int -> p a
fn =
  Int
-> InclusiveRange
-> (Int -> p (AList a))
-> (AList a -> AList a -> p (AList a))
-> AList a
-> p (AList a)
forall a (iv :: * -> *) (p :: * -> *).
(NFData a, ParFuture iv p) =>
Int
-> InclusiveRange -> (Int -> p a) -> (a -> a -> p a) -> a -> p a
C.parMapReduceRangeThresh Int
threshold InclusiveRange
range 
			  (\Int
x -> Int -> p a
fn Int
x p a -> (a -> p (AList a)) -> p (AList a)
forall a b. p a -> (a -> p b) -> p b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AList a -> p (AList a)
forall a. a -> p a
forall (m :: * -> *) a. Monad m => a -> m a
return (AList a -> p (AList a)) -> (a -> AList a) -> a -> p (AList a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> AList a
forall a. a -> AList a
singleton) AList a -> AList a -> p (AList a)
forall (f :: * -> *) (p :: * -> *) a.
ParFuture f p =>
AList a -> AList a -> p (AList a)
appendM AList a
forall a. AList a
empty

-- | \"Auto-partitioning\" version of 'parBuildThresh' that chooses the threshold based on
--    the size of the range and the number of processors..
parBuild :: (NFData a, ParFuture f p) => C.InclusiveRange -> (Int -> a) -> p (AList a)
parBuild :: forall a (f :: * -> *) (p :: * -> *).
(NFData a, ParFuture f p) =>
InclusiveRange -> (Int -> a) -> p (AList a)
parBuild InclusiveRange
range Int -> a
fn =
  InclusiveRange
-> (Int -> p (AList a))
-> (AList a -> AList a -> p (AList a))
-> AList a
-> p (AList a)
forall a (iv :: * -> *) (p :: * -> *).
(NFData a, ParFuture iv p) =>
InclusiveRange -> (Int -> p a) -> (a -> a -> p a) -> a -> p a
C.parMapReduceRange InclusiveRange
range (AList a -> p (AList a)
forall a. a -> p a
forall (m :: * -> *) a. Monad m => a -> m a
return (AList a -> p (AList a)) -> (Int -> AList a) -> Int -> p (AList a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> AList a
forall a. a -> AList a
singleton (a -> AList a) -> (Int -> a) -> Int -> AList a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a
fn) AList a -> AList a -> p (AList a)
forall (f :: * -> *) (p :: * -> *) a.
ParFuture f p =>
AList a -> AList a -> p (AList a)
appendM AList a
forall a. AList a
empty

-- | like 'parBuild', but the construction function is monadic
parBuildM :: (NFData a, ParFuture f p) => C.InclusiveRange -> (Int -> p a) -> p (AList a)
parBuildM :: forall a (f :: * -> *) (p :: * -> *).
(NFData a, ParFuture f p) =>
InclusiveRange -> (Int -> p a) -> p (AList a)
parBuildM InclusiveRange
range Int -> p a
fn =
  InclusiveRange
-> (Int -> p (AList a))
-> (AList a -> AList a -> p (AList a))
-> AList a
-> p (AList a)
forall a (iv :: * -> *) (p :: * -> *).
(NFData a, ParFuture iv p) =>
InclusiveRange -> (Int -> p a) -> (a -> a -> p a) -> a -> p a
C.parMapReduceRange InclusiveRange
range (\Int
x -> Int -> p a
fn Int
x p a -> (a -> p (AList a)) -> p (AList a)
forall a b. p a -> (a -> p b) -> p b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AList a -> p (AList a)
forall a. a -> p a
forall (m :: * -> *) a. Monad m => a -> m a
return (AList a -> p (AList a)) -> (a -> AList a) -> a -> p (AList a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> AList a
forall a. a -> AList a
singleton) AList a -> AList a -> p (AList a)
forall (f :: * -> *) (p :: * -> *) a.
ParFuture f p =>
AList a -> AList a -> p (AList a)
appendM AList a
forall a. AList a
empty

--------------------------------------------------------------------------------

-- TODO: Provide a strategy for @par@-based maps:

-- TODO: tryHead -- returns Maybe

-- TODO: headTail -- returns head and tail, 
--    i.e. if we're doing O(N) work, don't do it twice.

-- FIXME: Could be more efficient:
instance Eq a => Eq (AList a) where
 AList a
a == :: AList a -> AList a -> Bool
== AList a
b = AList a -> [a]
forall a. AList a -> [a]
toList AList a
a [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== AList a -> [a]
forall a. AList a -> [a]
toList AList a
b 

-- TODO: Finish me:
-- instance F.Foldable AList where
--  foldr fn init al = 
--   case al of 
--    ANil    -> 

-- instance Functor AList where
--  fmap = undefined

-- -- Walk the data structure without introducing any additional data-parallelism.
-- instance Traversable AList where 
--   traverse f al = 
--     case al of 
--       ANil    -> pure ANil
--       ASing x -> ASing <$> f x


--------------------------------------------------------------------------------
-- Internal helpers:

appendM :: ParFuture f p => AList a -> AList a -> p (AList a)
appendM :: forall (f :: * -> *) (p :: * -> *) a.
ParFuture f p =>
AList a -> AList a -> p (AList a)
appendM AList a
x AList a
y = AList a -> p (AList a)
forall a. a -> p a
forall (m :: * -> *) a. Monad m => a -> m a
return (AList a -> AList a -> AList a
forall a. AList a -> AList a -> AList a
append AList a
x AList a
y)