Add benchmarks

back/benchmarks/Main.hs

@@ -0,0 +1,49 @@
+-- | Module contains all stuff to migrate from AcidState to Postgres.
+module Main
+       (
+         main
+       ) where
+
+import Imports
+
+import Gauge
+import Hasql.Transaction.Sessions (Mode (..))
+
+import Guide.Database.Queries.Update
+import Guide.Database.Queries.Select
+import Guide.Types.Core
+import Guide.Database.Connection
+
+
+main :: IO ()
+main = do
+    conn <- connect
+    defaultMain [databaseBenchmark conn]
+  where
+    databaseBenchmark conn =
+      bgroup
+        "Database"
+        [ bench "select" $ nfIO $
+            runTransactionExceptT conn Read $ selectCategory "category1111"
+        , bench "updete" $ nfIO $
+            runTransactionExceptT conn Write $ updateCategory "category1111" update
+        ]
+    update :: Category -> Category
+    update = _categoryTitle .~ "title10"
+
+{-
+benchmarked Database/select
+time                 496.1 μs   (429.1 μs .. 551.4 μs)
+                     0.932 R²   (0.868 R² .. 0.976 R²)
+mean                 590.7 μs   (502.5 μs .. 939.6 μs)
+std dev              508.6 μs   (51.75 μs .. 1.065 ms)
+variance introduced by outliers: 97% (severely inflated)
+
+benchmarked Database/updete
+time                 497.4 μs   (429.4 μs .. 542.0 μs)
+                     0.900 R²   (0.825 R² .. 0.948 R²)
+mean                 1.429 ms   (520.2 μs .. 5.048 ms)
+std dev              6.175 ms   (104.7 μs .. 13.21 ms)
+variance introduced by outliers: 98% (severely inflated)
+
+-}

back/package.yaml

@@ -60,6 +60,8 @@ library:
   # You don't need to add modules here, all modules will be exposed automatically.
   #
   # exposed-modules:
+  ghc-options:
+    - -O
   dependencies:
   - acid-state
   - aeson
@@ -161,6 +163,7 @@ executables:
     # See https://github.com/sol/hpack/issues/182#issuecomment-310434881 for
     # the explanation of the quoting situation here.
     - '"-with-rtsopts=-T -N"'
+    - -O
     dependencies:
     - base
     - guide
@@ -197,3 +200,17 @@ tests:
     - temporary
     - webdriver
     - yaml
+
+benchmarks:
+  benchmarks:
+    main: Main.hs
+    source-dirs: benchmarks
+    dependencies:
+      - base <5
+      - guide
+      - gauge
+      - hasql
+      - hasql-transaction
+
+    ghc-options:
+    - -O

back/src/Guide/Markdown.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveAnyClass    #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE FlexibleInstances #-}
 
@@ -64,20 +65,35 @@ data MarkdownInline = MarkdownInline {
   markdownInlineSource   :: Text,
   markdownInlineHtml     :: ByteString,
   markdownInlineMarkdown :: ![MD.Node] }
-  deriving (Generic, Data, Eq)
+  deriving (Generic, Data, Eq, NFData)
 
 data MarkdownBlock = MarkdownBlock {
   markdownBlockSource   :: Text,
   markdownBlockHtml     :: ByteString,
   markdownBlockMarkdown :: ![MD.Node] }
-  deriving (Generic, Data, Eq)
+  deriving (Generic, Data, Eq, NFData)
 
 data MarkdownTree = MarkdownTree {
   markdownTreeSource    :: Text,
   markdownTreeStructure :: !(Document Text ByteString),
   markdownTreeIdPrefix  :: Text,
   markdownTreeTOC       :: Forest Heading }
-  deriving (Generic, Data, Eq)
+  deriving (Generic, Data, Eq, NFData)
+
+deriving instance NFData MD.Node
+deriving instance NFData MD.NodeType
+deriving instance NFData MD.ListAttributes
+deriving instance NFData MD.DelimType
+deriving instance NFData MD.ListType
+deriving instance NFData MD.PosInfo
+deriving instance NFData (WithSource [MD.Node])
+deriving instance (NFData b, NFData t) => NFData (Document t b)
+deriving instance (NFData b, NFData t) => NFData (Section t b)
+deriving instance NFData Heading
+-- instance NFData (Node a f) where
+--   rnf tree = foldl1 (seq . rnf) tree `seq` rnf (measure tree)
+  -- rnf = (`seq` ())
+  -- rnf (Node info nodeType nodes) = Node (rnf info) (rnf nodeType) (map rnf nodes)
 
 -- | Table-of-contents heading
 data Heading = Heading

back/src/Guide/Types/Core.hs

@@ -1,5 +1,6 @@
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 
 -- | Core types for content.
@@ -63,7 +64,7 @@ For an explanation of deriveSafeCopySorted, see Note [acid-state].
 data Trait = Trait {
   traitUid     :: Uid Trait,
   traitContent :: MarkdownInline }
-  deriving (Show, Generic, Data, Eq)
+  deriving (Show, Generic, Data, Eq, NFData)
 
 deriveSafeCopySorted 4 'extension ''Trait
 makeClassWithLenses ''Trait
@@ -161,7 +162,7 @@ data ItemSection
   = ItemProsConsSection
   | ItemEcosystemSection
   | ItemNotesSection
-  deriving (Eq, Ord, Show, Generic, Data)
+  deriving (Eq, Ord, Show, Generic, Data, NFData)
 
 deriveSafeCopySimple 0 'base ''ItemSection
 
@@ -203,7 +204,7 @@ data Item = Item {
   itemNotes       :: MarkdownTree,    -- ^ The notes section
   itemLink        :: Maybe Url        -- ^ Link to homepage or something
   }
-  deriving (Generic, Data, Eq, Show)
+  deriving (Generic, Data, Eq, Show, NFData)
 
 deriveSafeCopySorted 13 'extension ''Item
 makeClassWithLenses ''Item
@@ -267,7 +268,7 @@ data CategoryStatus
   = CategoryStub                -- ^ “Stub” = just created
   | CategoryWIP                 -- ^ “WIP” = work in progress
   | CategoryFinished            -- ^ “Finished” = complete or nearly complete
-  deriving (Eq, Show, Generic, Data)
+  deriving (Eq, Show, Generic, Data, NFData)
 
 deriveSafeCopySimple 2 'extension ''CategoryStatus
 
@@ -324,7 +325,7 @@ data Category = Category {
   -- 'ItemNotesSection', then notes will be shown for each item
   categoryEnabledSections :: Set ItemSection
   }
-  deriving (Generic, Data, Eq, Show)
+  deriving (Generic, Data, Eq, Show, NFData)
 
 deriveSafeCopySorted 13 'extension ''Category
 makeClassWithLenses ''Category

back/src/Guide/Uid.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveAnyClass    #-}
 
 -- | A type for unique identifiers.
 module Guide.Uid
@@ -24,7 +25,7 @@ newtype Uid a = Uid {uidToText :: Text}
   deriving stock (Generic, Eq, Ord, Data)
   deriving newtype
     (Read, Show, IsString, Buildable, ToHttpApiData, FromHttpApiData,
-     Hashable, ToJSON, FromJSON)
+     Hashable, ToJSON, FromJSON, NFData)
 
 ----------------------------------------------------------------------------
 -- Instances