From 52adc799071f146ff6b0e8120ddb7f094c64f0e3 Mon Sep 17 00:00:00 2001
From: Nikita Volkov <nikita.y.volkov@mail.ru>
Date: Fri, 14 Apr 2017 00:46:59 +0300
Subject: [PATCH] Add profiling

---
 hasql.cabal       | 21 ++++++++++
 profile-events    |  9 +++++
 profiling/Main.hs | 98 +++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 128 insertions(+)
 create mode 100755 profile-events
 create mode 100644 profiling/Main.hs

diff --git a/hasql.cabal b/hasql.cabal
index 115c0d2..b86047e 100644
--- a/hasql.cabal
+++ b/hasql.cabal
@@ -181,3 +181,24 @@ benchmark benchmarks
     -- general:
     bug == 1.*,
     rerebase < 2
+
+
+test-suite profiling
+  type:
+    exitcode-stdio-1.0
+  hs-source-dirs:
+    profiling
+  main-is:
+    Main.hs
+  ghc-options:
+    -O2
+    -threaded
+    -rtsopts
+  default-extensions:
+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples
+  default-language:
+    Haskell2010
+  build-depends:
+    hasql,
+    bug == 1.*,
+    rerebase == 1.*
diff --git a/profile-events b/profile-events
new file mode 100755
index 0000000..d29393f
--- /dev/null
+++ b/profile-events
@@ -0,0 +1,9 @@
+#!/bin/bash
+set -eo pipefail
+
+cabal build profiling --ghc-options="-eventlog"
+cd dist
+build/profiling/profiling simple +RTS -N2 -ls -RTS
+ghc-events-analyze --timed --bucket-width 2 --bucket-height 14 --ms --tick-every 10 --buckets 500 --window Session profiling.eventlog
+open profiling.0.timed.svg
+threadscope profiling.eventlog
diff --git a/profiling/Main.hs b/profiling/Main.hs
new file mode 100644
index 0000000..b8b725c
--- /dev/null
+++ b/profiling/Main.hs
@@ -0,0 +1,98 @@
+module Main where
+
+import Prelude
+import Bug
+import qualified Hasql.Connection as A
+import qualified Hasql.Session as B
+import qualified Hasql.Query as C
+import qualified Hasql.Decoders as D
+import qualified Hasql.Encoders as E
+import qualified Data.Vector as F
+
+
+main =
+  do
+    Right connection <- acquireConnection
+    traceEventIO "START Session"
+    Right result <- B.run sessionWithManySmallResults connection
+    traceEventIO "STOP Session"
+    return ()
+  where
+    acquireConnection =
+      A.acquire settings
+      where
+        settings =
+          A.settings host port user password database
+          where
+            host = "localhost"
+            port = 5432
+            user = "postgres"
+            password = ""
+            database = "postgres"
+
+
+-- * Sessions
+-------------------------
+
+sessionWithManySmallParameters :: Vector (Int64, Int64) -> B.Session ()
+sessionWithManySmallParameters =
+  $(todo "sessionWithManySmallParameters")
+
+sessionWithSingleLargeResultInVector :: B.Session (Vector (Int64, Int64))
+sessionWithSingleLargeResultInVector =
+  B.query () queryWithManyRowsInVector
+
+sessionWithSingleLargeResultInList :: B.Session (List (Int64, Int64))
+sessionWithSingleLargeResultInList =
+  B.query () queryWithManyRowsInList
+
+sessionWithManySmallResults :: B.Session (Vector (Int64, Int64))
+sessionWithManySmallResults =
+  F.replicateM 1000 (B.query () queryWithSingleRow)
+
+
+-- * Statements
+-------------------------
+
+queryWithManyParameters :: C.Query (Vector (Int64, Int64)) ()
+queryWithManyParameters =
+  $(todo "statementWithManyParameters")
+
+queryWithSingleRow :: C.Query () (Int64, Int64)
+queryWithSingleRow =
+  C.statement template encoder decoder True
+  where
+    template =
+      "SELECT 1, 2"
+    encoder =
+      conquer
+    decoder =
+      D.singleRow row
+      where
+        row =
+          tuple <$> D.value D.int8 <*> D.value D.int8
+          where
+            tuple !a !b =
+              (a, b)
+
+queryWithManyRows :: (D.Row (Int64, Int64) -> D.Result result) -> C.Query () result
+queryWithManyRows decoder =
+  C.statement template encoder (decoder rowDecoder) True
+  where
+    template =
+      "SELECT generate_series(0,1000) as a, generate_series(1000,2000) as b"
+    encoder =
+      conquer
+    rowDecoder =
+      tuple <$> D.value D.int8 <*> D.value D.int8
+      where
+        tuple !a !b =
+          (a, b)
+
+queryWithManyRowsInVector :: C.Query () (Vector (Int64, Int64))
+queryWithManyRowsInVector =
+  queryWithManyRows D.rowsVector
+
+queryWithManyRowsInList :: C.Query () (List (Int64, Int64))
+queryWithManyRowsInList =
+  queryWithManyRows D.rowsList