fraxl-0.1.0.0: tests/MonadBench.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}

module Main where

import ExampleDataSource
import Control.Monad.Fraxl
import Control.Monad
import Data.Time.Clock
import System.Environment
import System.Exit
import System.IO
import Text.Printf

main :: IO ()
main = do
    [test,n_] <- getArgs
    let n = read n_
    t0 <- getCurrentTime
    case test of
      -- parallel, identical queries
      "par1" -> evalCachedFraxl (fetchExample |:| fetchNil) $
        void $ sequenceA (replicate n (listWombats 3 :: Fraxl '[ExampleReq] IO [Id]))
      -- parallel, distinct queries
      "par2" -> evalCachedFraxl (fetchExample |:| fetchNil) $
        void $ sequenceA (map listWombats [1..fromIntegral n] :: [Fraxl '[ExampleReq] IO [Id]])
      -- sequential, identical queries
      "seqr" -> evalCachedFraxl (fetchExample |:| fetchNil) $
        foldr andThen (return ()) (replicate n (listWombats 3 :: Fraxl '[ExampleReq] IO [Id]))
      -- sequential, left-associated, distinct queries
      "seql" -> evalCachedFraxl (fetchExample |:| fetchNil) $
        void $ foldl andThen (return []) (map listWombats [1.. fromIntegral n] :: [Fraxl '[ExampleReq] IO [Id]])
      "tree" -> evalCachedFraxl (fetchExample |:| fetchNil) $ void (tree n :: Fraxl '[ExampleReq] IO [Id])
      _ -> do
        hPutStrLn stderr "syntax: monadbench par1|par2|seqr|seql NUM"
        exitWith (ExitFailure 1)
    t1 <- getCurrentTime
    printf "%d reqs: %.2fs\n" n (realToFrac (t1 `diffUTCTime` t0) :: Double)
  where
    -- can't use >>, it is aliased to *> and we want the real bind here
    andThen x y = x >>= const y

tree :: MonadFraxl ExampleReq m => Int -> m [Id]
tree 0 = listWombats 0
tree n = concat <$> sequenceA
  [ tree (n-1)
  , listWombats (fromIntegral n), tree (n-1)
  ]