content: {-# LANGUAGE RecordWildCards #-}
  
  import Benchmark.Prelude
  import Criterion.Main
  import qualified Data.Acid as Acid
  import qualified Data.Acid.Memory as Memory
  import qualified Benchmark.FileSystem as FS
  import qualified Benchmark.Model as Model; import Benchmark.Model (Model)
  import qualified System.Random as Random
  
  
  main :: IO ()
  main = defaultMain [benchmark defaultBenchmarkInterfaces [100,200,300,400]]
  
  benchmark :: [BenchmarkInterface] -> [Int] -> Benchmark
  benchmark bis sizes = env setupWorkingPath $ \ workingPath ->
      bgroup "" $ map (benchmarksGroup bis workingPath) sizes
  
  
  -- | An acid-state interface to be benchmarked.
  data BenchmarkInterface = forall m .
      BenchmarkInterface
          { benchName    :: String
            -- ^ Name of the interface, for use in constructing benchmarks.
          , benchPersist :: Bool
            -- ^ Does this interface actually persist data to disk? If
            -- it doesn't, some benchmarks are not applicable.
          , benchOpen    :: FS.FilePath -> IO (Acid.AcidState m)
            -- ^ Open an acid-state component with the given path.  Note
            -- that the type of the state is encapsulated within
            -- 'BenchmarkInterface'.
          , benchUpdate  :: Acid.AcidState m -> [[Int]] -> IO ()
            -- ^ Execute an 'insert' update against the acid-state.
          , benchQuery   :: Acid.AcidState m -> IO Int
            -- ^ Execute a 'sumUp' query against the state.
          }
  
  memoryBenchmarkInterface :: BenchmarkInterface
  memoryBenchmarkInterface =
      BenchmarkInterface { benchName    = "Memory"
                         , benchPersist = False
                         , benchOpen    = const $ Memory.openMemoryState mempty
                         , benchUpdate  = \ inst v -> Acid.update inst (Model.Insert v)
                         , benchQuery   = \ inst -> Acid.query inst Model.SumUp
                         }
  
  localBenchmarkInterface :: BenchmarkInterface
  localBenchmarkInterface =
      BenchmarkInterface { benchName    = "Local"
                         , benchPersist = True
                         , benchOpen    = \ p -> Acid.openLocalStateFrom (FS.encodeString p) mempty
                         , benchUpdate  = \ inst v -> Acid.update inst (Model.Insert v)
                         , benchQuery   = \ inst -> Acid.query inst Model.SumUp
                         }
  
  defaultBenchmarkInterfaces :: [BenchmarkInterface]
  defaultBenchmarkInterfaces = [memoryBenchmarkInterface, localBenchmarkInterface]
  
  
  setupWorkingPath :: IO FS.FilePath
  setupWorkingPath = do
    workingPath <- do workingPath <- FS.getTemporaryDirectory
                      rndStr <- replicateM 16 $ Random.randomRIO ('a', 'z')
                      return $ workingPath <> "acid-state" <> "benchmarks" <> "loading" <> FS.decodeString rndStr
    putStrLn $ "Working under the following temporary directory: " ++ FS.encodeString workingPath
    FS.removeTreeIfExists workingPath
    FS.createTree workingPath
    return workingPath
  
  
  benchmarksGroup :: [BenchmarkInterface] -> FS.FilePath -> Int -> Benchmark
  benchmarksGroup bis workingPath size =
    bgroup (show size)
    [ bgroup (benchName bi) $
        initializeBenchmarksGroup bi workingPath' size
      : if benchPersist bi then [openCloseBenchmarksGroup  bi workingPath' size] else []
    | bi <- bis
    ]
    where
      workingPath' = workingPath <> FS.decodeString (show size)
  
  
  -- | The Initialize benchmarks measure how long it takes to open an
  -- empty 'AcidState' component, call 'initialize' to populate it with
  -- data, and optionally checkpoint before closing.
  initializeBenchmarksGroup :: BenchmarkInterface -> FS.FilePath -> Int -> Benchmark
  initializeBenchmarksGroup bi workingPath size =
    bgroup "Initialize"
    [ bench "Without checkpoint" $ perRunEnv (prepareInitialize bi workingPath) $ \ _ ->
          initializeClose bi workingPath size
    , bench "With checkpoint" $ perRunEnv (prepareInitialize bi workingPath) $ \ _ ->
          initializeCheckpointClose bi workingPath size
    ]
  
  prepareInitialize :: BenchmarkInterface -> FS.FilePath -> IO ()
  prepareInitialize bi workingPath =
      when (benchPersist bi) $ do FS.removeTreeIfExists workingPath
                                  FS.createTree workingPath
  
  
  -- | The OpenClose benchmarks measure how long it takes to open an
  -- existing on-disk 'AcidState' component (either from a checkpoint or
  -- from a transaction log), optionally execute a query over the entire
  -- state, then close.  These benchmarks are not applicable if the
  -- interface being benchmarked does not persist data.
  openCloseBenchmarksGroup :: BenchmarkInterface -> FS.FilePath -> Int -> Benchmark
  openCloseBenchmarksGroup bi workingPath size =
    env (prepareOpenCloseBenchmarksGroup bi workingPath size) $ \ ~(logsInstancePath, checkpointInstancePath) -> bgroup "OpenClose"
      [
        bench "From Logs" $ nfIO $
          openClose bi logsInstancePath
      , bench "From Checkpoint" $ nfIO $
          openClose bi checkpointInstancePath
      , bench "From Logs (with query)" $ nfIO $
          openQueryClose bi logsInstancePath
      , bench "From Checkpoint (with query)" $ nfIO $
          openQueryClose bi checkpointInstancePath
      ]
  
  -- | Set up data on disk for the open/close benchmarks.  This
  -- initializes an instance, creates a copy of it (for restoring from
  -- transaction logs), then checkpoints.
  prepareOpenCloseBenchmarksGroup :: BenchmarkInterface -> FS.FilePath -> Int -> IO (FS.FilePath, FS.FilePath)
  prepareOpenCloseBenchmarksGroup bi workingPath size = do
    putStrLn $ "Preparing instances for size " ++ show size
  
    let
      logsInstancePath = workingPath <> "logs-instance"
      checkpointInstancePath = workingPath <> "checkpoint-instance"
  
    FS.createTree logsInstancePath
    FS.createTree checkpointInstancePath
  
    putStrLn "Initializing"
    initialize bi checkpointInstancePath size $ \inst -> do
  
      putStrLn "Copying"
      FS.copy checkpointInstancePath logsInstancePath
      FS.removeFile $ logsInstancePath <> "open.lock"
  
      putStrLn "Checkpointing"
      Acid.createCheckpoint inst
  
      putStrLn "Closing"
      Acid.closeAcidState inst
  
      return (logsInstancePath, checkpointInstancePath)
  
  
  initialize :: BenchmarkInterface -> FS.FilePath ->  Int -> (forall m . Acid.AcidState m -> IO r) -> IO r
  initialize BenchmarkInterface{..} p size k = do
      inst <- benchOpen p
      let values = replicate size $ replicate 100 $ replicate 100 1
      mapM_ (benchUpdate inst) values
      k inst
  
  initializeClose :: BenchmarkInterface -> FS.FilePath -> Int -> IO ()
  initializeClose bi p size = initialize bi p size Acid.closeAcidState
  
  initializeCheckpointClose :: BenchmarkInterface -> FS.FilePath -> Int -> IO ()
  initializeCheckpointClose bi p size =
    initialize bi p size $ \ inst -> do
      Acid.createCheckpoint inst
      Acid.closeAcidState inst
  
  
  openClose :: BenchmarkInterface -> FS.FilePath -> IO ()
  openClose BenchmarkInterface{..} p = benchOpen p >>= Acid.closeAcidState
  
  openQueryClose :: BenchmarkInterface -> FS.FilePath -> IO Int
  openQueryClose BenchmarkInterface{..} p = do
      inst <- benchOpen p
      n <- benchQuery inst
      Acid.closeAcidState inst
      return n
  