{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

{- |
Module      : System.MemInfo
Copyright   : (c) 2023 Tim Emiola
Maintainer  : Tim Emiola <adetokunbo@emio.la>
SPDX-License-Identifier: BSD3

Implements __printmem__, a command that computes the memory usage of some
processes
-}
module System.MemInfo (
  -- * Implement __printmem__
  getChoices,
  printProcs,

  -- * Read /MemUsage/
  readForOnePid,
  readMemUsage',
  readMemUsage,
  NotRun (..),
  LostPid (..),

  -- * Stream /MemUsage/ periodically
  unfoldMemUsage,
  unfoldMemUsageAfter',
  unfoldMemUsageAfter,

  -- * Obtain the process/program name
  ProcNamer,
  nameFromExeOnly,
  nameFor,
  nameAsFullCmd,

  -- * Index by pid or name
  ProcName,
  Indexer,
  dropId,
  withPid,

  -- * Print /MemUsage/
  printUsage',
  printUsage,

  -- * Convenient re-exports
  mkReportBud,
  ProcessID,
  AsCmdName (..),
) where

import Data.Bifunctor (Bifunctor (..))
import Data.Functor ((<&>))
import Data.List (sortBy)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Ord (Down (..), comparing)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Fmt (
  listF,
  (+|),
  (|+),
  (|++|),
 )
import System.Exit (exitFailure)
import System.MemInfo.Choices (
  Choices (..),
  PrintOrder (..),
  Style (..),
  getChoices,
 )
import System.MemInfo.Prelude
import System.MemInfo.Print (
  AsCmdName (..),
  fmtMemUsage,
  styleOutput,
 )
import System.MemInfo.Proc (
  BadStatus (..),
  ExeInfo (..),
  MemUsage (..),
  ProcUsage (..),
  StatusInfo (..),
  amass,
  parseExeInfo,
  parseFromSmap,
  parseFromStatm,
  parseStatusInfo,
 )
import System.MemInfo.SysInfo (
  ReportBud (..),
  fmtRamFlaws,
  fmtSwapFlaws,
  mkReportBud,
 )


{- | Print a report to @stdout@ displaying the memory usage of the programs
specified by @Choices@
-}
printProcs :: Choices -> IO ()
printProcs :: Choices -> IO ()
printProcs cs :: Choices
cs@Choices {choiceByPid :: Choices -> Bool
choiceByPid = Bool
byPid} = do
  ReportBud
bud <- Choices -> IO ReportBud
verify Choices
cs
  if Bool
byPid
    then Indexer (ProcessID, Text) -> ReportBud -> Choices -> IO ()
forall a.
(Ord a, AsCmdName a) =>
Indexer a -> ReportBud -> Choices -> IO ()
printProcs' Indexer (ProcessID, Text)
withPid ReportBud
bud Choices
cs
    else Indexer Text -> ReportBud -> Choices -> IO ()
forall a.
(Ord a, AsCmdName a) =>
Indexer a -> ReportBud -> Choices -> IO ()
printProcs' Indexer Text
dropId ReportBud
bud Choices
cs


printProcs' :: (Ord a, AsCmdName a) => Indexer a -> ReportBud -> Choices -> IO ()
printProcs' :: forall a.
(Ord a, AsCmdName a) =>
Indexer a -> ReportBud -> Choices -> IO ()
printProcs' Indexer a
indexer ReportBud
bud Choices
cs = do
  let Choices
        { choiceShowSwap :: Choices -> Bool
choiceShowSwap = Bool
showSwap
        , choiceOnlyTotal :: Choices -> Bool
choiceOnlyTotal = Bool
onlyTotal
        , choiceWatchSecs :: Choices -> Maybe Natural
choiceWatchSecs = Maybe Natural
watchSecsMb
        , choicePrintOrder :: Choices -> Maybe PrintOrder
choicePrintOrder = Maybe PrintOrder
printOrder
        , choiceReversed :: Choices -> Bool
choiceReversed = Bool
reversed
        , choiceStyle :: Choices -> Maybe Style
choiceStyle = Maybe Style
style
        } = Choices
cs
      style' :: Style
style' = Style -> Maybe Style -> Style
forall a. a -> Maybe a -> a
fromMaybe Style
Normal Maybe Style
style
      toList :: Map a MemUsage -> [(a, MemUsage)]
toList = ((a, MemUsage) -> (a, MemUsage) -> Ordering)
-> [(a, MemUsage)] -> [(a, MemUsage)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Bool
-> Maybe PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering
forall a.
Ord a =>
Bool
-> Maybe PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering
byPrintOrder' Bool
reversed Maybe PrintOrder
printOrder) ([(a, MemUsage)] -> [(a, MemUsage)])
-> (Map a MemUsage -> [(a, MemUsage)])
-> Map a MemUsage
-> [(a, MemUsage)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a MemUsage -> [(a, MemUsage)]
forall k a. Map k a -> [(k, a)]
Map.toList
      printEachCmd :: Map a MemUsage -> IO ()
printEachCmd = ReportBud -> Style -> Bool -> Bool -> [(a, MemUsage)] -> IO ()
forall a.
AsCmdName a =>
ReportBud -> Style -> Bool -> Bool -> [(a, MemUsage)] -> IO ()
printMemUsages ReportBud
bud Style
style' Bool
showSwap Bool
onlyTotal ([(a, MemUsage)] -> IO ())
-> (Map a MemUsage -> [(a, MemUsage)]) -> Map a MemUsage -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a MemUsage -> [(a, MemUsage)]
toList
      printTheTotal :: Map a MemUsage -> IO ()
printTheTotal = ReportBud -> Bool -> Bool -> [(a, MemUsage)] -> IO ()
forall k.
AsCmdName k =>
ReportBud -> Bool -> Bool -> [(k, MemUsage)] -> IO ()
onlyPrintTotal ReportBud
bud Bool
showSwap Bool
onlyTotal ([(a, MemUsage)] -> IO ())
-> (Map a MemUsage -> [(a, MemUsage)]) -> Map a MemUsage -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a MemUsage -> [(a, MemUsage)]
toList
      showTotal :: Map a MemUsage -> IO ()
showTotal = if Bool
onlyTotal then Map a MemUsage -> IO ()
printTheTotal else Map a MemUsage -> IO ()
printEachCmd
      namer :: ProcNamer
namer = if Choices -> Bool
choiceSplitArgs Choices
cs then ProcNamer
nameAsFullCmd else ProcNamer
nameFor
  case Maybe Natural
watchSecsMb of
    Maybe Natural
Nothing -> ProcNamer
-> Indexer a -> ReportBud -> IO (Either LostPid (Map a MemUsage))
forall a.
Ord a =>
ProcNamer
-> Indexer a -> ReportBud -> IO (Either LostPid (Map a MemUsage))
readMemUsage' ProcNamer
namer Indexer a
indexer ReportBud
bud IO (Either LostPid (Map a MemUsage))
-> (Either LostPid (Map a MemUsage) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (LostPid -> IO ())
-> (Map a MemUsage -> IO ())
-> Either LostPid (Map a MemUsage)
-> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either LostPid -> IO ()
forall a. LostPid -> IO a
haltLostPid Map a MemUsage -> IO ()
showTotal
    (Just Natural
spanSecs) -> do
      let unfold :: ReportBud
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfold = ProcNamer
-> Indexer a
-> Natural
-> ReportBud
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
forall a seconds.
(Ord a, AsCmdName a, Integral seconds) =>
ProcNamer
-> Indexer a
-> seconds
-> ReportBud
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter' ProcNamer
namer Indexer a
indexer Natural
spanSecs
      (ReportBud
 -> IO
      (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud)))
-> ReportBud -> (Map a MemUsage -> IO ()) -> IO ()
forall c.
(Ord c, AsCmdName c) =>
(ReportBud
 -> IO
      (Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud)))
-> ReportBud -> (Map c MemUsage -> IO ()) -> IO ()
loopPrintMemUsages ReportBud
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfold ReportBud
bud Map a MemUsage -> IO ()
showTotal


printMemUsages ::
  (AsCmdName a) =>
  ReportBud ->
  Style ->
  Bool ->
  Bool ->
  [(a, MemUsage)] ->
  IO ()
printMemUsages :: forall a.
AsCmdName a =>
ReportBud -> Style -> Bool -> Bool -> [(a, MemUsage)] -> IO ()
printMemUsages ReportBud
bud Style
style Bool
showSwap Bool
onlyTotal [(a, MemUsage)]
totals = do
  let overallIsAccurate :: Bool
overallIsAccurate = (Bool
showSwap Bool -> Bool -> Bool
&& ReportBud -> Bool
rbHasSwapPss ReportBud
bud) Bool -> Bool -> Bool
|| ReportBud -> Bool
rbHasPss ReportBud
bud
      output :: [Text]
output = Bool -> Style -> Bool -> [(a, MemUsage)] -> [Text]
forall a.
AsCmdName a =>
Bool -> Style -> Bool -> [(a, MemUsage)] -> [Text]
styleOutput Bool
showSwap Style
style Bool
overallIsAccurate [(a, MemUsage)]
totals
  (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> IO ()
Text.putStrLn [Text]
output
  ReportBud -> Bool -> Bool -> IO ()
reportFlaws ReportBud
bud Bool
showSwap Bool
onlyTotal


-- | Print the program name and memory usage, optionally hiding the swap size
printUsage' :: (AsCmdName a) => (a, MemUsage) -> Bool -> IO ()
printUsage' :: forall a. AsCmdName a => (a, MemUsage) -> Bool -> IO ()
printUsage' (a
name, MemUsage
mu) Bool
showSwap = Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> a -> MemUsage -> Text
forall a. AsCmdName a => Bool -> a -> MemUsage -> Text
fmtMemUsage Bool
showSwap a
name MemUsage
mu


-- | Like @'printUsage''@, but alway shows the swap size
printUsage :: (AsCmdName a) => (a, MemUsage) -> IO ()
printUsage :: forall a. AsCmdName a => (a, MemUsage) -> IO ()
printUsage = ((a, MemUsage) -> Bool -> IO ()) -> Bool -> (a, MemUsage) -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a, MemUsage) -> Bool -> IO ()
forall a. AsCmdName a => (a, MemUsage) -> Bool -> IO ()
printUsage' Bool
True


onlyPrintTotal :: (AsCmdName k) => ReportBud -> Bool -> Bool -> [(k, MemUsage)] -> IO ()
onlyPrintTotal :: forall k.
AsCmdName k =>
ReportBud -> Bool -> Bool -> [(k, MemUsage)] -> IO ()
onlyPrintTotal ReportBud
bud Bool
showSwap Bool
onlyTotal [(k, MemUsage)]
totals = do
  let (Int
private, Int
swap) = [MemUsage] -> (Int, Int)
overallTotals ([MemUsage] -> (Int, Int)) -> [MemUsage] -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ ((k, MemUsage) -> MemUsage) -> [(k, MemUsage)] -> [MemUsage]
forall a b. (a -> b) -> [a] -> [b]
map (k, MemUsage) -> MemUsage
forall a b. (a, b) -> b
snd [(k, MemUsage)]
totals
      printRawTotal :: Int -> IO ()
printRawTotal = Text -> IO ()
Text.putStrLn (Text -> IO ()) -> (Int -> Text) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text
fmtMemBytes
  if Bool
showSwap
    then do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ReportBud -> Bool
rbHasSwapPss ReportBud
bud) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
printRawTotal Int
swap
      ReportBud -> Bool -> Bool -> IO ()
reportFlaws ReportBud
bud Bool
showSwap Bool
onlyTotal
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe SwapFlaw -> Bool
forall a. Maybe a -> Bool
isJust (Maybe SwapFlaw -> Bool) -> Maybe SwapFlaw -> Bool
forall a b. (a -> b) -> a -> b
$ ReportBud -> Maybe SwapFlaw
rbSwapFlaws ReportBud
bud) IO ()
forall a. IO a
exitFailure
    else do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ReportBud -> Bool
rbHasPss ReportBud
bud) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
printRawTotal Int
private
      ReportBud -> Bool -> Bool -> IO ()
reportFlaws ReportBud
bud Bool
showSwap Bool
onlyTotal
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe RamFlaw -> Bool
forall a. Maybe a -> Bool
isJust (Maybe RamFlaw -> Bool) -> Maybe RamFlaw -> Bool
forall a b. (a -> b) -> a -> b
$ ReportBud -> Maybe RamFlaw
rbRamFlaws ReportBud
bud) IO ()
forall a. IO a
exitFailure


loopPrintMemUsages ::
  (Ord c, AsCmdName c) =>
  (ReportBud -> IO (Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud))) ->
  ReportBud ->
  (Map c MemUsage -> IO ()) ->
  IO ()
loopPrintMemUsages :: forall c.
(Ord c, AsCmdName c) =>
(ReportBud
 -> IO
      (Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud)))
-> ReportBud -> (Map c MemUsage -> IO ()) -> IO ()
loopPrintMemUsages ReportBud
-> IO
     (Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud))
unfold ReportBud
bud Map c MemUsage -> IO ()
showTotal = do
  let clearScreen :: IO ()
clearScreen = FilePath -> IO ()
putStrLn FilePath
"\o033c"
      warnHalting :: IO ()
warnHalting = Bool -> Text -> IO ()
errStrLn Bool
False Text
"halting: all monitored processes have stopped"
      handleNext :: Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud)
-> IO ()
handleNext (Left [ProcessID]
stopped) = do
        [ProcessID] -> IO ()
warnStopped [ProcessID]
stopped
        IO ()
warnHalting
      handleNext (Right ((Map c MemUsage
total, [ProcessID]
stopped), ReportBud
updated)) = do
        IO ()
clearScreen
        [ProcessID] -> IO ()
warnStopped [ProcessID]
stopped
        Map c MemUsage -> IO ()
showTotal Map c MemUsage
total
        ReportBud -> IO ()
go ReportBud
updated
      go :: ReportBud -> IO ()
go ReportBud
initial = ReportBud
-> IO
     (Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud))
unfold ReportBud
initial IO (Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud))
-> (Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud)
    -> IO ())
-> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either [ProcessID] ((Map c MemUsage, [ProcessID]), ReportBud)
-> IO ()
handleNext
  ReportBud -> IO ()
go ReportBud
bud


warnStopped :: [ProcessID] -> IO ()
warnStopped :: [ProcessID] -> IO ()
warnStopped [ProcessID]
pids = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ProcessID] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ProcessID]
pids) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  let errMsg :: Text
errMsg = Builder
"some processes stopped:pids:" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger (ProcessID -> Integer) -> [ProcessID] -> [Integer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ProcessID]
pids [Integer] -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
  Bool -> Text -> IO ()
errStrLn Bool
False Text
errMsg


-- | The name of a process or program in the memory report.
type ProcName = Text


-- | Like @'unfoldMemUsageAfter''@, but uses the default 'ProcNamer' and 'Indexer'
unfoldMemUsageAfter ::
  (Integral seconds) =>
  seconds ->
  ReportBud ->
  IO (Either [ProcessID] ((Map ProcName MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter :: forall seconds.
Integral seconds =>
seconds
-> ReportBud
-> IO
     (Either [ProcessID] ((Map Text MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter = ProcNamer
-> Indexer Text
-> seconds
-> ReportBud
-> IO
     (Either [ProcessID] ((Map Text MemUsage, [ProcessID]), ReportBud))
forall a seconds.
(Ord a, AsCmdName a, Integral seconds) =>
ProcNamer
-> Indexer a
-> seconds
-> ReportBud
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter' ProcNamer
nameFor Indexer Text
dropId


-- | Like @'unfoldMemUsage'@ but computes the @'MemUsage's@ after a delay
unfoldMemUsageAfter' ::
  (Ord a, AsCmdName a, Integral seconds) =>
  ProcNamer ->
  Indexer a ->
  seconds ->
  ReportBud ->
  IO (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter' :: forall a seconds.
(Ord a, AsCmdName a, Integral seconds) =>
ProcNamer
-> Indexer a
-> seconds
-> ReportBud
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsageAfter' ProcNamer
namer Indexer a
mkCmd seconds
spanSecs ReportBud
bud = do
  let spanMicros :: Int
spanMicros = Int
1000000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Integer -> Int
forall a. Num a => Integer -> a
fromInteger (seconds -> Integer
forall a. Integral a => a -> Integer
toInteger seconds
spanSecs)
  Int -> IO ()
threadDelay Int
spanMicros
  ProcNamer
-> Indexer a
-> ReportBud
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
forall a.
Ord a =>
ProcNamer
-> Indexer a
-> ReportBud
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsage ProcNamer
namer Indexer a
mkCmd ReportBud
bud


{- | Unfold @'MemUsage's@ specified by a @'ReportBud'@

The @ProcessID@ of stopped processes are reported, both as part of intermediate
invocations (via the @[ProcessID]@ in the @Right@), and in the final one (as the
value of the @Left@).
-}
unfoldMemUsage ::
  (Ord a) =>
  ProcNamer ->
  Indexer a ->
  ReportBud ->
  IO (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsage :: forall a.
Ord a =>
ProcNamer
-> Indexer a
-> ReportBud
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
unfoldMemUsage ProcNamer
namer Indexer a
mkCmd ReportBud
bud = do
  let changePids :: NonEmpty ProcessID -> ReportBud
changePids NonEmpty ProcessID
rbPids = ReportBud
bud {rbPids}
      dropStopped :: ReportBud -> [ProcessID] -> Maybe ReportBud
dropStopped ReportBud
t [] = ReportBud -> Maybe ReportBud
forall a. a -> Maybe a
Just ReportBud
t
      dropStopped ReportBud {rbPids :: ReportBud -> NonEmpty ProcessID
rbPids = NonEmpty ProcessID
ps} [ProcessID]
stopped =
        NonEmpty ProcessID -> ReportBud
changePids (NonEmpty ProcessID -> ReportBud)
-> Maybe (NonEmpty ProcessID) -> Maybe ReportBud
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ProcessID] -> Maybe (NonEmpty ProcessID)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ((ProcessID -> Bool) -> NonEmpty ProcessID -> [ProcessID]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter (ProcessID -> [ProcessID] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ProcessID]
stopped) NonEmpty ProcessID
ps)
      ReportBud {rbPids :: ReportBud -> NonEmpty ProcessID
rbPids = NonEmpty ProcessID
pids, rbHasPss :: ReportBud -> Bool
rbHasPss = Bool
hasPss} = ReportBud
bud
      nextState :: ([ProcessID], [(ProcessID, Text, ProcUsage)])
-> Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud)
nextState ([ProcessID]
stopped, []) = [ProcessID]
-> Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud)
forall a b. a -> Either a b
Left [ProcessID]
stopped
      nextState ([ProcessID]
stopped, [(ProcessID, Text, ProcUsage)]
xs) = case ReportBud -> [ProcessID] -> Maybe ReportBud
dropStopped ReportBud
bud [ProcessID]
stopped of
        Just ReportBud
updated -> ((Map a MemUsage, [ProcessID]), ReportBud)
-> Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud)
forall a b. b -> Either a b
Right ((Bool -> [(a, ProcUsage)] -> Map a MemUsage
forall a. Ord a => Bool -> [(a, ProcUsage)] -> Map a MemUsage
amass Bool
hasPss (Indexer a -> [(ProcessID, Text, ProcUsage)] -> [(a, ProcUsage)]
forall a b. (a -> b) -> [a] -> [b]
map Indexer a
mkCmd [(ProcessID, Text, ProcUsage)]
xs), [ProcessID]
stopped), ReportBud
updated)
        Maybe ReportBud
Nothing -> [ProcessID]
-> Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud)
forall a b. a -> Either a b
Left [ProcessID]
stopped
  ([ProcessID], [(ProcessID, Text, ProcUsage)])
-> Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud)
nextState (([ProcessID], [(ProcessID, Text, ProcUsage)])
 -> Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
-> IO ([ProcessID], [(ProcessID, Text, ProcUsage)])
-> IO
     (Either [ProcessID] ((Map a MemUsage, [ProcessID]), ReportBud))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ProcessID -> IO (Either LostPid (ProcessID, Text, ProcUsage)))
-> NonEmpty ProcessID
-> IO ([ProcessID], [(ProcessID, Text, ProcUsage)])
forall (t :: * -> *) (m :: * -> *) a b c.
(Foldable t, Monad m) =>
(a -> m (Either b c)) -> t a -> m ([a], [c])
foldlEitherM' (ProcNamer
-> ReportBud
-> ProcessID
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
readNameAndStats ProcNamer
namer ReportBud
bud) NonEmpty ProcessID
pids


-- | Load the @'MemUsage'@ of a program specified by its @ProcessID@
readForOnePid :: ProcessID -> IO (Either NotRun (ProcName, MemUsage))
readForOnePid :: ProcessID -> IO (Either NotRun (Text, MemUsage))
readForOnePid ProcessID
pid = do
  let mkBud' :: NonEmpty ProcessID -> IO (Either NotRun ReportBud)
mkBud' NonEmpty ProcessID
xs = NonEmpty ProcessID -> IO (Maybe ReportBud)
mkReportBud NonEmpty ProcessID
xs IO (Maybe ReportBud)
-> (Maybe ReportBud -> Either NotRun ReportBud)
-> IO (Either NotRun ReportBud)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Either NotRun ReportBud
-> (ReportBud -> Either NotRun ReportBud)
-> Maybe ReportBud
-> Either NotRun ReportBud
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NotRun -> Either NotRun ReportBud
forall a b. a -> Either a b
Left NotRun
OddKernel) ReportBud -> Either NotRun ReportBud
forall a b. b -> Either a b
Right
      noProc :: LostPid
noProc = ProcessID -> LostPid
NoProc ProcessID
pid
      fromMemUsage :: Map k a -> Either NotRun (k, a)
fromMemUsage Map k a
x = Either NotRun (k, a)
-> ((k, a) -> Either NotRun (k, a))
-> Maybe (k, a)
-> Either NotRun (k, a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NotRun -> Either NotRun (k, a)
forall a b. a -> Either a b
Left (NotRun -> Either NotRun (k, a)) -> NotRun -> Either NotRun (k, a)
forall a b. (a -> b) -> a -> b
$ LostPid -> NotRun
PidLost LostPid
noProc) (k, a) -> Either NotRun (k, a)
forall a b. b -> Either a b
Right (Map k a -> Maybe (k, a)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMin Map k a
x)
      andFromUsage :: Either LostPid (Map k a) -> Either NotRun (k, a)
andFromUsage = (LostPid -> Either NotRun (k, a))
-> (Map k a -> Either NotRun (k, a))
-> Either LostPid (Map k a)
-> Either NotRun (k, a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (NotRun -> Either NotRun (k, a)
forall a b. a -> Either a b
Left (NotRun -> Either NotRun (k, a))
-> (LostPid -> NotRun) -> LostPid -> Either NotRun (k, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LostPid -> NotRun
PidLost) Map k a -> Either NotRun (k, a)
forall {k} {a}. Map k a -> Either NotRun (k, a)
fromMemUsage
  ProcNamer
nameFor ProcessID
pid IO (Either LostPid Text)
-> (Either LostPid Text -> IO (Either NotRun (Text, MemUsage)))
-> IO (Either NotRun (Text, MemUsage))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left LostPid
err -> Either NotRun (Text, MemUsage)
-> IO (Either NotRun (Text, MemUsage))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either NotRun (Text, MemUsage)
 -> IO (Either NotRun (Text, MemUsage)))
-> Either NotRun (Text, MemUsage)
-> IO (Either NotRun (Text, MemUsage))
forall a b. (a -> b) -> a -> b
$ NotRun -> Either NotRun (Text, MemUsage)
forall a b. a -> Either a b
Left (NotRun -> Either NotRun (Text, MemUsage))
-> NotRun -> Either NotRun (Text, MemUsage)
forall a b. (a -> b) -> a -> b
$ LostPid -> NotRun
PidLost LostPid
err
    Right Text
_ ->
      NonEmpty ProcessID -> IO (Either NotRun ReportBud)
mkBud' (ProcessID
pid ProcessID -> [ProcessID] -> NonEmpty ProcessID
forall a. a -> [a] -> NonEmpty a
:| []) IO (Either NotRun ReportBud)
-> (Either NotRun ReportBud -> IO (Either NotRun (Text, MemUsage)))
-> IO (Either NotRun (Text, MemUsage))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left NotRun
err -> Either NotRun (Text, MemUsage)
-> IO (Either NotRun (Text, MemUsage))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either NotRun (Text, MemUsage)
 -> IO (Either NotRun (Text, MemUsage)))
-> Either NotRun (Text, MemUsage)
-> IO (Either NotRun (Text, MemUsage))
forall a b. (a -> b) -> a -> b
$ NotRun -> Either NotRun (Text, MemUsage)
forall a b. a -> Either a b
Left NotRun
err
        Right ReportBud
bud -> ReportBud -> IO (Either LostPid (Map Text MemUsage))
readMemUsage ReportBud
bud IO (Either LostPid (Map Text MemUsage))
-> (Either LostPid (Map Text MemUsage)
    -> Either NotRun (Text, MemUsage))
-> IO (Either NotRun (Text, MemUsage))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Either LostPid (Map Text MemUsage)
-> Either NotRun (Text, MemUsage)
forall {k} {a}. Either LostPid (Map k a) -> Either NotRun (k, a)
andFromUsage


-- | Like @'readMemUsage''@ but uses the default 'ProcNamer' and 'Indexer'
readMemUsage :: ReportBud -> IO (Either LostPid (Map ProcName MemUsage))
readMemUsage :: ReportBud -> IO (Either LostPid (Map Text MemUsage))
readMemUsage = ProcNamer
-> Indexer Text
-> ReportBud
-> IO (Either LostPid (Map Text MemUsage))
forall a.
Ord a =>
ProcNamer
-> Indexer a -> ReportBud -> IO (Either LostPid (Map a MemUsage))
readMemUsage' ProcNamer
nameFor Indexer Text
dropId


{- | Loads the @'MemUsage'@ specified by a @'ReportBud'@

Fails if

- the system does not have the expected /proc filesystem memory records
- any of the processes specified by @'ReportBud'@ are missing or inaccessible
-}
readMemUsage' ::
  (Ord a) =>
  ProcNamer ->
  Indexer a ->
  ReportBud ->
  IO (Either LostPid (Map a MemUsage))
readMemUsage' :: forall a.
Ord a =>
ProcNamer
-> Indexer a -> ReportBud -> IO (Either LostPid (Map a MemUsage))
readMemUsage' ProcNamer
namer Indexer a
mkCmd ReportBud
bud = do
  let amass' :: [(ProcessID, Text, ProcUsage)] -> Map a MemUsage
amass' [(ProcessID, Text, ProcUsage)]
cmds = Bool -> [(a, ProcUsage)] -> Map a MemUsage
forall a. Ord a => Bool -> [(a, ProcUsage)] -> Map a MemUsage
amass (ReportBud -> Bool
rbHasPss ReportBud
bud) ([(a, ProcUsage)] -> Map a MemUsage)
-> [(a, ProcUsage)] -> Map a MemUsage
forall a b. (a -> b) -> a -> b
$ Indexer a -> [(ProcessID, Text, ProcUsage)] -> [(a, ProcUsage)]
forall a b. (a -> b) -> [a] -> [b]
map Indexer a
mkCmd [(ProcessID, Text, ProcUsage)]
cmds
  ([(ProcessID, Text, ProcUsage)] -> Map a MemUsage)
-> Either LostPid [(ProcessID, Text, ProcUsage)]
-> Either LostPid (Map a MemUsage)
forall a b. (a -> b) -> Either LostPid a -> Either LostPid b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(ProcessID, Text, ProcUsage)] -> Map a MemUsage
amass' (Either LostPid [(ProcessID, Text, ProcUsage)]
 -> Either LostPid (Map a MemUsage))
-> IO (Either LostPid [(ProcessID, Text, ProcUsage)])
-> IO (Either LostPid (Map a MemUsage))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ProcessID -> IO (Either LostPid (ProcessID, Text, ProcUsage)))
-> NonEmpty ProcessID
-> IO (Either LostPid [(ProcessID, Text, ProcUsage)])
forall (t :: * -> *) (m :: * -> *) a b c.
(Foldable t, Monad m) =>
(a -> m (Either b c)) -> t a -> m (Either b [c])
foldlEitherM (ProcNamer
-> ReportBud
-> ProcessID
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
readNameAndStats ProcNamer
namer ReportBud
bud) (ReportBud -> NonEmpty ProcessID
rbPids ReportBud
bud)


readNameAndStats ::
  ProcNamer ->
  ReportBud ->
  ProcessID ->
  IO (Either LostPid (ProcessID, ProcName, ProcUsage))
readNameAndStats :: ProcNamer
-> ReportBud
-> ProcessID
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
readNameAndStats ProcNamer
namer ReportBud
bud ProcessID
pid = do
  ProcNamer
namer ProcessID
pid IO (Either LostPid Text)
-> (Either LostPid Text
    -> IO (Either LostPid (ProcessID, Text, ProcUsage)))
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left LostPid
e -> Either LostPid (ProcessID, Text, ProcUsage)
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid (ProcessID, Text, ProcUsage)
 -> IO (Either LostPid (ProcessID, Text, ProcUsage)))
-> Either LostPid (ProcessID, Text, ProcUsage)
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
forall a b. (a -> b) -> a -> b
$ LostPid -> Either LostPid (ProcessID, Text, ProcUsage)
forall a b. a -> Either a b
Left LostPid
e
    Right Text
name ->
      ReportBud -> ProcessID -> IO (Either LostPid ProcUsage)
readMemStats ReportBud
bud ProcessID
pid IO (Either LostPid ProcUsage)
-> (Either LostPid ProcUsage
    -> IO (Either LostPid (ProcessID, Text, ProcUsage)))
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left LostPid
e -> Either LostPid (ProcessID, Text, ProcUsage)
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid (ProcessID, Text, ProcUsage)
 -> IO (Either LostPid (ProcessID, Text, ProcUsage)))
-> Either LostPid (ProcessID, Text, ProcUsage)
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
forall a b. (a -> b) -> a -> b
$ LostPid -> Either LostPid (ProcessID, Text, ProcUsage)
forall a b. a -> Either a b
Left LostPid
e
        Right ProcUsage
stats -> Either LostPid (ProcessID, Text, ProcUsage)
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid (ProcessID, Text, ProcUsage)
 -> IO (Either LostPid (ProcessID, Text, ProcUsage)))
-> Either LostPid (ProcessID, Text, ProcUsage)
-> IO (Either LostPid (ProcessID, Text, ProcUsage))
forall a b. (a -> b) -> a -> b
$ (ProcessID, Text, ProcUsage)
-> Either LostPid (ProcessID, Text, ProcUsage)
forall a b. b -> Either a b
Right (ProcessID
pid, Text
name, ProcUsage
stats)


reportFlaws :: ReportBud -> Bool -> Bool -> IO ()
reportFlaws :: ReportBud -> Bool -> Bool -> IO ()
reportFlaws ReportBud
bud Bool
showSwap Bool
onlyTotal = do
  let reportSwap :: SwapFlaw -> IO ()
reportSwap = Bool -> Text -> IO ()
errStrLn Bool
onlyTotal (Text -> IO ()) -> (SwapFlaw -> Text) -> SwapFlaw -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwapFlaw -> Text
fmtSwapFlaws
      reportRam :: RamFlaw -> IO ()
reportRam = Bool -> Text -> IO ()
errStrLn Bool
onlyTotal (Text -> IO ()) -> (RamFlaw -> Text) -> RamFlaw -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RamFlaw -> Text
fmtRamFlaws
      (Maybe RamFlaw
ram, Maybe SwapFlaw
swap) = (ReportBud -> Maybe RamFlaw
rbRamFlaws ReportBud
bud, ReportBud -> Maybe SwapFlaw
rbSwapFlaws ReportBud
bud)
  -- when showSwap, report swap flaws
  -- unless (showSwap and onlyTotal), show ram flaws
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
showSwap (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (SwapFlaw -> IO ()) -> Maybe SwapFlaw -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) SwapFlaw -> IO ()
reportSwap Maybe SwapFlaw
swap
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
onlyTotal Bool -> Bool -> Bool
&& Bool
showSwap) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (RamFlaw -> IO ()) -> Maybe RamFlaw -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) RamFlaw -> IO ()
reportRam Maybe RamFlaw
ram


verify :: Choices -> IO ReportBud
verify :: Choices -> IO ReportBud
verify Choices
cs = Maybe (NonEmpty ProcessID) -> IO (Either NotRun ReportBud)
verify' (Choices -> Maybe (NonEmpty ProcessID)
choicePidsToShow Choices
cs) IO (Either NotRun ReportBud)
-> (Either NotRun ReportBud -> IO ReportBud) -> IO ReportBud
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (NotRun -> IO ReportBud)
-> (ReportBud -> IO ReportBud)
-> Either NotRun ReportBud
-> IO ReportBud
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> IO ReportBud
forall a. Text -> IO a
haltErr (Text -> IO ReportBud)
-> (NotRun -> Text) -> NotRun -> IO ReportBud
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NotRun -> Text
fmtNotRun) ReportBud -> IO ReportBud
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure


verify' :: Maybe (NonEmpty ProcessID) -> IO (Either NotRun ReportBud)
verify' :: Maybe (NonEmpty ProcessID) -> IO (Either NotRun ReportBud)
verify' Maybe (NonEmpty ProcessID)
pidsMb = do
  let mkBud' :: NonEmpty ProcessID -> IO (Either NotRun ReportBud)
mkBud' NonEmpty ProcessID
xs = NonEmpty ProcessID -> IO (Maybe ReportBud)
mkReportBud NonEmpty ProcessID
xs IO (Maybe ReportBud)
-> (Maybe ReportBud -> Either NotRun ReportBud)
-> IO (Either NotRun ReportBud)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Either NotRun ReportBud
-> (ReportBud -> Either NotRun ReportBud)
-> Maybe ReportBud
-> Either NotRun ReportBud
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NotRun -> Either NotRun ReportBud
forall a b. a -> Either a b
Left NotRun
OddKernel) ReportBud -> Either NotRun ReportBud
forall a b. b -> Either a b
Right
      thenMkBud :: Either NotRun (NonEmpty ProcessID) -> IO (Either NotRun ReportBud)
thenMkBud = (NotRun -> IO (Either NotRun ReportBud))
-> (NonEmpty ProcessID -> IO (Either NotRun ReportBud))
-> Either NotRun (NonEmpty ProcessID)
-> IO (Either NotRun ReportBud)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either NotRun ReportBud -> IO (Either NotRun ReportBud)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either NotRun ReportBud -> IO (Either NotRun ReportBud))
-> (NotRun -> Either NotRun ReportBud)
-> NotRun
-> IO (Either NotRun ReportBud)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NotRun -> Either NotRun ReportBud
forall a b. a -> Either a b
Left) NonEmpty ProcessID -> IO (Either NotRun ReportBud)
mkBud'
  case Maybe (NonEmpty ProcessID)
pidsMb of
    Just NonEmpty ProcessID
pids -> NonEmpty ProcessID -> IO (Either NotRun (NonEmpty ProcessID))
checkAllExist NonEmpty ProcessID
pids IO (Either NotRun (NonEmpty ProcessID))
-> (Either NotRun (NonEmpty ProcessID)
    -> IO (Either NotRun ReportBud))
-> IO (Either NotRun ReportBud)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either NotRun (NonEmpty ProcessID) -> IO (Either NotRun ReportBud)
thenMkBud
    Maybe (NonEmpty ProcessID)
Nothing -> IO (Either NotRun (NonEmpty ProcessID))
allKnownProcs IO (Either NotRun (NonEmpty ProcessID))
-> (Either NotRun (NonEmpty ProcessID)
    -> IO (Either NotRun ReportBud))
-> IO (Either NotRun ReportBud)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either NotRun (NonEmpty ProcessID) -> IO (Either NotRun ReportBud)
thenMkBud


procRoot :: String
procRoot :: FilePath
procRoot = FilePath
"/proc/"


pidPath :: String -> ProcessID -> FilePath
pidPath :: FilePath -> ProcessID -> FilePath
pidPath FilePath
base ProcessID
pid = Builder
"" Builder -> Builder -> FilePath
forall b. FromBuilder b => Builder -> Builder -> b
+| FilePath
procRoot FilePath -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|++| ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger ProcessID
pid Integer -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"/" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| FilePath
base FilePath -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""


{- | pidExists returns false for any ProcessID that does not exist or cannot
be accessed
-}
pidExeExists :: ProcessID -> IO Bool
pidExeExists :: ProcessID -> IO Bool
pidExeExists = (Either LostPid ExeInfo -> Bool)
-> IO (Either LostPid ExeInfo) -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LostPid -> Bool)
-> (ExeInfo -> Bool) -> Either LostPid ExeInfo -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> LostPid -> Bool
forall a b. a -> b -> a
const Bool
False) (Bool -> ExeInfo -> Bool
forall a b. a -> b -> a
const Bool
True)) (IO (Either LostPid ExeInfo) -> IO Bool)
-> (ProcessID -> IO (Either LostPid ExeInfo))
-> ProcessID
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessID -> IO (Either LostPid ExeInfo)
exeInfo


-- | Obtain the @ProcName@ as the full cmd path
nameAsFullCmd :: ProcNamer
nameAsFullCmd :: ProcNamer
nameAsFullCmd ProcessID
pid = do
  let cmdlinePath :: FilePath
cmdlinePath = FilePath -> ProcessID -> FilePath
pidPath FilePath
"cmdline" ProcessID
pid
      err :: LostPid
err = ProcessID -> LostPid
NoCmdLine ProcessID
pid
      recombine :: NonEmpty Text -> Text
recombine = Text -> [Text] -> Text
Text.intercalate Text
" " ([Text] -> Text)
-> (NonEmpty Text -> [Text]) -> NonEmpty Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.toList
      orLostPid :: Maybe (NonEmpty Text) -> Either LostPid Text
orLostPid = Either LostPid Text
-> (NonEmpty Text -> Either LostPid Text)
-> Maybe (NonEmpty Text)
-> Either LostPid Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (LostPid -> Either LostPid Text
forall a b. a -> Either a b
Left LostPid
err) (Text -> Either LostPid Text
forall a b. b -> Either a b
Right (Text -> Either LostPid Text)
-> (NonEmpty Text -> Text) -> NonEmpty Text -> Either LostPid Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Text -> Text
recombine)
  FilePath -> IO Text
readUtf8Text FilePath
cmdlinePath IO Text
-> (Text -> IO (Either LostPid Text)) -> IO (Either LostPid Text)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Either LostPid Text -> IO (Either LostPid Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid Text -> IO (Either LostPid Text))
-> (Maybe (NonEmpty Text) -> Either LostPid Text)
-> Maybe (NonEmpty Text)
-> IO (Either LostPid Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (NonEmpty Text) -> Either LostPid Text
orLostPid) (Maybe (NonEmpty Text) -> IO (Either LostPid Text))
-> (Text -> Maybe (NonEmpty Text))
-> Text
-> IO (Either LostPid Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe (NonEmpty Text)
parseCmdline


{- | Obtain the @ProcName@ by examining the path linked by
__{proc_root}\/pid\/exe__
-}
nameFromExeOnly :: ProcNamer
nameFromExeOnly :: ProcNamer
nameFromExeOnly ProcessID
pid = do
  ProcessID -> IO (Either LostPid ExeInfo)
exeInfo ProcessID
pid IO (Either LostPid ExeInfo)
-> (Either LostPid ExeInfo -> IO (Either LostPid Text))
-> IO (Either LostPid Text)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right ExeInfo
i | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ExeInfo -> Bool
eiDeleted ExeInfo
i -> Either LostPid Text -> IO (Either LostPid Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid Text -> IO (Either LostPid Text))
-> Either LostPid Text -> IO (Either LostPid Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either LostPid Text
forall a b. b -> Either a b
Right (Text -> Either LostPid Text) -> Text -> Either LostPid Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
baseName (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ExeInfo -> Text
eiOriginal ExeInfo
i
    -- when the exe bud ends with (deleted), the version of the exe used to
    -- invoke the process has been removed from the filesystem. Sometimes it has
    -- been updated; examining both the original bud and the version in
    -- cmdline help determine what occurred
    Right ExeInfo {eiOriginal :: ExeInfo -> Text
eiOriginal = Text
orig} ->
      Text -> IO Bool
exists Text
orig IO Bool
-> (Bool -> IO (Either LostPid Text)) -> IO (Either LostPid Text)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> Either LostPid Text -> IO (Either LostPid Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid Text -> IO (Either LostPid Text))
-> Either LostPid Text -> IO (Either LostPid Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either LostPid Text
forall a b. b -> Either a b
Right (Text -> Either LostPid Text) -> Text -> Either LostPid Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
baseName (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Builder
"" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Text
orig Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" [updated]"
        Bool
_ -> do
          let cmdlinePath :: FilePath
cmdlinePath = FilePath -> ProcessID -> FilePath
pidPath FilePath
"cmdline" ProcessID
pid
          FilePath -> IO Text
readUtf8Text FilePath
cmdlinePath IO Text
-> (Text -> Maybe (NonEmpty Text)) -> IO (Maybe (NonEmpty Text))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> Maybe (NonEmpty Text)
parseCmdline IO (Maybe (NonEmpty Text))
-> (Maybe (NonEmpty Text) -> IO (Either LostPid Text))
-> IO (Either LostPid Text)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just (Text
x :| [Text]
_) -> do
              let addSuffix' :: Bool -> Text
addSuffix' Bool
b = Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if Bool
b then Text
" [updated]" else Text
" [deleted]"
              Text -> Either LostPid Text
forall a b. b -> Either a b
Right (Text -> Either LostPid Text)
-> (Bool -> Text) -> Bool -> Either LostPid Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
baseName (Text -> Text) -> (Bool -> Text) -> Bool -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Text
addSuffix' (Bool -> Either LostPid Text)
-> IO Bool -> IO (Either LostPid Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO Bool
exists Text
x
            -- args should not be empty when {pid_root}/exe resolves to a
            -- path, it's an error if it is
            Maybe (NonEmpty Text)
Nothing -> Either LostPid Text -> IO (Either LostPid Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid Text -> IO (Either LostPid Text))
-> Either LostPid Text -> IO (Either LostPid Text)
forall a b. (a -> b) -> a -> b
$ LostPid -> Either LostPid Text
forall a b. a -> Either a b
Left (LostPid -> Either LostPid Text) -> LostPid -> Either LostPid Text
forall a b. (a -> b) -> a -> b
$ ProcessID -> LostPid
NoCmdLine ProcessID
pid
    Left LostPid
e -> Either LostPid Text -> IO (Either LostPid Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid Text -> IO (Either LostPid Text))
-> Either LostPid Text -> IO (Either LostPid Text)
forall a b. (a -> b) -> a -> b
$ LostPid -> Either LostPid Text
forall a b. a -> Either a b
Left LostPid
e


-- | Functions that obtain a process name given its @pid@
type ProcNamer = ProcessID -> IO (Either LostPid ProcName)


{- | Obtain the @ProcName@ by examining the path linked by
__{proc_root}\/pid\/exe__ or its parent's name if that is a better match
-}
nameFor :: ProcNamer
nameFor :: ProcNamer
nameFor ProcessID
pid =
  ProcNamer
nameFromExeOnly ProcessID
pid
    IO (Either LostPid Text)
-> (Either LostPid Text -> IO (Either LostPid Text))
-> IO (Either LostPid Text)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (LostPid -> IO (Either LostPid Text))
-> (Text -> IO (Either LostPid Text))
-> Either LostPid Text
-> IO (Either LostPid Text)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either LostPid Text -> IO (Either LostPid Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid Text -> IO (Either LostPid Text))
-> (LostPid -> Either LostPid Text)
-> LostPid
-> IO (Either LostPid Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LostPid -> Either LostPid Text
forall a b. a -> Either a b
Left) (ProcessID -> Text -> IO (Either LostPid Text)
parentNameIfMatched ProcessID
pid)


parentNameIfMatched :: ProcessID -> Text -> IO (Either LostPid ProcName)
parentNameIfMatched :: ProcessID -> Text -> IO (Either LostPid Text)
parentNameIfMatched ProcessID
pid Text
candidate = do
  let isMatch :: StatusInfo -> Bool
isMatch = (Text -> Text -> Bool) -> Text -> Text -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Text -> Bool
Text.isPrefixOf Text
candidate (Text -> Bool) -> (StatusInfo -> Text) -> StatusInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StatusInfo -> Text
siName
  ProcessID -> IO (Either LostPid StatusInfo)
statusInfo ProcessID
pid IO (Either LostPid StatusInfo)
-> (Either LostPid StatusInfo -> IO (Either LostPid Text))
-> IO (Either LostPid Text)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left LostPid
err -> Either LostPid Text -> IO (Either LostPid Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid Text -> IO (Either LostPid Text))
-> Either LostPid Text -> IO (Either LostPid Text)
forall a b. (a -> b) -> a -> b
$ LostPid -> Either LostPid Text
forall a b. a -> Either a b
Left LostPid
err
    Right StatusInfo
si | StatusInfo -> Bool
isMatch StatusInfo
si -> Either LostPid Text -> IO (Either LostPid Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid Text -> IO (Either LostPid Text))
-> Either LostPid Text -> IO (Either LostPid Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either LostPid Text
forall a b. b -> Either a b
Right Text
candidate
    Right StatusInfo
si ->
      ProcNamer
nameFromExeOnly (StatusInfo -> ProcessID
siParent StatusInfo
si) IO (Either LostPid Text)
-> (Either LostPid Text -> IO (Either LostPid Text))
-> IO (Either LostPid Text)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right Text
n | Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
candidate -> Either LostPid Text -> IO (Either LostPid Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid Text -> IO (Either LostPid Text))
-> Either LostPid Text -> IO (Either LostPid Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either LostPid Text
forall a b. b -> Either a b
Right Text
n
        Either LostPid Text
_ -> Either LostPid Text -> IO (Either LostPid Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid Text -> IO (Either LostPid Text))
-> Either LostPid Text -> IO (Either LostPid Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either LostPid Text
forall a b. b -> Either a b
Right (Text -> Either LostPid Text) -> Text -> Either LostPid Text
forall a b. (a -> b) -> a -> b
$ StatusInfo -> Text
siName StatusInfo
si


-- | Represents errors that prevent a report from being generated
data NotRun
  = PidLost LostPid
  | MissingPids (NonEmpty ProcessID)
  | NeedsRoot
  | OddKernel
  | NoRecords
  deriving (NotRun -> NotRun -> Bool
(NotRun -> NotRun -> Bool)
-> (NotRun -> NotRun -> Bool) -> Eq NotRun
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NotRun -> NotRun -> Bool
== :: NotRun -> NotRun -> Bool
$c/= :: NotRun -> NotRun -> Bool
/= :: NotRun -> NotRun -> Bool
Eq, Int -> NotRun -> ShowS
[NotRun] -> ShowS
NotRun -> FilePath
(Int -> NotRun -> ShowS)
-> (NotRun -> FilePath) -> ([NotRun] -> ShowS) -> Show NotRun
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NotRun -> ShowS
showsPrec :: Int -> NotRun -> ShowS
$cshow :: NotRun -> FilePath
show :: NotRun -> FilePath
$cshowList :: [NotRun] -> ShowS
showList :: [NotRun] -> ShowS
Show)


fmtNotRun :: NotRun -> Text
fmtNotRun :: NotRun -> Text
fmtNotRun NotRun
NeedsRoot = Text
"run as root when no pids are specified using -p"
fmtNotRun (PidLost LostPid
x) = LostPid -> Text
fmtLostPid LostPid
x
fmtNotRun NotRun
OddKernel = Text
"unrecognized kernel version"
fmtNotRun (MissingPids NonEmpty ProcessID
pids) = Builder
"no records available for: " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| NonEmpty Integer -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
listF (ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger (ProcessID -> Integer) -> NonEmpty ProcessID -> NonEmpty Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty ProcessID
pids) Builder -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
fmtNotRun NotRun
NoRecords = Text
"could not find any process records"


{- | Represents reasons a specified @pid@ may not have memory
records.
-}
data LostPid
  = NoExeFile ProcessID
  | NoStatusCmd ProcessID
  | NoStatusParent ProcessID
  | NoCmdLine ProcessID
  | BadStatm ProcessID
  | NoProc ProcessID
  deriving (LostPid -> LostPid -> Bool
(LostPid -> LostPid -> Bool)
-> (LostPid -> LostPid -> Bool) -> Eq LostPid
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LostPid -> LostPid -> Bool
== :: LostPid -> LostPid -> Bool
$c/= :: LostPid -> LostPid -> Bool
/= :: LostPid -> LostPid -> Bool
Eq, Int -> LostPid -> ShowS
[LostPid] -> ShowS
LostPid -> FilePath
(Int -> LostPid -> ShowS)
-> (LostPid -> FilePath) -> ([LostPid] -> ShowS) -> Show LostPid
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LostPid -> ShowS
showsPrec :: Int -> LostPid -> ShowS
$cshow :: LostPid -> FilePath
show :: LostPid -> FilePath
$cshowList :: [LostPid] -> ShowS
showList :: [LostPid] -> ShowS
Show)


fmtLostPid :: LostPid -> Text
fmtLostPid :: LostPid -> Text
fmtLostPid (NoStatusCmd ProcessID
pid) = Builder
"missing:no name in {proc_root}/" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger ProcessID
pid Integer -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"/status"
fmtLostPid (NoStatusParent ProcessID
pid) = Builder
"missing:no ppid in {proc_root}/" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger ProcessID
pid Integer -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"/status"
fmtLostPid (NoExeFile ProcessID
pid) = Builder
"missing:{proc_root}/" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger ProcessID
pid Integer -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"/exe"
fmtLostPid (NoCmdLine ProcessID
pid) = Builder
"missing:{proc_root}/" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger ProcessID
pid Integer -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"/cmdline"
fmtLostPid (NoProc ProcessID
pid) = Builder
"missing:memory records for pid:" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger ProcessID
pid Integer -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
fmtLostPid (BadStatm ProcessID
pid) = Builder
"missing:invalid memory record in {proc_root}/" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger ProcessID
pid Integer -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"/statm"


haltLostPid :: LostPid -> IO a
haltLostPid :: forall a. LostPid -> IO a
haltLostPid LostPid
err = do
  Handle -> Text -> IO ()
Text.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Builder
"halting due to " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| LostPid -> Text
fmtLostPid LostPid
err Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
  IO a
forall a. IO a
exitFailure


exeInfo :: ProcessID -> IO (Either LostPid ExeInfo)
exeInfo :: ProcessID -> IO (Either LostPid ExeInfo)
exeInfo ProcessID
pid = do
  let exePath :: FilePath
exePath = FilePath -> ProcessID -> FilePath
pidPath FilePath
"exe" ProcessID
pid
      handledErr :: IOError -> Bool
handledErr IOError
e = IOError -> Bool
isDoesNotExistError IOError
e Bool -> Bool -> Bool
|| IOError -> Bool
isPermissionError IOError
e
      onIOE :: IOError -> IO (Either LostPid b)
onIOE IOError
e = if IOError -> Bool
handledErr IOError
e then Either LostPid b -> IO (Either LostPid b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LostPid -> Either LostPid b
forall a b. a -> Either a b
Left (LostPid -> Either LostPid b) -> LostPid -> Either LostPid b
forall a b. (a -> b) -> a -> b
$ ProcessID -> LostPid
NoExeFile ProcessID
pid) else IOError -> IO (Either LostPid b)
forall e a. Exception e => e -> IO a
throwIO IOError
e
  (IOError -> IO (Either LostPid ExeInfo))
-> IO (Either LostPid ExeInfo) -> IO (Either LostPid ExeInfo)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOError -> IO (Either LostPid ExeInfo)
forall {b}. IOError -> IO (Either LostPid b)
onIOE (IO (Either LostPid ExeInfo) -> IO (Either LostPid ExeInfo))
-> IO (Either LostPid ExeInfo) -> IO (Either LostPid ExeInfo)
forall a b. (a -> b) -> a -> b
$ do
    ExeInfo -> Either LostPid ExeInfo
forall a b. b -> Either a b
Right (ExeInfo -> Either LostPid ExeInfo)
-> (FilePath -> ExeInfo) -> FilePath -> Either LostPid ExeInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ExeInfo
parseExeInfo (Text -> ExeInfo) -> (FilePath -> Text) -> FilePath -> ExeInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack (FilePath -> Either LostPid ExeInfo)
-> IO FilePath -> IO (Either LostPid ExeInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
getSymbolicLinkTarget FilePath
exePath


exists :: Text -> IO Bool
exists :: Text -> IO Bool
exists = FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool) -> (Text -> FilePath) -> Text -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
Text.unpack


statusInfo :: ProcessID -> IO (Either LostPid StatusInfo)
statusInfo :: ProcessID -> IO (Either LostPid StatusInfo)
statusInfo ProcessID
pid = do
  let statusPath :: FilePath
statusPath = FilePath -> ProcessID -> FilePath
pidPath FilePath
"status" ProcessID
pid
      fromBadStatus :: BadStatus -> LostPid
fromBadStatus BadStatus
NoCmd = ProcessID -> LostPid
NoStatusCmd ProcessID
pid
      fromBadStatus BadStatus
NoParent = ProcessID -> LostPid
NoStatusParent ProcessID
pid
  (BadStatus -> LostPid)
-> Either BadStatus StatusInfo -> Either LostPid StatusInfo
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first BadStatus -> LostPid
fromBadStatus (Either BadStatus StatusInfo -> Either LostPid StatusInfo)
-> (Text -> Either BadStatus StatusInfo)
-> Text
-> Either LostPid StatusInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either BadStatus StatusInfo
parseStatusInfo (Text -> Either LostPid StatusInfo)
-> IO Text -> IO (Either LostPid StatusInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
readUtf8Text FilePath
statusPath


parseCmdline :: Text -> Maybe (NonEmpty Text)
parseCmdline :: Text -> Maybe (NonEmpty Text)
parseCmdline =
  let split' :: Text -> [Text]
split' = (Char -> Bool) -> Text -> [Text]
Text.split Char -> Bool
isNullOrSpace (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
Text.dropWhileEnd Char -> Bool
isNull
   in [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Text] -> Maybe (NonEmpty Text))
-> (Text -> [Text]) -> Text -> Maybe (NonEmpty Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
split'


nonExisting :: NonEmpty ProcessID -> IO [ProcessID]
nonExisting :: NonEmpty ProcessID -> IO [ProcessID]
nonExisting = (ProcessID -> IO Bool) -> [ProcessID] -> IO [ProcessID]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (IO Bool -> IO Bool)
-> (ProcessID -> IO Bool) -> ProcessID -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessID -> IO Bool
pidExeExists) ([ProcessID] -> IO [ProcessID])
-> (NonEmpty ProcessID -> [ProcessID])
-> NonEmpty ProcessID
-> IO [ProcessID]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ProcessID -> [ProcessID]
forall a. NonEmpty a -> [a]
NE.toList


checkAllExist :: NonEmpty ProcessID -> IO (Either NotRun (NonEmpty ProcessID))
checkAllExist :: NonEmpty ProcessID -> IO (Either NotRun (NonEmpty ProcessID))
checkAllExist NonEmpty ProcessID
pids =
  NonEmpty ProcessID -> IO [ProcessID]
nonExisting NonEmpty ProcessID
pids IO [ProcessID]
-> ([ProcessID] -> IO (Either NotRun (NonEmpty ProcessID)))
-> IO (Either NotRun (NonEmpty ProcessID))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [] -> Either NotRun (NonEmpty ProcessID)
-> IO (Either NotRun (NonEmpty ProcessID))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either NotRun (NonEmpty ProcessID)
 -> IO (Either NotRun (NonEmpty ProcessID)))
-> Either NotRun (NonEmpty ProcessID)
-> IO (Either NotRun (NonEmpty ProcessID))
forall a b. (a -> b) -> a -> b
$ NonEmpty ProcessID -> Either NotRun (NonEmpty ProcessID)
forall a b. b -> Either a b
Right NonEmpty ProcessID
pids
    ProcessID
x : [ProcessID]
xs -> Either NotRun (NonEmpty ProcessID)
-> IO (Either NotRun (NonEmpty ProcessID))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either NotRun (NonEmpty ProcessID)
 -> IO (Either NotRun (NonEmpty ProcessID)))
-> Either NotRun (NonEmpty ProcessID)
-> IO (Either NotRun (NonEmpty ProcessID))
forall a b. (a -> b) -> a -> b
$ NotRun -> Either NotRun (NonEmpty ProcessID)
forall a b. a -> Either a b
Left (NotRun -> Either NotRun (NonEmpty ProcessID))
-> NotRun -> Either NotRun (NonEmpty ProcessID)
forall a b. (a -> b) -> a -> b
$ NonEmpty ProcessID -> NotRun
MissingPids (NonEmpty ProcessID -> NotRun) -> NonEmpty ProcessID -> NotRun
forall a b. (a -> b) -> a -> b
$ ProcessID
x ProcessID -> [ProcessID] -> NonEmpty ProcessID
forall a. a -> [a] -> NonEmpty a
:| [ProcessID]
xs


allKnownProcs :: IO (Either NotRun (NonEmpty ProcessID))
allKnownProcs :: IO (Either NotRun (NonEmpty ProcessID))
allKnownProcs =
  let readNaturals :: IO [FilePath] -> IO [ProcessID]
readNaturals = ([FilePath] -> [ProcessID]) -> IO [FilePath] -> IO [ProcessID]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath -> Maybe ProcessID) -> [FilePath] -> [ProcessID]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FilePath -> Maybe ProcessID
forall a. Read a => FilePath -> Maybe a
readMaybe)
      orNoPids :: Maybe b -> Either NotRun b
orNoPids = Either NotRun b
-> (b -> Either NotRun b) -> Maybe b -> Either NotRun b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NotRun -> Either NotRun b
forall a b. a -> Either a b
Left NotRun
NoRecords) b -> Either NotRun b
forall a b. b -> Either a b
Right
   in IO [FilePath] -> IO [ProcessID]
readNaturals (FilePath -> IO [FilePath]
listDirectory FilePath
procRoot)
        IO [ProcessID] -> ([ProcessID] -> IO [ProcessID]) -> IO [ProcessID]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ProcessID -> IO Bool) -> [ProcessID] -> IO [ProcessID]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ProcessID -> IO Bool
pidExeExists
        IO [ProcessID]
-> ([ProcessID] -> IO (Either NotRun (NonEmpty ProcessID)))
-> IO (Either NotRun (NonEmpty ProcessID))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either NotRun (NonEmpty ProcessID)
-> IO (Either NotRun (NonEmpty ProcessID))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Either NotRun (NonEmpty ProcessID)
 -> IO (Either NotRun (NonEmpty ProcessID)))
-> ([ProcessID] -> Either NotRun (NonEmpty ProcessID))
-> [ProcessID]
-> IO (Either NotRun (NonEmpty ProcessID))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (NonEmpty ProcessID) -> Either NotRun (NonEmpty ProcessID)
forall {b}. Maybe b -> Either NotRun b
orNoPids
        (Maybe (NonEmpty ProcessID) -> Either NotRun (NonEmpty ProcessID))
-> ([ProcessID] -> Maybe (NonEmpty ProcessID))
-> [ProcessID]
-> Either NotRun (NonEmpty ProcessID)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ProcessID] -> Maybe (NonEmpty ProcessID)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty


baseName :: Text -> Text
baseName :: Text -> Text
baseName = FilePath -> Text
Text.pack (FilePath -> Text) -> (Text -> FilePath) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
takeBaseName ShowS -> (Text -> FilePath) -> Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
Text.unpack


readMemStats :: ReportBud -> ProcessID -> IO (Either LostPid ProcUsage)
readMemStats :: ReportBud -> ProcessID -> IO (Either LostPid ProcUsage)
readMemStats ReportBud
bud ProcessID
pid = do
  Bool
statmExists <- FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> ProcessID -> FilePath
pidPath FilePath
"statm" ProcessID
pid
  if
    | ReportBud -> Bool
rbHasSmaps ReportBud
bud -> ProcUsage -> Either LostPid ProcUsage
forall a b. b -> Either a b
Right (ProcUsage -> Either LostPid ProcUsage)
-> (Text -> ProcUsage) -> Text -> Either LostPid ProcUsage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ProcUsage
parseFromSmap (Text -> Either LostPid ProcUsage)
-> IO Text -> IO (Either LostPid ProcUsage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProcessID -> IO Text
readSmaps ProcessID
pid
    | Bool
statmExists -> do
        let readStatm' :: IO Text
readStatm' = FilePath -> IO Text
readUtf8Text (FilePath -> IO Text) -> FilePath -> IO Text
forall a b. (a -> b) -> a -> b
$ FilePath -> ProcessID -> FilePath
pidPath FilePath
"statm" ProcessID
pid
            orLostPid :: Maybe b -> Either LostPid b
orLostPid = Either LostPid b
-> (b -> Either LostPid b) -> Maybe b -> Either LostPid b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (LostPid -> Either LostPid b
forall a b. a -> Either a b
Left (LostPid -> Either LostPid b) -> LostPid -> Either LostPid b
forall a b. (a -> b) -> a -> b
$ ProcessID -> LostPid
BadStatm ProcessID
pid) b -> Either LostPid b
forall a b. b -> Either a b
Right
        Maybe ProcUsage -> Either LostPid ProcUsage
forall {b}. Maybe b -> Either LostPid b
orLostPid (Maybe ProcUsage -> Either LostPid ProcUsage)
-> (Text -> Maybe ProcUsage) -> Text -> Either LostPid ProcUsage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KernelVersion -> Text -> Maybe ProcUsage
parseFromStatm (ReportBud -> KernelVersion
rbKernel ReportBud
bud) (Text -> Either LostPid ProcUsage)
-> IO Text -> IO (Either LostPid ProcUsage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text
readStatm'
    | Bool
otherwise -> Either LostPid ProcUsage -> IO (Either LostPid ProcUsage)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LostPid ProcUsage -> IO (Either LostPid ProcUsage))
-> Either LostPid ProcUsage -> IO (Either LostPid ProcUsage)
forall a b. (a -> b) -> a -> b
$ LostPid -> Either LostPid ProcUsage
forall a b. a -> Either a b
Left (LostPid -> Either LostPid ProcUsage)
-> LostPid -> Either LostPid ProcUsage
forall a b. (a -> b) -> a -> b
$ ProcessID -> LostPid
NoProc ProcessID
pid


readSmaps :: ProcessID -> IO Text
readSmaps :: ProcessID -> IO Text
readSmaps ProcessID
pid = do
  let smapPath :: FilePath
smapPath = FilePath -> ProcessID -> FilePath
pidPath FilePath
"smaps" ProcessID
pid
      rollupPath :: FilePath
rollupPath = FilePath -> ProcessID -> FilePath
pidPath FilePath
"smaps_rollup" ProcessID
pid
  Bool
hasSmaps <- FilePath -> IO Bool
doesFileExist FilePath
smapPath
  Bool
hasRollup <- FilePath -> IO Bool
doesFileExist FilePath
rollupPath
  if
    | Bool
hasRollup -> FilePath -> IO Text
readUtf8Text FilePath
rollupPath
    | Bool
hasSmaps -> FilePath -> IO Text
readUtf8Text FilePath
smapPath
    | Bool
otherwise -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
Text.empty


overallTotals :: [MemUsage] -> (Int, Int)
overallTotals :: [MemUsage] -> (Int, Int)
overallTotals [MemUsage]
cts =
  let step :: (Int, Int) -> MemUsage -> (Int, Int)
step (Int
private, Int
swap) MemUsage
ct = (Int
private Int -> Int -> Int
forall a. Num a => a -> a -> a
+ MemUsage -> Int
muPrivate MemUsage
ct, Int
swap Int -> Int -> Int
forall a. Num a => a -> a -> a
+ MemUsage -> Int
muSwap MemUsage
ct)
   in ((Int, Int) -> MemUsage -> (Int, Int))
-> (Int, Int) -> [MemUsage] -> (Int, Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int, Int) -> MemUsage -> (Int, Int)
step (Int
0, Int
0) [MemUsage]
cts


fmtMemBytes :: Int -> Text
fmtMemBytes :: Int -> Text
fmtMemBytes Int
x = Builder
"" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024 Int -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""


foldlEitherM ::
  (Foldable t, Monad m) =>
  (a -> m (Either b c)) ->
  t a ->
  m (Either b [c])
foldlEitherM :: forall (t :: * -> *) (m :: * -> *) a b c.
(Foldable t, Monad m) =>
(a -> m (Either b c)) -> t a -> m (Either b [c])
foldlEitherM a -> m (Either b c)
f t a
xs =
  let go :: Either b [c] -> a -> m (Either b [c])
go (Left b
err) a
_ = Either b [c] -> m (Either b [c])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either b [c] -> m (Either b [c]))
-> Either b [c] -> m (Either b [c])
forall a b. (a -> b) -> a -> b
$ b -> Either b [c]
forall a b. a -> Either a b
Left b
err
      go (Right [c]
acc) a
a =
        a -> m (Either b c)
f a
a m (Either b c)
-> (Either b c -> m (Either b [c])) -> m (Either b [c])
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left b
err -> Either b [c] -> m (Either b [c])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either b [c] -> m (Either b [c]))
-> Either b [c] -> m (Either b [c])
forall a b. (a -> b) -> a -> b
$ b -> Either b [c]
forall a b. a -> Either a b
Left b
err
          Right c
y -> Either b [c] -> m (Either b [c])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either b [c] -> m (Either b [c]))
-> Either b [c] -> m (Either b [c])
forall a b. (a -> b) -> a -> b
$ [c] -> Either b [c]
forall a b. b -> Either a b
Right (c
y c -> [c] -> [c]
forall a. a -> [a] -> [a]
: [c]
acc)
   in (Either b [c] -> a -> m (Either b [c]))
-> Either b [c] -> t a -> m (Either b [c])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM Either b [c] -> a -> m (Either b [c])
go ([c] -> Either b [c]
forall a b. b -> Either a b
Right []) t a
xs


foldlEitherM' ::
  (Foldable t, Monad m) =>
  (a -> m (Either b c)) ->
  t a ->
  m ([a], [c])
foldlEitherM' :: forall (t :: * -> *) (m :: * -> *) a b c.
(Foldable t, Monad m) =>
(a -> m (Either b c)) -> t a -> m ([a], [c])
foldlEitherM' a -> m (Either b c)
f t a
xs =
  let
    go :: ([a], [c]) -> a -> m ([a], [c])
go ([a]
as, [c]
cs) a
a =
      a -> m (Either b c)
f a
a m (Either b c) -> (Either b c -> m ([a], [c])) -> m ([a], [c])
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left b
_ -> ([a], [c]) -> m ([a], [c])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as, [c]
cs)
        Right c
c -> ([a], [c]) -> m ([a], [c])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a]
as, c
c c -> [c] -> [c]
forall a. a -> [a] -> [a]
: [c]
cs)
   in
    (([a], [c]) -> a -> m ([a], [c]))
-> ([a], [c]) -> t a -> m ([a], [c])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM ([a], [c]) -> a -> m ([a], [c])
go ([a]
forall a. Monoid a => a
mempty, [c]
forall a. Monoid a => a
mempty) t a
xs


haltErr :: Text -> IO a
haltErr :: forall a. Text -> IO a
haltErr Text
err = do
  Bool -> Text -> IO ()
errStrLn Bool
True Text
err
  IO a
forall a. IO a
exitFailure


errStrLn :: Bool -> Text -> IO ()
errStrLn :: Bool -> Text -> IO ()
errStrLn Bool
errOrWarn Text
txt = do
  let prefix :: Text
prefix = if Bool
errOrWarn then Text
"error: " else Text
"warning: "
  Handle -> Text -> IO ()
Text.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txt


-- | Functions that generate the report index
type Indexer index = (ProcessID, ProcName, ProcUsage) -> (index, ProcUsage)


{- | Index a @'ProcUsage'@ using the program name and process ID.

Each @ProcUsage@ remains distinct when added to a @MemUsage@
-}
withPid :: Indexer (ProcessID, ProcName)
withPid :: Indexer (ProcessID, Text)
withPid (ProcessID
pid, Text
name, ProcUsage
pp) = ((ProcessID
pid, Text
name), ProcUsage
pp)


{- | Index a @'ProcUsage'@ using just the program name

@ProcUsage's@ with the same @ProcName@ will be merged when added to a @MemUsage@
-}
dropId :: Indexer ProcName
dropId :: Indexer Text
dropId (ProcessID
_pid, Text
name, ProcUsage
pp) = (Text
name, ProcUsage
pp)


byPrintOrder ::
  (Ord c) =>
  (((c, MemUsage) -> Int) -> (c, MemUsage) -> (c, MemUsage) -> Ordering) ->
  PrintOrder ->
  (c, MemUsage) ->
  (c, MemUsage) ->
  Ordering
byPrintOrder :: forall c.
Ord c =>
(((c, MemUsage) -> Int)
 -> (c, MemUsage) -> (c, MemUsage) -> Ordering)
-> PrintOrder -> (c, MemUsage) -> (c, MemUsage) -> Ordering
byPrintOrder ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f PrintOrder
Swap = ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f (((c, MemUsage) -> Int)
 -> (c, MemUsage) -> (c, MemUsage) -> Ordering)
-> ((c, MemUsage) -> Int)
-> (c, MemUsage)
-> (c, MemUsage)
-> Ordering
forall a b. (a -> b) -> a -> b
$ MemUsage -> Int
muSwap (MemUsage -> Int)
-> ((c, MemUsage) -> MemUsage) -> (c, MemUsage) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c, MemUsage) -> MemUsage
forall a b. (a, b) -> b
snd
byPrintOrder ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f PrintOrder
Shared = ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f (((c, MemUsage) -> Int)
 -> (c, MemUsage) -> (c, MemUsage) -> Ordering)
-> ((c, MemUsage) -> Int)
-> (c, MemUsage)
-> (c, MemUsage)
-> Ordering
forall a b. (a -> b) -> a -> b
$ MemUsage -> Int
muShared (MemUsage -> Int)
-> ((c, MemUsage) -> MemUsage) -> (c, MemUsage) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c, MemUsage) -> MemUsage
forall a b. (a, b) -> b
snd
byPrintOrder ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f PrintOrder
Private = ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f (((c, MemUsage) -> Int)
 -> (c, MemUsage) -> (c, MemUsage) -> Ordering)
-> ((c, MemUsage) -> Int)
-> (c, MemUsage)
-> (c, MemUsage)
-> Ordering
forall a b. (a -> b) -> a -> b
$ MemUsage -> Int
muPrivate (MemUsage -> Int)
-> ((c, MemUsage) -> MemUsage) -> (c, MemUsage) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c, MemUsage) -> MemUsage
forall a b. (a, b) -> b
snd
byPrintOrder ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f PrintOrder
Count = ((c, MemUsage) -> Int)
-> (c, MemUsage) -> (c, MemUsage) -> Ordering
f (((c, MemUsage) -> Int)
 -> (c, MemUsage) -> (c, MemUsage) -> Ordering)
-> ((c, MemUsage) -> Int)
-> (c, MemUsage)
-> (c, MemUsage)
-> Ordering
forall a b. (a -> b) -> a -> b
$ MemUsage -> Int
muCount (MemUsage -> Int)
-> ((c, MemUsage) -> MemUsage) -> (c, MemUsage) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c, MemUsage) -> MemUsage
forall a b. (a, b) -> b
snd


byPrintOrder' ::
  (Ord a) =>
  Bool ->
  Maybe PrintOrder ->
  (a, MemUsage) ->
  (a, MemUsage) ->
  Ordering
byPrintOrder' :: forall a.
Ord a =>
Bool
-> Maybe PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering
byPrintOrder' Bool
reversed Maybe PrintOrder
mbOrder =
  let cmpUsage :: (b -> Int) -> b -> b -> Ordering
cmpUsage = if Bool
reversed then (b -> Int) -> b -> b -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing else (b -> Int) -> b -> b -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing'
      cmpName :: (b -> a) -> b -> b -> Ordering
cmpName = if Bool
reversed then (b -> a) -> b -> b -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing else (b -> a) -> b -> b -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing'
      byName :: (a, b) -> (a, b) -> Ordering
byName = ((a, b) -> a) -> (a, b) -> (a, b) -> Ordering
forall {b}. (b -> a) -> b -> b -> Ordering
cmpName (a, b) -> a
forall a b. (a, b) -> a
fst
      byUsage :: PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering
byUsage = (((a, MemUsage) -> Int)
 -> (a, MemUsage) -> (a, MemUsage) -> Ordering)
-> PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering
forall c.
Ord c =>
(((c, MemUsage) -> Int)
 -> (c, MemUsage) -> (c, MemUsage) -> Ordering)
-> PrintOrder -> (c, MemUsage) -> (c, MemUsage) -> Ordering
byPrintOrder ((a, MemUsage) -> Int)
-> (a, MemUsage) -> (a, MemUsage) -> Ordering
forall {b}. (b -> Int) -> b -> b -> Ordering
cmpUsage
   in ((a, MemUsage) -> (a, MemUsage) -> Ordering)
-> (PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering)
-> Maybe PrintOrder
-> (a, MemUsage)
-> (a, MemUsage)
-> Ordering
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a, MemUsage) -> (a, MemUsage) -> Ordering
forall {b}. (a, b) -> (a, b) -> Ordering
byName PrintOrder -> (a, MemUsage) -> (a, MemUsage) -> Ordering
byUsage Maybe PrintOrder
mbOrder


comparing' :: (Ord a) => (b -> a) -> b -> b -> Ordering
comparing' :: forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing' b -> a
f b
a b
b = Down a -> Down a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> Down a
forall a. a -> Down a
Down (a -> Down a) -> a -> Down a
forall a b. (a -> b) -> a -> b
$ b -> a
f b
a) (a -> Down a
forall a. a -> Down a
Down (a -> Down a) -> a -> Down a
forall a b. (a -> b) -> a -> b
$ b -> a
f b
b)