Operational Monadの利用方法について

AsyncOperationalSample.hs

{-# LANGUAGE GADTs #-}

module Main where


import           Control.Concurrent        (threadDelay)
import           Control.Concurrent.Async
import           Control.Monad.Operational

-- Databaseから値を取得する処理
type Database a = Program DatabaseApi a

data DatabaseApi a where
    GetData :: DatabaseApi (Async Int)

getDataFromDb :: Database (Async Int)
getDataFromDb = singleton GetData


runDatabase :: Database a
            -> IO a
runDatabase = eval . view
    where
        eval :: ProgramView DatabaseApi a -> IO a
        eval (Return x) = return x
        eval (GetData :>>= k) = do
            x <- async dbAccess
            runDatabase (k x)

        dbAccess :: IO Int
        dbAccess = do
            _ <- threadDelay (1000 * 5000) -- 5s
            return 1


-- Httpから値を取得する処理
type Http a = Program HttpApi a

data HttpApi a where
    GetObject :: HttpApi (Async Int)

getDataFromHttp :: Http (Async Int)
getDataFromHttp = singleton GetObject


runHttp :: Http a
        -> IO a
runHttp = eval . view
    where
        eval :: ProgramView HttpApi a -> IO a
        eval (Return x) = return x
        eval (GetObject :>>= k) = do
            x <- async httpAccess
            runHttp (k x)

        httpAccess :: IO Int
        httpAccess = do
            _ <- threadDelay (1000 * 5000) -- 5s
            return 2


-- 2つの処理をまとめる
type DataOperation a = Program DataOperationApi a

data DataOperationApi a where
    DbOperation :: Database a -> DataOperationApi a
    HttpOperation :: Http a -> DataOperationApi a

runDataOperation :: DataOperation a
                 -> IO a
runDataOperation = eval . view
    where
        eval :: ProgramView DataOperationApi a -> IO a
        eval (Return x) = return x
        eval (DbOperation op :>>= k) = do
            r <- runDatabase op
            runDataOperation (k r)
        eval (HttpOperation op :>>= k) = do
            r <- runHttp op
            runDataOperation (k r)

liftDatabaseOp :: Database a
               -> DataOperation a
liftDatabaseOp op = singleton $ DbOperation op

liftHttpOp :: Http a
          -> DataOperation a
liftHttpOp op = singleton $ HttpOperation op


logic :: DataOperation (IO (Async Int))
logic = do
    db <- liftDatabaseOp getDataFromDb
    http <- liftHttpOp getDataFromHttp
    return $ async $ uncurry (+) <$> waitBoth db http


main :: IO ()
main = do
    r <- runDataOperation logic
    r1 <- wait <$> r
    print =<< r1

OperationalSample.hs

{-# LANGUAGE GADTs #-}

module Main where


import           Control.Monad.Operational

-- Databaseから値を取得する処理
type Database a = Program DatabaseApi a

data DatabaseApi a where
    GetData :: DatabaseApi Int

getDataFromDb :: Database Int
getDataFromDb = singleton GetData

runDatabase :: Database a
            -> IO a
runDatabase = eval . view
    where
        eval :: ProgramView DatabaseApi a -> IO a
        eval (Return x) = return x
        eval (GetData :>>= k) =
            runDatabase (k 1)


-- Httpから値を取得する処理
type Http a = Program HttpApi a

data HttpApi a where
    GetObject :: HttpApi Int

getDataFromHttp :: Http Int
getDataFromHttp = singleton GetObject

runHttp :: Http a
        -> IO a
runHttp = eval . view
    where
        eval :: ProgramView HttpApi a -> IO a
        eval (Return x) = return x
        eval (GetObject :>>= k) =
            runHttp (k 2)


-- 2つの処理をまとめる
type DataOperation a = Program DataOperationApi a

data DataOperationApi a where
    DbOperation :: Database a -> DataOperationApi a
    HttpOperation :: Http a -> DataOperationApi a

runDataOperation :: DataOperation a
                 -> IO a
runDataOperation = eval . view
    where
        eval :: ProgramView DataOperationApi a -> IO a
        eval (Return x) = return x
        eval (DbOperation op :>>= k) = do
            r <- runDatabase op
            runDataOperation (k r)
        eval (HttpOperation op :>>= k) = do
            r <- runHttp op
            runDataOperation (k r)

liftDatabaseOp :: Database a
               -> DataOperation a
liftDatabaseOp op = singleton $ DbOperation op

liftHttpOp :: Http a
          -> DataOperation a
liftHttpOp op = singleton $ HttpOperation op


logic :: DataOperation Int
logic = do
    db <- liftDatabaseOp getDataFromDb
    http <- liftHttpOp getDataFromHttp
    return $ db + http


main :: IO ()
main = print =<< runDataOperation logic -- 3が出力

OperationalWithConcurrently.hs

module Concurrent where


import           Control.Concurrent                   (threadDelay)
import           Control.Concurrent.Async.Lifted.Safe
import           Control.Monad.Operational


type Hoge a = Program HogeApi a

data HogeApi a where
    GetHoge :: Int -> HogeApi Int

getHoge :: Int -> Hoge Int
getHoge i = singleton $ GetHoge i


runHoge :: Hoge a -> IO a
runHoge = eval . view
    where
        eval :: ProgramView HogeApi a -> IO a
        eval (Return x) = return x
        eval (GetHoge i :>>= k) = do
            !_ <- threadDelay $ 1000 * 3000
            r <- return $ i * 2
            runHoge (k r)


type Fuga a = Program FugaApi a

data FugaApi a where
    GetFuga :: Int -> FugaApi Int

getFuga :: Int -> Fuga Int
getFuga i = singleton $ GetFuga i


runFuga :: Fuga a -> IO a
runFuga = eval . view
    where
        eval :: ProgramView FugaApi a -> IO a
        eval (Return x) = return x
        eval (GetFuga i :>>= k) = do
            !_ <- threadDelay $ 1000 * 3000
            r <- return $ i * 3
            runFuga (k r)


type HogeFuga a = Program HogeFugaApi a

data HogeFugaApi a where
    HogeService :: Hoge a -> HogeFugaApi a
    FugaService :: Fuga a -> HogeFugaApi a
    Concurrent :: Concurrently IO a -> HogeFugaApi a

liftHoge :: Hoge a -> HogeFuga a
liftHoge op = singleton $ HogeService op

liftFuga :: Fuga a -> HogeFuga a
liftFuga op = singleton $ FugaService op

concurrent :: Concurrently IO a -> HogeFuga a
concurrent op = singleton $ Concurrent op


runHogeFuga :: HogeFuga a -> IO a
runHogeFuga = eval . view
    where
        eval :: ProgramView HogeFugaApi a -> IO a
        eval (Return x) = return x
        eval (HogeService op :>>= k) = do
            r <- runHoge op
            runHogeFuga (k r)
        eval (FugaService op :>>= k) = do
            r <- runFuga op
            runHogeFuga (k r)
        eval (Concurrent op :>>= k) = do
            r <- runConcurrently op
            runHogeFuga (k r)


logicA :: HogeFuga Int
logicA = do
    (a,b,c) <- concurrent concurrentlyOperation
    return $ a + b + c
    where
        concurrentlyOperation = (,,) <$> Concurrently (runHogeFuga . liftHoge $ getHoge 10)
                                     <*> Concurrently (runHogeFuga . liftHoge $ getHoge 20)
                                     <*> Concurrently (runHogeFuga . liftFuga $ getFuga 20)


logicB :: Int -> HogeFuga String
logicB i
        | i >= 100 = return "Over 100"
        | otherwise = return "Other"

logic :: HogeFuga String
logic = logicA >>= logicB