hcat: Add Metrics module

flake.nix

@@ -15,17 +15,11 @@
       let
         pkgs = nixpkgs.legacyPackages.${system};
 
-        haskellPackages = pkgs.haskell.packages.ghc924;
+        overlay = final: prev: { hcat = final.callCabal2nix "hcat" ./. { }; };
 
-        jailbreakUnbreak = pkg:
+        haskellPackages = pkgs.haskell.packages.ghc924.extend overlay;
-          pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; }));
-
-        packageName = "hcat";
       in {
-        packages.${packageName} =
+        packages.default = haskellPackages.hcat;
-          haskellPackages.callCabal2nix packageName self { };
-
-        packages.default = self.packages.${system}.${packageName};
 
         apps = {
           # run with: nix run #.hcat
@@ -62,7 +56,7 @@
         devShells.default = haskellPackages.shellFor {
           inherit (self.checks.${system}.pre-commit-check) shellHook;
 
-          packages = _: [ self.packages.${system}.default ];
+          packages = p: [ p.hcat ];
 
           withHoogle = true;
 

hcat.cabal

@@ -20,6 +20,7 @@ library
       HCat
       HCat.FileInfo
       HCat.Internal
+      HCat.Metrics
       HCat.Screen
       HCat.StatusLine
   other-modules:
@@ -33,6 +34,7 @@ library
   ghc-options: -Wall -fdefer-typed-holes
   build-depends:
       base >=4.13 && <5
+    , containers
     , directory
     , process
     , text
@@ -52,6 +54,7 @@ executable hcat
   ghc-options: -Wall -fdefer-typed-holes
   build-depends:
       base >=4.13 && <5
+    , containers
     , directory
     , hcat
     , time
@@ -73,6 +76,7 @@ test-suite doctest
       doctest:doctest
   build-depends:
       base >=4.13 && <5
+    , containers
     , directory
     , process
     , time
@@ -97,6 +101,7 @@ test-suite spec
   build-depends:
       QuickCheck
     , base >=4.13 && <5
+    , containers
     , directory
     , hcat
     , hspec

package.yaml

@@ -13,6 +13,7 @@ dependencies:
   - base >= 4.13 && < 5
   - time
   - directory
+  - containers
 #  - bytestring
 
 ghc-options:

src/HCat/Metrics.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | Define some metrics
+module HCat.Metrics where
+
+import Control.Exception (SomeException, try)
+
+import Data.Time.Clock (diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds)
+
+import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
+import Data.Map.Merge.Strict qualified as Merge
+import Data.Map.Strict (Map, singleton)
+import Data.Map.Strict qualified as Map
+import Data.Monoid
+
+data Metrics = Metrics
+  { metricSuccessCount :: Sum Int
+  , metricFailureCount :: Sum Int
+  , metricCallDuration :: Timings
+  }
+  deriving (Show, Eq)
+
+newtype Timings = Timings {getTimings :: Map String (Sum Int)}
+  deriving (Show) via Map String (Sum Int)
+  deriving (Eq, Ord)
+
+prettyMetrics :: Metrics -> String
+prettyMetrics Metrics{..} =
+  unlines
+    [ "success: " <> prettySuccess
+    , "failure: " <> prettyFailure
+    , "timings: " <> "\n" <> prettyTimings
+    ]
+ where
+  prettySuccess = show . getSum $ metricSuccessCount
+  prettyFailure = show . getSum $ metricFailureCount
+  prettyTimings = unlines . fmap (indentation . prettyTiming) $ Map.toList (getTimings metricCallDuration)
+
+  prettyTiming (name, duration) = name <> ": " <> (show . getSum $ duration)
+
+  indentation :: String -> String
+  indentation = (<>) "   "
+
+merge :: (Semigroup v, Ord k) => Map k v -> Map k v -> Map k v
+merge = Merge.merge Merge.preserveMissing Merge.preserveMissing (Merge.zipWithMatched (const (<>)))
+
+instance Semigroup Timings where
+  (Timings lhs) <> (Timings rhs) = Timings $ lhs `merge` rhs
+
+instance Monoid Timings where
+  mempty = Timings mempty
+
+instance Semigroup Metrics where
+  (Metrics a b c) <> (Metrics a' b' c') = Metrics (a <> a') (b <> b') (c <> c')
+
+instance Monoid Metrics where
+  mempty = Metrics mempty mempty mempty
+
+success :: Metrics
+success = Metrics (Sum 1) mempty mempty
+
+failure :: Metrics
+failure = Metrics mempty (Sum 1) mempty
+
+timing :: String -> Int -> Metrics
+timing name duration = Metrics mempty mempty (Timings $ singleton name (Sum duration))
+
+newtype MetricsRef = MetricsRef (IORef Metrics)
+
+newMetrics :: IO MetricsRef
+newMetrics = MetricsRef <$> newIORef mempty
+
+storeMetric :: Metrics -> MetricsRef -> IO ()
+storeMetric m (MetricsRef r) = modifyIORef r (m <>)
+
+countSuccess :: MetricsRef -> IO ()
+countSuccess = storeMetric success
+
+countFailure :: MetricsRef -> IO ()
+countFailure = storeMetric failure
+
+countTiming :: MetricsRef -> String -> Int -> IO ()
+countTiming metrics name duration = storeMetric (timing name duration) metrics
+
+accountFor :: MetricsRef -> String -> IO a -> IO (Either SomeException a)
+accountFor metrics name action = do
+  startTime <- getCurrentTime
+  result <- try action
+  endTime <- getCurrentTime
+  let duration = floor . nominalDiffTimeToSeconds $ diffUTCTime endTime startTime
+  _ <- case result of
+    Left _ -> countFailure metrics
+    Right _ -> countSuccess metrics
+  countTiming metrics name duration
+  pure result
+
+printMetrics :: MetricsRef -> IO ()
+printMetrics (MetricsRef metrics) = do
+  m <- readIORef metrics
+  putStr $ prettyMetrics m