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

-- | Some experimental support for 'OpenList's, which are streams in
-- the 'Par' monad that support constant-time append.

module Control.Monad.Par.OpenList
--module Main
 (
  OpenList(),
  empty, singleton, cons, head, tail, length,
  close, join,
  toList, fromList, toLazyList, 
  parMapM, parBuild, parBuildM,  
  openlist_tests, 
  chaintest, 
  async_test, lazy_chaintest
-- , main

 , IList(..), newCell
 )
where 

import Control.Monad hiding (join)
import Control.DeepSeq
import Control.Concurrent.MVar
import Control.Monad.Par hiding (parMapM)
import Control.Monad.Par.IList
import Control.Monad.Par.Internal

import Prelude hiding (length,head,tail,drop,take,null)
import qualified Prelude as P
-- import System.IO.Unsafe
import GHC.IO (unsafePerformIO, unsafeDupablePerformIO)
import Test.HUnit 
import Debug.Trace

-- -----------------------------------------------------------------------------
-- Open Lists -- IVars at the tail.
--
-- These have some of the advantages of imperative lists, such as
-- constant time appending, while retaining determinism and having
-- O(1) access to the head of the list unlike tree-shaped lists
-- (e.g. append-based rather than cons-based).


-- An OpenList must be handled functionally.  Extending the list as
-- an effect will not change its tail pointer.
data OpenList a = OpenList (IList a) (IList a)

-- This is likewise a pretty meaningless NFData instance:
instance NFData a => NFData (OpenList a) where 
  rnf (OpenList hp tp) = rnf hp `seq` rnf tp 


-- | An empty open list.  Supports further extension.
empty :: OpenList a
empty = OpenList Null Null

null :: OpenList a -> Bool
null (OpenList Null Null) = True
null _                    = False

-- | A single element open list.
singleton :: a -> Par (OpenList a)
singleton x = 
  do pv <- new 
     let cell = Cons x pv
     return (OpenList cell cell)

-- TODO/FIXME: Need to decide whether there should be closed and open empty lists!!

-- | Terminate a non-empty open list so that it cannot be extended further.
close :: NFData a => OpenList a -> Par (OpenList a)
close orig@(OpenList Null _) = return orig
close orig@(OpenList _   tp) = do put (tl tp) Null; return orig


-- This version ignores the tail pointer and seeks out the end of the
-- list (at the present time).
-- unsafeClose :: NFData a => OpenList a -> Par (OpenList a)
-- unsafeClose orig@(OpenList Null _) = return orig



-- | Destructive append operation.
join :: NFData a => OpenList a -> OpenList a -> Par (OpenList a)
join (OpenList Null _) right = return right
join left  (OpenList Null _) = return left 
join (OpenList hp1 tp1) (OpenList hp2 tp2) =
    do put (tl tp1) hp2
       return (OpenList hp1 tp2)

-- | Head of an OpenList.
head :: OpenList a -> a
head (OpenList Null _) = error "cannot take head of null OpenList"
head (OpenList hp _)   = hd hp

headCell (OpenList hp _) = OpenList hp hp 
lastCell (OpenList _ tp) = OpenList tp tp

-- | Tail of an OpenList.  Beware, if the list contains only one
--   element (e.g. the result of tail will be null), it must be CLOSED
--   for tail to work.
tail :: OpenList a -> Par (OpenList a)
-- NOTE: We could fix this limitation by adding a length field to the OpenList.
tail (OpenList Null _) = error "cannot take tail of null OpenList"
tail (OpenList hp tp)  = 
  do nxt <- get (tl hp)
     case nxt of
       Null -> return empty
       _    -> return (OpenList nxt tp)


drop :: NFData a => Int -> OpenList a -> Par (OpenList a)
drop 0 ls = return ls
drop n ls = do tl <- tail ls
	       drop (n-1) tl

-- This copies a prefix and makes it open once again irrespective of
-- whether the input list is open or closed.
take :: NFData a => Int -> OpenList a -> Par (OpenList a)
take 0 ls = return empty
take n ls = do tl   <- tail ls
	       rest <- take (n-1) tl
	       cons (head ls) rest

-- Take the length of a closed OpenList.
-- length :: OpenList a -> Par Int
length (OpenList Null _) = return 0
-- length (OpenList (Cons a _) (Cons b _)) | a == b = return 1
length ls = do t   <- tail ls 
	       len <- length t
	       return (len+1)

-- | Add an element to the front of an OpenList.  Works irrespective
-- | of whether the input is closed.
cons :: NFData a => a -> OpenList a -> Par (OpenList a)
-- Careful, consing should not close the openlist:
cons car (OpenList Null _) = singleton car
cons car (OpenList hp tp) = 
  do cdr <- newFull_ hp
     return (OpenList (Cons car cdr) tp)

newCell x = do pv <-new; return (Cons x pv)

-- | Convert a list to an OpenList, open to extension at the tail.
fromList :: NFData a => [a] -> Par (OpenList a)
fromList [] = return empty
fromList (h:t) = 
  --   This function is inefficient and could be replaced with an additional IList data constructor.
    do head <- newCell h
       rest <- loop head t
       return (OpenList head rest)
 where 
   loop last  []   = return last
   loop last (h:t) = 
    do cell <- newCell h
       put (tl last) cell
       loop cell t

-- | Convert a CLOSED OpenList to a list. 
toList :: NFData a => (OpenList a) -> Par [a] 
-- Note: presently not tail-recursive:
toList (OpenList hp _) = loop hp
 where 
  loop Null = return []
  loop (Cons head pv) = 
    do 
       rest <- get pv
       converted <- loop rest
       return (head : converted)

-- Strict map over closed lists.
-- 
-- parMap for OpenLists does not support a nice divide-and-conquer.
-- (Well, it would support the appending if we were willing to scan ahead to find the length.)
-- OpenLists are not Traversable... so we can't just use Par.parMap.
--
-- TODO: Perhaps this should use a strategy for each element:
-- parMapM :: NFData b => (a -> Par b) -> OpenList a -> Par (OpenList b)
parMapM _ (OpenList Null _) = return empty
-- parMapM fn (OpenList (Cons a _) (Cons b _)) | a == b =  fn a >>= singleton 
parMapM fn ls = 
  do h <- spawn (fn (head ls))
     t <- tail ls
     h' <- get h
     t2 <- parMapM fn t
     cons h' t2

-- maybe the following too?
-- parMapM_ :: (a -> Par ()) -> OpenList a -> Par () 

-- | Build an OpenList with a divide-and-conquer parallel strategy.
parBuild :: NFData a => InclusiveRange -> (Int -> a) -> Par (OpenList a)
parBuild range fn =
  parMapReduceRange range (singleton . fn) join empty

-- | Build an OpenList with a divide-and-conquer parallel strategy,
--   allowing nested parallelism in the per-element computation.
parBuildM :: NFData a => InclusiveRange -> (Int -> Par a) -> Par (OpenList a)
parBuildM range fn =
  parMapReduceRange range ((>>= singleton) . fn) join empty


-- | OpenLists can only be printed properly in the Par monad.  @show@
--   on an open list will only give a hint -- what the first and last
--   elements of the openlist are.
instance Show a => Show (OpenList a) where 
  show (OpenList Null _) = "OpenList []"
  show (OpenList (Cons fst _) (Cons lst _)) = 
      "OpenList ["++show fst++".."++ show lst ++"]"

       

debugshow (OpenList (Cons h1 _) (Cons h2 _)) = "Cons|Cons|eq/"++show(h1==h2)
debugshow (OpenList Null       Null)       = "Null|Null"
debugshow (OpenList Null       (Cons _ _)) = error$ "invalid Null|Cons openlist"
debugshow (OpenList (Cons _ _) Null)       = error$ "invalid Cons|Null openlist"

-- Check the length of an openlist from head pointer to tail pointer
-- (not including anything present beyond the tail pointer).
-- WARNING: ASSUMES UNIQUE ELEMENTS:
debuglength :: Eq a => OpenList a -> Par Int
debuglength (OpenList Null Null) = return 0
debuglength orig@(OpenList (Cons hp1 tp1) (Cons hp2 tp2))
  | hp1 == hp2 = return 1
  | otherwise  = do rest <- tail orig
    	  	    sum  <- debuglength rest
		    return (1 + sum)

-- -----------------------------------------------------------------------------
-- Synchronization using native Haskell IVars (e.g. MVars).

-- The MList datatype is internal to the module.
-- These MVars are only written once:
data MList a = MNull | MCons (a, MVar (MList a))

_unsafe_io :: IO a -> Par a
_unsafe_io io =  let x = unsafePerformIO io in
		 x `seq` return x

_unsafe_dupable :: IO a -> Par a
_unsafe_dupable io = 
  let x = unsafeDupablePerformIO io in 
  x `seq` return x

-- Return a lazy list:
mListToList :: MList a -> [a]
mListToList MNull = []
mListToList (MCons(hd,tl)) = 
    let rest = unsafeDupablePerformIO$ 
	       do tl' <- readMVar tl  
		  return (mListToList tl')
    in  (hd : rest)

iListToMList :: IList a -> Par (MList a)
iListToMList Null = return MNull
iListToMList il = 
  do mv <- _unsafe_dupable newEmptyMVar
     fork $ do t <- get (tl il)
	       r <- iListToMList t
	       _unsafe_io$ putMVar mv r
     return (MCons (hd il, mv))

-- | Asynchronously convert an OpenList to a lazy list.  Returns immediately.
toLazyList :: OpenList a -> Par [a]
toLazyList (OpenList head _) = iListToMList head >>= return . mListToList 
-- toLazyList ol = toMList ol >>= return . mListToList 






-- -----------------------------------------------------------------------------
-- Testing

test_ol0 = runPar (cons 'a' empty >>= cons 'b' >>= close >>= tail >>= tail >>= length)

test_ol1 :: Int
test_ol1 = runPar$ do l :: OpenList Int <- join empty empty
		      length l

test_ol2 :: String
test_ol2 = show$ runPar$ do 
 ls1 <- fromList [10,11,12]
 ls2 <- singleton (5::Int)
 join ls1 ls2

test_ol3 :: [Int]
test_ol3 = runPar$ do ol :: OpenList Int <- fromList [1..10]
		      close ol
		      toList ol

test_ol4 :: Int
test_ol4 = runPar$ do ol <- fromList [1..10]		      
		      t1 <- tail ol
		      t2 <- tail t1
		      return (head t2)

test_ol5 :: Int
test_ol5 = runPar$ fromList ([1..10] :: [Int]) >>= close >>= length

test_ol6 :: [Int]
test_ol6 = runPar$ do
  l1 <- fromList [1..10]
  close l1
  l2 <- parMapM (return . (+ 1)) l1
  close l2
  toList l2


test_ol7 :: [Int]
test_ol7 = runPar$ do 
  a <- singleton 1
  b <- singleton 2
  join a b
  close b
  toLazyList a

test_ol8 :: [Int]
test_ol8 = runPar$ do 
  a <- singleton 1
  b <- singleton 2
  c <- singleton 3
  d <- singleton 4
  join c d
  join a b
  join b c
  close d
  toLazyList a

test_ll :: [Int]
test_ll = runPar$
   do l <- fromList [1..1000]
      close l 
      toLazyList l

chaintest :: Int -> Par (IList Int)
chaintest 0   = error "must have chain length >= 1"
chaintest len = loop 0 len 
 where 
   loop i 1 = do tl <- if i == len-1 
		       then newFull_ Null 
		       else new
                 when (i == len-1) (print_$ " == GOT END: "++show i)
		 return (Cons i tl)
   loop i n =
    do let half = n `quot` 2
       ifst <- spawn_$ loop i half 
       fork $ do 
		 snd <- loop (i+half) half
		 fst <- get ifst
		 lastfst <- dropIList (half-1) fst 
		 put (tl lastfst) snd
		 return ()     
       get ifst

dropIList :: NFData a => Int -> IList a -> Par (IList a)
dropIList 0 ls = return ls
dropIList n ls = do rest <- get (tl ls)
	            dropIList (n-1) rest

-- lazy_chaintest i = chaintest i >>= toLazyList
lazy_chaintest :: Int -> Par [Int]
lazy_chaintest i = do il <- chaintest i 
		      ml <- iListToMList il
		      return (mListToList ml)

-- If we create a large, lazy chain, taking just the head should be quick.
async_test = 
  do putStrLn "BeginTest"
--     let lazy = runParAsync$ lazy_chaintest 1048576
--     let lazy = runParAsync$ lazy_chaintest 32768
     let lazy = runParAsync$ lazy_chaintest 1024
--     let lazy = runPar$ lazy_chaintest 1024
     putStrLn$ "Resulting list "++ show lazy
     putStrLn$ "Got head: "++ show (P.take 3 lazy)
     putStrLn "EndTest"

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

print_ msg = trace msg $ return ()

dbg0 = debugshow$ runPar$ singleton 'a' >>= close 

-- This one is an error:
err1 = debugshow$ runPar$ singleton 'a' >>= tail  >>= close 
-- But this will work:
dbg1 = debugshow$ runPar$ fromList "ab" >>= tail  >>= close 

dbg2 = debugshow$ runPar$ singleton 'a' >>= close >>= tail 

-- This is invalid:
err2 = debugshow$ runPar$ singleton 'a' >>= tail 

-- TODO: HUnit These.
openlist_tests :: Test
openlist_tests = 
  TestList 
    [
     -- First a few small, unnamed tests:
     0                   ~=? runPar (length (empty :: OpenList Int)),
     "a"                 ~=? runPar (singleton 'a' >>= close >>= toList),
     1                   ~=? runPar (singleton 'a' >>= close >>= length),
     1                   ~=? runPar (cons 'b' empty >>= close >>= length),

     TestLabel "singleton, close"          $ "Cons|Cons|eq/True" ~=? dbg0,
     TestLabel "tail then close - SKETCHY" $ "Cons|Cons|eq/True" ~=? dbg1,
     TestLabel "close then tail"           $ "Null|Null" ~=? dbg2,
--     TestLabel "tail no close"   $ "" ~=? dbg3,

     TestLabel "tail of singleton" $ 
     0                   ~=? runPar (singleton 'a' >>= close >>= tail >>= length),
     TestLabel "tail tail of cons cons" $ 
     0                   ~=? test_ol0,

     TestLabel "join of two empty's still length zero" $ 
     0                   ~=? test_ol1,
     TestLabel "test show instance" $ 
     "OpenList [10..5]"  ~=? test_ol2,

     TestLabel "toList" $ 
     [1..10]             ~=? test_ol3,

     TestLabel "head . tail . tail" $ 
     3                   ~=? test_ol4,

     TestLabel "length . fromList" $ 
     10                  ~=? test_ol5,

     TestLabel "test parMap" $ 
     [2..11]             ~=? test_ol6,

     TestLabel "test 7" $ 
     [1,2]              ~=? test_ol7,

     TestLabel "test 8" $ 
     [1..4]             ~=? test_ol8,

     TestLabel "test lazy list conversion" $ 
     [1..1000]          ~=? test_ll,

     TestLabel "chaintest" $
     [0..511]           ~=? runPar (lazy_chaintest 512),

     TestLabel "asynchronous chaintest" $
     [0..511]           ~=? runParAsync (lazy_chaintest 512)

    ]

main = async_test