Merge pull request #8 from adetokunbo/allow-different-output-fmts

Allow different output fmts

src/System/MemInfo.hs

@@ -59,6 +59,7 @@ 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
@@ -69,13 +70,17 @@ import Fmt (
  (|++|),
  )
 import System.Exit (exitFailure)
-import System.MemInfo.Choices (Choices (..), PrintOrder (..), getChoices)
+import System.MemInfo.Choices (
+ Choices (..),
+ PrintOrder (..),
+ Style (..),
+ getChoices,
+ )
 import System.MemInfo.Prelude
 import System.MemInfo.Print (
  AsCmdName (..),
- fmtAsHeader,
  fmtMemUsage,
- fmtOverall,
+ styleOutput,
  )
 import System.MemInfo.Proc (
  BadStatus (..),
@@ -116,13 +121,15 @@ printProcs' indexer bud cs = do
  , choiceWatchSecs = watchSecsMb
  , choicePrintOrder = printOrder
  , choiceReversed = reversed
+ , choiceStyle = style
  } = cs
+ style' = fromMaybe Normal style
  toList = sortBy (byPrintOrder' reversed printOrder) . Map.toList
- printEachCmd = printMemUsages bud showSwap onlyTotal . toList
+ printEachCmd = printMemUsages bud style' showSwap onlyTotal . toList
  printTheTotal = onlyPrintTotal bud showSwap onlyTotal . toList
  showTotal = if onlyTotal then printTheTotal else printEachCmd
  namer = if choiceSplitArgs cs then nameAsFullCmd else nameFor
- case (watchSecsMb) of
+ case watchSecsMb of
  Nothing -> readMemUsage' namer indexer bud >>= either haltLostPid showTotal
  (Just spanSecs) -> do
  let unfold = unfoldMemUsageAfter' namer indexer spanSecs
@@ -132,17 +139,15 @@ printProcs' indexer bud cs = do
 printMemUsages ::
  (AsCmdName a) =>
  ReportBud ->
+ Style ->
  Bool ->
  Bool ->
  [(a, MemUsage)] ->
  IO ()
-printMemUsages bud showSwap onlyTotal totals = do
- let overall = overallTotals $ map snd totals
- overallIsAccurate = (showSwap && rbHasSwapPss bud) || rbHasPss bud
- print' (name, stats) = Text.putStrLn $ fmtMemUsage showSwap name stats
- Text.putStrLn $ fmtAsHeader showSwap
- mapM_ print' totals
- when overallIsAccurate $ Text.putStrLn $ fmtOverall showSwap overall
+printMemUsages bud style showSwap onlyTotal totals = do
+ let overallIsAccurate = (showSwap && rbHasSwapPss bud) || rbHasPss bud
+ output = styleOutput showSwap style overallIsAccurate totals
+ mapM_ Text.putStrLn output
  reportFlaws bud showSwap onlyTotal
 
 

src/System/MemInfo/Choices.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 {- |
 Module : System.MemInfo.Choices
@@ -13,17 +14,20 @@ __printmem__ command
 -}
 module System.MemInfo.Choices (
  Choices (..),
+ Style (..),
  PrintOrder (..),
  cmdInfo,
  getChoices,
 ) where
 
+import qualified Data.Text as Text
 import GHC.Generics (Generic)
 import Options.Applicative (
  Parser,
  ParserInfo,
  ReadM,
  auto,
+ eitherReader,
  execParser,
  help,
  helper,
@@ -55,6 +59,7 @@ data Choices = Choices
  , choiceWatchSecs :: !(Maybe Natural)
  , choicePidsToShow :: !(Maybe (NonEmpty ProcessID))
  , choicePrintOrder :: !(Maybe PrintOrder)
+ , choiceStyle :: !(Maybe Style)
  }
  deriving (Eq, Show, Generic)
 
@@ -75,6 +80,7 @@ parseChoices =
  <*> optional parseWatchPeriodSecs
  <*> optional parseChoicesPidsToShow
  <*> optional parsePrintOrder
+ <*> optional parseStyle
 
 
 parseChoicesPidsToShow :: Parser (NonEmpty ProcessID)
@@ -148,10 +154,10 @@ positiveNum =
 
 parsePrintOrder :: Parser PrintOrder
 parsePrintOrder =
- option auto
+ option autoIgnoreCase
  $ short 'b'
  <> long "order-by"
- <> metavar "<Private | Swap | Shared | Count>"
+ <> metavar "< private | swap | shared | count >"
  <> help "Orders the output by ascending values of the given field"
 
 
@@ -162,3 +168,33 @@ data PrintOrder
  | Shared
  | Count
  deriving (Eq, Show, Read, Generic)
+
+
+parseStyle :: Parser Style
+parseStyle =
+ option autoIgnoreCase
+ $ short 'y'
+ <> long "output-style"
+ <> metavar "< [normal] | csv >"
+ <> help (Text.unpack styleHelp)
+
+
+styleHelp :: Text
+styleHelp =
+ Text.unlines
+ [ "Determines how the output report is presented;"
+ , "'normal' is the default and is the same as if this option was omitted;"
+ , "'csv' outputs the usage and header rows in csv format, with all values in KiB and 'overall' row."
+ , "With 'csv', the --total (-t) flag is ignored"
+ ]
+
+
+-- | Determines the format style of the output
+data Style
+ = Csv
+ | Normal
+ deriving (Eq, Show, Read, Generic)
+
+
+autoIgnoreCase :: (Read a) => ReadM a
+autoIgnoreCase = eitherReader $ readEither . Text.unpack . Text.toTitle . Text.pack

src/System/MemInfo/Print.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 {- |
@@ -14,10 +15,12 @@ module System.MemInfo.Print (
  fmtAsHeader,
  fmtOverall,
  fmtMemUsage,
+ styleOutput,
 ) where
 
 import qualified Data.Text as Text
 import Fmt (
+ build,
  fixedF,
  padBothF,
  padLeftF,
@@ -28,10 +31,16 @@ import Fmt (
  (|++|),
  (||+),
  )
+import System.MemInfo.Choices (Style (..))
 import System.MemInfo.Prelude
 import System.MemInfo.Proc (MemUsage (..))
 
 
+-- | Generate the output for a given report using the specified style
+styleOutput :: (AsCmdName a) => Bool -> Style -> Bool -> [(a, MemUsage)] -> [Text]
+styleOutput showSwap style isAccurate = outputOf isAccurate (printStyle style showSwap)
+
+
 {- | Generates the text of a row displaying the metrics for a single command in
 the memory report
 -}
@@ -44,12 +53,24 @@ fmtMemUsage showSwap name ct =
  all' = padl $ muPrivate ct
  swap' = padl $ muSwap ct
  name' = cmdWithCount name $ muCount ct
- ram = "" +| private |+ " + " +| shared |+ " = " +| all' |+ ""
- label = "" +| name' |+ ""
+ ram = private |+ " + " +| shared |+ " = " +| all'
+ numbers = if showSwap then ram +| swap' else ram
+ in
+ numbers |+ "\t" +| name' |+ ""
+
+
+fmtMemUsageCsv :: (AsCmdName a) => Bool -> a -> MemUsage -> Text
+fmtMemUsageCsv showSwap name ct =
+ let
+ private = build $ muPrivate ct - muShared ct
+ shared = build $ muShared ct
+ all' = build $ muPrivate ct
+ swap' = build $ muSwap ct
+ name' = cmdWithCount name $ muCount ct
+ ram = private |+ "," +| shared |+ "," +| all' |+ ","
+ numbers = if showSwap then ram +| swap' |+ "," else ram
  in
- if showSwap
- then ram <> ("" +| swap' |+ "\t") <> label
- else ram <> "\t" <> label
+ numbers +| name' |+ ""
 
 
 -- | Generates the text showing the overall memory in the memory report
@@ -109,12 +130,25 @@ fmtAsHeader showSwap =
  all' = padl hdrRamUsed
  name' = padr hdrProgram
  swap' = padl hdrSwapUsed
- ram = "" +| private |+ " + " +| shared |+ " = " +| all' |+ ""
- label = "" +| name' |+ ""
+ ram = private |+ " + " +| shared |+ " = " +| all'
+ numbers = if showSwap then ram +| swap' else ram
  in
- if showSwap
- then ram <> ("" +| swap' |+ "\t") <> label
- else ram <> "\t" <> label
+ numbers |+ "\t" +| name' |+ ""
+
+
+-- | Generates the text of the printed header of the memory report
+fmtAsHeaderCsv :: Bool -> Text
+fmtAsHeaderCsv showSwap =
+ let
+ private = build hdrPrivate
+ shared = build hdrShared
+ all' = build hdrRamUsed
+ name' = build hdrProgram
+ swap' = build hdrSwapUsed
+ ram = private |+ "," +| shared |+ "," +| all' |+ ","
+ numbers = if showSwap then ram +| swap' |+ "," else ram
+ in
+ numbers +| name' |+ ""
 
 
 {- | Identifies a type as a label to use to index programs in the report
@@ -139,3 +173,42 @@ instance AsCmdName Text where
 instance AsCmdName (ProcessID, Text) where
  asCmdName (pid, name) = "" +| name |+ " [" +| toInteger pid |+ "]"
  cmdWithCount cmd _count = "" +| asCmdName cmd |+ ""
+
+
+overallTotals :: [MemUsage] -> (Int, Int)
+overallTotals cts =
+ let step (private, swap) ct = (private + muPrivate ct, swap + muSwap ct)
+ in foldl' step (0, 0) cts
+
+
+data Printers a = Printers
+ { psUsage :: a -> MemUsage -> Text
+ , psHeader :: Text
+ , psOverall :: (Int, Int) -> Maybe Text
+ }
+
+
+printStyle :: (AsCmdName a) => Style -> Bool -> Printers a
+printStyle style showSwap =
+ let usageFmt Normal = fmtMemUsage
+ usageFmt Csv = fmtMemUsageCsv
+ headerFmt Normal = fmtAsHeader
+ headerFmt Csv = fmtAsHeaderCsv
+ overallFmt Normal x = Just $ fmtOverall showSwap x
+ overallFmt Csv _ = Nothing
+ in Printers
+ { psUsage = usageFmt style showSwap
+ , psOverall = overallFmt style
+ , psHeader = headerFmt style showSwap
+ }
+
+
+outputOf :: (AsCmdName a) => Bool -> Printers a -> [(a, MemUsage)] -> [Text]
+outputOf isAccurate style usages =
+ let Printers {psUsage, psHeader, psOverall} = style
+ overall = psOverall $ overallTotals $ map snd usages
+ headerAndRows = [psHeader] <> map (uncurry psUsage) usages
+ in case overall of
+ Nothing -> headerAndRows
+ Just _ | not isAccurate -> headerAndRows
+ Just o -> headerAndRows <> [o]

test/MemInfo/ChoicesSpec.hs

@@ -10,11 +10,13 @@ module MemInfo.ChoicesSpec where
 
 import Data.GenValidity (GenValid (..))
 import qualified Data.List.NonEmpty as NE
+import Data.Text (Text)
+import qualified Data.Text as Text
 import MemInfo.OrphanInstances ()
 import Options.Applicative (defaultPrefs, execParserPure, getParseResult)
 import System.MemInfo.Choices (Choices (..), cmdInfo)
 import Test.Hspec
-import Test.QuickCheck (Gen, Property, forAll, suchThat)
+import Test.QuickCheck (Gen, Property, elements, forAll, suchThat)
 
 
 spec :: Spec
@@ -31,11 +33,16 @@ prop_roundtripParseChoices =
 genCmdLine :: Gen (Choices, [String])
 genCmdLine = do
  choices <- genValid `suchThat` ((/= Just 0) . choiceWatchSecs)
- pure (choices, cmdlineOf choices)
+ changeCase <- genChangeCase
+ pure (choices, cmdlineOf (Text.unpack . changeCase . Text.pack) choices)
 
 
-cmdlineOf :: Choices -> [String]
-cmdlineOf c =
+genChangeCase :: (Gen (Text -> Text))
+genChangeCase = elements [id, Text.toLower, Text.toUpper]
+
+
+cmdlineOf :: (String -> String) -> Choices -> [String]
+cmdlineOf changeCase c =
  let
  splitArgs = if choiceSplitArgs c then ("-s" :) else id
  onlyTotal = if choiceOnlyTotal c then ("-t" :) else id
@@ -46,7 +53,8 @@ cmdlineOf c =
  onePid x = "-p " ++ show x
  manyPids xs = (map onePid (NE.toList xs) ++)
  pidsToShow = maybe id manyPids $ choicePidsToShow c
- printOrder = maybe id (\x -> (("-b " ++ show x) :)) $ choicePrintOrder c
+ printOrder = maybe id (\x -> (("-b " ++ changeCase (show x)) :)) $ choicePrintOrder c
+ style = maybe id (\x -> (("-y " ++ changeCase (show x)) :)) $ choiceStyle c
  in
  reversed
  $ printOrder
@@ -55,4 +63,5 @@ cmdlineOf c =
  $ onlyTotal
  $ byPid
  $ showSwap
+ $ style
  $ watchSecs mempty

test/MemInfo/OrphanInstances.hs

@@ -20,7 +20,7 @@ module MemInfo.OrphanInstances where
 import Data.GenValidity (GenValid (..))
 import Data.GenValidity.Text ()
 import Data.List.NonEmpty (nonEmpty)
-import System.MemInfo.Choices (Choices (..), PrintOrder)
+import System.MemInfo.Choices (Choices (..), PrintOrder, Style)
 import System.MemInfo.Proc (ExeInfo (..), StatusInfo)
 import System.Posix.Types (CPid (..), ProcessID)
 import Test.QuickCheck (Gen, frequency, suchThat)
@@ -58,6 +58,12 @@ deriving instance Validity PrintOrder
 deriving anyclass instance GenValid PrintOrder
 
 
+deriving instance Validity Style
+
+
+deriving instance GenValid Style
+
+
 instance GenValid Choices where
  genValid =
  let genPositiveMb = frequency [(1, pure Nothing), (5, Just <$> genPositive)]
@@ -71,3 +77,4 @@ instance GenValid Choices where
  <*> genPositiveMb
  <*> genPids
  <*> genValid
+ <*> genValid