Free Applicative Example

FreeAp.hs

module Main where

import Lib
import Data.Monoid 
import Data.Maybe 
import qualified Data.Map.Strict as Map
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
import Control.Applicative.Free

data TwitterHandle = TwitterHandle {  unTwitterHandle :: String }
  deriving (Show, Ord, Eq)

data SocialNetworkAction next =
  GetFollowers TwitterHandle ([TwitterHandle] -> next)

instance Functor SocialNetworkAction where
  fmap f (GetFollowers handle cont) = GetFollowers handle (f . cont)

getFollowers :: TwitterHandle -> DslA [TwitterHandle]
getFollowers handle = liftAp $ GetFollowers handle id

type DslA a = Ap SocialNetworkAction a

testProgram :: DslA ([TwitterHandle], [TwitterHandle])
testProgram =
  (,) <$> getFollowers (TwitterHandle "dan") <*> getFollowers (TwitterHandle "dan")

getFollowersIO :: TwitterHandle -> IO [TwitterHandle]
getFollowersIO handle = do
  print ("About to get:" <> show handle)
  threadDelay 1000000
  return [handle]

runSocialNetworkRequests :: Ap SocialNetworkAction a -> IO a
runSocialNetworkRequests (Pure a) = pure a
runSocialNetworkRequests (Ap (GetFollowers handle continuation) y) = do
  let action1 = getFollowersIO handle
  let action2 = runSocialNetworkRequests y
  (a1result, a2result) <- concurrently action1 action2
  return $ a2result (continuation a1result)

deduplicatingInterpreter :: Ap SocialNetworkAction a -> IO a
deduplicatingInterpreter p = go mempty p
  where
    go :: Map.Map TwitterHandle (Async [TwitterHandle]) -> Ap SocialNetworkAction a -> IO a
    go _ (Pure a) = pure a
    go xs (Ap (GetFollowers handle continuation) y) = do
        asyncGetFollowers <- maybe (async $ getFollowersIO handle) return (Map.lookup handle xs)
        let xs' = Map.insert handle asyncGetFollowers xs
        (action1, action2) <- concurrently (wait asyncGetFollowers) (go xs' y)
        return $ action2 (continuation action1)

getListOfRequests :: Ap SocialNetworkAction a -> [TwitterHandle]
getListOfRequests (Pure a) = []
getListOfRequests (Ap (GetFollowers handle _) n) = handle:(getListOfRequests n)

main :: IO ()
main = do
  deduplicatingInterpreter testProgram >>= printResult
  where
    printResult r = print ("result: " <> show r)