Free Applicative Example

FreeAp.hs

module Main where

import Lib
import Data.Monoid
import Data.Map (Map)
import Data.Maybe
import qualified Data.Map 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], [TwitterHandle])
testProgram =
  (,,) <$> getFollowers (TwitterHandle "dan") <*> getFollowers (TwitterHandle "Thomas") <*> getFollowers (TwitterHandle "Thomas")

getFollowersIO :: TwitterHandle -> IO [TwitterHandle]
getFollowersIO handle =
  print handle >> threadDelay 2000000 >> return [handle]

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

dedupeConcurrentInterpret :: Map TwitterHandle (Async [TwitterHandle]) -> Ap SocialNetworkAction a -> IO a
dedupeConcurrentInterpret cache (Pure a) = return a
dedupeConcurrentInterpret cache (Ap (GetFollowers handle continuation) y) = do
  action1 <- maybe (async $ getFollowersIO handle) return (Map.lookup handle cache)
  let cache' = Map.insert handle action1 cache
  let action2 = dedupeConcurrentInterpret cache' y
  (a1result, a2result) <- concurrently (wait action1) action2
  return $ a2result (continuation a1result)

interpreter :: SocialNetworkAction a -> IO a
interpreter (GetFollowers handle n) = do
  print $ "Starting to get " <> show handle
  threadDelay 1000000
  return $ n [TwitterHandle "Brownie"]

main :: IO ()
main =
  --runAp interpreter testProgram >>  = print
  -- print $ retractAp testProgram
  print =<< dedupeConcurrentInterpret mempty testProgram