promiseWrap.hs

promiseWrap.hs

{- stack
    --resolver lts-5.5
    --install-ghc
    runghc
  -}


{-# LANGUAGE ScopedTypeVariables, TupleSections #-}

import Data.IORef
import Control.Monad
import Control.Applicative
import Data.IntMap(IntMap)
import qualified Data.IntMap as Map
import Data.Bifunctor
import Data.Unique
import System.IO.Unsafe

----------
-- EVENT/PROMISE
----------

-- | A stream of occurences
newtype Event a = E ((a -> IO ()) -> IO (IO ()))

instance Functor Event where
  fmap f (E aProvider) = E $ \bSink ->
    aProvider $ contramapSink f bSink
    where
      contramapSink f aSink x = aSink (f x)

newEvent :: IO (a -> IO (), Event a)
newEvent = do
  ints  <- newIORef 0
  sinks <- newIORef Map.empty
  let insert sink = do
      modifyIORef ints succ
      i <- readIORef ints
      modifyIORef sinks (Map.insert i sink)
      pure $ modifyIORef sinks (Map.delete i)
  let dispatch value = do
      sinksNow <- readIORef sinks
      mapM_ ($ value) sinksNow
  pure (dispatch, E insert)

subscribe :: Event a -> (a -> IO ()) -> IO (IO ()) -- returns unsubscribe action
subscribe (E x) = x

filterJust :: Event (Maybe a) -> Event a
filterJust (E taProvider) = E $ \aSink -> do
  taProvider $ mapM_ aSink

-- | A value that might not be available yet.
data Promise a = F { getF :: (IO (Either a (Event a))) }
-- Invariant: The returned Event fires at most once

instance Functor Promise where
  fmap f (F k) = F $ fmap (bimap f (fmap f)) k

instance Applicative Promise where
  pure x = F $ pure $ Left $ x
  (<*>) = ap

instance Monad Promise where
  return = pure
  F m >>= k = F $ do
    aOrEa <- m
    getF $ case aOrEa of
      Left x -> k x
      Right e -> F $ do
        (u2, e2) <- newEvent
        subscribe e $ \ioAOrEa -> do
          aOrEa <- getF $ k ioAOrEa
          case aOrEa of
            Left a -> u2 (a)
            Right e3 -> subscribe e3 u2 >> pure () -- TODO unsub
        pure $ Right e2

-- | Create a promise and a callback to fulfill it.
newPromise :: IO (a -> IO (), Promise a)
newPromise = do
  (u, e') <- newEvent
  (u', e) <- newEvent -- this extra layer is to guard against >1 fulfill
  us <- subscribe e' u'
  v <- newIORef Nothing
  subscribe e (writeIORef v . Just)
  let f = F $ do
        x <- readIORef v
        pure $ case x of
          Just x -> Left x
          Nothing -> Right e
  pure (\x -> u x >> us, f)

-- | Call the callback immediatly, or as soon as fulfilled, and at most once.
whenFulfilled :: Promise a -> (a -> IO ()) -> IO ()
whenFulfilled (F k) u = do
  r <- k
  case r of
    Left x -> u x
    Right e -> void $ subscribe e u

liftIO :: IO a -> Promise a
liftIO k = F (fmap Left $ k)

promiseFromEvent :: Event a -> IO (Promise a) -- fulfilled on first occurence
promiseFromEvent e = do
  (u, f) <- newPromise
  subscribe e u
  pure f

----------
-- BASE API
----------

-- JSON
data JSON

-- Business logic
data Info = Info String deriving Show
data User = User String deriving Show

-- Serialize (with an extra "id" field)
userToJSON :: (Int, User) -> JSON
infoParseJSON  :: JSON -> (Int, Info) -- ignore parse errors

-- Transport
type URL = String
data Connection
open :: URL -> (JSON -> IO ()) -> IO Connection
send :: Connection -> JSON -> IO ()

[ infoParseJSON, userToJSON, open, send ] = error "Base API not implemented"

----------
-- SOLUTION
----------

data Session = S (JSON -> IO ()) (Event JSON)

newSession :: URL -> Promise Session
newSession url = liftIO $ do
  (cb, msgIn :: Event JSON) <- newEvent
  conn :: Connection <- open url cb
  pure $ S (send conn) msgIn

getUserInfo :: Session -> User -> Promise Info
getUserInfo (S msgOut msgIn) user =
  join $ liftIO $ do
    i <- hashUnique <$> newUnique
    result <- promiseFromEvent $ filterJust $ filterMsg i msgIn
    msgOut (userToJSON (i, user))
    pure result
  where
    filterMsg :: Int -> Event JSON -> Event (Maybe Info)
    filterMsg i msgs = flip fmap msgs $ \msg ->
      let  (i', info) = infoParseJSON msg in
        if i == i'
            then Just info
            else Nothing

main = flip whenFulfilled (print . ("Info:", )) $ do
  s <- newSession "ws://apilocation"
  getUserInfo s (User "hans")