haxl-demo.hs

{-# LANGUAGE
    GADTs, 
    ExistentialQuantification
 #-}

import Control.Monad
import Data.IORef
import Data.Sequence
import Data.Foldable

-- application-specific request
-- data Request a    
data Request a where
    WriteLog :: String -> Request String


data FetchStatus a 
  = NotFetched 
  | FetchSuccess a

-- wrap `Request a` with `IORef (FetchStatus a)`
data BlockedRequest = 
  forall a . BlockedRequest (Request a) 
                            (IORef (FetchStatus a))

-- Result blocked by seq of blocked requests and a continuation
data Result a 
  = Done a 
  | Blocked (Seq BlockedRequest) (Fetch a)

-- Fetch is an IO action of some Result
-- "record syntax", which is just syntactic sugar
-- data Fetch a = Fetch (IO (Result a))
newtype Fetch a = Fetch { unFetch :: IO (Result a) }

instance Applicative Fetch where
  pure = return

  Fetch f <*> Fetch x = Fetch $ do
    f' <- f
    x' <- x
    case (f', x') of
      (Done g,        Done y       ) -> return (Done (g y))
      (Done g,        Blocked br c ) -> return (Blocked br (g <$> c))
      (Blocked br c,  Done y       ) -> return (Blocked br (c <*> return y))
      (Blocked br1 c, Blocked br2 d) -> return (Blocked (br1 >< br2) (c <*> d))   -- concat seq

instance Monad Fetch where 
  return a = Fetch $ return (Done a)

  Fetch m >>= k = Fetch $ do
    r <- m 
    case r of
      Done a       -> unFetch (k a)
      Blocked br c -> return (Blocked br (c >>= k))

instance Functor Fetch where
  fmap f x = pure f <*> x


dataFetch :: Request a -> Fetch a
dataFetch request = Fetch $ do
  box <- newIORef NotFetched
  let br = BlockedRequest request box
  let cont = Fetch $ do
      FetchSuccess a <- readIORef box
      return $ Done a
  return (Blocked (singleton br) cont)    -- singleton :: a -> Seq a

-- abstract application-specific fetch
fetch :: [BlockedRequest] -> IO ()
fetch = mapM_ doOne 
  where
    doOne :: BlockedRequest -> IO ()
    doOne (BlockedRequest (WriteLog str) var) = do
      putStrLn $ "log:" ++ str        -- side effect
      putSuccess var str

putSuccess :: IORef (FetchStatus a) -> a -> IO ()
putSuccess r a = writeIORef r (FetchSuccess a)

runFetch :: Fetch a -> IO a 
runFetch (Fetch h) = do
  r <- h 
  case r of 
    Done a -> return a 
    Blocked br cont -> do 
      fetch (toList br) 
      runFetch cont

writelog :: String -> Fetch String
writelog str = dataFetch (WriteLog str)

logM :: Fetch String
logM = do
  a <- writelog "Hello"
  if a == "" then writelog "World" else writelog "Haxl"

logA :: Fetch String
logA = (++) <$> writelog "Hello" <*> writelog "World"

main :: IO String
main = do 
  runFetch logM
  -- runFetch logA