Demonstrating how to use the Haxl library.

Main.hs

{-# LANGUAGE DeriveDataTypeable, GADTs, MultiParamTypeClasses, OverloadedStrings, StandaloneDeriving, TypeFamilies #-}
import Control.Applicative
import Control.Monad
import Data.Hashable
import Data.Typeable
import Haxl.Core
import Text.Printf


data E a where
    E :: String -> String -> E String
  deriving Typeable

data F a where
    F_1 :: String -> String -> F String
    F_2 :: String -> String -> F String
  deriving Typeable

runE :: E a -> ResultVar a -> IO ()
runE (E x y) var = putSuccess var (printf "E(%s,%s)" x y)

runF :: F a -> ResultVar a -> IO ()
runF (F_1 x y) var = putSuccess var (printf "F_1(%s,%s)" x y)
runF (F_2 x y) var = putSuccess var (printf "F_2(%s,%s)" x y)

deriving instance Show (E a)
deriving instance Show (F a)
deriving instance Eq (E a)
deriving instance Eq (F a)

instance DataSourceName E where
    dataSourceName _ = "E"
instance DataSourceName F where
    dataSourceName _ = "F"

instance Show1 E where
    show1 (E x y) = printf "E(%s,%s)" x y
instance Show1 F where
    show1 (F_1 x y) = printf "F_1(%s,%s)" x y
    show1 (F_2 x y) = printf "F_2(%s,%s)" x y

instance Hashable (E a) where
    hashWithSalt salt (E x y) = hashWithSalt salt (x, y)
instance Hashable (F a) where
    hashWithSalt salt (F_1 x y) = hashWithSalt salt (1 :: Int, x, y)
    hashWithSalt salt (F_2 x y) = hashWithSalt salt (2 :: Int, x, y)

instance StateKey E where
    data State E = NoStateE
instance StateKey F where
    data State F = NoStateF

traceRequests :: Show1 r => [BlockedFetch r] -> IO ()
traceRequests reqs = printf "Computing %s\n" (show strs)
  where
    strs = fmap showRequest reqs
    showRequest (BlockedFetch req _) = show1 req

instance DataSource () E where
    fetch _ _ _ reqs = SyncFetch $ do
        traceRequests reqs
        forM_ reqs $ \(BlockedFetch req var) -> runE req var
instance DataSource () F where
    fetch _ _ _ reqs = SyncFetch $ do
        traceRequests reqs
        forM_ reqs $ \(BlockedFetch req var) -> runF req var


initialState :: StateStore
initialState = stateSet NoStateE
             $ stateSet NoStateF
             $ stateEmpty


f_1 :: GenHaxl () String -> GenHaxl () String -> GenHaxl () String
f_1 x y = join (dataFetch <$> (F_1 <$> x <*> y))

f_2 :: GenHaxl () String -> GenHaxl () String -> GenHaxl () String
f_2 x y = join (dataFetch <$> (F_1 <$> x <*> y))

e :: GenHaxl () String -> GenHaxl () String -> GenHaxl () String
e x y = join (dataFetch <$> (E <$> x <*> y))

-- |
-- >>> main
-- Computing ["F_1(y',z')","F_1(x',y')","F_1(y,z)","F_1(x,y)"]
-- Computing ["E(F_1(x',y'),F_1(y',z'))","E(F_1(x,y),F_1(y,z))"]
-- Computing ["E(E(F_1(x,y),F_1(y,z)),E(F_1(x',y'),F_1(y',z')))"]
-- "E(E(F_1(x,y),F_1(y,z)),E(F_1(x',y'),F_1(y',z')))"
main :: IO ()
main = do
    myEnv <- initEnv initialState ()
    r <- runHaxl myEnv $ e (e (f_1 x y) (f_2 y z))
                           (e (f_1 x' y') (f_2 y' z'))
    print r
  where
    x, y, z, x', y', z' :: GenHaxl () String
    x = pure "x"
    y = pure "y"
    z = pure "z"
    x' = pure "x'"
    y' = pure "y'"
    z' = pure "z'"