New command 'chart': generate balances pie chart

Commands/All.hs

@@ -20,6 +20,9 @@ module Commands.All (
 #endif
 #ifdef WEB
                      module Commands.Web,
+#endif
+#ifdef CHART
+                     module Commands.Chart
 #endif
               )
 where
@@ -36,3 +39,6 @@ import Commands.UI
 #ifdef WEB
 import Commands.Web
 #endif
+#ifdef CHART
+import Commands.Chart
+#endif

Commands/Chart.hs

@@ -0,0 +1,77 @@
+{-|
+
+Generate balances pie chart
+
+-}
+
+module Commands.Chart
+where
+import Ledger.Utils
+import Ledger.Types
+import Ledger.Amount
+import Ledger.AccountName
+import Ledger.Transaction
+import Ledger.Ledger
+import Ledger.Commodity
+import Options
+
+import Graphics.Rendering.Chart
+import Data.Colour
+import Data.Colour.Names
+import Data.List
+
+-- | Generate an image with the pie chart and write it to a file
+chart :: [Opt] -> [String] -> Ledger -> IO ()
+chart opts args l = renderableToPNGFile (toRenderable chart) w h filename
+    where
+      chart = genPie opts args l
+      filename = getOption opts ChartOutput "hledger.png"
+      (w,h) = parseSize $ getOption opts ChartSize "1024x1024"
+
+-- | Extract string option value from a list of options or use the default
+getOption :: [Opt] -> (String->Opt) -> String -> String
+getOption opts opt def = 
+    case reverse $ optValuesForConstructor opt opts of
+        [] -> def
+        x:_ -> x
+
+-- | Parse image size from a command-line option
+parseSize :: String -> (Int,Int)
+parseSize str = (read w, read h)
+    where
+    x = fromMaybe (error "Size should be in WIDTHxHEIGHT format") $ findIndex (=='x') str
+    (w,_:h) = splitAt x str
+
+-- | Generate pie chart
+genPie :: [Opt] -> [String] -> Ledger -> PieLayout
+genPie opts _ l = defaultPieLayout
+    { pie_background_ = solidFillStyle $ opaque $ white
+    , pie_plot_ = pie_chart }
+    where
+      pie_chart = defaultPieChart { pie_data_ = items }
+      items = mapMaybe (uncurry accountPieItem) $
+              flatten $
+              balances $
+              ledgerAccountTree (depthFromOpts opts) l
+
+-- | Convert all quantities of MixedAccount to a single commodity
+amountValue :: MixedAmount -> Double
+amountValue = quantity . convertMixedAmountTo unknown
+
+-- | Generate a tree of account names together with their balances.
+--   The balance of account is decremented by the balance of its subaccounts
+--   which are drawn on the chart.
+balances :: Tree Account -> Tree (AccountName, Double)
+balances (Node rootAcc subAccs) = Node newroot newsubs
+    where
+      newroot = (aname rootAcc,
+                 amountValue $
+                 abalance rootAcc - (sum . map (abalance . root)) subAccs)
+      newsubs = map balances subAccs
+
+-- | Build a single pie chart item
+accountPieItem :: AccountName -> Double -> Maybe PieItem 
+accountPieItem accname balance =
+    if balance == 0
+        then Nothing 
+        else Just $ PieItem accname 0 balance

Options.hs

@@ -38,6 +38,9 @@ usagehdr =
 #endif
 #ifdef WEB
   "  web       - run a simple web-based UI\n" ++
+#endif
+#ifdef CHART
+  "  chart     - generate balances pie chart\n" ++
 #endif
   "  test      - run self-tests\n" ++
   "\n" ++
@@ -81,6 +84,10 @@ options = [
  ,Option ""    ["binary-filename"] (NoArg BinaryFilename) "show the download filename for this hledger build"
  ,Option ""    ["debug"]        (NoArg  Debug)         "show extra debug output; implies verbose"
  ,Option ""    ["debug-no-ui"]  (NoArg  DebugNoUI)     "run ui commands with no output"
+#ifdef CHART
+ ,Option "o" ["output"]  (ReqArg ChartOutput "FILE")    "chart: output filename (default: hledger.png)"
+ ,Option ""  ["size"] (ReqArg ChartSize "WIDTHxHEIGHT") "chart: image size (default: 1024x1024)"
+#endif
  ]
 
 -- | An option value from a command-line flag.
@@ -109,6 +116,10 @@ data Opt =
     | BinaryFilename
     | Debug
     | DebugNoUI
+#ifdef CHART
+    | ChartOutput {value::String}
+    | ChartSize   {value::String}
+#endif
     deriving (Show,Eq)
 
 -- these make me nervous

Version.hs

@@ -66,5 +66,8 @@ configflags   = tail [""
 #endif
 #ifdef WEB
   ,"web"
+#endif
+#ifdef CHART
+  ,"chart"
 #endif
  ]

hledger.cabal

@@ -37,6 +37,10 @@ flag web
   description: enable the web ui
   default:     False
 
+flag chart
+  description: enable the pie chart generation
+  default:     False
+
 library
   exposed-modules:
                   Ledger
@@ -146,6 +150,12 @@ executable hledger
                  ,HTTP >= 4000.0 && < 4000.1
                  ,applicative-extras
 
+  if flag(chart)
+    cpp-options: -DCHART
+    other-modules:Commands.Chart
+    build-depends:
+                  Chart >= 0.11 && < 0.12
+                 ,colour
 
 -- source-repository head
 --   type:     darcs

hledger.hs

@@ -67,6 +67,9 @@ main = do
 #endif
 #ifdef WEB
        | cmd `isPrefixOf` "web"       = withLedgerDo opts args cmd web
+#endif
+#ifdef CHART
+       | cmd `isPrefixOf` "chart"       = withLedgerDo opts args cmd chart
 #endif
        | cmd `isPrefixOf` "test"      = runtests opts args >> return ()
        | otherwise                    = putStr usage