Add a --for-each option
authorJoachim Breitner <mail@joachim-breitner.de>
Mon, 4 Nov 2013 22:52:08 +0000 (22:52 +0000)
committerJoachim Breitner <mail@joachim-breitner.de>
Mon, 4 Nov 2013 22:52:08 +0000 (22:52 +0000)
src/LeftFold.hs
src/Stats.hs
src/stats-main.hs

index 8006e27..9c748e9 100644 (file)
@@ -7,6 +7,8 @@ import Data.List
 import Data.Monoid
 import Data.Strict ((:!:), Pair((:!:)))
 import qualified Data.Strict as S
+import qualified Data.Map.Strict as M
+import Data.Maybe
 
 
 data LeftFold x a = forall s. LeftFold {
@@ -47,8 +49,13 @@ mapElems :: LeftFold y a -> (x -> y) -> LeftFold x a
 mapElems (Pure x) _ = (Pure x)
 mapElems (LeftFold s p f) t = LeftFold s (\s x -> p s $! t x) f
 
-filterWith :: (x -> Bool) -> LeftFold (Bool :!: x) a -> LeftFold x a
-filterWith p f = f `mapElems` (\x -> (p x :!: x))
+filterElems :: (x -> Bool) -> LeftFold x a -> LeftFold x a 
+filterElems _ (Pure x) = (Pure x)
+filterElems pred (LeftFold s p f) = LeftFold s (\s x -> if pred x then p s x else s) f
+
+adjoin :: (x -> Bool) -> LeftFold (Bool :!: x) a -> LeftFold x a
+adjoin p f = f `mapElems` (\x -> (p x :!: x))
+
 
 onSelected :: LeftFold x a -> LeftFold (Bool :!: x) a
 onSelected (Pure x) = Pure x
@@ -100,6 +107,12 @@ runOnIntervals (LeftFold si pi fi) (LeftFold so po fo) = LeftFold (S.Nothing :!:
           finish (S.Just si :!: S.Just so) = fo (po so (fi si))
           finish (S.Just si :!: S.Nothing) = fo (po so (fi si))
 
+multiplex :: Ord k => (a -> k) -> LeftFold a b -> LeftFold a (M.Map k b)
+multiplex key (LeftFold si pi fi) = LeftFold M.empty go finish
+    where go m x = M.alter go' (key x) m
+            where go' mbOld = Just $ pi (fromMaybe si mbOld) x
+          finish = M.map fi
+
 lfLength :: LeftFold x Int
 lfLength = leftFold 0 (\c _ -> c + 1)
 
index 69b98e2..591afa2 100644 (file)
@@ -6,12 +6,14 @@ module Stats (
     ReportResults(..),
     ActivityFilter(..),
     Filter(..),
+    Repeater(..),
     defaultFilter,
     defaultReportOptions,
     parseActivityMatcher,
     filterPredicate,
     prepareCalculations,
-    processReports,
+    processReport,
+    processRepeater,
     renderReport
     ) where
 
@@ -26,7 +28,8 @@ import Data.MyText (Text,pack,unpack)
 import Data.Function (on)
 import System.Locale (defaultTimeLocale)
 import Control.Applicative
-import Data.Strict ((:!:))
+import Data.Strict ((:!:), Pair(..))
+import qualified Data.Strict as Strict
 import Data.Traversable (sequenceA)
 
 import Data
@@ -51,6 +54,9 @@ data ActivityMatcher = MatchActivity Activity | MatchCategory Category
 data ActivityFilter = ExcludeActivity ActivityMatcher | OnlyActivity ActivityMatcher
         deriving (Show, Eq)
 
+data Repeater = ByDay | ByMonth | ByYear
+        deriving (Show, Eq)
+
 -- Supported report output formats: text, comma-separated values and
 -- tab-separated values
 data ReportFormat = RFText | RFCSV | RFTSV
@@ -79,6 +85,7 @@ data ReportResults =
         | PieChartOfTimePercValues  String [(String, String, Double)]
         | ListOfIntervals String [Interval]
         | MultipleReportResults [ReportResults]
+        | RepeatedReportResults String [(String, ReportResults)]
 
 
 filterPredicate :: [Filter] -> TimeLogEntry (Ctx, ActivityData) -> Bool
@@ -160,8 +167,19 @@ calcSums = LeftFold M.empty
                 let go' m act = M.insertWith' (+) act (fromInteger (tlRate tl)/1000) m
                 in foldl' go' m (snd (tlData tl))) id
 
-processReports :: ReportOptions -> [Report] ->  LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) [ReportResults]
-processReports opts = sequenceA . map (processReport opts)
+processRepeater :: Repeater -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults
+processRepeater ByDay rep =
+    filterElems (\(b :!: _) -> b) $ 
+    pure (RepeatedReportResults "Day" . map (\(d,rr) -> (showGregorian d, rr)) . M.toList) <*>
+    multiplex (utctDay . tlTime . Strict.snd) rep
+processRepeater ByMonth rep =
+    filterElems (\(b :!: _) -> b) $ 
+    pure (RepeatedReportResults "Month" . map (\((y,m),rr) -> (show y ++ "-" ++ show m, rr)) . M.toList) <*>
+    multiplex ((\(y,m,d) -> (y, m)). toGregorian . utctDay . tlTime . Strict.snd) rep
+processRepeater ByYear rep =
+    filterElems (\(b :!: _) -> b) $ 
+    pure (RepeatedReportResults "Year" . map (\(y,rr) -> (show y, rr)) . M.toList) <*>
+    multiplex ((\(y,m,d) -> y). toGregorian . utctDay . tlTime . Strict.snd) rep
 
 processReport :: ReportOptions -> Report -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults
 processReport opts GeneralInfos =
@@ -187,6 +205,7 @@ processReport opts GeneralInfos =
     onSelected calcTotalTime
 
 processReport opts  TotalTime =
+    onSelected $
         pure (\totalTimeSel sums -> 
             ListOfTimePercValues "Total time per tag" .
             mapMaybe (\(tag,time) ->
@@ -202,8 +221,8 @@ processReport opts  TotalTime =
             sortBy (comparing snd) $
             M.toList $
             sums) <*>
-    onSelected calcTotalTime <*>
-    onSelected calcSums 
+    calcTotalTime <*>
+    calcSums 
 
 processReport opts (Category cat) = pure (\c -> processCategoryReport opts c cat) <*>
     prepareCalculations
@@ -324,22 +343,26 @@ renderReport opts reportdata =
 
 doRender :: ReportOptions -> ReportResults -> String
 doRender opts reportdata = case roReportFormat opts of
-                RFText -> renderReportText reportdata
-                RFCSV -> renderReportCSV reportdata
-                RFTSV -> renderReportTSV reportdata
+                RFText -> renderReportText id reportdata
+                RFCSV -> renderWithDelimiter "," $ renderXSV reportdata
+                RFTSV -> renderWithDelimiter "\t" $ renderXSV reportdata
 
-renderReportText (ListOfFields title dats) = 
-    underline title ++
+renderReportText titleMod (ListOfFields title dats) = 
+    underline (titleMod title) ++
     (tabulate False $ map (\(f,v) -> [f,v]) dats)
 
-renderReportText (ListOfTimePercValues title dats) = 
-    underline title ++ (tabulate True $ listOfValues dats)
+renderReportText titleMod (ListOfTimePercValues title dats) = 
+    underline (titleMod title) ++ (tabulate True $ listOfValues dats)
+
+renderReportText titleMod (PieChartOfTimePercValues title dats) = 
+    underline (titleMod title) ++ (tabulate True $ piechartOfValues dats)
 
-renderReportText (PieChartOfTimePercValues title dats) = 
-    underline title ++ (tabulate True $ piechartOfValues dats)
+renderReportText titleMod (ListOfIntervals title dats) = 
+    underline (titleMod title) ++ (tabulate True $ listOfIntervals dats)
 
-renderReportText (ListOfIntervals title dats) = 
-    underline title ++ (tabulate True $ listOfIntervals dats)
+renderReportText titleMod (RepeatedReportResults cat reps) = 
+    intercalate "\n" $ map (\(v,rr) -> renderReportText (titleMod . mod v) rr) reps
+  where mod v s = s ++ " (" ++ cat ++ " " ++ v ++ ")"
 
 listOfValues dats =
     ["Tag","Time","Percentage"] :
@@ -355,31 +378,20 @@ listOfIntervals dats =
 
 -- The reporting of "General Information" is not supported for the
 -- comma-separated output format.
-renderReportCSV (ListOfFields title dats) = 
-    error ("\"" ++ title ++ "\"" ++ " not supported for comma-separated output format")
+renderXSV (ListOfFields title dats) = 
+    error ("\"" ++ title ++ "\"" ++ " not supported for this output format")
 
-renderReportCSV (ListOfTimePercValues _ dats) = 
-    renderWithDelimiter "," (listOfValues dats)
+renderXSV (ListOfTimePercValues _ dats) = listOfValues dats
 
-renderReportCSV (PieChartOfTimePercValues _ dats) = 
-    renderWithDelimiter "," (piechartOfValues dats)
+renderXSV (PieChartOfTimePercValues _ dats) = piechartOfValues dats
 
-renderReportCSV (ListOfIntervals title dats) = 
-    renderWithDelimiter "," (listOfIntervals dats)
+renderXSV (ListOfIntervals title dats) = listOfIntervals dats
 
--- The reporting of "General Information" is not supported for the
--- TAB-separated output format.
-renderReportTSV (ListOfFields title dats) = 
-    error ("\"" ++ title ++ "\"" ++ " not supported for TAB-separated output format")
-
-renderReportTSV (ListOfTimePercValues _ dats) = 
-    renderWithDelimiter "\t" (listOfValues dats)
-
-renderReportTSV (PieChartOfTimePercValues _ dats) = 
-    renderWithDelimiter "\t" (piechartOfValues dats)
-
-renderReportTSV (ListOfIntervals title dats) = 
-    renderWithDelimiter "\t" (listOfIntervals dats)
+-- A bit code-smelly here.
+renderXSV (RepeatedReportResults cat reps) = title : fields
+  where
+    title = cat : head (renderXSV (snd (head reps)))
+    fields = concatMap (\(v,rr) -> map (v:) (tail (renderXSV rr))) reps
 
 renderWithDelimiter :: String -> [[String]] -> String
 renderWithDelimiter delim datasource =
index 7996988..4006651 100644 (file)
@@ -29,6 +29,7 @@ import Paths_arbtt (version)
 data Options = Options
     { optReports :: [Report]
     , optFilters :: [Filter]
+    , optRepeater :: [Repeater]
     , optAlsoInactive :: Bool
     , optReportOptions :: ReportOptions
     , optLogFile :: String
@@ -39,6 +40,7 @@ defaultOptions :: FilePath -> Options
 defaultOptions dir = Options
     { optReports = []
     , optFilters = []
+    , optRepeater = []
     , optAlsoInactive = False
     , optReportOptions = defaultReportOptions
     , optLogFile = dir </> "capture.log"
@@ -124,8 +126,20 @@ options =
               (ReqArg (\arg opt -> let ro = (optReportOptions opt) { roReportFormat = readReportFormat arg }
                                    in  return opt { optReportOptions = ro }) "FORMAT")
               "one of: text, csv (comma-separated values), tsv (TAB-separated values) (default: Text)"
+     , Option ""       ["for-each"]
+              (ReqArg (\arg opt -> let repeater = readRepeater arg : optRepeater opt
+                                   in  return opt { optRepeater = repeater }) "PERIOD")
+              "one of: day, month, year"
      ]
 
+readRepeater :: String -> Repeater
+readRepeater arg =
+    case map toLower arg of
+        "day"   -> ByDay
+        "month" -> ByMonth
+        "year"  -> ByYear
+        _       -> error ("Unsupported parameter to --for-each: '" ++ arg ++ "'")
+
 readReportFormat :: String -> ReportFormat
 readReportFormat arg =
     case map toLower arg of
@@ -176,18 +190,24 @@ main = do
      exitFailure
       
   let filters = (if optAlsoInactive flags then id else (defaultFilter:)) $ optFilters flags
-  let reps = case optReports flags of {[] -> [TotalTime]; reps -> reverse reps }
+
+  let rep = case optReports flags of
+                [] -> TotalTime
+                [x] -> x
+                _ -> error "Please specify exactly one report to generate"
+  let repeater = foldr (.) id $ map processRepeater (optRepeater flags)
 
   -- These are defined here, but of course only evaluated when any report
   -- refers to them. Some are needed by more than one report, which is then
   -- advantageous.
   let opts = optReportOptions flags
-  let results = runLeftFold (filterPredicate filters `filterWith` (processReports opts reps)) allTags
+  let fold = filterPredicate filters `adjoin` repeater (processReport opts rep)
+  let result = runLeftFold fold allTags
 
   -- Force the results a bit, to ensure the progress bar to be shown before the title
-  results `seq` return ()
+  result `seq` return ()
   
-  renderReport opts (MultipleReportResults results)
+  renderReport opts result
 
 {-
 import Data.Accessor