yeah I'm thinking about Orc again

orca.hs

{- 
This came from looking at the source for the orc package on hackage.
I wanted to know why it works, and to see if I can come up with an
alternative implementation which does cool things, and possibly provide
a mechanism for orchestrating non-linear tube computations.
-}

-- | Pilfered from the orc package on Hackage.
-- The original is specialized to one MonadIO instance.
-- Also this looks suspiciously like a continuation monad.
newtype Orc m a = Orc { (#) :: (a -> m ()) -> m () }

instance MonadIO m => Functor (Orc m) where
    fmap f orc = Orc $ \k -> orc # (k . f)

instance MonadIO m => Applicative (Orc m) where
    pure x = Orc $ \k -> k x
    orcF <*> orcA = Orc (\k ->
        orcF # (\f ->
            orcA # (\a -> k (f a))))

instance MonadIO m => Monad (Orc m) where
    return = pure
    -- back in my day monads were triples of map, unit, and join tyvm
    ma >>= f = _join (fmap f ma) where
        _join orc = Orc $ \k -> orc # (\x -> x # k)

instance MonadTrans Orc where
    lift m = Orc (m >>=)

evalOrc :: MonadIO m => Orc m () -> m ()
evalOrc orc = orc # return

-- | Signal the cessation of an Orc computation.
stop :: MonadIO m => Orc m a
stop = Orc $ \_ -> return ()

-- | Hey I was right Orc is a continuation monad!
callCC :: MonadIO m => ((a -> Orc m b) -> Orc m a) -> Orc m a
callCC f = Orc $ \k -> (f (\x -> Orc $ \_ -> k x)) # k

-- 'callCC' demonstration. Kind of a tangent but it hints at the
-- deeper relationship between continuations and concurrency.
whatsYourName :: String -> IO ()
whatsYourName name =
    (# id) $ do
        response <- callCC $ \exit -> do
            validateName name exit
            return $ "Welcome, " ++ name
        return $ putStrLn $ "response: " ++ response

validateName :: (Applicative f, Foldable t)
             => t a -> (String -> f ()) -> f ()
validateName name exit = when (null name) (exit "fuck you")

-- ohay look delimited continuations, too
reset :: MonadIO m => Orc m () -> Orc m ()
reset = lift . evalOrc

shift :: MonadIO m => ((a -> m ()) -> Orc m ()) -> Orc m a
shift f = Orc (evalOrc . f)

{- * TODO

The following primitives must be implemented somehow. My strong suspicion is
that tubes will play a role in this, as they are both continuations and streams
returning more than once.

Additionally, oleg has shown that something like

  Tube a b (Tube a b m) ()
  
can effectively yield results asynchronously. Well, it permits asynchronous results
to be passed along as they come; ultimately asynchronicity is dependent on the runtime.

The function wrapped up inside
`Orc` needs only to produce the specified function - so taking an existing function
and using arbitrarily nested tubes is fine as long as the final function has that
signature.

-- | Parallel choice operator with no left or right bias. Returns
--   results as they become available.
par :: MonadIO m => Orc m a -> Orc m a -> Orc m a

Current implementation in the package:

  par :: Orc a -> Orc a -> Orc a
  par p q = Orc $ \k -> do
      fork (p # k)
      q # k

This *really* looks like

  someNestedTube p q = do
    lift p
    q

-- | Biased choice operator. Seems like it's the same as (>>) ...
(<+>) :: MonadIO m => Orc m a -> Orc m a

Current implementation:

  p <+> q = Orc $ \k -> do
      w <- newGroup
      local w $ fork (p # k)
      finished w
      q # k

{- |
Immediately fires up a thread for p, and then returns a handle to the first
result of that thread which is also of type Orc a. An invocation to eagerly
is non-blocking, while an invocation of the resulting handle is blocking.
-}
eagerly :: MonadIO m => Orc m a -> Orc m (Orc m a)


Current implementation:

    eagerly p = Orc $ \k -> do
        res <- newEmptyMVar
        w <- newGroup
        local w $ fork (p `saveOnce` (res,w))
        k (liftIO $ readMVar res)

    saveOnce :: Orc a -> (MVar a, Group) -> HIO ()
    p `saveOnce` (r,w) = do
        ticket <- newMVar ()
        p # \x -> (takeMVar ticket >> putMVar r x >> close w)

-- | Executes an orc computation, returns the first result, and discards the rest.
cut :: MonadIO m => Orc m a -> Orc m a
cut = join . eagerly

-}