-- Copyright (c) 2014-present, Facebook, Inc.
-- All rights reserved.
--
-- This source code is distributed under the terms of a BSD license,
-- found in the LICENSE file.

{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | Psuedo-parallel operations.  Most users should import "Haxl.Core"
-- instead.
--
module Haxl.Core.Parallel
  ( -- * Parallel operations
    biselect
  , pAnd
  , pOr
  , unsafeChooseFirst
  ) where

import Haxl.Core.Monad hiding (catch, throw)
import Haxl.Core.Exception

import Control.Exception (throw)

-- -----------------------------------------------------------------------------
-- Parallel operations

-- Bind more tightly than .&&, .||
infixr 5 `pAnd`
infixr 4 `pOr`


biselect :: GenHaxl u w (Either a b)
         -> GenHaxl u w (Either a c)
         -> GenHaxl u w (Either a (b,c))
biselect :: GenHaxl u w (Either a b)
-> GenHaxl u w (Either a c) -> GenHaxl u w (Either a (b, c))
biselect GenHaxl u w (Either a b)
haxla GenHaxl u w (Either a c)
haxlb = (Either a b -> Either a b)
-> (Either a c -> Either a c)
-> (a -> Either a (b, c))
-> ((b, c) -> Either a (b, c))
-> GenHaxl u w (Either a b)
-> GenHaxl u w (Either a c)
-> GenHaxl u w (Either a (b, c))
forall l a b r c t u w.
(l -> Either a b)
-> (r -> Either a c)
-> (a -> t)
-> ((b, c) -> t)
-> GenHaxl u w l
-> GenHaxl u w r
-> GenHaxl u w t
biselect_opt Either a b -> Either a b
forall a. a -> a
id Either a c -> Either a c
forall a. a -> a
id a -> Either a (b, c)
forall a b. a -> Either a b
Left (b, c) -> Either a (b, c)
forall a b. b -> Either a b
Right GenHaxl u w (Either a b)
haxla GenHaxl u w (Either a c)
haxlb

{-# INLINE biselect_opt #-}
biselect_opt :: (l -> Either a b)
             -> (r -> Either a c)
             -> (a -> t)
             -> ((b,c) -> t)
             -> GenHaxl u w l
             -> GenHaxl u w r
             -> GenHaxl u w t
biselect_opt :: (l -> Either a b)
-> (r -> Either a c)
-> (a -> t)
-> ((b, c) -> t)
-> GenHaxl u w l
-> GenHaxl u w r
-> GenHaxl u w t
biselect_opt l -> Either a b
discrimA r -> Either a c
discrimB a -> t
left (b, c) -> t
right GenHaxl u w l
haxla GenHaxl u w r
haxlb =
  let go :: GenHaxl u w l -> GenHaxl u w r -> GenHaxl u w t
go (GenHaxl Env u w -> IO (Result u w l)
haxla) (GenHaxl Env u w -> IO (Result u w r)
haxlb) = (Env u w -> IO (Result u w t)) -> GenHaxl u w t
forall u w a. (Env u w -> IO (Result u w a)) -> GenHaxl u w a
GenHaxl ((Env u w -> IO (Result u w t)) -> GenHaxl u w t)
-> (Env u w -> IO (Result u w t)) -> GenHaxl u w t
forall a b. (a -> b) -> a -> b
$ \Env u w
env -> do
        Result u w l
ra <- Env u w -> IO (Result u w l)
haxla Env u w
env
        case Result u w l
ra of
          Done l
ea ->
            case l -> Either a b
discrimA l
ea of
              Left a
a -> Result u w t -> IO (Result u w t)
forall (m :: * -> *) a. Monad m => a -> m a
return (t -> Result u w t
forall u w a. a -> Result u w a
Done (a -> t
left a
a))
              Right b
b -> do
                  Result u w r
rb <- Env u w -> IO (Result u w r)
haxlb Env u w
env
                  case Result u w r
rb of
                    Done r
eb ->
                      case r -> Either a c
discrimB r
eb of
                        Left a
a -> Result u w t -> IO (Result u w t)
forall (m :: * -> *) a. Monad m => a -> m a
return (t -> Result u w t
forall u w a. a -> Result u w a
Done (a -> t
left a
a))
                        Right c
c -> Result u w t -> IO (Result u w t)
forall (m :: * -> *) a. Monad m => a -> m a
return (t -> Result u w t
forall u w a. a -> Result u w a
Done ((b, c) -> t
right (b
b,c
c)))
                    Throw SomeException
e -> Result u w t -> IO (Result u w t)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeException -> Result u w t
forall u w a. SomeException -> Result u w a
Throw SomeException
e)
                    Blocked IVar u w b
ib Cont u w r
haxlb' ->
                      Result u w t -> IO (Result u w t)
forall (m :: * -> *) a. Monad m => a -> m a
return (IVar u w b -> Cont u w t -> Result u w t
forall u w a b. IVar u w b -> Cont u w a -> Result u w a
Blocked IVar u w b
ib
                              (Cont u w r
haxlb' Cont u w r -> (r -> GenHaxl u w t) -> Cont u w t
forall u w a b. Cont u w b -> (b -> GenHaxl u w a) -> Cont u w a
:>>= \r
b' -> b -> r -> GenHaxl u w t
forall (m :: * -> *). Monad m => b -> r -> m t
go_right b
b r
b'))
          Throw SomeException
e -> Result u w t -> IO (Result u w t)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeException -> Result u w t
forall u w a. SomeException -> Result u w a
Throw SomeException
e)
          Blocked IVar u w b
ia Cont u w l
haxla' -> do
            Result u w r
rb <- Env u w -> IO (Result u w r)
haxlb Env u w
env
            case Result u w r
rb of
              Done r
eb ->
                case r -> Either a c
discrimB r
eb of
                  Left a
a -> Result u w t -> IO (Result u w t)
forall (m :: * -> *) a. Monad m => a -> m a
return (t -> Result u w t
forall u w a. a -> Result u w a
Done (a -> t
left a
a))
                  Right c
c ->
                     Result u w t -> IO (Result u w t)
forall (m :: * -> *) a. Monad m => a -> m a
return (IVar u w b -> Cont u w t -> Result u w t
forall u w a b. IVar u w b -> Cont u w a -> Result u w a
Blocked IVar u w b
ia
                             (Cont u w l
haxla' Cont u w l -> (l -> GenHaxl u w t) -> Cont u w t
forall u w a b. Cont u w b -> (b -> GenHaxl u w a) -> Cont u w a
:>>= \l
a' -> l -> c -> GenHaxl u w t
forall (m :: * -> *). Monad m => l -> c -> m t
go_left l
a' c
c))
              Throw SomeException
e -> Result u w t -> IO (Result u w t)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeException -> Result u w t
forall u w a. SomeException -> Result u w a
Throw SomeException
e)
              Blocked IVar u w b
ib Cont u w r
haxlb' -> do
                IVar u w ()
i <- IO (IVar u w ())
forall u w a. IO (IVar u w a)
newIVar
                Env u w -> GenHaxl u w () -> IVar u w () -> IVar u w b -> IO ()
forall u w b a.
Env u w -> GenHaxl u w b -> IVar u w b -> IVar u w a -> IO ()
addJob Env u w
env (() -> GenHaxl u w ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) IVar u w ()
i IVar u w b
ia
                Env u w -> GenHaxl u w () -> IVar u w () -> IVar u w b -> IO ()
forall u w b a.
Env u w -> GenHaxl u w b -> IVar u w b -> IVar u w a -> IO ()
addJob Env u w
env (() -> GenHaxl u w ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) IVar u w ()
i IVar u w b
ib
                Result u w t -> IO (Result u w t)
forall (m :: * -> *) a. Monad m => a -> m a
return (IVar u w () -> Cont u w t -> Result u w t
forall u w a b. IVar u w b -> Cont u w a -> Result u w a
Blocked IVar u w ()
i (GenHaxl u w t -> Cont u w t
forall u w a. GenHaxl u w a -> Cont u w a
Cont (GenHaxl u w l -> GenHaxl u w r -> GenHaxl u w t
go (Cont u w l -> GenHaxl u w l
forall u w a. Cont u w a -> GenHaxl u w a
toHaxl Cont u w l
haxla') (Cont u w r -> GenHaxl u w r
forall u w a. Cont u w a -> GenHaxl u w a
toHaxl Cont u w r
haxlb'))))
                -- The code above makes sure that the computation
                -- wakes up whenever either 'ia' or 'ib' is filled.
                -- The ivar 'i' is used as a synchronisation point
                -- for the whole computation, and we make sure that
                -- whenever 'ia' or 'ib' are filled in then 'i' will
                -- also be filled.

      go_right :: b -> r -> m t
go_right b
b r
eb =
        case r -> Either a c
discrimB r
eb of
          Left a
a -> t -> m t
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> t
left a
a)
          Right c
c -> t -> m t
forall (m :: * -> *) a. Monad m => a -> m a
return ((b, c) -> t
right (b
b,c
c))
      go_left :: l -> c -> m t
go_left l
ea c
c =
        case l -> Either a b
discrimA l
ea of
          Left a
a -> t -> m t
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> t
left a
a)
          Right b
b -> t -> m t
forall (m :: * -> *) a. Monad m => a -> m a
return ((b, c) -> t
right (b
b,c
c))
  in GenHaxl u w l -> GenHaxl u w r -> GenHaxl u w t
forall u w. GenHaxl u w l -> GenHaxl u w r -> GenHaxl u w t
go GenHaxl u w l
haxla GenHaxl u w r
haxlb

-- | Parallel version of '(.||)'.  Both arguments are evaluated in
-- parallel, and if either returns 'True' then the other is
-- not evaluated any further.
--
-- WARNING: exceptions may be unpredictable when using 'pOr'.  If one
-- argument returns 'True' before the other completes, then 'pOr'
-- returns 'True' immediately, ignoring a possible exception that
-- the other argument may have produced if it had been allowed to
-- complete.
pOr :: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool
pOr :: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool
pOr GenHaxl u w Bool
x GenHaxl u w Bool
y = (Bool -> Either () ())
-> (Bool -> Either () ())
-> (() -> Bool)
-> (((), ()) -> Bool)
-> GenHaxl u w Bool
-> GenHaxl u w Bool
-> GenHaxl u w Bool
forall l a b r c t u w.
(l -> Either a b)
-> (r -> Either a c)
-> (a -> t)
-> ((b, c) -> t)
-> GenHaxl u w l
-> GenHaxl u w r
-> GenHaxl u w t
biselect_opt Bool -> Either () ()
discrim Bool -> Either () ()
discrim () -> Bool
forall p. p -> Bool
left ((), ()) -> Bool
forall p. p -> Bool
right GenHaxl u w Bool
x GenHaxl u w Bool
y
  where
    discrim :: Bool -> Either () ()
discrim Bool
True = () -> Either () ()
forall a b. a -> Either a b
Left ()
    discrim Bool
False = () -> Either () ()
forall a b. b -> Either a b
Right ()
    left :: p -> Bool
left p
_ = Bool
True
    right :: p -> Bool
right p
_ = Bool
False

-- | Parallel version of '(.&&)'.  Both arguments are evaluated in
-- parallel, and if either returns 'False' then the other is
-- not evaluated any further.
--
-- WARNING: exceptions may be unpredictable when using 'pAnd'.  If one
-- argument returns 'False' before the other completes, then 'pAnd'
-- returns 'False' immediately, ignoring a possible exception that
-- the other argument may have produced if it had been allowed to
-- complete.
pAnd :: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool
pAnd :: GenHaxl u w Bool -> GenHaxl u w Bool -> GenHaxl u w Bool
pAnd GenHaxl u w Bool
x GenHaxl u w Bool
y = (Bool -> Either () ())
-> (Bool -> Either () ())
-> (() -> Bool)
-> (((), ()) -> Bool)
-> GenHaxl u w Bool
-> GenHaxl u w Bool
-> GenHaxl u w Bool
forall l a b r c t u w.
(l -> Either a b)
-> (r -> Either a c)
-> (a -> t)
-> ((b, c) -> t)
-> GenHaxl u w l
-> GenHaxl u w r
-> GenHaxl u w t
biselect_opt Bool -> Either () ()
discrim Bool -> Either () ()
discrim () -> Bool
forall p. p -> Bool
left ((), ()) -> Bool
forall p. p -> Bool
right GenHaxl u w Bool
x GenHaxl u w Bool
y
  where
    discrim :: Bool -> Either () ()
discrim Bool
False = () -> Either () ()
forall a b. a -> Either a b
Left ()
    discrim Bool
True = () -> Either () ()
forall a b. b -> Either a b
Right ()
    left :: p -> Bool
left p
_ = Bool
False
    right :: p -> Bool
right p
_ = Bool
True

-- | This function takes two haxl computations as input, and returns the
-- output of whichever computation finished first. This is clearly
-- non-deterministic in its output and exception behavior, be careful when
-- using it.
unsafeChooseFirst
  :: GenHaxl u w a
  -> GenHaxl u w b
  -> GenHaxl u w (Either a b)
unsafeChooseFirst :: GenHaxl u w a -> GenHaxl u w b -> GenHaxl u w (Either a b)
unsafeChooseFirst GenHaxl u w a
x GenHaxl u w b
y = (a -> Either (Either a b) ())
-> (b -> Either (Either a b) ())
-> (Either a b -> Either a b)
-> (((), ()) -> Either a b)
-> GenHaxl u w a
-> GenHaxl u w b
-> GenHaxl u w (Either a b)
forall l a b r c t u w.
(l -> Either a b)
-> (r -> Either a c)
-> (a -> t)
-> ((b, c) -> t)
-> GenHaxl u w l
-> GenHaxl u w r
-> GenHaxl u w t
biselect_opt a -> Either (Either a b) ()
forall a b. a -> Either (Either a b) ()
discrimx b -> Either (Either a b) ()
forall b a. b -> Either (Either a b) ()
discrimy Either a b -> Either a b
forall a. a -> a
id ((), ()) -> Either a b
forall p a. p -> a
right GenHaxl u w a
x GenHaxl u w b
y
  where
    discrimx :: a -> Either (Either a b) ()
    discrimx :: a -> Either (Either a b) ()
discrimx a
a = Either a b -> Either (Either a b) ()
forall a b. a -> Either a b
Left (a -> Either a b
forall a b. a -> Either a b
Left a
a)

    discrimy :: b -> Either (Either a b) ()
    discrimy :: b -> Either (Either a b) ()
discrimy b
b = Either a b -> Either (Either a b) ()
forall a b. a -> Either a b
Left (b -> Either a b
forall a b. b -> Either a b
Right b
b)

    right :: p -> a
right p
_ = CriticalError -> a
forall a e. Exception e => e -> a
throw (CriticalError -> a) -> CriticalError -> a
forall a b. (a -> b) -> a -> b
$ Text -> CriticalError
CriticalError
      Text
"unsafeChooseFirst: We should never have a 'Right ()'"