diff --git a/flake.nix b/flake.nix index 04aa9f8..a665510 100644 --- a/flake.nix +++ b/flake.nix @@ -15,11 +15,17 @@ let pkgs = nixpkgs.legacyPackages.${system}; - overlay = final: prev: { hcat = final.callCabal2nix "hcat" ./. { }; }; + haskellPackages = pkgs.haskell.packages.ghc924; - haskellPackages = pkgs.haskell.packages.ghc924.extend overlay; + jailbreakUnbreak = pkg: + pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; })); + + packageName = "hcat"; in { - packages.default = haskellPackages.hcat; + packages.${packageName} = + haskellPackages.callCabal2nix packageName self { }; + + packages.default = self.packages.${system}.${packageName}; apps = { # run with: nix run #.hcat @@ -56,7 +62,7 @@ devShells.default = haskellPackages.shellFor { inherit (self.checks.${system}.pre-commit-check) shellHook; - packages = p: [ p.hcat ]; + packages = _: [ self.packages.${system}.default ]; withHoogle = true; diff --git a/hcat.cabal b/hcat.cabal index 3385961..c10f21a 100644 --- a/hcat.cabal +++ b/hcat.cabal @@ -20,7 +20,6 @@ library HCat HCat.FileInfo HCat.Internal - HCat.Metrics HCat.Screen HCat.StatusLine other-modules: @@ -34,7 +33,6 @@ library ghc-options: -Wall -fdefer-typed-holes build-depends: base >=4.13 && <5 - , containers , directory , process , text @@ -54,7 +52,6 @@ executable hcat ghc-options: -Wall -fdefer-typed-holes build-depends: base >=4.13 && <5 - , containers , directory , hcat , time @@ -76,7 +73,6 @@ test-suite doctest doctest:doctest build-depends: base >=4.13 && <5 - , containers , directory , process , time @@ -101,7 +97,6 @@ test-suite spec build-depends: QuickCheck , base >=4.13 && <5 - , containers , directory , hcat , hspec diff --git a/package.yaml b/package.yaml index b8277e8..37763d1 100644 --- a/package.yaml +++ b/package.yaml @@ -13,7 +13,6 @@ dependencies: - base >= 4.13 && < 5 - time - directory - - containers # - bytestring ghc-options: diff --git a/src/HCat/Metrics.hs b/src/HCat/Metrics.hs deleted file mode 100644 index ed9dfcc..0000000 --- a/src/HCat/Metrics.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# 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