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