diff --git a/flake.nix b/flake.nix index a665510..04aa9f8 100644 --- a/flake.nix +++ b/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: - pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; })); - - packageName = "hcat"; + haskellPackages = pkgs.haskell.packages.ghc924.extend overlay; in { - packages.${packageName} = - haskellPackages.callCabal2nix packageName self { }; - - packages.default = self.packages.${system}.${packageName}; + packages.default = haskellPackages.hcat; 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; diff --git a/hcat.cabal b/hcat.cabal index c10f21a..3385961 100644 --- a/hcat.cabal +++ b/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 diff --git a/package.yaml b/package.yaml index 37763d1..b8277e8 100644 --- a/package.yaml +++ b/package.yaml @@ -13,6 +13,7 @@ dependencies: - base >= 4.13 && < 5 - time - directory + - containers # - bytestring ghc-options: diff --git a/src/HCat/Metrics.hs b/src/HCat/Metrics.hs new file mode 100644 index 0000000..ed9dfcc --- /dev/null +++ b/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