find.hs

----------------------------------------------------
-- The 'Find' monad

-- | A 'Find' computation of type represents a search problem which may result in an 'a' (or nothing at all) operating in a monad 'm'. The contract is that if there are any 'a's which could be returned, then one must be.
newtype Find m a = Find { unFind :: m (Maybe a) }

instance MonadConc m => Functor (Find m) where
  fmap f (Find ma) = Find $ fmap (fmap f) ma

instance MonadConc m => Applicative (Find m) where
  pure = return

  f <*> a = do
    -- Register interest in @f@ and @a@.
    requires f
    requires a

    -- Block until things interested in all succeed, or fail if one fails.
    block

    -- Return result.
    f' <- f
    a' <- a
    return $ f' a'

instance MonadConc m => Monad (Find m) where
  return a = Find (return $ Just a)

  (Find ma) >>= (Find mf) = Find $ do
    a <- ma
    case a of
      Just a' -> do
        f <- mf
        case f of
          Just f' -> return . Just $ f' a'
          Nothing -> return Nothing
      Nothing -> return Nothing

  fail _ = Find $ return Nothing

-- | The Alternative and MonadPlus instances just say we can choose between two things in a sane way. Specifically, by one which successfully evaluates.
instance MonadConc m => Alternative (Find m) where
  empty = fail ""
  a <|> b = oneOf [a, b]

instance MonadConc m => MonadPlus (Find m) where
  mzero = empty
  mplus = (<|>)

-- | Run a search problem and cleverly allocate tasks to processors to make it speedy.
runFind :: MonadConc m => Find m a -> m (Maybe a)

----------------------------------------------------
-- Some functions

-- | Find a thing in a list which satisfies some predicate.
findIn :: MonadConc m => (a -> Bool) -> [a] -> Find m a
findIn f as = oneOf [if f a then a `seq` success a else failure | a <- as]

-- | 'findIn' in operator form.
(!) :: MonadConc m -> [a] -> (a -> Bool) -> Find m a
(!) = flip findIn

-- | Find a thing from two different sources which satisfies a predicate.
findEither :: MonadConc m => (a -> Bool) -> (b -> Bool) -> [a] -> [b] -> Find (Either a b)
findEither f g as bs = (Left <$> findIn f as) <|> (Right <$> findIn g bs)

-- | Find things from two different sources which satisfy a predicate.
--
-- An alternative formulation could be:
--
-- > findBoth f g as bs = do
-- >   a <- findIn f as
-- >   b <- findIn g bs
-- >   return (a, b)
--
-- But this imposes a sequencing between the first and second 'findIn's, causing a loss of parallelism.
-- The applicative instance can overcome this, as it doesn't need to pull a value out and then plug it back in.
findBoth :: MonadConc m => (a -> Bool) -> (b -> Bool) -> [a] -> [b] -> Find (a, b)
findBoth f g as bs = (,) <$> findIn f as <*> findIn g bs

-- | Computation which always succeeds with a value (same as 'return').
success :: MonadConc m => a -> Find m a
success = return

-- | Computation which never succeeds (same as 'empty'/'mzero').
failure :: MonadConc m => Find m a
failure = mzero

-- | Start executing in parallel, and when one non-failing solution is found kill the still executing tasks.
oneOf :: MonadConc m => [Find m a] -> Find m a
oneOf = -- magical primitive function, this would queue up work items to the worker threads spawned by 'runFind'.

----------------------------------------------------
-- Magical primitives

-- | Specify that the current computation requires the value of this one.
requires :: MonadConc m => Find m a -> Find m ()

-- | Block until every required computation succeeds, or fail if any one does.
block :: MonadConc m => Find m ()