{-# LANGUAGE RankNTypes, NamedFieldPuns, BangPatterns,
             ExistentialQuantification, MultiParamTypeClasses, CPP #-}
{- OPTIONS_GHC -Wall -fno-warn-name-shadowing -fwarn-unused-imports -}

{-# LANGUAGE TypeFamilies #-}

{- | This is the scheduler described in the paper "A Monad for
     Deterministic Parallelism".  It is based on a lazy @Trace@ data
     structure that separates the scheduler from the @Par@ monad
     method implementations.

 -}

module Control.Monad.Par.Scheds.Trace (
    Par, runPar, runParIO, fork,
    IVar, new, newFull, newFull_, get, put, put_,
    spawn, spawn_, spawnP, fixPar, FixParException (..)
  ) where

import qualified Control.Monad.Par.Class as PC
import Control.Monad.Par.Scheds.TraceInternal
import Control.DeepSeq
import Control.Monad as M hiding (mapM, sequence, join)
import Prelude hiding (mapM, sequence, head,tail)

#ifdef NEW_GENERIC
import qualified       Control.Par.Class as PN
import qualified       Control.Par.Class.Unsafe as PU
#endif

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

-- Not in 6.12: {- INLINABLE fork -}
{-# INLINE fork #-}
fork :: Par () -> Par ()
fork :: Par () -> Par ()
fork Par ()
p = forall a. ((a -> Trace) -> Trace) -> Par a
Par forall a b. (a -> b) -> a -> b
$ \() -> Trace
c -> Trace -> Trace -> Trace
Fork (forall a. Par a -> (a -> Trace) -> Trace
runCont Par ()
p (\()
_ -> Trace
Done)) (() -> Trace
c ())

-- --------------------------------------------------------------------------------
-- -- Standard instances:

-- <boilerplate>
spawn :: NFData a => Par a -> Par (IVar a)
spawn :: forall a. NFData a => Par a -> Par (IVar a)
spawn Par a
p  = do IVar a
r <- forall a. Par (IVar a)
new;  Par () -> Par ()
fork (Par a
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. NFData a => IVar a -> a -> Par ()
put IVar a
r);   forall (m :: * -> *) a. Monad m => a -> m a
return IVar a
r
spawn_ :: Par a -> Par (IVar a)
spawn_ :: forall a. Par a -> Par (IVar a)
spawn_ Par a
p = do IVar a
r <- forall a. Par (IVar a)
new;  Par () -> Par ()
fork (Par a
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. IVar a -> a -> Par ()
put_ IVar a
r);  forall (m :: * -> *) a. Monad m => a -> m a
return IVar a
r
-- </boilerplate>>

spawnP :: NFData a => a -> Par (IVar a)
spawnP :: forall a. NFData a => a -> Par (IVar a)
spawnP a
a = forall a. NFData a => Par a -> Par (IVar a)
spawn (forall (m :: * -> *) a. Monad m => a -> m a
return a
a)

instance PC.ParFuture IVar Par  where
  get :: forall a. IVar a -> Par a
get    = forall a. IVar a -> Par a
get
  spawn :: forall a. NFData a => Par a -> Par (IVar a)
spawn  = forall a. NFData a => Par a -> Par (IVar a)
spawn
  spawn_ :: forall a. Par a -> Par (IVar a)
spawn_ = forall a. Par a -> Par (IVar a)
spawn_
  spawnP :: forall a. NFData a => a -> Par (IVar a)
spawnP = forall a. NFData a => a -> Par (IVar a)
spawnP

instance PC.ParIVar IVar Par  where
  fork :: Par () -> Par ()
fork = Par () -> Par ()
fork
  new :: forall a. Par (IVar a)
new  = forall a. Par (IVar a)
new
  put :: forall a. NFData a => IVar a -> a -> Par ()
put  = forall a. NFData a => IVar a -> a -> Par ()
put
  put_ :: forall a. IVar a -> a -> Par ()
put_ = forall a. IVar a -> a -> Par ()
put_
  newFull :: forall a. NFData a => a -> Par (IVar a)
newFull  = forall a. NFData a => a -> Par (IVar a)
newFull
  newFull_ :: forall a. a -> Par (IVar a)
newFull_ = forall a. a -> Par (IVar a)
newFull_
--  yield = yield

#ifdef NEW_GENERIC
instance PU.ParMonad Par where
  fork = fork  
  internalLiftIO io = Par (LiftIO io)

instance PU.ParThreadSafe Par where
  unsafeParIO io = Par (LiftIO io)  
    
instance PN.ParFuture Par where
  type Future Par = IVar
  type FutContents Par a = ()
  get    = get
  spawn  = spawn
  spawn_ = spawn_
  spawnP = spawnP
  
instance PN.ParIVar Par  where
  new  = new
  put_ = put_
  newFull = newFull
  newFull_ = newFull_
#endif