Compile time benchmarking

persistent-template/Database/Persist/TH.hs

@@ -867,7 +867,7 @@ mkKeyTypeDec mps t = do
                then do pfDec <- pfInstD
                        return (pfDec, supplement [''Show, ''Read, ''Eq, ''Ord, ''Generic])
                 else do
-                    let allInstances = supplement [''Show, ''Read, ''Eq, ''Ord, ''PathPiece, ''ToHttpApiData, ''FromHttpApiData, ''PersistField, ''PersistFieldSql, ''ToJSON, ''FromJSON]
+                    let allInstances = supplement [''Show, ''Read, ''Eq, ''Ord, ''PathPiece, ''PersistField, ''PersistFieldSql, ''ToJSON, ''FromJSON]
                     if customKeyType
                       then return ([], allInstances)
                       else do
@@ -926,8 +926,6 @@ mkKeyTypeDec mps t = do
              deriving newtype instance Read (BackendKey $(pure backendT)) => Read (Key $(pure recordType))
              deriving newtype instance Eq (BackendKey $(pure backendT)) => Eq (Key $(pure recordType))
              deriving newtype instance Ord (BackendKey $(pure backendT)) => Ord (Key $(pure recordType))
-             deriving newtype instance ToHttpApiData (BackendKey $(pure backendT)) => ToHttpApiData (Key $(pure recordType))
-             deriving newtype instance FromHttpApiData (BackendKey $(pure backendT)) => FromHttpApiData(Key $(pure recordType))
              deriving newtype instance PathPiece (BackendKey $(pure backendT)) => PathPiece (Key $(pure recordType))
              deriving newtype instance PersistField (BackendKey $(pure backendT)) => PersistField (Key $(pure recordType))
              deriving newtype instance PersistFieldSql (BackendKey $(pure backendT)) => PersistFieldSql (Key $(pure recordType))

persistent-template/compile-time-testing/README.md

@@ -0,0 +1,52 @@
+This directory contains example projects to compile, for the purpose of testing reducing compilation time of Persistent models. Ideally the projects are varied, from intentional test cases (e.g. 10 models each with 100 fields) to real world projects.
+
+The current projects are:
+
+* `Mercury`. Copied from a production codebase, with modifications (mostly changing enums to `Text`). 42 models. Features UUID primary keys, composite primary keys, and timestamp fields.
+
+The recommended testing procedure is:
+
+### Dependencies
+
+* [`bench`](https://hackage.haskell.org/package/bench), a command-line wrapper around [`criterion`](https://hackage.haskell.org/package/criterion)
+* `uuidgen`, to generate a random file name.
+* `ruby`, to run a script to aggregate timings.
+
+
+### Procedure
+
+1. Starting from `master`, build your example project. You want it such that future runs will have all of its dependencies built. Also add the `-ddump-timings` and `-ddump-to-file` flags so you can see where the generated file is:
+
+```
+stack build PROJECTNAME --ghc-options='-O0 -ddump-timings -ddump-to-file'
+```
+
+2. Find the location of the `.dump-timings` files:
+
+```
+find persistent-template/compile-time-testing/projects/PROJECTDIR/.stack-work -type f -name '*.dump-timings'
+```
+
+Copy the path to the module you want to check compilation data on. An example path is `persistent-template/compile-time-testing/projects/Mercury/.stack-work/dist/x86_64-osx/Cabal-2.4.0.1/build/TestPerformance.dump-timings`, but it will vary.
+
+3. Benchmark:
+
+```
+mkdir RESULTS_DIR
+bench --before="stack clean PROJECTNAME" "stack build PROJECTNAME --ghc-options='-O0 -ddump-timings -ddump-to-file'" --after="cp PATH_TO_TIMINGS_FILE RESULTS_DIR/`uuidgen`.dump-timings"
+```
+
+4. This benchmark will include the noise/overhead of calling GHC and compiling other files. To get module-specific data, use the `add-timings.rb` script to see how long compiling your specific module took.
+
+5. Repeat steps 3–4 once or twice more with a new results directory. These times are your baseline to compare any changes against.
+
+6. Make your change to `persistent-template`.
+
+7. Compile your example project again.
+8. Perform steps 3–4 to see how your change affects compilation speeds.
+
+
+### TODO
+
+* Improve the script to do better data analysis. Ideally it would use similar methods to Criterion, like an ordinary least squares regression, included an R^2 goodness of fit, standard deviation, etc.
+* Simplify/script the procedure

persistent-template/compile-time-testing/add-timings.rb

@@ -0,0 +1,24 @@
+#!ruby -w
+
+directory = ARGV[0]
+puts "Looking for data in #{directory}"
+
+Dir.chdir(directory)
+filenames = Dir.glob('*.dump-timings')
+
+totals = []
+
+filenames.each do |name|
+  text = File.read(name)
+  lines = text.split("\n")
+  total = 0
+  lines.each do |line|
+    start, time = line.split("time=")
+    total += time.to_f
+  end
+
+  totals << total
+end
+
+mean = totals.inject(0.0) { |sum, el| sum + el } / totals.size
+puts "Mean is #{mean}ms"

persistent-template/compile-time-testing/projects/Mercury/Instances.hs

@@ -0,0 +1,40 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Instances where
+
+import Database.Persist.Sql
+import Data.UUID (UUID, fromASCIIBytes, toASCIIBytes, toText, fromText)
+import Web.PathPieces (PathPiece(..))
+import qualified Data.Text as T
+import qualified Data.Aeson as J
+import Data.Aeson (Value(..))
+import qualified Data.Text.Encoding as TE
+
+instance PersistField UUID where
+  toPersistValue = PersistDbSpecific . toASCIIBytes
+  fromPersistValue (PersistDbSpecific uuid) =
+    case fromASCIIBytes uuid of
+      Nothing -> Left $ "Model/CustomTypes.hs: Failed to deserialize a UUID; received: " <> T.pack (show uuid)
+      Just uuid' -> Right uuid'
+  fromPersistValue x = Left $ "Model/CustomTypes.hs: When trying to deserialize a UUID: expected PersistDbSpecific, received: " <> (T.pack $ show x)
+
+instance PersistFieldSql UUID where
+  sqlType _ = SqlOther "uuid"
+
+instance PathPiece UUID where
+  toPathPiece = toText
+  fromPathPiece = fromText
+
+instance PersistField Value where
+  toPersistValue value = PersistText $ TE.encodeUtf8 $ J.encode value
+  fromPersistValue (PersistText t) = case J.eitherDecode (cs t) of
+    Left s -> Left $ "Error decoding into Value; received " ++ t ++ " error: " ++ T.pack s
+    Right v -> Right v
+  fromPersistValue (PersistByteString bs) = case J.eitherDecode (TE.encodeUtf8 bs) of
+    Left s -> Left $ "Error decoding into Value; received " ++ TE.encodeUtf8 bs ++ " error: " ++ T.pack s
+    Right v -> Right v
+  fromPersistValue _x = Left . T.pack $ "Value: When expecting PersistByteString/PersistText, received: " ++ show x
+
+instance PersistFieldSql Value where
+  sqlType _ = SqlOther "jsonb"

persistent-template/compile-time-testing/projects/Mercury/LICENSE

@@ -0,0 +1,20 @@
+Copyright (c) 2020 Michael Snoyman, http://www.yesodweb.com/
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

persistent-template/compile-time-testing/projects/Mercury/Main.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+module Main where
+
+import Instances ()
+import Data.Text (Text)
+
+import Database.Persist.Quasi
+import Database.Persist.TH
+import Data.UUID (UUID)
+import Data.Time (UTCTime)
+import Data.ByteString
+import Data.Aeson (Value)
+
+
+main :: IO ()
+main = pure ()
+
+share [mkPersist sqlSettings]
+  $(persistFileWith lowerCaseSettings "models.persistentmodels")

persistent-template/compile-time-testing/projects/Mercury/README.md

@@ -0,0 +1 @@
+bench --before="stack clean mercury" "stack build mercury --ghc-options='-O0 -ddump-timings -ddump-to-file'" --after="cp ./.stack-work/dist/x86_64-osx/Cabal-2.4.0.1/build/Main.dump-timings results/`uuidgen`.dump-timings"

persistent-template/compile-time-testing/projects/Mercury/mercury.cabal

@@ -0,0 +1,43 @@
+name:            mercury
+version:         2.8.3.0
+license:         MIT
+license-file:    LICENSE
+author:          Michael Snoyman <michael@snoyman.com>
+maintainer:      Michael Snoyman <michael@snoyman.com>, Greg Weber <greg@gregweber.info>
+synopsis:        Type-safe, non-relational, multi-backend persistence.
+description:     Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/persistent-template>.
+category:        Database, Yesod
+stability:       Stable
+cabal-version:   >= 1.10
+build-type:      Simple
+homepage:        http://www.yesodweb.com/book/persistent
+bug-reports:     https://github.com/yesodweb/persistent/issues
+extra-source-files: README.md
+
+library
+    build-depends:   base                     >= 4.10      && < 5
+                   , persistent               >= 2.11      && < 3
+                   , aeson                    >= 1.0       && < 1.5
+                   , bytestring               >= 0.10
+                   , containers
+                   , http-api-data            >= 0.3.7
+                   , monad-control            >= 1.0       && < 1.1
+                   , monad-logger
+                   , path-pieces
+                   , template-haskell         >= 2.11
+                   , text                     >= 1.2
+                   , th-lift-instances        >= 0.1.14    && < 0.2
+                   , transformers             >= 0.5       && < 0.6
+                   , unordered-containers
+                   , persistent-template
+                   , uuid
+                   , time
+    exposed-modules: Main
+                     Instances
+    ghc-options:     -Wall
+    default-language: Haskell2010
+
+
+source-repository head
+  type:     git
+  location: git://github.com/yesodweb/persistent.git