{-# 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 :: Par a -> a
runPar (Done x :: a
x) = a
x

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

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

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

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

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

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

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

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

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

instance MonadFix Par where
   mfix :: (a -> Par a) -> Par a
mfix = (a -> Par a) -> Par a
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 :: (a -> Par a) -> Par a
fixPar f :: a -> Par a
f =
  let fr :: Par a
fr = a -> Par a
f (case Par a
fr of Done x :: 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>
--------------------------------------------------------------------------------