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