{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies, CPP #-}

-- | This scheduler uses sparks (par/pseq) directly, but only supplies
--   the @Monad.Par.Class.ParFuture@ interface.

module Control.Monad.Par.Scheds.Sparks
 (
   Par(..), Future(..),
   runPar, 
   get, spawn, spawn_, spawnP, fixPar
 ) 
where 

import Control.Applicative
import Control.Monad
import Control.DeepSeq
import Control.Parallel
import qualified Control.Monad.Par.Class as PC
import Control.Monad.Fix (MonadFix (mfix))
-- import Control.Parallel.Strategies (rpar)

#ifdef NEW_GENERIC
import qualified       Control.Par.Class as PN
import qualified       Control.Par.Class.Unsafe as PU
import System.IO.Unsafe (unsafePerformIO)
#endif


{-# INLINE runPar #-}
{-# INLINE spawn #-}
{-# INLINE spawn_ #-}
{-# INLINE spawnP #-}
{-# INLINE get #-}

data Par    a = Done   a
data Future a = Future a

runPar :: Par a -> a
runPar :: forall a. Par a -> a
runPar (Done a
x) = a
x

spawn_ :: Par a -> Par (Future a)
-- spawn_ a = do a' <- rpar (runPar a); return (Future a')
spawn_ :: forall a. Par a -> Par (Future a)
spawn_ Par a
a = let a' :: a
a' = forall a. Par a -> a
runPar Par a
a in a
a' forall a b. a -> b -> b
`par` forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Future a
Future a
a')

spawn :: NFData a => Par a -> Par (Future a)
spawn :: forall a. NFData a => Par a -> Par (Future a)
spawn Par a
a = let a' :: a
a' = forall a. Par a -> a
runPar Par a
a in a
a' forall a b. a -> b -> b
`par` forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Future a
Future (forall a. NFData a => a -> ()
rnf a
a' forall a b. a -> b -> b
`pseq` a
a'))

spawnP :: NFData a => a -> Par (Future a)
spawnP :: forall a. NFData a => a -> Par (Future a)
spawnP a
a = a
a forall a b. a -> b -> b
`par` forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Future a
Future (forall a. NFData a => a -> ()
rnf a
a forall a b. a -> b -> b
`pseq` a
a))

get :: Future a -> Par a
get :: forall a. Future a -> Par a
get (Future a
a) = a
a forall a b. a -> b -> b
`pseq` forall (m :: * -> *) a. Monad m => a -> m a
return a
a

--------------------------------------------------------------------------------
-- <boilerplate>

instance Monad Par where
  return :: forall a. a -> Par a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Done a
x >>= :: forall a b. Par a -> (a -> Par b) -> Par b
>>= a -> Par b
k = a -> Par b
k a
x

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

instance Functor Par where
   fmap :: forall a b. (a -> b) -> Par a -> Par b
fmap a -> b
f Par a
xs = Par a
xs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f

instance Applicative Par where
   <*> :: forall a b. Par (a -> b) -> Par a -> Par b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
   pure :: forall a. a -> Par a
pure  = forall a. a -> Par a
Done

instance MonadFix Par where
   mfix :: forall a. (a -> Par a) -> Par a
mfix = forall a. (a -> Par a) -> Par a
fixPar

-- | Take the monadic fixpoint of a 'Par' computation. This is
-- the definition of 'mfix' for 'Par'.
fixPar :: (a -> Par a) -> Par a
fixPar :: forall a. (a -> Par a) -> Par a
fixPar a -> Par a
f =
  let fr :: Par a
fr = a -> Par a
f (case Par a
fr of Done a
x -> a
x)
  in Par a
fr

#ifdef NEW_GENERIC
doio :: IO a -> Par a
doio io = let x = unsafePerformIO io in
          return $! x

instance PU.ParMonad Par where
  -- This is a No-Op for this monad.  Because there are no side-effects permitted,
  -- there is no way to observe whether anything happens on the child thread.
  -- fork _m = return ()
  -- FIXME: except for exceptions!!

  -- This version doesn't work, because the spark may get spilled/dropped:
  -- fork m = spawn m

  -- I think this is all that we're left with:
  fork m = m
  internalLiftIO = doio

instance PU.ParThreadSafe Par where
  unsafeParIO = doio

instance PN.ParFuture Par where
  type Future Par = Future
  type FutContents Par a = ()
  get    = get
  spawn  = spawn
  spawn_ = spawn_
  spawnP = spawnP
#endif

-- </boilerplate>
--------------------------------------------------------------------------------