Add profiling

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.*

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

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