    {-# 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' = 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 a. a -> Par 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 :: forall a. NFData a => Par a -> Par (Future a)
    spawn 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 a. a -> Par 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 :: forall a. NFData a => a -> Par (Future a)
    spawnP a
    a = a
    a a -> Par (Future a) -> Par (Future a)
    forall a b. a -> b -> b
    `par` Future a -> Par (Future a)
    forall a. a -> Par 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 :: forall a. Future a -> Par a
    get (Future a
    a) = a
    a a -> Par a -> Par a
    forall a b. a -> b -> b
    `pseq` a -> Par a
    forall a. a -> Par a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    a

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

    instance Monad Par where
      return :: forall a. a -> Par a
    return = a -> Par a
    forall a. a -> Par a
    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    = Future a -> Par a
    forall a. Future a -> Par a
    get
      spawn :: forall a. NFData a => Par a -> Par (Future a)
    spawn  = Par a -> Par (Future a)
    forall a. NFData a => Par a -> Par (Future a)
    spawn
      spawn_ :: forall a. Par a -> Par (Future a)
    spawn_ = Par a -> Par (Future a)
    forall a. Par a -> Par (Future a)
    spawn_
      spawnP :: forall a. NFData a => a -> Par (Future a)
    spawnP = a -> Par (Future a)
    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 Par a -> (a -> Par b) -> Par b
    forall a b. Par a -> (a -> Par b) -> Par b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= b -> Par b
    forall a. a -> Par a
    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
       <*> :: forall a b. 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 :: forall a. a -> Par a
    pure  = a -> Par a
    forall a. a -> Par a
    Done

    instance MonadFix Par where
       mfix :: forall a. (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 :: 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>
    --------------------------------------------------------------------------------