{-# 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 ANil         = ()
 rnf (ASing a)    = rnf a 
 rnf (Append l r) = rnf l `seq` rnf r
 rnf (AList  l)   = rnf l

instance Show a => Show (AList a) where 
  show al = "fromList "++ show (toList al)

-- TODO: Better Serialization
instance S.Serialize a => S.Serialize (AList a) where
  put al = S.put (toList al)
  get = do x <- S.get 
	   return (fromList x)



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

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

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

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

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

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


-- | Balance the tree representation of an AList.  
balance :: AList a -> AList a
balance = fromListBalanced . 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 x ANil = ASing x
cons x al   = Append (ASing x) 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 al = 
  case loop al of
    Just x -> x 
    Nothing -> error "cannot take head of an empty AList"
 where 
  -- Alas there are an infinite number of representations for null:
  loop al =
   case al of 
     Append l r -> case loop l of 
		     x@(Just _) -> x
		     Nothing    -> loop r
     ASing x     -> Just x
     AList (h:_) -> Just h
     AList []    -> Nothing
     ANil        -> Nothing

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

     ASing _     -> Just ANil
     AList (_:t) -> Just (AList t)
     AList []    -> Nothing
     ANil        -> Nothing

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

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

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

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

depth :: AList a -> Int
depth ANil      = 0
depth (ASing _) = 1
depth (AList _) = 1
depth (Append l r) = 1 + max (depth l) (depth 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 p l = loop l 
 where 
  loop ANil         = ANil
  loop o@(ASing x)  = if p x then o else ANil
  loop   (AList ls) = AList$ P.filter p ls
  loop (Append x y) = 
     let l = loop x
	 r = loop y in
     case (l,r) of 
       (ANil,ANil) -> ANil
       (ANil,y)    -> y
       (x,ANil)    -> x
       (x,y)       -> Append x y

-- | The usual `map` operation.
map :: (a -> b) -> AList a -> AList b
map _  ANil = ANil 
map f (ASing x) = ASing (f x)
map f (AList l) = AList (P.map f l)
map f (Append x y) = Append (map f x) (map f 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 threshold range fn =
  C.parMapReduceRangeThresh threshold range
			  (return . singleton . fn) appendM 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 threshold range fn =
  C.parMapReduceRangeThresh threshold range 
			  (\x -> fn x >>= return . singleton) appendM 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 range fn =
  C.parMapReduceRange range (return . singleton . fn) appendM empty

-- | like 'parBuild', but the construction function is monadic
parBuildM :: (NFData a, ParFuture f p) => C.InclusiveRange -> (Int -> p a) -> p (AList a)
parBuildM range fn =
  C.parMapReduceRange range (\x -> fn x >>= return . singleton) appendM 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
 a == b = toList a == toList 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 x y = return (append x y)