AList.hs

{-# LANGUAGE CPP #-}
{-# 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
 (
  -- * The 'AList' type and operations
  AList(..),
  empty, singleton, cons, head, tail, length, null, append,
  toList, fromList,
  -- * Operations to build 'AList's in the 'Par' monad
  parBuildThresh, parBuildThreshM,
  parBuild, parBuildM,
 )
where 


import Control.DeepSeq
import Prelude hiding (length,head,tail,null)
import qualified Prelude as P
import Control.Monad.Par

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

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

#if 0
 data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)
 instance Traversable Tree
	traverse f Empty = pure Empty
	traverse f (Leaf x) = Leaf <$> f x
	traverse f (Node l k r) = Node <$> traverse f l <*> f k <*> traverse f r
#endif


-- 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

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

-- | /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 #-}
{-# INLINE singleton #-}
{-# INLINE fromList #-}

-- | /O(1)/ an empty 'AList'
empty :: AList a
empty = ANil

-- | /O(1)/ a singleton 'AList'
singleton :: a -> AList a
singleton = ASing

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

-- | /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 


-- | /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

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


appendM :: AList a -> AList a -> Par (AList a)
appendM x y = return (append x y)

-- | 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 => Int -> InclusiveRange -> (Int -> a) -> Par (AList a)
parBuildThresh threshold range fn =
  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 => Int -> InclusiveRange -> (Int -> Par a) -> Par (AList a)
parBuildThreshM threshold range fn =
  parMapReduceRangeThresh threshold range 
			  ((fmap singleton) . fn) 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 => InclusiveRange -> (Int -> a) -> Par (AList a)
parBuild range fn =
  parMapReduceRange range (return . singleton . fn) appendM empty

-- | like 'parBuild', but the construction function is monadic
parBuildM :: NFData a => InclusiveRange -> (Int -> Par a) -> Par (AList a)
parBuildM range fn =
  parMapReduceRange range ((fmap singleton) . fn) appendM empty


-- | 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)