hledger 0.7.0 → 0.8

raw patch · 34 files changed

+1470/−1199 lines, 34 filesdep +Chartdep +colourdep ~HTTPdep ~happstackdep ~happstack-dataPVP ok

version bump matches the API change (PVP)

Dependencies added: Chart, colour

Dependency ranges changed: HTTP, happstack, happstack-data, happstack-server, happstack-state, utf8-string, vty, xhtml

API changes (from Hackage documentation)

Files

• Commands/Add.hs +54/−50
• Commands/All.hs +6/−0
• Commands/Balance.hs +13/−10
• Commands/Chart.hs +108/−0
• Commands/Convert.hs +16/−14
• Commands/Histogram.hs +16/−18
• Commands/Print.hs +9/−12
• Commands/Register.hs +69/−75
• Commands/Stats.hs +7/−7
• Commands/UI.hs +39/−41
• Commands/Web.hs +58/−49
• Ledger.hs +4/−6
• Ledger/Account.hs +1/−2
• Ledger/AccountName.hs +4/−0
• Ledger/Amount.hs +17/−14
• Ledger/Dates.hs +6/−2
• Ledger/IO.hs +31/−37
• Ledger/Journal.hs +321/−0
• Ledger/Ledger.hs +42/−78
• Ledger/LedgerTransaction.hs +0/−133
• Ledger/Parse.hs +31/−24
• Ledger/Posting.hs +38/−10
• Ledger/RawLedger.hs +0/−215
• Ledger/TimeLog.hs +16/−15
• Ledger/Transaction.hs +122/−30
• Ledger/Types.hs +58/−59
• Options.hs +31/−4
• README +3/−2
• Tests.hs +271/−254
• Utils.hs +29/−20
• Version.hs +4/−1
• data/web/style.css +15/−0
• hledger.cabal +28/−17
• hledger.hs +3/−0

@@ -15,59 +15,61 @@ import System.IO.Error import Text.ParserCombinators.Parsec import Utils (ledgerFromStringWithOpts)-+import qualified Data.Foldable as Foldable (find)  -- | Read ledger transactions from the terminal, prompting for each field, -- and append them to the ledger file. If the ledger came from stdin, this -- command has no effect. add :: [Opt] -> [String] -> Ledger -> IO ()-add _ args l-    | filepath (rawledger l) == "-" = return ()+add opts args l+    | filepath (journal l) == "-" = return ()     | otherwise = do   hPutStrLn stderr     "Enter one or more transactions, which will be added to your ledger file.\n\-    \To complete a transaction, enter . as account name. To quit, enter control-d."-  getAndAddTransactions l args `catch` (\e -> unless (isEOFError e) $ ioError e)+    \To complete a transaction, enter . as account name. To quit, press control-c."+  today <- getCurrentDay+  getAndAddTransactions l opts args today `catch` (\e -> unless (isEOFError e) $ ioError e)  -- | Read a number of ledger transactions from the command line, -- prompting, validating, displaying and appending them to the ledger -- file, until end of input (then raise an EOF exception). Any -- command-line arguments are used as the first transaction's description.-getAndAddTransactions :: Ledger -> [String] -> IO ()-getAndAddTransactions l args = do-  l <- getTransaction l args >>= addTransaction l-  getAndAddTransactions l []+getAndAddTransactions :: Ledger -> [Opt] -> [String] -> Day -> IO ()+getAndAddTransactions l opts args defaultDate = do+  (ledgerTransaction,date) <- getTransaction l opts args defaultDate+  l <- ledgerAddTransaction l ledgerTransaction+  getAndAddTransactions l opts args date  -- | Read a transaction from the command line, with history-aware prompting.-getTransaction :: Ledger -> [String] -> IO LedgerTransaction-getTransaction l args = do+getTransaction :: Ledger -> [Opt] -> [String] -> Day -> IO (Transaction,Day)+getTransaction l opts args defaultDate = do   today <- getCurrentDay   datestr <- askFor "date" -            (Just $ showDate today)+            (Just $ showDate defaultDate)             (Just $ \s -> null s ||               isRight (parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s))-  description <- if null args -                  then askFor "description" Nothing (Just $ not . null) -                  else do-                         let description = unwords args-                         hPutStrLn stderr $ "description: " ++ description-                         return description-  let historymatches = transactionsSimilarTo l description+  description <- askFor "description" Nothing (Just $ not . null) +  let historymatches = transactionsSimilarTo l args description       bestmatch | null historymatches = Nothing                 | otherwise = Just $ snd $ head historymatches-      bestmatchpostings = maybe Nothing (Just . ltpostings) bestmatch+      bestmatchpostings = maybe Nothing (Just . tpostings) bestmatch       date = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) datestr+      accept x = x == "." || (not . null) x &&+        if NoNewAccts `elem` opts+            then isJust $ Foldable.find (== x) ant+            else True+        where (ant,_,_,_) = groupPostings . journalPostings . journal $ l       getpostingsandvalidate = do-        ps <- getPostings bestmatchpostings []-        let t = nullledgertxn{ltdate=date-                             ,ltstatus=False-                             ,ltdescription=description-                             ,ltpostings=ps-                             }+        ps <- getPostings accept bestmatchpostings []+        let t = nulltransaction{tdate=date+                               ,tstatus=False+                               ,tdescription=description+                               ,tpostings=ps+                               }             retry = do               hPutStrLn stderr $ "\n" ++ nonzerobalanceerror ++ ". Re-enter:"               getpostingsandvalidate-        either (const retry) return $ balanceLedgerTransaction t+        either (const retry) (return . flip (,) date) $ balanceTransaction t   unless (null historymatches)         (do          hPutStrLn stderr "Similar transactions found, using the first for defaults:\n"@@ -76,18 +78,18 @@  -- | Read postings from the command line until . is entered, using the -- provided historical postings, if any, to guess defaults.-getPostings :: Maybe [Posting] -> [Posting] -> IO [Posting]-getPostings historicalps enteredps = do-  account <- askFor (printf "account %d" n) defaultaccount (Just $ not . null)+getPostings :: (AccountName -> Bool) -> Maybe [Posting] -> [Posting] -> IO [Posting]+getPostings accept historicalps enteredps = do+  account <- askFor (printf "account %d" n) defaultaccount (Just accept)   if account=="."     then return enteredps     else do       amountstr <- askFor (printf "amount  %d" n) defaultamount validateamount       let amount = fromparse $ parse (someamount <|> return missingamt) "" amountstr-      let p = nullrawposting{paccount=stripbrackets account,-                             pamount=amount,-                             ptype=postingtype account}-      getPostings historicalps $ enteredps ++ [p]+      let p = nullposting{paccount=stripbrackets account,+                          pamount=amount,+                          ptype=postingtype account}+      getPostings accept historicalps $ enteredps ++ [p]     where       n = length enteredps + 1       enteredrealps = filter isReal enteredps@@ -125,14 +127,14 @@ -- | Append this transaction to the ledger's file. Also, to the ledger's -- transaction list, but we don't bother updating the other fields - this -- is enough to include new transactions in the history matching.-addTransaction :: Ledger -> LedgerTransaction -> IO Ledger-addTransaction l t = do+ledgerAddTransaction :: Ledger -> Transaction -> IO Ledger+ledgerAddTransaction l t = do   appendToLedgerFile l $ show t-  putStrLn $ printf "\nAdded transaction to %s:" (filepath $ rawledger l)+  putStrLn $ printf "\nAdded transaction to %s:" (filepath $ journal l)   putStrLn =<< registerFromString (show t)-  return l{rawledger=rl{ledger_txns=ts}}-      where rl = rawledger l-            ts = ledger_txns rl ++ [t]+  return l{journal=rl{jtxns=ts}}+      where rl = journal l+            ts = jtxns rl ++ [t]  -- | Append data to the ledger's file, ensuring proper separation from any -- existing data; or if the file is "-", dump it to stdout.@@ -142,10 +144,10 @@     then putStr $ sep ++ s     else appendFile f $ sep++s     where -      f = filepath $ rawledger l-      -- we keep looking at the original raw text from when the ledger+      f = filepath $ journal l+      -- XXX we are looking at the original raw text from when the ledger       -- was first read, but that's good enough for now-      t = rawledgertext l+      t = jtext $ journal l       sep | null $ strip t = ""           | otherwise = replicate (2 - min 2 (length lastnls)) '\n'           where lastnls = takeWhile (=='\n') $ reverse t@@ -154,8 +156,9 @@ registerFromString :: String -> IO String registerFromString s = do   now <- getCurrentLocalTime-  l <- ledgerFromStringWithOpts [] [] now s-  return $ showRegisterReport [Empty] [] l+  l <- ledgerFromStringWithOpts [] s+  return $ showRegisterReport opts (optsToFilterSpec opts [] now) l+    where opts = [Empty]  -- | Return a similarity measure, from 0 to 1, for two strings. -- This is Simon White's letter pairs algorithm from@@ -176,18 +179,19 @@ letterPairs (a:b:rest) = [a,b] : letterPairs (b:rest) letterPairs _ = [] +compareLedgerDescriptions :: [Char] -> [Char] -> Double compareLedgerDescriptions s t = compareStrings s' t'     where s' = simplify s           t' = simplify t           simplify = filter (not . (`elem` "0123456789")) -transactionsSimilarTo :: Ledger -> String -> [(Double,LedgerTransaction)]-transactionsSimilarTo l s =+transactionsSimilarTo :: Ledger -> [String] -> String -> [(Double,Transaction)]+transactionsSimilarTo l apats s =     sortBy compareRelevanceAndRecency                $ filter ((> threshold).fst)-               [(compareLedgerDescriptions s $ ltdescription t, t) | t <- ts]+               [(compareLedgerDescriptions s $ tdescription t, t) | t <- ts]     where-      compareRelevanceAndRecency (n1,t1) (n2,t2) = compare (n2,ltdate t2) (n1,ltdate t1)-      ts = ledger_txns $ rawledger l+      compareRelevanceAndRecency (n1,t1) (n2,t2) = compare (n2,tdate t2) (n1,tdate t1)+      ts = jtxns $ filterJournalTransactionsByAccount apats $ journal l       threshold = 0 

@@ -21,6 +21,9 @@ #ifdef WEB                      module Commands.Web, #endif+#ifdef CHART+                     module Commands.Chart+#endif               ) where import Commands.Add@@ -35,4 +38,7 @@ #endif #ifdef WEB import Commands.Web+#endif+#ifdef CHART+import Commands.Chart #endif

@@ -101,7 +101,7 @@ import Ledger.Types import Ledger.Amount import Ledger.AccountName-import Ledger.Transaction+import Ledger.Posting import Ledger.Ledger import Options import System.IO.UTF8@@ -109,23 +109,26 @@  -- | Print a balance report. balance :: [Opt] -> [String] -> Ledger -> IO ()-balance opts args = putStr . showBalanceReport opts args+balance opts args l = do+  t <- getCurrentLocalTime+  putStr $ showBalanceReport opts (optsToFilterSpec opts args t) l  -- | Generate a balance report with the specified options for this ledger.-showBalanceReport :: [Opt] -> [String] -> Ledger -> String-showBalanceReport opts _ l = acctsstr ++ totalstr+showBalanceReport :: [Opt] -> FilterSpec -> Ledger -> String+showBalanceReport opts filterspec l = acctsstr ++ totalstr     where+      l' = cacheLedger'' filterspec l       acctsstr = unlines $ map showacct interestingaccts           where-            showacct = showInterestingAccount l interestingaccts-            interestingaccts = filter (isInteresting opts l) acctnames+            showacct = showInterestingAccount l' interestingaccts+            interestingaccts = filter (isInteresting opts l') acctnames             acctnames = sort $ tail $ flatten $ treemap aname accttree-            accttree = ledgerAccountTree (depthFromOpts opts) l+            accttree = ledgerAccountTree (fromMaybe 99999 $ depthFromOpts opts) l'       totalstr | NoTotal `elem` opts = ""                | notElem Empty opts && isZeroMixedAmount total = ""                | otherwise = printf "--------------------\n%s\n" $ padleft 20 $ showMixedAmountWithoutPrice total           where-            total = sum $ map abalance $ ledgerTopAccounts l+            total = sum $ map abalance $ ledgerTopAccounts l'  -- | Display one line of the balance report with appropriate indenting and eliding. showInterestingAccount :: Ledger -> [AccountName] -> AccountName -> String@@ -147,11 +150,11 @@     | numinterestingsubs==1 && not atmaxdepth = notlikesub     | otherwise = notzero || emptyflag     where-      atmaxdepth = accountNameLevel a == depthFromOpts opts+      atmaxdepth = isJust d && Just (accountNameLevel a) == d where d = depthFromOpts opts       emptyflag = Empty `elem` opts       acct = ledgerAccount l a       notzero = not $ isZeroMixedAmount inclbalance where inclbalance = abalance acct-      notlikesub = not $ isZeroMixedAmount exclbalance where exclbalance = sumTransactions $ atransactions acct+      notlikesub = not $ isZeroMixedAmount exclbalance where exclbalance = sumPostings $ apostings acct       numinterestingsubs = length $ filter isInterestingTree subtrees           where             isInterestingTree = treeany (isInteresting opts l . aname)

@@ -0,0 +1,108 @@+{-|++Generate balances pie chart++-}++module Commands.Chart+where+import Ledger.Utils+import Ledger.Types+import Ledger.Amount+import Ledger.Ledger+import Ledger.Commodity+import Options++import Control.Monad (liftM3)+import Graphics.Rendering.Chart+import Data.Colour+import Data.Colour.Names+import Data.Colour.RGBSpace+import Data.Colour.RGBSpace.HSL (hsl)+import Data.Colour.SRGB.Linear (rgb)+import Data.List+import Safe (readDef)++-- | Generate an image with the pie chart and write it to a file+chart :: [Opt] -> [String] -> Ledger -> IO ()+chart opts args l = do+  t <- getCurrentLocalTime+  let chart = genPie opts (optsToFilterSpec opts args t) l+  renderableToPNGFile (toRenderable chart) w h filename+    where+      filename = getOption opts ChartOutput chartoutput+      (w,h) = parseSize $ getOption opts ChartSize chartsize++-- | 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] -> FilterSpec -> Ledger -> PieLayout+genPie opts filterspec l = defaultPieLayout { pie_background_ = solidFillStyle $ opaque $ white+                                            , pie_plot_ = pie_chart }+    where+      pie_chart = defaultPieChart { pie_data_ = map (uncurry accountPieItem) chartitems'+                                  , pie_start_angle_ = (-90)+                                  , pie_colors_ = mkColours hue+                                  , pie_label_style_ = defaultFontStyle{font_size_=12}+                                  }+      chartitems' = debug "chart" $ top num samesignitems+      (samesignitems, sign) = sameSignNonZero rawitems+      rawitems = debug "raw" $ flatten $ balances $+                 ledgerAccountTree (fromMaybe 99999 $ depthFromOpts opts) $ cacheLedger'' filterspec l+      top n t = topn ++ [other]+          where+            (topn,rest) = splitAt n $ reverse $ sortBy (comparing snd) t+            other = ("other", sum $ map snd rest)+      num = readDef (fromIntegral chartitems) (getOption opts ChartItems (show chartitems))+      hue = if sign > 0 then red else green where (red, green) = (0, 110)+      debug s = if Debug `elem` opts then ltrace s else id++-- | Select the nonzero items with same sign as the first, and make+-- them positive. Also return a 1 or -1 corresponding to the original sign.+sameSignNonZero :: [(AccountName, Double)] -> ([(AccountName, Double)], Int)+sameSignNonZero is | null nzs = ([], 1)+                   | otherwise = (map pos $ filter (test.snd) nzs, sign)+                   where+                     nzs = filter ((/=0).snd) is+                     pos (a,b) = (a, abs b)+                     sign = if snd (head nzs) >= 0 then 1 else (-1)+                     test = if sign > 0 then (>0) else (<0)++-- | 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 -> PieItem+accountPieItem accname balance = PieItem accname offset balance where offset = 0++-- | Generate an infinite color list suitable for charts.+mkColours :: Double -> [AlphaColour Double]+mkColours hue = cycle $ [opaque $ rgbToColour $ hsl h s l | (h,s,l) <- liftM3 (,,)+                         [hue] [0.7] [0.1,0.2..0.7] ]++rgbToColour :: (Fractional a) => RGB a -> Colour a+rgbToColour (RGB r g b) = rgb r g b

@@ -6,7 +6,7 @@ module Commands.Convert where import Options (Opt(Debug)) import Version (versionstr)-import Ledger.Types (Ledger,AccountName,LedgerTransaction(..),Posting(..),PostingType(..))+import Ledger.Types (Ledger,AccountName,Transaction(..),Posting(..),PostingType(..)) import Ledger.Utils (strip, spacenonewline, restofline) import Ledger.Parse (someamount, emptyCtx, ledgeraccountname) import Ledger.Amount (nullmixedamt)@@ -237,7 +237,7 @@  -- csv record conversion -transactionFromCsvRecord :: CsvRules -> CsvRecord -> LedgerTransaction+transactionFromCsvRecord :: CsvRules -> CsvRecord -> Transaction transactionFromCsvRecord rules fields =   let        date = parsedate $ normaliseDate $ maybe "1900/1/1" (fields !!) (dateField rules)@@ -256,32 +256,34 @@       unknownacct | (readDef 0 amountstr' :: Double) < 0 = "income:unknown"                   | otherwise = "expenses:unknown"       (acct,newdesc) = identify (accountRules rules) unknownacct desc-  in-    LedgerTransaction {-              ltdate=date,-              lteffectivedate=Nothing,-              ltstatus=status,-              ltcode=code,-              ltdescription=newdesc,-              ltcomment=comment,-              ltpreceding_comment_lines=precomment,-              ltpostings=[+      t = Transaction {+              tdate=date,+              teffectivedate=Nothing,+              tstatus=status,+              tcode=code,+              tdescription=newdesc,+              tcomment=comment,+              tpreceding_comment_lines=precomment,+              tpostings=[                    Posting {                      pstatus=False,                      paccount=acct,                      pamount=amount,                      pcomment="",-                     ptype=RegularPosting+                     ptype=RegularPosting,+                     ptransaction=Just t                    },                    Posting {                      pstatus=False,                      paccount=baseAccount rules,                      pamount=(-amount),                      pcomment="",-                     ptype=RegularPosting+                     ptype=RegularPosting,+                     ptransaction=Just t                    }                   ]             }+  in t  -- | Convert some date string with unknown format to YYYY/MM/DD. normaliseDate :: String -> String

@@ -15,35 +15,33 @@ barchar = '*'  -- | Print a histogram of some statistic per reporting interval, such as--- number of transactions per day.+-- number of postings per day. histogram :: [Opt] -> [String] -> Ledger -> IO ()-histogram opts args = putStr . showHistogram opts args+histogram opts args l = do+  t <- getCurrentLocalTime+  putStr $ showHistogram opts (optsToFilterSpec opts args t) l -showHistogram :: [Opt] -> [String] -> Ledger -> String-showHistogram opts args l = concatMap (printDayWith countBar) daytxns+showHistogram :: [Opt] -> FilterSpec -> Ledger -> String+showHistogram opts filterspec l = concatMap (printDayWith countBar) dayps     where       i = intervalFromOpts opts       interval | i == NoInterval = Daily                | otherwise = i-      fullspan = rawLedgerDateSpan $ rawledger l+      fullspan = journalDateSpan $ journal l       days = filter (DateSpan Nothing Nothing /=) $ splitSpan interval fullspan-      daytxns = [(s, filter (isTransactionInDateSpan s) ts) | s <- days]+      dayps = [(s, filter (isPostingInDateSpan s) ps) | s <- days]       -- same as Register-      -- should count raw transactions, not posting transactions-      ts = sortBy (comparing tdate) $ filterempties $ filter matchapats $ filterdepth $ ledgerTransactions l+      -- should count transactions, not postings ?+      ps = sortBy (comparing postingDate) $ filterempties $ filter matchapats $ filterdepth $ ledgerPostings l       filterempties           | Empty `elem` opts = id-          | otherwise = filter (not . isZeroMixedAmount . tamount)-      matchapats = matchpats apats . taccount-      (apats,_) = parsePatternArgs args-      filterdepth | interval == NoInterval = filter (\t -> accountNameLevel (taccount t) <= depth)+          | otherwise = filter (not . isZeroMixedAmount . pamount)+      matchapats = matchpats apats . paccount+      apats = acctpats filterspec+      filterdepth | interval == NoInterval = filter (\p -> accountNameLevel (paccount p) <= depth)                   | otherwise = id-      depth = depthFromOpts opts+      depth = fromMaybe 99999 $ depthFromOpts opts  printDayWith f (DateSpan b _, ts) = printf "%s %s\n" (show $ fromJust b) (f ts) -countBar ts = replicate (length ts) barchar--total = show . sumTransactions---- totalBar ts = replicate (sumTransactions ts) barchar+countBar ps = replicate (length ps) barchar

@@ -14,16 +14,13 @@  -- | Print ledger transactions in standard format. print' :: [Opt] -> [String] -> Ledger -> IO ()-print' opts args = putStr . showLedgerTransactions opts args+print' opts args l = do+  t <- getCurrentLocalTime+  putStr $ showTransactions (optsToFilterSpec opts args t) l -showLedgerTransactions :: [Opt] -> [String] -> Ledger -> String-showLedgerTransactions opts args l = concatMap (showLedgerTransactionForPrint effective) txns-    where -      txns = sortBy (comparing ltdate) $-               ledger_txns $ -               filterRawLedgerPostingsByDepth depth $ -               filterRawLedgerTransactionsByAccount apats $ -               rawledger l-      depth = depthFromOpts opts-      effective = Effective `elem` opts-      (apats,_) = parsePatternArgs args+showTransactions :: FilterSpec -> Ledger -> String+showTransactions filterspec l =+    concatMap (showTransactionForPrint effective) $ sortBy (comparing tdate) txns+        where+          effective = EffectiveDate == whichdate filterspec+          txns = jtxns $ filterJournalTransactions filterspec $ journal l

@@ -6,7 +6,6 @@  module Commands.Register where-import Data.Function (on) import Prelude hiding (putStr) import Ledger import Options@@ -15,106 +14,101 @@  -- | Print a register report. register :: [Opt] -> [String] -> Ledger -> IO ()-register opts args = putStr . showRegisterReport opts args--{- |-Generate the register report. Each ledger entry is displayed as two or-more lines like this:+register opts args l = do+  t <- getCurrentLocalTime+  putStr $ showRegisterReport opts (optsToFilterSpec opts args t) l -@-date (10)  description (20)     account (22)            amount (11)  balance (12)-DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaa  AAAAAAAAAAA AAAAAAAAAAAA-                                aaaaaaaaaaaaaaaaaaaaaa  AAAAAAAAAAA AAAAAAAAAAAA-                                ...                     ...         ...-@--}-showRegisterReport :: [Opt] -> [String] -> Ledger -> String-showRegisterReport opts args l-    | interval == NoInterval = showtxns displayedts nulltxn startbal-    | otherwise = showtxns summaryts nulltxn startbal+-- | Generate the register report, which is a list of postings with transaction+-- info and a running balance.+showRegisterReport :: [Opt] -> FilterSpec -> Ledger -> String+showRegisterReport opts filterspec l+    | interval == NoInterval = showpostings displayedps nullposting startbal+    | otherwise = showpostings summaryps nullposting startbal     where+      startbal = sumPostings precedingps+      (displayedps, _) = span displayExprMatches restofps+      (precedingps, restofps) = break displayExprMatches sortedps+      sortedps = sortBy (comparing postingDate) ps+      ps = journalPostings $ filterJournalPostings filterspec $ journal l+      summaryps = concatMap summarisespan spans+      summarisespan s = summarisePostingsInDateSpan s depth empty (postingsinspan s)+      postingsinspan s = filter (isPostingInDateSpan s) displayedps+      spans = splitSpan interval (postingsDateSpan displayedps)       interval = intervalFromOpts opts-      ts = sortBy (comparing tdate) $ filterempties $ filtertxns apats $ filterdepth $ ledgerTransactions l-      filterdepth | interval == NoInterval = filter (\t -> accountNameLevel (taccount t) <= depth)-                  | otherwise = id-      filterempties-          | Empty `elem` opts = id-          | otherwise = filter (not . isZeroMixedAmount . tamount)-      (precedingts, ts') = break (matchdisplayopt dopt) ts-      (displayedts, _) = span (matchdisplayopt dopt) ts'-      startbal = sumTransactions precedingts-      (apats,_) = parsePatternArgs args-      matchdisplayopt Nothing _ = True-      matchdisplayopt (Just e) t = (fromparse $ parsewith datedisplayexpr e) t-      dopt = displayFromOpts opts       empty = Empty `elem` opts       depth = depthFromOpts opts-      summaryts = concatMap summarisespan (zip spans [1..])-      summarisespan (s,n) = summariseTransactionsInDateSpan s n depth empty (transactionsinspan s)-      transactionsinspan s = filter (isTransactionInDateSpan s) displayedts-      spans = splitSpan interval (ledgerDateSpan l)+      dispexpr = displayExprFromOpts opts+      displayExprMatches p = case dispexpr of+                               Nothing -> True+                               Just e  -> (fromparse $ parsewith datedisplayexpr e) p                         --- | Convert a date span (representing a reporting interval) and a list of--- transactions within it to a new list of transactions aggregated by--- account, which showtxns will render as a summary for this interval.+-- | Given a date span (representing a reporting interval) and a list of+-- postings within it: aggregate the postings so there is only one per+-- account, and adjust their date/description so that they will render+-- as a summary for this interval. --  -- As usual with date spans the end date is exclusive, but for display -- purposes we show the previous day as end date, like ledger. -- --- A unique tnum value is provided so that the new transactions will be--- grouped as one entry.--- --- When a depth argument is present, transactions to accounts of greater+-- When a depth argument is present, postings to accounts of greater -- depth are aggregated where possible. -- --- The showempty flag forces the display of a zero-transaction span--- and also zero-transaction accounts within the span.-summariseTransactionsInDateSpan :: DateSpan -> Int -> Int -> Bool -> [Transaction] -> [Transaction]-summariseTransactionsInDateSpan (DateSpan b e) tnum depth showempty ts-    | null ts && showempty = [txn]-    | null ts = []-    | otherwise = summaryts'+-- The showempty flag forces the display of a zero-posting span+-- and also zero-posting accounts within the span.+summarisePostingsInDateSpan :: DateSpan -> Maybe Int -> Bool -> [Posting] -> [Posting]+summarisePostingsInDateSpan (DateSpan b e) depth showempty ps+    | null ps && showempty = [p]+    | null ps = []+    | otherwise = summaryps'     where-      txn = nulltxn{tnum=tnum, tdate=b', tdescription="- "++ showDate (addDays (-1) e')}-      b' = fromMaybe (tdate $ head ts) b-      e' = fromMaybe (tdate $ last ts) e-      summaryts'-          | showempty = summaryts-          | otherwise = filter (not . isZeroMixedAmount . tamount) summaryts-      txnanames = sort $ nub $ map taccount ts+      postingwithinfo date desc = nullposting{ptransaction=Just nulltransaction{tdate=date,tdescription=desc}}+      p = postingwithinfo b' ("- "++ showDate (addDays (-1) e'))+      b' = fromMaybe (postingDate $ head ps) b+      e' = fromMaybe (postingDate $ last ps) e+      summaryps'+          | showempty = summaryps+          | otherwise = filter (not . isZeroMixedAmount . pamount) summaryps+      anames = sort $ nub $ map paccount ps       -- aggregate balances by account, like cacheLedger, then do depth-clipping-      (_,_,exclbalof,inclbalof) = groupTransactions ts-      clippedanames = clipAccountNames depth txnanames-      isclipped a = accountNameLevel a >= depth+      (_,_,exclbalof,inclbalof) = groupPostings ps+      clippedanames = nub $ map (clipAccountName d) anames+      isclipped a = accountNameLevel a >= d+      d = fromMaybe 99999 $ depth       balancetoshowfor a =           (if isclipped a then inclbalof else exclbalof) (if null a then "top" else a)-      summaryts = [txn{taccount=a,tamount=balancetoshowfor a} | a <- clippedanames]+      summaryps = [p{paccount=a,pamount=balancetoshowfor a} | a <- clippedanames] -clipAccountNames :: Int -> [AccountName] -> [AccountName]-clipAccountNames d as = nub $ map (clip d) as -    where clip d = accountNameFromComponents . take d . accountNameComponents+{- |+Show postings one per line, plus transaction info for the first posting of+each transaction, and a running balance. Eg: --- | Show transactions one per line, with each date/description appearing--- only once, and a running balance.-showtxns [] _ _ = ""-showtxns (t:ts) tprev bal = this ++ showtxns ts t bal'+@+date (10)  description (20)     account (22)            amount (11)  balance (12)+DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaa  AAAAAAAAAAA AAAAAAAAAAAA+                                aaaaaaaaaaaaaaaaaaaaaa  AAAAAAAAAAA AAAAAAAAAAAA+@+-}+showpostings :: [Posting] -> Posting -> MixedAmount -> String+showpostings [] _ _ = ""+showpostings (p:ps) pprev bal = this ++ showpostings ps p bal'     where-      this = showtxn (t `issame` tprev) t bal'-      issame = (==) `on` tnum-      bal' = bal + tamount t+      this = showposting isfirst p bal'+      isfirst = ptransaction p /= ptransaction pprev+      bal' = bal + pamount p --- | Show one transaction line and balance with or without the entry details.-showtxn :: Bool -> Transaction -> MixedAmount -> String-showtxn omitdesc t b = concatBottomPadded [entrydesc ++ p ++ " ", bal] ++ "\n"+-- | Show one posting and running balance, with or without transaction info.+showposting :: Bool -> Posting -> MixedAmount -> String+showposting withtxninfo p b = concatBottomPadded [txninfo ++ pstr ++ " ", bal] ++ "\n"     where       ledger3ishlayout = False       datedescwidth = if ledger3ishlayout then 34 else 32-      entrydesc = if omitdesc then replicate datedescwidth ' ' else printf "%s %s " date desc+      txninfo = if withtxninfo then printf "%s %s " date desc else replicate datedescwidth ' '       date = showDate da       datewidth = 10       descwidth = datedescwidth - datewidth - 2       desc = printf ("%-"++(show descwidth)++"s") $ elideRight descwidth de :: String-      p = showPostingWithoutPrice $ Posting s a amt "" tt+      pstr = showPostingWithoutPrice p       bal = padleft 12 (showMixedAmountOrZeroWithoutPrice b)-      Transaction{tstatus=s,tdate=da,tdescription=de,taccount=a,tamount=amt,ttype=tt} = t+      (da,de) = case ptransaction p of Just (Transaction{tdate=da',tdescription=de'}) -> (da',de')+                                       Nothing -> (nulldate,"") 

@@ -16,7 +16,7 @@ stats :: [Opt] -> [String] -> Ledger -> IO () stats opts args l = do   today <- getCurrentDay-  putStr $ showStats opts args l today+  putStr $ showStats opts args (cacheLedger' l) today  showStats :: [Opt] -> [String] -> Ledger -> Day -> String showStats _ _ l today =@@ -27,14 +27,14 @@       w1 = maximum $ map (length . fst) stats       w2 = maximum $ map (length . show . snd) stats       stats = [-         ("File", filepath $ rawledger l)+         ("File", filepath $ journal l)         ,("Period", printf "%s to %s (%d days)" (start span) (end span) days)         ,("Transactions", printf "%d (%0.1f per day)" tnum txnrate)         ,("Transactions last 30 days", printf "%d (%0.1f per day)" tnum30 txnrate30)         ,("Transactions last 7 days", printf "%d (%0.1f per day)" tnum7 txnrate7)         ,("Last transaction", maybe "none" show lastdate ++                               maybe "" (printf " (%d days ago)") lastelapsed)---        ,("Payees/descriptions", show $ length $ nub $ map ltdescription ts)+--        ,("Payees/descriptions", show $ length $ nub $ map tdescription ts)         ,("Accounts", show $ length $ accounts l)         ,("Commodities", show $ length $ commodities l)       -- Transactions this month     : %(monthtxns)s (last month in the same period: %(lastmonthtxns)s)@@ -43,9 +43,9 @@       -- Days since last transaction : %(recentelapsed)s        ]            where-             ts = sortBy (comparing ltdate) $ ledger_txns $ rawledger l+             ts = sortBy (comparing tdate) $ jtxns $ journal l              lastdate | null ts = Nothing-                      | otherwise = Just $ ltdate $ last ts+                      | otherwise = Just $ tdate $ last ts              lastelapsed = maybe Nothing (Just . diffDays today) lastdate              tnum = length ts              span = rawdatespan l@@ -57,9 +57,9 @@              txnrate | days==0 = 0                      | otherwise = fromIntegral tnum / fromIntegral days :: Double              tnum30 = length $ filter withinlast30 ts-             withinlast30 t = d >= addDays (-30) today && (d<=today) where d = ltdate t+             withinlast30 t = d >= addDays (-30) today && (d<=today) where d = tdate t              txnrate30 = fromIntegral tnum30 / 30 :: Double              tnum7 = length $ filter withinlast7 ts-             withinlast7 t = d >= addDays (-7) today && (d<=today) where d = ltdate t+             withinlast7 t = d >= addDays (-7) today && (d<=today) where d = tdate t              txnrate7 = fromIntegral tnum7 / 7 :: Double 

@@ -52,7 +52,8 @@   v <- mkVty   DisplayRegion w h <- display_bounds $ terminal v   let opts' = SubTotal:opts-  let a = enter BalanceScreen+  t <-  getCurrentLocalTime+  let a = enter t BalanceScreen           AppState {                   av=v                  ,aw=fromIntegral w@@ -71,15 +72,16 @@ go a@AppState{av=av,aopts=opts} = do   when (notElem DebugNoUI opts) $ update av (renderScreen a)   k <- next_event av+  t <- getCurrentLocalTime   case k of      EvResize x y                -> go $ resize x y a     EvKey (KASCII 'l') [MCtrl]  -> refresh av >> go a{amsg=helpmsg}-    EvKey (KASCII 'b') []       -> go $ resetTrailAndEnter BalanceScreen a-    EvKey (KASCII 'r') []       -> go $ resetTrailAndEnter RegisterScreen a-    EvKey (KASCII 'p') []       -> go $ resetTrailAndEnter PrintScreen a-    EvKey KRight []             -> go $ drilldown a-    EvKey KEnter []             -> go $ drilldown a-    EvKey KLeft  []             -> go $ backout a+    EvKey (KASCII 'b') []       -> go $ resetTrailAndEnter t BalanceScreen a+    EvKey (KASCII 'r') []       -> go $ resetTrailAndEnter t RegisterScreen a+    EvKey (KASCII 'p') []       -> go $ resetTrailAndEnter t PrintScreen a+    EvKey KRight []             -> go $ drilldown t a+    EvKey KEnter []             -> go $ drilldown t a+    EvKey KLeft  []             -> go $ backout t a     EvKey KUp    []             -> go $ moveUpAndPushEdge a     EvKey KDown  []             -> go $ moveDownAndPushEdge a     EvKey KHome  []             -> go $ moveToTop a@@ -208,32 +210,32 @@ screen a = scr where (Loc scr _ _) = loc a  -- | Enter a new screen, saving the old ui location on the stack.-enter :: Screen -> AppState -> AppState -enter scr@BalanceScreen a  = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a-enter scr@RegisterScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a-enter scr@PrintScreen a    = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a+enter :: LocalTime -> Screen -> AppState -> AppState+enter t scr@BalanceScreen a  = updateData t $ pushLoc Loc{scr=scr,sy=0,cy=0} a+enter t scr@RegisterScreen a = updateData t $ pushLoc Loc{scr=scr,sy=0,cy=0} a+enter t scr@PrintScreen a    = updateData t $ pushLoc Loc{scr=scr,sy=0,cy=0} a -resetTrailAndEnter scr = enter scr . clearLocs+resetTrailAndEnter t scr = enter t scr . clearLocs  -- | Regenerate the display data appropriate for the current screen.-updateData :: AppState -> AppState-updateData a@AppState{aopts=opts,aargs=args,aledger=l} =+updateData :: LocalTime -> AppState -> AppState+updateData t a@AppState{aopts=opts,aargs=args,aledger=l} =     case screen a of-      BalanceScreen  -> a{abuf=lines $ showBalanceReport opts [] l, aargs=[]}-      RegisterScreen -> a{abuf=lines $ showRegisterReport opts args l}-      PrintScreen    -> a{abuf=lines $ showLedgerTransactions opts args l}+      BalanceScreen  -> a{abuf=lines $ showBalanceReport opts (optsToFilterSpec opts args t) l, aargs=[]}+      RegisterScreen -> a{abuf=lines $ showRegisterReport opts (optsToFilterSpec opts args t) l}+      PrintScreen    -> a{abuf=lines $ showTransactions (optsToFilterSpec opts args t) l} -backout :: AppState -> AppState-backout a | screen a == BalanceScreen = a-          | otherwise = updateData $ popLoc a+backout :: LocalTime -> AppState -> AppState+backout t a | screen a == BalanceScreen = a+            | otherwise = updateData t $ popLoc a -drilldown :: AppState -> AppState-drilldown a =+drilldown :: LocalTime -> AppState -> AppState+drilldown t a =     case screen a of-      BalanceScreen  -> enter RegisterScreen a{aargs=[currentAccountName a]}-      RegisterScreen -> scrollToLedgerTransaction e $ enter PrintScreen a+      BalanceScreen  -> enter t RegisterScreen a{aargs=[currentAccountName a]}+      RegisterScreen -> scrollToTransaction e $ enter t PrintScreen a       PrintScreen   -> a-    where e = currentLedgerTransaction a+    where e = currentTransaction a  -- | Get the account name currently highlighted by the cursor on the -- balance screen. Results undefined while on other screens.@@ -260,34 +262,30 @@  -- | If on the print screen, move the cursor to highlight the specified entry -- (or a reasonable guess). Doesn't work.-scrollToLedgerTransaction :: LedgerTransaction -> AppState -> AppState-scrollToLedgerTransaction e a@AppState{abuf=buf} = setCursorY cy $ setScrollY sy a+scrollToTransaction :: Maybe Transaction -> AppState -> AppState+scrollToTransaction Nothing a = a+scrollToTransaction (Just t) a@AppState{abuf=buf} = setCursorY cy $ setScrollY sy a     where-      entryfirstline = head $ lines $ showLedgerTransaction e+      entryfirstline = head $ lines $ showTransaction t       halfph = pageHeight a `div` 2       y = fromMaybe 0 $ findIndex (== entryfirstline) buf       sy = max 0 $ y - halfph       cy = y - sy --- | Get the entry containing the transaction currently highlighted by the--- cursor on the register screen (or best guess). Results undefined while--- on other screens. Doesn't work.-currentLedgerTransaction :: AppState -> LedgerTransaction-currentLedgerTransaction a@AppState{aledger=l,abuf=buf} = entryContainingTransaction a t+-- | Get the transaction containing the posting currently highlighted by+-- the cursor on the register screen (or best guess). Results undefined+-- while on other screens.+currentTransaction :: AppState -> Maybe Transaction+currentTransaction a@AppState{aledger=l,abuf=buf} = ptransaction p     where-      t = safehead nulltxn $ filter ismatch $ ledgerTransactions l-      ismatch t = tdate t == parsedate (take 10 datedesc)-                  && take 70 (showtxn False t nullmixedamt) == (datedesc ++ acctamt)+      p = safehead nullposting $ filter ismatch $ ledgerPostings l+      ismatch p = postingDate p == parsedate (take 10 datedesc)+                  && take 70 (showposting False p nullmixedamt) == (datedesc ++ acctamt)       datedesc = take 32 $ fromMaybe "" $ find (not . (" " `isPrefixOf`)) $ safehead "" rest : reverse above       acctamt = drop 32 $ safehead "" rest       safehead d ls = if null ls then d else head ls       (above,rest) = splitAt y buf       y = posY a---- | Get the entry which contains the given transaction.--- Will raise an error if there are problems.-entryContainingTransaction :: AppState -> Transaction -> LedgerTransaction-entryContainingTransaction AppState{aledger=l} t = ledger_txns (rawledger l) !! tnum t  -- renderers 

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} {-# OPTIONS_GHC -F -pgmFtrhsx #-} {-|  A web-based UI.@@ -6,6 +6,7 @@  module Commands.Web where+import Codec.Binary.UTF8.String (decodeString) import Control.Applicative.Error (Failing(Success,Failure)) import Control.Concurrent import Control.Monad.Reader (ask)@@ -23,6 +24,11 @@ import Network.Loli.Type (AppUnit) import Network.Loli.Utils (update) import Options hiding (value)+#ifdef MAKE+import Paths_hledger_make (getDataFileName)+#else+import Paths_hledger (getDataFileName)+#endif import System.Directory (getModificationTime) import System.IO.Storage (withStore, putValue, getValue) import System.Process (readProcess)@@ -36,13 +42,14 @@ import qualified Hack.Contrib.Response (redirect) -- import qualified Text.XHtml.Strict as H -import Commands.Add (addTransaction)+import Commands.Add (ledgerAddTransaction) import Commands.Balance import Commands.Histogram import Commands.Print import Commands.Register import Ledger-import Utils (openBrowserOn, readLedgerWithOpts)+import Utils (openBrowserOn)+import Ledger.IO (readLedger)  -- import Debug.Trace -- strace :: Show a => a -> a@@ -80,14 +87,14 @@ ledgerFileModifiedTime l     | null path = getClockTime     | otherwise = getModificationTime path `Prelude.catch` \_ -> getClockTime-    where path = filepath $ rawledger l+    where path = filepath $ journal l  ledgerFileReadTime :: Ledger -> ClockTime-ledgerFileReadTime l = filereadtime $ rawledger l+ledgerFileReadTime l = filereadtime $ journal l  reload :: Ledger -> IO Ledger reload l = do-  l' <- readLedgerWithOpts [] [] (filepath $ rawledger l)+  l' <- readLedger (filepath $ journal l)   putValue "hledger" "ledger" l'   return l'             @@ -99,24 +106,25 @@   -- when (Debug `elem` opts) $ printf "checking file, last modified %s, last read %s, %s\n" (show tmod) (show tread) (show newer)   if newer    then do-     when (Verbose `elem` opts) $ printf "%s has changed, reloading\n" (filepath $ rawledger l)+     when (Verbose `elem` opts) $ printf "%s has changed, reloading\n" (filepath $ journal l)      reload l    else return l  -- refilter :: [Opt] -> [String] -> Ledger -> LocalTime -> IO Ledger--- refilter opts args l t = return $ filterAndCacheLedgerWithOpts opts args t (rawledgertext l) (rawledger l)+-- refilter opts args l t = return $ filterAndCacheLedgerWithOpts opts args t (jtext $ journal l) (journal l)  server :: [Opt] -> [String] -> Ledger -> IO () server opts args l =   -- server initialisation   withStore "hledger" $ do -- IO ()+    t <- getCurrentLocalTime+    webfiles <- getDataFileName "web"     putValue "hledger" "ledger" l     -- XXX hack-happstack abstraction leak     hostname <- readProcess "hostname" [] "" `catch` \_ -> return "hostname"     runWithConfig (ServerConf tcpport hostname) $            -- (Env -> IO Response) -> IO ()       \env -> do -- IO Response        -- general request handler-       printf $ "request\n"        let a = intercalate "+" $ reqparam env "a"            p = intercalate "+" $ reqparam env "p"            opts' = opts ++ [Period p]@@ -124,20 +132,20 @@        l' <- fromJust `fmap` getValue "hledger" "ledger"        l'' <- reloadIfChanged opts' args' l'        -- declare path-specific request handlers-       let command :: [String] -> ([Opt] -> [String] -> Ledger -> String) -> AppUnit-           command msgs f = string msgs $ f opts' args' l''+       let command :: [String] -> ([Opt] -> FilterSpec -> Ledger -> String) -> AppUnit+           command msgs f = string msgs $ f opts' (optsToFilterSpec opts' args' t) l''        (loli $                                               -- State Loli () -> (Env -> IO Response)          do-          get  "/balance"   $ command [] showBalanceReport   -- String -> ReaderT Env (StateT Response IO) () -> State Loli ()+          get  "/balance"   $ command [] showBalanceReport  -- String -> ReaderT Env (StateT Response IO) () -> State Loli ()           get  "/register"  $ command [] showRegisterReport           get  "/histogram" $ command [] showHistogram-          get  "/journal"   $ ledgerpage [] l'' (showLedgerTransactions opts' args')-          post "/journal"   $ handleAddform l''+          get  "/transactions"   $ ledgerpage [] l'' (showTransactions (optsToFilterSpec opts' args' t))+          post "/transactions"   $ handleAddform l''           get  "/env"       $ getenv >>= (text . show)           get  "/params"    $ getenv >>= (text . show . Hack.Contrib.Request.params)           get  "/inputs"    $ getenv >>= (text . show . Hack.Contrib.Request.inputs)-          public (Just "Commands/Web") ["/static"]-          get  "/"          $ redirect ("journal") Nothing+          public (Just webfiles) ["/style.css"]+          get  "/"          $ redirect ("transactions") Nothing           ) env  ledgerpage :: [String] -> Ledger -> (Ledger -> String) -> AppUnit@@ -186,7 +194,7 @@     <html>       <head>         <meta http-equiv = "Content-Type" content = "text/html; charset=utf-8" />-        <link rel="stylesheet" type="text/css" href="/static/style.css" media="all" />+        <link rel="stylesheet" type="text/css" href="/style.css" media="all" />         <title><% title %></title>       </head>       <body>@@ -201,8 +209,8 @@     <div id="navbar">       <a href="http://hledger.org" id="hledgerorglink">hledger.org</a>       <% navlinks env %>---      <% searchform env %>-      <a href="http://hledger.org/README.html" id="helplink">help</a>+      <% searchform env %>+      <a href="http://hledger.org/MANUAL.html" id="helplink">help</a>     </div>  getParamOrNull p = fromMaybe "" `fmap` getParam p@@ -214,7 +222,7 @@    let addparams=(++(printf "?a=%s&p=%s" (urlEncode a) (urlEncode p)))        link s = <a href=(addparams s) class="navlink"><% s %></a>    <div id="navlinks">-     <% link "journal" %> |+     <% link "transactions" %> |      <% link "register" %> |      <% link "balance" %>     </div>@@ -236,8 +244,8 @@ addform :: Hack.Env -> HSP XML addform env = do   let inputs = Hack.Contrib.Request.inputs env-      date  = fromMaybe "" $ lookup "date"  inputs-      desc  = fromMaybe "" $ lookup "desc"  inputs+      date  = decodeString $ fromMaybe "" $ lookup "date"  inputs+      desc  = decodeString $ fromMaybe "" $ lookup "desc"  inputs   <div>    <div id="addform">    <form action="" method="POST">@@ -260,8 +268,8 @@ transactionfields :: Int -> Hack.Env -> HSP XML transactionfields n env = do   let inputs = Hack.Contrib.Request.inputs env-      acct = fromMaybe "" $ lookup acctvar inputs-      amt  = fromMaybe "" $ lookup amtvar  inputs+      acct = decodeString $ fromMaybe "" $ lookup acctvar inputs+      amt  = decodeString $ fromMaybe "" $ lookup amtvar  inputs   <tr>     <td>       [NBSP][NBSP]@@ -278,17 +286,18 @@ handleAddform l = do   env <- getenv   d <- io getCurrentDay-  handle $ validate env d+  t <- io getCurrentLocalTime+  handle t $ validate env d   where-    validate :: Hack.Env -> Day -> Failing LedgerTransaction+    validate :: Hack.Env -> Day -> Failing Transaction     validate env today =         let inputs = Hack.Contrib.Request.inputs env-            date  = fromMaybe "" $ lookup "date"  inputs-            desc  = fromMaybe "" $ lookup "desc"  inputs-            acct1 = fromMaybe "" $ lookup "acct1" inputs-            amt1  = fromMaybe "" $ lookup "amt1"  inputs-            acct2 = fromMaybe "" $ lookup "acct2" inputs-            amt2  = fromMaybe "" $ lookup "amt2"  inputs+            date  = decodeString $ fromMaybe "today" $ lookup "date"  inputs+            desc  = decodeString $ fromMaybe "" $ lookup "desc"  inputs+            acct1 = decodeString $ fromMaybe "" $ lookup "acct1" inputs+            amt1  = decodeString $ fromMaybe "" $ lookup "amt1"  inputs+            acct2 = decodeString $ fromMaybe "" $ lookup "acct2" inputs+            amt2  = decodeString $ fromMaybe "" $ lookup "amt2"  inputs             validateDate ""  = ["missing date"]             validateDate _   = []             validateDesc ""  = ["missing description"]@@ -302,20 +311,20 @@             validateAmt2 _   = []             amt1' = either (const missingamt) id $ parse someamount "" amt1             amt2' = either (const missingamt) id $ parse someamount "" amt2-            t = LedgerTransaction {-                            ltdate = parsedate $ fixSmartDateStr today date-                           ,lteffectivedate=Nothing-                           ,ltstatus=False-                           ,ltcode=""-                           ,ltdescription=desc-                           ,ltcomment=""-                           ,ltpostings=[-                             Posting False acct1 amt1' "" RegularPosting-                            ,Posting False acct2 amt2' "" RegularPosting+            t = Transaction {+                            tdate = parsedate $ fixSmartDateStr today date+                           ,teffectivedate=Nothing+                           ,tstatus=False+                           ,tcode=""+                           ,tdescription=desc+                           ,tcomment=""+                           ,tpostings=[+                             Posting False acct1 amt1' "" RegularPosting (Just t')+                            ,Posting False acct2 amt2' "" RegularPosting (Just t')                             ]-                           ,ltpreceding_comment_lines=""+                           ,tpreceding_comment_lines=""                            }-            (t', berr) = case balanceLedgerTransaction t of+            (t', berr) = case balanceTransaction t of                            Right t'' -> (t'', [])                            Left e -> (t, [e])             errs = concat [@@ -331,10 +340,10 @@           False -> Failure errs           True  -> Success t' -    handle :: Failing LedgerTransaction -> AppUnit-    handle (Failure errs) = hsp errs addform -    handle (Success t)    = do-                    io $ addTransaction l t >> reload l-                    ledgerpage [msg] l (showLedgerTransactions [] [])+    handle :: LocalTime -> Failing Transaction -> AppUnit+    handle _ (Failure errs) = hsp errs addform+    handle ti (Success t)   = do+                    io $ ledgerAddTransaction l t >> reload l+                    ledgerpage [msg] l (showTransactions (optsToFilterSpec [] [] ti))        where msg = printf "Added transaction:\n%s" (show t) 

@@ -13,13 +13,12 @@                module Ledger.Commodity,                module Ledger.Dates,                module Ledger.IO,-               module Ledger.LedgerTransaction,+               module Ledger.Transaction,                module Ledger.Ledger,                module Ledger.Parse,-               module Ledger.RawLedger,+               module Ledger.Journal,                module Ledger.Posting,                module Ledger.TimeLog,-               module Ledger.Transaction,                module Ledger.Types,                module Ledger.Utils,               )@@ -30,12 +29,11 @@ import Ledger.Commodity import Ledger.Dates import Ledger.IO-import Ledger.LedgerTransaction+import Ledger.Transaction import Ledger.Ledger import Ledger.Parse-import Ledger.RawLedger+import Ledger.Journal import Ledger.Posting import Ledger.TimeLog-import Ledger.Transaction import Ledger.Types import Ledger.Utils

@@ -4,8 +4,7 @@  - an 'AccountName', -- all 'Transaction's (postings plus ledger transaction info) in the-  account, excluding subaccounts+- all 'Posting's in the account, excluding subaccounts  - a 'MixedAmount' representing the account balance, including subaccounts. 

@@ -73,6 +73,8 @@           accounttreesfrom as = [Node a (accounttreesfrom $ subs a) | a <- as]           subs = subAccountNamesFrom (expandAccountNames accts) +nullaccountnametree = Node "top" []+ accountNameTreeFrom2 accts =     Node "top" $ unfoldForest (\a -> (a, subs a)) $ topAccountNames accts         where@@ -164,4 +166,6 @@           | length ss > 1 = elideparts width (done++[take 2 $ head ss]) (tail ss)           | otherwise = done++ss +clipAccountName :: Int -> AccountName -> AccountName+clipAccountName n = accountNameFromComponents . take n . accountNameComponents 

@@ -10,31 +10,28 @@   EUR 3.44    GOOG 500   1.5h-  90apples+  90 apples   0  @ -A 'MixedAmount' is zero or more simple amounts:+An amount may also have a per-unit price, or conversion rate, in terms+of some other commodity. If present, this is displayed after \@:  @-  $50 + EUR 3-  16h + $13.55 + AAPL 500 + 6 oranges+  EUR 3 \@ $1.35 @ -Amounts often have a price per unit, or conversion rate, in terms of-another commodity. If present, this is displayed after \@:+A 'MixedAmount' is zero or more simple amounts.  Mixed amounts are+usually normalised so that there is no more than one amount in each+commodity, and no zero amounts (or, there is just a single zero amount+and no others.):  @-  EUR 3 \@ $1.35+  $50 + EUR 3+  16h + $13.55 + AAPL 500 + 6 oranges+  0 @ -A normalised mixed amount has at most one amount in each commodity-price,-and no zero amounts (or it has just a single zero amount and no others.)--In principle we can convert an amount to any other commodity to which we-have a known sequence of conversion rates; in practice we only do one-conversion step (eg to show cost basis with -B).- We can do limited arithmetic with simple or mixed amounts: either price-preserving arithmetic with similarly-priced amounts, or price-discarding arithmetic which ignores and discards prices.@@ -88,6 +85,12 @@ -- exchange rate (which is currently always 1). convertAmountTo :: Commodity -> Amount -> Amount convertAmountTo c2 (Amount c1 q _) = Amount c2 (q * conversionRate c1 c2) Nothing++-- | Convert mixed amount to the specified commodity+convertMixedAmountTo :: Commodity -> MixedAmount -> Amount+convertMixedAmountTo c2 (Mixed ams) = Amount c2 total Nothing+    where+    total = sum . map (quantity . convertAmountTo c2) $ ams  -- | Convert an amount to the commodity of its saved price, if any. costOfAmount :: Amount -> Amount

@@ -1,9 +1,11 @@ {-| +Date parsing and utilities for hledger.+ For date and time values, we use the standard Day and UTCTime types.  A 'SmartDate' is a date which may be partially-specified or relative.-Eg 2008/12/31, but also 2008/12, 12/31, tomorrow, last week, next year.+Eg 2008\/12\/31, but also 2008\/12, 12\/31, tomorrow, last week, next year. We represent these as a triple of strings like (\"2008\",\"12\",\"\"), (\"\",\"\",\"tomorrow\"), (\"\",\"last\",\"week\"). @@ -115,7 +117,7 @@       span (y,m,"")              = (startofmonth day, nextmonth day) where day = fromGregorian (read y) (read m) 1       span (y,m,d)               = (day, nextday day) where day = fromGregorian (read y) (read m) (read d) --- | Convert a smart date string to an explicit yyyy/mm/dd string using+-- | Convert a smart date string to an explicit yyyy\/mm\/dd string using -- the provided reference date. fixSmartDateStr :: Day -> String -> String fixSmartDateStr t s = printf "%04d/%02d/%02d" y m d@@ -422,3 +424,5 @@ nulldatespan = DateSpan Nothing Nothing  mkdatespan b = DateSpan (Just $ parsedate b) . Just . parsedate++nulldate = parsedate "1900/01/01"

@@ -5,14 +5,15 @@ module Ledger.IO where import Control.Monad.Error-import Ledger.Ledger (cacheLedger)+import Ledger.Ledger (cacheLedger', nullledger) import Ledger.Parse (parseLedger)-import Ledger.RawLedger (canonicaliseAmounts,filterRawLedger,rawLedgerSelectingDate)-import Ledger.Types (FilterSpec(..),WhichDate(..),DateSpan(..),RawLedger(..),Ledger(..))+import Ledger.Types (FilterSpec(..),WhichDate(..),Journal(..),Ledger(..)) import Ledger.Utils (getCurrentLocalTime)+import Ledger.Dates (nulldatespan) import System.Directory (getHomeDirectory) import System.Environment (getEnv)-import System.IO+import Prelude hiding (readFile)+import System.IO.UTF8 import System.FilePath ((</>)) import System.Time (getClockTime) @@ -23,14 +24,16 @@ timelogdefaultfilename = ".timelog"  nullfilterspec = FilterSpec {-                  datespan=DateSpan Nothing Nothing-                 ,cleared=Nothing-                 ,real=False-                 ,costbasis=False-                 ,acctpats=[]-                 ,descpats=[]-                 ,whichdate=ActualDate-                 }+     datespan=nulldatespan+    ,cleared=Nothing+    ,real=False+    ,empty=False+    ,costbasis=False+    ,acctpats=[]+    ,descpats=[]+    ,whichdate=ActualDate+    ,depth=Nothing+    }  -- | Get the user's default ledger file path. myLedgerPath :: IO String@@ -58,36 +61,27 @@  -- | Read a ledger from this file, with no filtering, or give an error. readLedger :: FilePath -> IO Ledger-readLedger = readLedgerWithFilterSpec nullfilterspec---- | Read a ledger from this file, filtering according to the filter spec.,--- | or give an error.-readLedgerWithFilterSpec :: FilterSpec -> FilePath -> IO Ledger-readLedgerWithFilterSpec fspec f = do-  s <- readFile f+readLedger f = do   t <- getClockTime-  rl <- rawLedgerFromString s-  return $ filterAndCacheLedger fspec s rl{filepath=f, filereadtime=t}+  s <- readFile f+  j <- journalFromString s+  return $ cacheLedger' $ nullledger{journal=j{filepath=f,filereadtime=t,jtext=s}} --- | Read a RawLedger from the given string, using the current time as+-- -- | Read a ledger from this file, filtering according to the filter spec.,+-- -- | or give an error.+-- readLedgerWithFilterSpec :: FilterSpec -> FilePath -> IO Ledger+-- readLedgerWithFilterSpec fspec f = do+--   s <- readFile f+--   t <- getClockTime+--   rl <- journalFromString s+--   return $ filterAndCacheLedger fspec s rl{filepath=f, filereadtime=t}++-- | Read a Journal from the given string, using the current time as -- reference time, or give a parse error.-rawLedgerFromString :: String -> IO RawLedger-rawLedgerFromString s = do+journalFromString :: String -> IO Journal+journalFromString s = do   t <- getCurrentLocalTime   liftM (either error id) $ runErrorT $ parseLedger t "(string)" s---- | Convert a RawLedger to a canonicalised, cached and filtered Ledger.-filterAndCacheLedger :: FilterSpec -> String -> RawLedger -> Ledger-filterAndCacheLedger (FilterSpec{datespan=datespan,cleared=cleared,real=real,-                                 costbasis=costbasis,acctpats=acctpats,-                                 descpats=descpats,whichdate=whichdate})-                     rawtext-                     rl = -    (cacheLedger acctpats -    $ filterRawLedger datespan descpats cleared real -    $ rawLedgerSelectingDate whichdate-    $ canonicaliseAmounts costbasis rl-    ){rawledgertext=rawtext}  -- -- | Expand ~ in a file path (does not handle ~name). -- tildeExpand :: FilePath -> IO FilePath

@@ -0,0 +1,321 @@+{-|++A 'Journal' is a parsed ledger file, containing 'Transaction's.+It can be filtered and massaged in various ways, then \"crunched\"+to form a 'Ledger'.++-}++module Ledger.Journal+where+import qualified Data.Map as Map+import Data.Map (findWithDefault, (!))+import System.Time (ClockTime(TOD))+import Ledger.Utils+import Ledger.Types+import Ledger.AccountName+import Ledger.Amount+import Ledger.Transaction (ledgerTransactionWithDate)+import Ledger.Posting+import Ledger.TimeLog+++instance Show Journal where+    show j = printf "Journal with %d transactions, %d accounts: %s"+             (length (jtxns j) ++              length (jmodifiertxns j) ++              length (jperiodictxns j))+             (length accounts)+             (show accounts)+             -- ++ (show $ journalTransactions l)+             where accounts = flatten $ journalAccountNameTree j++nulljournal :: Journal+nulljournal = Journal { jmodifiertxns = []+                      , jperiodictxns = []+                      , jtxns = []+                      , open_timelog_entries = []+                      , historical_prices = []+                      , final_comment_lines = []+                      , filepath = ""+                      , filereadtime = TOD 0 0+                      , jtext = ""+                      }++addTransaction :: Transaction -> Journal -> Journal+addTransaction t l0 = l0 { jtxns = t : jtxns l0 }++addModifierTransaction :: ModifierTransaction -> Journal -> Journal+addModifierTransaction mt l0 = l0 { jmodifiertxns = mt : jmodifiertxns l0 }++addPeriodicTransaction :: PeriodicTransaction -> Journal -> Journal+addPeriodicTransaction pt l0 = l0 { jperiodictxns = pt : jperiodictxns l0 }++addHistoricalPrice :: HistoricalPrice -> Journal -> Journal+addHistoricalPrice h l0 = l0 { historical_prices = h : historical_prices l0 }++addTimeLogEntry :: TimeLogEntry -> Journal -> Journal+addTimeLogEntry tle l0 = l0 { open_timelog_entries = tle : open_timelog_entries l0 }++journalPostings :: Journal -> [Posting]+journalPostings = concatMap tpostings . jtxns++journalAccountNamesUsed :: Journal -> [AccountName]+journalAccountNamesUsed = accountNamesFromPostings . journalPostings++journalAccountNames :: Journal -> [AccountName]+journalAccountNames = sort . expandAccountNames . journalAccountNamesUsed++journalAccountNameTree :: Journal -> Tree AccountName+journalAccountNameTree = accountNameTreeFrom . journalAccountNames++-- Various kinds of filtering on journals. We do it differently depending+-- on the command.++-- | Keep only transactions we are interested in, as described by+-- the filter specification. May also massage the data a little.+filterJournalTransactions :: FilterSpec -> Journal -> Journal+filterJournalTransactions FilterSpec{datespan=datespan+                                    ,cleared=cleared+                                    -- ,real=real+                                    -- ,empty=empty+                                    -- ,costbasis=_+                                    ,acctpats=apats+                                    ,descpats=dpats+                                    ,whichdate=whichdate+                                    ,depth=depth+                                    } =+    filterJournalTransactionsByClearedStatus cleared .+    filterJournalPostingsByDepth depth .+    filterJournalTransactionsByAccount apats .+    filterJournalTransactionsByDescription dpats .+    filterJournalTransactionsByDate datespan .+    journalSelectingDate whichdate++-- | Keep only postings we are interested in, as described by+-- the filter specification. May also massage the data a little.+-- This can leave unbalanced transactions.+filterJournalPostings :: FilterSpec -> Journal -> Journal+filterJournalPostings FilterSpec{datespan=datespan+                                ,cleared=cleared+                                ,real=real+                                ,empty=empty+--                                ,costbasis=costbasis+                                ,acctpats=apats+                                ,descpats=dpats+                                ,whichdate=whichdate+                                ,depth=depth+                                } =+    filterJournalPostingsByRealness real .+    filterJournalPostingsByClearedStatus cleared .+    filterJournalPostingsByEmpty empty .+    filterJournalPostingsByDepth depth .+    filterJournalPostingsByAccount apats .+    filterJournalTransactionsByDescription dpats .+    filterJournalTransactionsByDate datespan .+    journalSelectingDate whichdate++-- | Keep only ledger transactions whose description matches the description patterns.+filterJournalTransactionsByDescription :: [String] -> Journal -> Journal+filterJournalTransactionsByDescription pats j@Journal{jtxns=ts} = j{jtxns=filter matchdesc ts}+    where matchdesc = matchpats pats . tdescription++-- | Keep only ledger transactions which fall between begin and end dates.+-- We include transactions on the begin date and exclude transactions on the end+-- date, like ledger.  An empty date string means no restriction.+filterJournalTransactionsByDate :: DateSpan -> Journal -> Journal+filterJournalTransactionsByDate (DateSpan begin end) j@Journal{jtxns=ts} = j{jtxns=filter match ts}+    where match t = maybe True (tdate t>=) begin && maybe True (tdate t<) end++-- | Keep only ledger transactions which have the requested+-- cleared/uncleared status, if there is one.+filterJournalTransactionsByClearedStatus :: Maybe Bool -> Journal -> Journal+filterJournalTransactionsByClearedStatus Nothing j = j+filterJournalTransactionsByClearedStatus (Just val) j@Journal{jtxns=ts} = j{jtxns=filter match ts}+    where match = (==val).tstatus++-- | Keep only postings which have the requested cleared/uncleared status,+-- if there is one.+filterJournalPostingsByClearedStatus :: Maybe Bool -> Journal -> Journal+filterJournalPostingsByClearedStatus Nothing j = j+filterJournalPostingsByClearedStatus (Just c) j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts}+    where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter ((==c) . postingCleared) ps}++-- | Strip out any virtual postings, if the flag is true, otherwise do+-- no filtering.+filterJournalPostingsByRealness :: Bool -> Journal -> Journal+filterJournalPostingsByRealness False l = l+filterJournalPostingsByRealness True j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts}+    where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter isReal ps}++-- | Strip out any postings with zero amount, unless the flag is true.+filterJournalPostingsByEmpty :: Bool -> Journal -> Journal+filterJournalPostingsByEmpty True l = l+filterJournalPostingsByEmpty False j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts}+    where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter (not . isEmptyPosting) ps}++-- | Keep only transactions which affect accounts deeper than the specified depth.+filterJournalTransactionsByDepth :: Maybe Int -> Journal -> Journal+filterJournalTransactionsByDepth Nothing j = j+filterJournalTransactionsByDepth (Just d) j@Journal{jtxns=ts} =+    j{jtxns=(filter (any ((<= d+1) . accountNameLevel . paccount) . tpostings) ts)}++-- | Strip out any postings to accounts deeper than the specified depth+-- (and any ledger transactions which have no postings as a result).+filterJournalPostingsByDepth :: Maybe Int -> Journal -> Journal+filterJournalPostingsByDepth Nothing j = j+filterJournalPostingsByDepth (Just d) j@Journal{jtxns=ts} =+    j{jtxns=filter (not . null . tpostings) $ map filtertxns ts}+    where filtertxns t@Transaction{tpostings=ps} =+              t{tpostings=filter ((<= d) . accountNameLevel . paccount) ps}++-- | Keep only transactions which affect accounts matched by the account patterns.+filterJournalTransactionsByAccount :: [String] -> Journal -> Journal+filterJournalTransactionsByAccount apats j@Journal{jtxns=ts} = j{jtxns=filter match ts}+    where match = any (matchpats apats . paccount) . tpostings++-- | Keep only postings which affect accounts matched by the account patterns.+-- This can leave transactions unbalanced.+filterJournalPostingsByAccount :: [String] -> Journal -> Journal+filterJournalPostingsByAccount apats j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts}+    where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter (matchpats apats . paccount) ps}++-- | Convert this journal's transactions' primary date to either the+-- actual or effective date.+journalSelectingDate :: WhichDate -> Journal -> Journal+journalSelectingDate ActualDate j = j+journalSelectingDate EffectiveDate j =+    j{jtxns=map (ledgerTransactionWithDate EffectiveDate) $ jtxns j}++-- | Convert all the journal's amounts to their canonical display settings.+-- Ie, in each commodity, amounts will use the display settings of the first+-- amount detected, and the greatest precision of the amounts detected.+-- Also, missing unit prices are added if known from the price history.+-- Also, amounts are converted to cost basis if that flag is active.+-- XXX refactor+canonicaliseAmounts :: Bool -> Journal -> Journal+canonicaliseAmounts costbasis j@Journal{jtxns=ts} = j{jtxns=map fixledgertransaction ts}+    where+      fixledgertransaction (Transaction d ed s c de co ts pr) = Transaction d ed s c de co (map fixrawposting ts) pr+          where+            fixrawposting (Posting s ac a c t txn) = Posting s ac (fixmixedamount a) c t txn+            fixmixedamount (Mixed as) = Mixed $ map fixamount as+            fixamount = (if costbasis then costOfAmount else id) . fixprice . fixcommodity+            fixcommodity a = a{commodity=c} where c = canonicalcommoditymap ! symbol (commodity a)+            canonicalcommoditymap =+                Map.fromList [(s,firstc{precision=maxp}) | s <- commoditysymbols,+                        let cs = commoditymap ! s,+                        let firstc = head cs,+                        let maxp = maximum $ map precision cs+                       ]+            commoditymap = Map.fromList [(s,commoditieswithsymbol s) | s <- commoditysymbols]+            commoditieswithsymbol s = filter ((s==) . symbol) commodities+            commoditysymbols = nub $ map symbol commodities+            commodities = map commodity (concatMap (amounts . pamount) (journalPostings j)+                                         ++ concatMap (amounts . hamount) (historical_prices j))+            fixprice :: Amount -> Amount+            fixprice a@Amount{price=Just _} = a+            fixprice a@Amount{commodity=c} = a{price=journalHistoricalPriceFor j d c}++            -- | Get the price for a commodity on the specified day from the price database, if known.+            -- Does only one lookup step, ie will not look up the price of a price.+            journalHistoricalPriceFor :: Journal -> Day -> Commodity -> Maybe MixedAmount+            journalHistoricalPriceFor j d Commodity{symbol=s} = do+              let ps = reverse $ filter ((<= d).hdate) $ filter ((s==).hsymbol) $ sortBy (comparing hdate) $ historical_prices j+              case ps of (HistoricalPrice{hamount=a}:_) -> Just $ canonicaliseCommodities a+                         _ -> Nothing+                  where+                    canonicaliseCommodities (Mixed as) = Mixed $ map canonicaliseCommodity as+                        where canonicaliseCommodity a@Amount{commodity=Commodity{symbol=s}} =+                                  a{commodity=findWithDefault (error "programmer error: canonicaliseCommodity failed") s canonicalcommoditymap}++-- | Get just the amounts from a ledger, in the order parsed.+journalAmounts :: Journal -> [MixedAmount]+journalAmounts = map pamount . journalPostings++-- | Get just the ammount commodities from a ledger, in the order parsed.+journalCommodities :: Journal -> [Commodity]+journalCommodities = map commodity . concatMap amounts . journalAmounts++-- | Get just the amount precisions from a ledger, in the order parsed.+journalPrecisions :: Journal -> [Int]+journalPrecisions = map precision . journalCommodities++-- | Close any open timelog sessions using the provided current time.+journalConvertTimeLog :: LocalTime -> Journal -> Journal+journalConvertTimeLog t l0 = l0 { jtxns = convertedTimeLog ++ jtxns l0+                                  , open_timelog_entries = []+                                  }+    where convertedTimeLog = entriesFromTimeLogEntries t $ open_timelog_entries l0++-- | The (fully specified) date span containing all the raw ledger's transactions,+-- or DateSpan Nothing Nothing if there are none.+journalDateSpan :: Journal -> DateSpan+journalDateSpan j+    | null ts = DateSpan Nothing Nothing+    | otherwise = DateSpan (Just $ tdate $ head ts) (Just $ addDays 1 $ tdate $ last ts)+    where+      ts = sortBy (comparing tdate) $ jtxns j++-- | Check if a set of ledger account/description patterns matches the+-- given account name or entry description.  Patterns are case-insensitive+-- regular expression strings; those beginning with - are anti-patterns.+matchpats :: [String] -> String -> Bool+matchpats pats str =+    (null positives || any match positives) && (null negatives || not (any match negatives))+    where+      (negatives,positives) = partition isnegativepat pats+      match "" = True+      match pat = containsRegex (abspat pat) str+      negateprefix = "not:"+      isnegativepat = (negateprefix `isPrefixOf`)+      abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat++-- | Calculate the account tree and account balances from a journal's+-- postings, and return the results for efficient lookup.+crunchJournal :: Journal -> (Tree AccountName, Map.Map AccountName Account)+crunchJournal j = (ant,amap)+    where+      (ant,psof,_,inclbalof) = (groupPostings . journalPostings) j+      amap = Map.fromList [(a, acctinfo a) | a <- flatten ant]+      acctinfo a = Account a (psof a) (inclbalof a)++-- | Given a list of postings, return an account name tree and three query+-- functions that fetch postings, balance, and subaccount-including+-- balance by account name.  This factors out common logic from+-- cacheLedger and summarisePostingsInDateSpan.+groupPostings :: [Posting] -> (Tree AccountName,+                             (AccountName -> [Posting]),+                             (AccountName -> MixedAmount),+                             (AccountName -> MixedAmount))+groupPostings ps = (ant,psof,exclbalof,inclbalof)+    where+      anames = sort $ nub $ map paccount ps+      ant = accountNameTreeFrom $ expandAccountNames anames+      allanames = flatten ant+      pmap = Map.union (postingsByAccount ps) (Map.fromList [(a,[]) | a <- allanames])+      psof = (pmap !)+      balmap = Map.fromList $ flatten $ calculateBalances ant psof+      exclbalof = fst . (balmap !)+      inclbalof = snd . (balmap !)++-- | Add subaccount-excluding and subaccount-including balances to a tree+-- of account names somewhat efficiently, given a function that looks up+-- transactions by account name.+calculateBalances :: Tree AccountName -> (AccountName -> [Posting]) -> Tree (AccountName, (MixedAmount, MixedAmount))+calculateBalances ant psof = addbalances ant+    where+      addbalances (Node a subs) = Node (a,(bal,bal+subsbal)) subs'+          where+            bal         = sumPostings $ psof a+            subsbal     = sum $ map (snd . snd . root) subs'+            subs'       = map addbalances subs++-- | Convert a list of postings to a map from account name to that+-- account's postings.+postingsByAccount :: [Posting] -> Map.Map AccountName [Posting]+postingsByAccount ps = m'+    where+      sortedps = sortBy (comparing paccount) ps+      groupedps = groupBy (\p1 p2 -> paccount p1 == paccount p2) sortedps+      m' = Map.fromList [(paccount $ head g, g) | g <- groupedps]

@@ -1,11 +1,11 @@ {-|  A compound data type for efficiency. A 'Ledger' caches information derived-from a 'RawLedger' for easier querying. Also it typically has had-uninteresting 'LedgerTransaction's and 'Posting's filtered out. It+from a 'Journal' for easier querying. Also it typically has had+uninteresting 'Transaction's and 'Posting's filtered out. It contains: -- the original unfiltered 'RawLedger'+- the original unfiltered 'Journal'  - a tree of 'AccountName's @@ -54,88 +54,56 @@ module Ledger.Ledger where import qualified Data.Map as Map-import Data.Map ((!))+import Data.Map (findWithDefault, fromList) import Ledger.Utils import Ledger.Types-import Ledger.Account ()+import Ledger.Account (nullacct) import Ledger.AccountName-import Ledger.Transaction-import Ledger.RawLedger+import Ledger.Journal+import Ledger.Posting   instance Show Ledger where     show l = printf "Ledger with %d transactions, %d accounts\n%s"-             (length (ledger_txns $ rawledger l) +-              length (modifier_txns $ rawledger l) +-              length (periodic_txns $ rawledger l))+             (length (jtxns $ journal l) ++              length (jmodifiertxns $ journal l) ++              length (jperiodictxns $ journal l))              (length $ accountnames l)              (showtree $ accountnametree l) --- | Convert a raw ledger to a more efficient cached type, described above.  -cacheLedger :: [String] -> RawLedger -> Ledger-cacheLedger apats l = Ledger{rawledgertext="",rawledger=l,accountnametree=ant,accountmap=acctmap}-    where-      (ant,txnsof,_,inclbalof) = groupTransactions $ filtertxns apats $ rawLedgerTransactions l-      acctmap = Map.fromList [(a, mkacct a) | a <- flatten ant]-          where mkacct a = Account a (txnsof a) (inclbalof a)+nullledger :: Ledger+nullledger = Ledger{+      journal = nulljournal,+      accountnametree = nullaccountnametree,+      accountmap = fromList []+    } --- | Given a list of transactions, return an account name tree and three--- query functions that fetch transactions, balance, and--- subaccount-including balance by account name. --- This is to factor out common logic from cacheLedger and--- summariseTransactionsInDateSpan.-groupTransactions :: [Transaction] -> (Tree AccountName,-                                     (AccountName -> [Transaction]), -                                     (AccountName -> MixedAmount), -                                     (AccountName -> MixedAmount))-groupTransactions ts = (ant,txnsof,exclbalof,inclbalof)-    where-      txnanames = sort $ nub $ map taccount ts-      ant = accountNameTreeFrom $ expandAccountNames txnanames-      allanames = flatten ant-      txnmap = Map.union (transactionsByAccount ts) (Map.fromList [(a,[]) | a <- allanames])-      balmap = Map.fromList $ flatten $ calculateBalances ant txnsof-      txnsof = (txnmap !) -      exclbalof = fst . (balmap !)-      inclbalof = snd . (balmap !)--- debug---       txnsof a = (txnmap ! (trace ("ts "++a) a))---       exclbalof a = fst $ (balmap ! (trace ("eb "++a) a))---       inclbalof a = snd $ (balmap ! (trace ("ib "++a) a))+-- | Convert a journal to a more efficient cached ledger, described above.+cacheLedger :: Journal -> Ledger+cacheLedger j = nullledger{journal=j,accountnametree=ant,accountmap=amap}+    where (ant, amap) = crunchJournal j --- | Add subaccount-excluding and subaccount-including balances to a tree--- of account names somewhat efficiently, given a function that looks up--- transactions by account name.-calculateBalances :: Tree AccountName -> (AccountName -> [Transaction]) -> Tree (AccountName, (MixedAmount, MixedAmount))-calculateBalances ant txnsof = addbalances ant-    where -      addbalances (Node a subs) = Node (a,(bal,bal+subsbal)) subs'-          where-            bal         = sumTransactions $ txnsof a-            subsbal     = sum $ map (snd . snd . root) subs'-            subs'       = map addbalances subs+-- | Add (or recalculate) the cached journal info in a ledger.+cacheLedger' :: Ledger -> CachedLedger+cacheLedger' l = l{accountnametree=ant,accountmap=amap}+    where (ant, amap) = crunchJournal $ journal l --- | Convert a list of transactions to a map from account name to the list--- of all transactions in that account. -transactionsByAccount :: [Transaction] -> Map.Map AccountName [Transaction]-transactionsByAccount ts = m'-    where-      sortedts = sortBy (comparing taccount) ts-      groupedts = groupBy (\t1 t2 -> taccount t1 == taccount t2) sortedts-      m' = Map.fromList [(taccount $ head g, g) | g <- groupedts]--- The special account name "top" can be used to look up all transactions. ?---      m' = Map.insert "top" sortedts m+-- | Like cacheLedger, but filtering the journal first.+cacheLedger'' filterspec l@Ledger{journal=j} = l{journal=j',accountnametree=ant,accountmap=amap}+    where (ant, amap) = crunchJournal j'+          j' = filterJournalPostings filterspec{depth=Nothing} j -filtertxns :: [String] -> [Transaction] -> [Transaction]-filtertxns apats = filter (matchpats apats . taccount)+type CachedLedger = Ledger  -- | List a ledger's account names. ledgerAccountNames :: Ledger -> [AccountName] ledgerAccountNames = drop 1 . flatten . accountnametree --- | Get the named account from a ledger.+-- | Get the named account from a (cached) ledger.+-- If the ledger has not been cached (with crunchJournal or+-- cacheLedger'), this returns the null account. ledgerAccount :: Ledger -> AccountName -> Account-ledgerAccount = (!) . accountmap+ledgerAccount l a = findWithDefault nullacct a $ accountmap l  -- | List a ledger's accounts, in tree order ledgerAccounts :: Ledger -> [Account]@@ -154,9 +122,9 @@ ledgerSubAccounts l Account{aname=a} =      map (ledgerAccount l) $ filter (`isSubAccountNameOf` a) $ accountnames l --- | List a ledger's "transactions", ie postings with transaction info attached.-ledgerTransactions :: Ledger -> [Transaction]-ledgerTransactions = rawLedgerTransactions . rawledger+-- | List a ledger's postings, in the order parsed.+ledgerPostings :: Ledger -> [Posting]+ledgerPostings = journalPostings . journal  -- | Get a ledger's tree of accounts to the specified depth. ledgerAccountTree :: Int -> Ledger -> Tree Account@@ -169,11 +137,7 @@ -- | The (fully specified) date span containing all the ledger's (filtered) transactions, -- or DateSpan Nothing Nothing if there are none. ledgerDateSpan :: Ledger -> DateSpan-ledgerDateSpan l-    | null ts = DateSpan Nothing Nothing-    | otherwise = DateSpan (Just $ tdate $ head ts) (Just $ addDays 1 $ tdate $ last ts)-    where-      ts = sortBy (comparing tdate) $ ledgerTransactions l+ledgerDateSpan = postingsDateSpan . ledgerPostings  -- | Convenience aliases. accountnames :: Ledger -> [AccountName]@@ -194,11 +158,11 @@ subaccounts :: Ledger -> Account -> [Account] subaccounts = ledgerSubAccounts -transactions :: Ledger -> [Transaction]-transactions = ledgerTransactions+postings :: Ledger -> [Posting]+postings = ledgerPostings  commodities :: Ledger -> [Commodity]-commodities = nub . rawLedgerCommodities . rawledger+commodities = nub . journalCommodities . journal  accounttree :: Int -> Ledger -> Tree Account accounttree = ledgerAccountTree@@ -210,7 +174,7 @@ -- datespan = ledgerDateSpan  rawdatespan :: Ledger -> DateSpan-rawdatespan = rawLedgerDateSpan . rawledger+rawdatespan = journalDateSpan . journal  ledgeramounts :: Ledger -> [MixedAmount]-ledgeramounts = rawLedgerAmounts . rawledger+ledgeramounts = journalAmounts . journal

@@ -1,133 +0,0 @@-{-|--A 'LedgerTransaction' represents a regular transaction in the ledger-file. It normally contains two or more balanced 'Posting's.---}--module Ledger.LedgerTransaction-where-import Ledger.Utils-import Ledger.Types-import Ledger.Dates-import Ledger.Posting-import Ledger.Amount---instance Show LedgerTransaction where show = showLedgerTransactionUnelided--instance Show ModifierTransaction where -    show t = "= " ++ mtvalueexpr t ++ "\n" ++ unlines (map show (mtpostings t))--instance Show PeriodicTransaction where -    show t = "~ " ++ ptperiodicexpr t ++ "\n" ++ unlines (map show (ptpostings t))--nullledgertxn :: LedgerTransaction-nullledgertxn = LedgerTransaction {-              ltdate=parsedate "1900/1/1", -              lteffectivedate=Nothing, -              ltstatus=False, -              ltcode="", -              ltdescription="", -              ltcomment="",-              ltpostings=[],-              ltpreceding_comment_lines=""-            }--{-|-Show a ledger entry, formatted for the print command. ledger 2.x's-standard format looks like this:--@-yyyy/mm/dd[ *][ CODE] description.........          [  ; comment...............]-    account name 1.....................  ...$amount1[  ; comment...............]-    account name 2.....................  ..$-amount1[  ; comment...............]--pcodewidth    = no limit -- 10          -- mimicking ledger layout.-pdescwidth    = no limit -- 20          -- I don't remember what these mean,-pacctwidth    = 35 minimum, no maximum  -- they were important at the time.-pamtwidth     = 11-pcommentwidth = no limit -- 22-@--}-showLedgerTransaction :: LedgerTransaction -> String-showLedgerTransaction = showLedgerTransaction' True False--showLedgerTransactionUnelided :: LedgerTransaction -> String-showLedgerTransactionUnelided = showLedgerTransaction' False False--showLedgerTransactionForPrint :: Bool -> LedgerTransaction -> String-showLedgerTransactionForPrint effective = showLedgerTransaction' False effective--showLedgerTransaction' :: Bool -> Bool -> LedgerTransaction -> String-showLedgerTransaction' elide effective t =-    unlines $ [description] ++ showpostings (ltpostings t) ++ [""]-    where-      description = concat [date, status, code, desc, comment]-      date | effective = showdate $ fromMaybe (ltdate t) $ lteffectivedate t-           | otherwise = showdate (ltdate t) ++ maybe "" showedate (lteffectivedate t)-      status = if ltstatus t then " *" else ""-      code = if length (ltcode t) > 0 then printf " (%s)" $ ltcode t else ""-      desc = ' ' : ltdescription t-      comment = if null com then "" else "  ; " ++ com where com = ltcomment t-      showdate = printf "%-10s" . showDate-      showedate = printf "=%s" . showdate-      showpostings ps-          | elide && length ps > 1 && isLedgerTransactionBalanced t-              = map showposting (init ps) ++ [showpostingnoamt (last ps)]-          | otherwise = map showposting ps-          where-            showposting p = showacct p ++ "  " ++ showamount (pamount p) ++ showcomment (pcomment p)-            showpostingnoamt p = rstrip $ showacct p ++ "              " ++ showcomment (pcomment p)-            showacct p = "    " ++ showstatus p ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p))-            w = maximum $ map (length . paccount) ps-            showamount = printf "%12s" . showMixedAmount-            showcomment s = if null s then "" else "  ; "++s-            showstatus p = if pstatus p then "* " else ""---- | Show an account name, clipped to the given width if any, and--- appropriately bracketed/parenthesised for the given posting type.-showAccountName :: Maybe Int -> PostingType -> AccountName -> String-showAccountName w = fmt-    where-      fmt RegularPosting = take w'-      fmt VirtualPosting = parenthesise . reverse . take (w'-2) . reverse-      fmt BalancedVirtualPosting = bracket . reverse . take (w'-2) . reverse-      w' = fromMaybe 999999 w-      parenthesise s = "("++s++")"-      bracket s = "["++s++"]"--isLedgerTransactionBalanced :: LedgerTransaction -> Bool-isLedgerTransactionBalanced (LedgerTransaction {ltpostings=ps}) = -    all (isReallyZeroMixedAmount . costOfMixedAmount . sum . map pamount)-            [filter isReal ps, filter isBalancedVirtual ps]---- | Ensure that this entry is balanced, possibly auto-filling a missing--- amount first. We can auto-fill if there is just one non-virtual--- transaction without an amount. The auto-filled balance will be--- converted to cost basis if possible. If the entry can not be balanced,--- return an error message instead.-balanceLedgerTransaction :: LedgerTransaction -> Either String LedgerTransaction-balanceLedgerTransaction t@LedgerTransaction{ltpostings=ps}-    | length missingamounts' > 1 = Left $ printerr "could not balance this transaction, too many missing amounts"-    | not $ isLedgerTransactionBalanced t' = Left $ printerr nonzerobalanceerror-    | otherwise = Right t'-    where-      (withamounts, missingamounts) = partition hasAmount $ filter isReal ps-      (_, missingamounts') = partition hasAmount ps-      t' = t{ltpostings=ps'}-      ps' | length missingamounts == 1 = map balance ps-          | otherwise = ps-          where -            balance p | isReal p && not (hasAmount p) = p{pamount = costOfMixedAmount (-otherstotal)}-                      | otherwise = p-                      where otherstotal = sum $ map pamount withamounts-      printerr s = printf "%s:\n%s" s (showLedgerTransactionUnelided t)--nonzerobalanceerror = "could not balance this transaction, amounts do not add up to zero"---- | Convert the primary date to either the actual or effective date.-ledgerTransactionWithDate :: WhichDate -> LedgerTransaction -> LedgerTransaction-ledgerTransactionWithDate ActualDate t = t-ledgerTransactionWithDate EffectiveDate t = t{ltdate=fromMaybe (ltdate t) (lteffectivedate t)}-    

@@ -18,9 +18,9 @@ import Ledger.Dates import Ledger.AccountName (accountNameFromComponents,accountNameComponents) import Ledger.Amount-import Ledger.LedgerTransaction+import Ledger.Transaction import Ledger.Posting-import Ledger.RawLedger+import Ledger.Journal import System.FilePath(takeDirectory,combine)  @@ -63,21 +63,21 @@  -- let's get to it -parseLedgerFile :: LocalTime -> FilePath -> ErrorT String IO RawLedger+parseLedgerFile :: LocalTime -> FilePath -> ErrorT String IO Journal parseLedgerFile t "-" = liftIO getContents >>= parseLedger t "-" parseLedgerFile t f   = liftIO (readFile f) >>= parseLedger t f  -- | Parses the contents of a ledger file, or gives an error.  Requires -- the current (local) time to calculate any unfinished timelog sessions, -- we pass it in for repeatability.-parseLedger :: LocalTime -> FilePath -> String -> ErrorT String IO RawLedger+parseLedger :: LocalTime -> FilePath -> String -> ErrorT String IO Journal parseLedger reftime inname intxt =   case runParser ledgerFile emptyCtx inname intxt of-    Right m  -> liftM (rawLedgerConvertTimeLog reftime) $ m `ap` return rawLedgerEmpty+    Right m  -> liftM (journalConvertTimeLog reftime) $ m `ap` return nulljournal     Left err -> throwError $ show err  -ledgerFile :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))+ledgerFile :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerFile = do items <- many ledgerItem                 eof                 return $ liftM (foldr (.) id) $ sequence items@@ -86,7 +86,7 @@       -- character, excepting transactions versus empty (blank or       -- comment-only) lines, can use choice w/o try       ledgerItem = choice [ ledgerDirective-                          , liftM (return . addLedgerTransaction) ledgerTransaction+                          , liftM (return . addTransaction) ledgerTransaction                           , liftM (return . addModifierTransaction) ledgerModifierTransaction                           , liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction                           , liftM (return . addHistoricalPrice) ledgerHistoricalPrice@@ -95,7 +95,7 @@                           , liftM (return . addTimeLogEntry)  timelogentry                           ] -ledgerDirective :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))+ledgerDirective :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerDirective = do char '!' <?> "directive"                      directive <- many nonspace                      case directive of@@ -104,7 +104,7 @@                        "end"     -> ledgerAccountEnd                        _         -> mzero -ledgerInclude :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))+ledgerInclude :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerInclude = do many1 spacenonewline                    filename <- restofline                    outerState <- getState@@ -127,19 +127,19 @@                                                       return $ homedir ++ drop 1 inname                       | otherwise                = return inname -ledgerAccountBegin :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))+ledgerAccountBegin :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerAccountBegin = do many1 spacenonewline                         parent <- ledgeraccountname                         newline                         pushParentAccount parent                         return $ return id -ledgerAccountEnd :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))+ledgerAccountEnd :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerAccountEnd = popParentAccount >> return (return id)  -- parsers --- | Parse a RawLedger from either a ledger file or a timelog file.+-- | Parse a Journal from either a ledger file or a timelog file. -- It tries first the timelog parser then the ledger parser; this means -- parse errors for ledgers are useful while those for timelogs are not. @@ -295,7 +295,7 @@   return $ HistoricalPrice date symbol price  -- like ledgerAccountBegin, updates the LedgerFileCtx-ledgerDefaultYear :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))+ledgerDefaultYear :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal)) ledgerDefaultYear = do   char 'Y' <?> "default year"   many spacenonewline@@ -307,18 +307,18 @@  -- | Try to parse a ledger entry. If we successfully parse an entry, ensure it is balanced, -- and if we cannot, raise an error.-ledgerTransaction :: GenParser Char LedgerFileCtx LedgerTransaction+ledgerTransaction :: GenParser Char LedgerFileCtx Transaction ledgerTransaction = do   date <- ledgerdate <?> "transaction"-  edate <- try (ledgereffectivedate <?> "effective date") <|> return Nothing+  edate <- try (ledgereffectivedate date <?> "effective date") <|> return Nothing   status <- ledgerstatus   code <- ledgercode   description <- many1 spacenonewline >> liftM rstrip (many1 (noneOf ";\n") <?> "description")   comment <- ledgercomment <|> return ""   restofline   postings <- ledgerpostings-  let t = LedgerTransaction date edate status code description comment postings ""-  case balanceLedgerTransaction t of+  let t = txnTieKnot $ Transaction date edate status code description comment postings ""+  case balanceTransaction t of     Right t' -> return t'     Left err -> fail err @@ -352,10 +352,17 @@   let tod = TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s)   return $ LocalTime day tod -ledgereffectivedate :: GenParser Char LedgerFileCtx (Maybe Day)-ledgereffectivedate = do+ledgereffectivedate :: Day -> GenParser Char LedgerFileCtx (Maybe Day)+ledgereffectivedate actualdate = do   char '='-  edate <- ledgerdate+  -- kludgily use actual date for default year+  let withDefaultYear d p = do+        y <- getYear+        let (y',_,_) = toGregorian d in setYear y'+        r <- p+        when (isJust y) $ setYear $ fromJust y+        return r+  edate <- withDefaultYear actualdate ledgerdate   return $ Just edate  ledgerstatus :: GenParser Char st Bool@@ -392,7 +399,7 @@   many spacenonewline   comment <- ledgercomment <|> return ""   restofline-  return (Posting status account' amount comment ptype)+  return (Posting status account' amount comment ptype Nothing)  -- Qualify with the parent account from parsing context transactionaccountname :: GenParser Char LedgerFileCtx AccountName@@ -557,8 +564,8 @@ -- misc parsing  -- | Parse a --display expression which is a simple date predicate, like--- "d>[DATE]" or "d<=[DATE]", and return a transaction-matching predicate.-datedisplayexpr :: GenParser Char st (Transaction -> Bool)+-- "d>[DATE]" or "d<=[DATE]", and return a posting-matching predicate.+datedisplayexpr :: GenParser Char st (Posting -> Bool) datedisplayexpr = do   char 'd'   op <- compareop@@ -566,7 +573,7 @@   (y,m,d) <- smartdate   char ']'   let date    = parsedate $ printf "%04s/%02s/%02s" y m d-      test op = return $ (`op` date) . tdate+      test op = return $ (`op` date) . postingDate   case op of     "<"  -> test (<)     "<=" -> test (<=)

@@ -1,11 +1,9 @@ {-|  A 'Posting' represents a 'MixedAmount' being added to or subtracted from a-single 'Account'.  Each 'LedgerTransaction' contains two or more postings-which should add up to 0.  --Generally, we use these with the ledger transaction's date and description-added, which we call a 'Transaction'.+single 'Account'.  Each 'Transaction' contains two or more postings which+should add up to 0. Postings also reference their parent transaction, so+we can get a date or description for a posting (from the transaction).  -} @@ -15,33 +13,34 @@ import Ledger.Types import Ledger.Amount import Ledger.AccountName+import Ledger.Dates (nulldate)   instance Show Posting where show = showPosting -nullrawposting = Posting False "" nullmixedamt "" RegularPosting+nullposting = Posting False "" nullmixedamt "" RegularPosting Nothing  showPosting :: Posting -> String-showPosting (Posting _ a amt com ttype) = +showPosting (Posting{paccount=a,pamount=amt,pcomment=com,ptype=t}) =     concatTopPadded [showaccountname a ++ " ", showamount amt, comment]     where       ledger3ishlayout = False       acctnamewidth = if ledger3ishlayout then 25 else 22       showaccountname = printf ("%-"++(show acctnamewidth)++"s") . bracket . elideAccountName width-      (bracket,width) = case ttype of+      (bracket,width) = case t of                           BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2)                           VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2)                           _ -> (id,acctnamewidth)       showamount = padleft 12 . showMixedAmountOrZero       comment = if null com then "" else "  ; " ++ com -- XXX refactor-showPostingWithoutPrice (Posting _ a amt com ttype) =+showPostingWithoutPrice (Posting{paccount=a,pamount=amt,pcomment=com,ptype=t}) =     concatTopPadded [showaccountname a ++ " ", showamount amt, comment]     where       ledger3ishlayout = False       acctnamewidth = if ledger3ishlayout then 25 else 22       showaccountname = printf ("%-"++(show acctnamewidth)++"s") . bracket . elideAccountName width-      (bracket,width) = case ttype of+      (bracket,width) = case t of                           BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2)                           VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2)                           _ -> (id,acctnamewidth)@@ -64,4 +63,33 @@     | head a == '[' && last a == ']' = BalancedVirtualPosting     | head a == '(' && last a == ')' = VirtualPosting     | otherwise = RegularPosting++accountNamesFromPostings :: [Posting] -> [AccountName]+accountNamesFromPostings = nub . map paccount++sumPostings :: [Posting] -> MixedAmount+sumPostings = sum . map pamount++postingDate :: Posting -> Day+postingDate p = maybe nulldate tdate $ ptransaction p++postingCleared :: Posting -> Bool+postingCleared p = maybe False tstatus $ ptransaction p++-- | Does this posting fall within the given date span ?+isPostingInDateSpan :: DateSpan -> Posting -> Bool+isPostingInDateSpan (DateSpan Nothing Nothing)   _ = True+isPostingInDateSpan (DateSpan Nothing (Just e))  p = postingDate p < e+isPostingInDateSpan (DateSpan (Just b) Nothing)  p = postingDate p >= b+isPostingInDateSpan (DateSpan (Just b) (Just e)) p = d >= b && d < e where d = postingDate p++isEmptyPosting :: Posting -> Bool+isEmptyPosting = isZeroMixedAmount . pamount++-- | Get the minimal date span which contains all the postings, or+-- DateSpan Nothing Nothing if there are none.+postingsDateSpan :: [Posting] -> DateSpan+postingsDateSpan [] = DateSpan Nothing Nothing+postingsDateSpan ps = DateSpan (Just $ postingDate $ head ps') (Just $ addDays 1 $ postingDate $ last ps')+    where ps' = sortBy (comparing postingDate) ps 

@@ -1,215 +0,0 @@-{-|--A 'RawLedger' is a parsed ledger file. We call it raw to distinguish from-the cached 'Ledger'.---}--module Ledger.RawLedger-where-import qualified Data.Map as Map-import Data.Map (findWithDefault, (!))-import System.Time (ClockTime(TOD))-import Ledger.Utils-import Ledger.Types-import Ledger.AccountName-import Ledger.Amount-import Ledger.LedgerTransaction (ledgerTransactionWithDate)-import Ledger.Transaction-import Ledger.Posting-import Ledger.TimeLog---instance Show RawLedger where-    show l = printf "RawLedger with %d transactions, %d accounts: %s"-             (length (ledger_txns l) +-              length (modifier_txns l) +-              length (periodic_txns l))-             (length accounts)-             (show accounts)-             -- ++ (show $ rawLedgerTransactions l)-             where accounts = flatten $ rawLedgerAccountNameTree l--rawLedgerEmpty :: RawLedger-rawLedgerEmpty = RawLedger { modifier_txns = []-                           , periodic_txns = []-                           , ledger_txns = []-                           , open_timelog_entries = []-                           , historical_prices = []-                           , final_comment_lines = []-                           , filepath = ""-                           , filereadtime = TOD 0 0-                           }--addLedgerTransaction :: LedgerTransaction -> RawLedger -> RawLedger-addLedgerTransaction t l0 = l0 { ledger_txns = t : ledger_txns l0 }--addModifierTransaction :: ModifierTransaction -> RawLedger -> RawLedger-addModifierTransaction mt l0 = l0 { modifier_txns = mt : modifier_txns l0 }--addPeriodicTransaction :: PeriodicTransaction -> RawLedger -> RawLedger-addPeriodicTransaction pt l0 = l0 { periodic_txns = pt : periodic_txns l0 }--addHistoricalPrice :: HistoricalPrice -> RawLedger -> RawLedger-addHistoricalPrice h l0 = l0 { historical_prices = h : historical_prices l0 }--addTimeLogEntry :: TimeLogEntry -> RawLedger -> RawLedger-addTimeLogEntry tle l0 = l0 { open_timelog_entries = tle : open_timelog_entries l0 }--rawLedgerTransactions :: RawLedger -> [Transaction]-rawLedgerTransactions = txnsof . ledger_txns-    where txnsof ts = concatMap flattenLedgerTransaction $ zip ts [1..]--rawLedgerAccountNamesUsed :: RawLedger -> [AccountName]-rawLedgerAccountNamesUsed = accountNamesFromTransactions . rawLedgerTransactions--rawLedgerAccountNames :: RawLedger -> [AccountName]-rawLedgerAccountNames = sort . expandAccountNames . rawLedgerAccountNamesUsed--rawLedgerAccountNameTree :: RawLedger -> Tree AccountName-rawLedgerAccountNameTree = accountNameTreeFrom . rawLedgerAccountNames---- | Remove ledger transactions we are not interested in.--- Keep only those which fall between the begin and end dates, and match--- the description pattern, and are cleared or real if those options are active.-filterRawLedger :: DateSpan -> [String] -> Maybe Bool -> Bool -> RawLedger -> RawLedger-filterRawLedger span pats clearedonly realonly =-    filterRawLedgerPostingsByRealness realonly .-    filterRawLedgerTransactionsByClearedStatus clearedonly .-    filterRawLedgerTransactionsByDate span .-    filterRawLedgerTransactionsByDescription pats---- | Keep only ledger transactions whose description matches the description patterns.-filterRawLedgerTransactionsByDescription :: [String] -> RawLedger -> RawLedger-filterRawLedgerTransactionsByDescription pats (RawLedger ms ps ts tls hs f fp ft) =-    RawLedger ms ps (filter matchdesc ts) tls hs f fp ft-    where matchdesc = matchpats pats . ltdescription---- | Keep only ledger transactions which fall between begin and end dates.--- We include transactions on the begin date and exclude transactions on the end--- date, like ledger.  An empty date string means no restriction.-filterRawLedgerTransactionsByDate :: DateSpan -> RawLedger -> RawLedger-filterRawLedgerTransactionsByDate (DateSpan begin end) (RawLedger ms ps ts tls hs f fp ft) =-    RawLedger ms ps (filter matchdate ts) tls hs f fp ft-    where-      matchdate t = maybe True (ltdate t>=) begin && maybe True (ltdate t<) end---- | Keep only ledger transactions which have the requested--- cleared/uncleared status, if there is one.-filterRawLedgerTransactionsByClearedStatus :: Maybe Bool -> RawLedger -> RawLedger-filterRawLedgerTransactionsByClearedStatus Nothing rl = rl-filterRawLedgerTransactionsByClearedStatus (Just val) (RawLedger ms ps ts tls hs f fp ft) =-    RawLedger ms ps (filter ((==val).ltstatus) ts) tls hs f fp ft---- | Strip out any virtual postings, if the flag is true, otherwise do--- no filtering.-filterRawLedgerPostingsByRealness :: Bool -> RawLedger -> RawLedger-filterRawLedgerPostingsByRealness False l = l-filterRawLedgerPostingsByRealness True (RawLedger mts pts ts tls hs f fp ft) =-    RawLedger mts pts (map filtertxns ts) tls hs f fp ft-    where filtertxns t@LedgerTransaction{ltpostings=ps} = t{ltpostings=filter isReal ps}---- | Strip out any postings to accounts deeper than the specified depth--- (and any ledger transactions which have no postings as a result).-filterRawLedgerPostingsByDepth :: Int -> RawLedger -> RawLedger-filterRawLedgerPostingsByDepth depth (RawLedger mts pts ts tls hs f fp ft) =-    RawLedger mts pts (filter (not . null . ltpostings) $ map filtertxns ts) tls hs f fp ft-    where filtertxns t@LedgerTransaction{ltpostings=ps} =-              t{ltpostings=filter ((<= depth) . accountNameLevel . paccount) ps}---- | Keep only ledger transactions which affect accounts matched by the account patterns.-filterRawLedgerTransactionsByAccount :: [String] -> RawLedger -> RawLedger-filterRawLedgerTransactionsByAccount apats (RawLedger ms ps ts tls hs f fp ft) =-    RawLedger ms ps (filter (any (matchpats apats . paccount) . ltpostings) ts) tls hs f fp ft---- | Convert this ledger's transactions' primary date to either their--- actual or effective date.-rawLedgerSelectingDate :: WhichDate -> RawLedger -> RawLedger-rawLedgerSelectingDate ActualDate rl = rl-rawLedgerSelectingDate EffectiveDate rl =-    rl{ledger_txns=map (ledgerTransactionWithDate EffectiveDate) $ ledger_txns rl}---- | Give all a ledger's amounts their canonical display settings.  That--- is, in each commodity, amounts will use the display settings of the--- first amount detected, and the greatest precision of the amounts--- detected.--- Also, missing unit prices are added if known from the price history.--- Also, amounts are converted to cost basis if that flag is active.--- XXX refactor-canonicaliseAmounts :: Bool -> RawLedger -> RawLedger-canonicaliseAmounts costbasis rl@(RawLedger ms ps ts tls hs f fp ft) = RawLedger ms ps (map fixledgertransaction ts) tls hs f fp ft-    where-      fixledgertransaction (LedgerTransaction d ed s c de co ts pr) = LedgerTransaction d ed s c de co (map fixrawposting ts) pr-          where-            fixrawposting (Posting s ac a c t) = Posting s ac (fixmixedamount a) c t-            fixmixedamount (Mixed as) = Mixed $ map fixamount as-            fixamount = (if costbasis then costOfAmount else id) . fixprice . fixcommodity-            fixcommodity a = a{commodity=c} where c = canonicalcommoditymap ! symbol (commodity a)-            canonicalcommoditymap =-                Map.fromList [(s,firstc{precision=maxp}) | s <- commoditysymbols,-                        let cs = commoditymap ! s,-                        let firstc = head cs,-                        let maxp = maximum $ map precision cs-                       ]-            commoditymap = Map.fromList [(s,commoditieswithsymbol s) | s <- commoditysymbols]-            commoditieswithsymbol s = filter ((s==) . symbol) commodities-            commoditysymbols = nub $ map symbol commodities-            commodities = map commodity (concatMap (amounts . tamount) (rawLedgerTransactions rl)-                                         ++ concatMap (amounts . hamount) (historical_prices rl))-            fixprice :: Amount -> Amount-            fixprice a@Amount{price=Just _} = a-            fixprice a@Amount{commodity=c} = a{price=rawLedgerHistoricalPriceFor rl d c}--            -- | Get the price for a commodity on the specified day from the price database, if known.-            -- Does only one lookup step, ie will not look up the price of a price.-            rawLedgerHistoricalPriceFor :: RawLedger -> Day -> Commodity -> Maybe MixedAmount-            rawLedgerHistoricalPriceFor rl d Commodity{symbol=s} = do-              let ps = reverse $ filter ((<= d).hdate) $ filter ((s==).hsymbol) $ sortBy (comparing hdate) $ historical_prices rl-              case ps of (HistoricalPrice{hamount=a}:_) -> Just $ canonicaliseCommodities a-                         _ -> Nothing-                  where-                    canonicaliseCommodities (Mixed as) = Mixed $ map canonicaliseCommodity as-                        where canonicaliseCommodity a@Amount{commodity=Commodity{symbol=s}} =-                                  a{commodity=findWithDefault (error "programmer error: canonicaliseCommodity failed") s canonicalcommoditymap}---- | Get just the amounts from a ledger, in the order parsed.-rawLedgerAmounts :: RawLedger -> [MixedAmount]-rawLedgerAmounts = map tamount . rawLedgerTransactions---- | Get just the ammount commodities from a ledger, in the order parsed.-rawLedgerCommodities :: RawLedger -> [Commodity]-rawLedgerCommodities = map commodity . concatMap amounts . rawLedgerAmounts---- | Get just the amount precisions from a ledger, in the order parsed.-rawLedgerPrecisions :: RawLedger -> [Int]-rawLedgerPrecisions = map precision . rawLedgerCommodities---- | Close any open timelog sessions using the provided current time.-rawLedgerConvertTimeLog :: LocalTime -> RawLedger -> RawLedger-rawLedgerConvertTimeLog t l0 = l0 { ledger_txns = convertedTimeLog ++ ledger_txns l0-                                  , open_timelog_entries = []-                                  }-    where convertedTimeLog = entriesFromTimeLogEntries t $ open_timelog_entries l0---- | The (fully specified) date span containing all the raw ledger's transactions,--- or DateSpan Nothing Nothing if there are none.-rawLedgerDateSpan :: RawLedger -> DateSpan-rawLedgerDateSpan rl-    | null ts = DateSpan Nothing Nothing-    | otherwise = DateSpan (Just $ ltdate $ head ts) (Just $ addDays 1 $ ltdate $ last ts)-    where-      ts = sortBy (comparing ltdate) $ ledger_txns rl---- | Check if a set of ledger account/description patterns matches the--- given account name or entry description.  Patterns are case-insensitive--- regular expression strings; those beginning with - are anti-patterns.-matchpats :: [String] -> String -> Bool-matchpats pats str =-    (null positives || any match positives) && (null negatives || not (any match negatives))-    where-      (negatives,positives) = partition isnegativepat pats-      match "" = True-      match pat = containsRegex (abspat pat) str-      negateprefix = "not:"-      isnegativepat = (negateprefix `isPrefixOf`)-      abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat

@@ -2,7 +2,7 @@  A 'TimeLogEntry' is a clock-in, clock-out, or other directive in a timelog file (see timeclock.el or the command-line version). These can be-converted to 'LedgerTransactions' and queried like a ledger.+converted to 'Transactions' and queried like a ledger.  -} @@ -12,7 +12,7 @@ import Ledger.Types import Ledger.Dates import Ledger.Commodity-import Ledger.LedgerTransaction+import Ledger.Transaction  instance Show TimeLogEntry where      show t = printf "%s %s %s" (show $ tlcode t) (show $ tldatetime t) (tlcomment t)@@ -35,7 +35,7 @@ -- | Convert time log entries to ledger transactions. When there is no -- clockout, add one with the provided current time. Sessions crossing -- midnight are split into days to give accurate per-day totals.-entriesFromTimeLogEntries :: LocalTime -> [TimeLogEntry] -> [LedgerTransaction]+entriesFromTimeLogEntries :: LocalTime -> [TimeLogEntry] -> [Transaction] entriesFromTimeLogEntries _ [] = [] entriesFromTimeLogEntries now [i]     | odate > idate = entryFromTimeLogInOut i o' : entriesFromTimeLogEntries now [i',o]@@ -59,21 +59,21 @@ -- | Convert a timelog clockin and clockout entry to an equivalent ledger -- entry, representing the time expenditure. Note this entry is  not balanced, -- since we omit the \"assets:time\" transaction for simpler output.-entryFromTimeLogInOut :: TimeLogEntry -> TimeLogEntry -> LedgerTransaction+entryFromTimeLogInOut :: TimeLogEntry -> TimeLogEntry -> Transaction entryFromTimeLogInOut i o     | otime >= itime = t     | otherwise = -        error $ "clock-out time less than clock-in time in:\n" ++ showLedgerTransaction t+        error $ "clock-out time less than clock-in time in:\n" ++ showTransaction t     where-      t = LedgerTransaction {-            ltdate         = idate,-            lteffectivedate = Nothing,-            ltstatus       = True,-            ltcode         = "",-            ltdescription  = showtime itod ++ "-" ++ showtime otod,-            ltcomment      = "",-            ltpostings = ps,-            ltpreceding_comment_lines=""+      t = Transaction {+            tdate         = idate,+            teffectivedate = Nothing,+            tstatus       = True,+            tcode         = "",+            tdescription  = showtime itod ++ "-" ++ showtime otod,+            tcomment      = "",+            tpostings = ps,+            tpreceding_comment_lines=""           }       showtime = take 5 . show       acctname = tlcomment i@@ -84,6 +84,7 @@       idate    = localDay itime       hrs      = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc       amount   = Mixed [hours hrs]-      ps       = [Posting False acctname amount "" RegularPosting+      ps       = [Posting{pstatus=False,paccount=acctname,pamount=amount,+                          pcomment="",ptype=RegularPosting,ptransaction=Just t}                  --,Posting "assets:time" (-amount) "" RegularPosting                  ]

@@ -1,50 +1,142 @@ {-| -A compound data type for efficiency. A 'Transaction' is a 'Posting' with-its parent 'LedgerTransaction' \'s date and description attached. The-\"transaction\" term is pretty ingrained in the code, docs and with users,-so we've kept it. These are what we work with most of the time when doing-reports.+A 'Transaction' represents a single balanced entry in the ledger file. It+normally contains two or more balanced 'Posting's.  -}  module Ledger.Transaction where-import Ledger.Dates import Ledger.Utils import Ledger.Types-import Ledger.LedgerTransaction (showAccountName)+import Ledger.Dates+import Ledger.Posting import Ledger.Amount  -instance Show Transaction where show=showTransaction+instance Show Transaction where show = showTransactionUnelided +instance Show ModifierTransaction where +    show t = "= " ++ mtvalueexpr t ++ "\n" ++ unlines (map show (mtpostings t))++instance Show PeriodicTransaction where +    show t = "~ " ++ ptperiodicexpr t ++ "\n" ++ unlines (map show (ptpostings t))++nulltransaction :: Transaction+nulltransaction = Transaction {+                    tdate=nulldate,+                    teffectivedate=Nothing, +                    tstatus=False, +                    tcode="", +                    tdescription="", +                    tcomment="",+                    tpostings=[],+                    tpreceding_comment_lines=""+                  }++{-|+Show a ledger entry, formatted for the print command. ledger 2.x's+standard format looks like this:++@+yyyy/mm/dd[ *][ CODE] description.........          [  ; comment...............]+    account name 1.....................  ...$amount1[  ; comment...............]+    account name 2.....................  ..$-amount1[  ; comment...............]++pcodewidth    = no limit -- 10          -- mimicking ledger layout.+pdescwidth    = no limit -- 20          -- I don't remember what these mean,+pacctwidth    = 35 minimum, no maximum  -- they were important at the time.+pamtwidth     = 11+pcommentwidth = no limit -- 22+@+-} showTransaction :: Transaction -> String-showTransaction (Transaction _ stat d desc a amt ttype) = -    s ++ unwords [showDate d,desc,a',show amt,show ttype]-    where s = if stat then " *" else ""-          a' = showAccountName Nothing ttype a+showTransaction = showTransaction' True False --- | Convert a 'LedgerTransaction' to two or more 'Transaction's. An id number--- is attached to the transactions to preserve their grouping - it should--- be unique per entry.-flattenLedgerTransaction :: (LedgerTransaction, Int) -> [Transaction]-flattenLedgerTransaction (LedgerTransaction d _ s _ desc _ ps _, n) = -    [Transaction n s d desc (paccount p) (pamount p) (ptype p) | p <- ps]+showTransactionUnelided :: Transaction -> String+showTransactionUnelided = showTransaction' False False -accountNamesFromTransactions :: [Transaction] -> [AccountName]-accountNamesFromTransactions = nub . map taccount+showTransactionForPrint :: Bool -> Transaction -> String+showTransactionForPrint effective = showTransaction' False effective -sumTransactions :: [Transaction] -> MixedAmount-sumTransactions = sum . map tamount+showTransaction' :: Bool -> Bool -> Transaction -> String+showTransaction' elide effective t =+    unlines $ [description] ++ showpostings (tpostings t) ++ [""]+    where+      description = concat [date, status, code, desc, comment]+      date | effective = showdate $ fromMaybe (tdate t) $ teffectivedate t+           | otherwise = showdate (tdate t) ++ maybe "" showedate (teffectivedate t)+      status = if tstatus t then " *" else ""+      code = if length (tcode t) > 0 then printf " (%s)" $ tcode t else ""+      desc = ' ' : tdescription t+      comment = if null com then "" else "  ; " ++ com where com = tcomment t+      showdate = printf "%-10s" . showDate+      showedate = printf "=%s" . showdate+      showpostings ps+          | elide && length ps > 1 && isTransactionBalanced t+              = map showposting (init ps) ++ [showpostingnoamt (last ps)]+          | otherwise = map showposting ps+          where+            showposting p = showacct p ++ "  " ++ showamount (pamount p) ++ showcomment (pcomment p)+            showpostingnoamt p = rstrip $ showacct p ++ "              " ++ showcomment (pcomment p)+            showacct p = "    " ++ showstatus p ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p))+            w = maximum $ map (length . paccount) ps+            showamount = printf "%12s" . showMixedAmount+            showcomment s = if null s then "" else "  ; "++s+            showstatus p = if pstatus p then "* " else "" -nulltxn :: Transaction-nulltxn = Transaction 0 False (parsedate "1900/1/1") "" "" nullmixedamt RegularPosting+-- | Show an account name, clipped to the given width if any, and+-- appropriately bracketed/parenthesised for the given posting type.+showAccountName :: Maybe Int -> PostingType -> AccountName -> String+showAccountName w = fmt+    where+      fmt RegularPosting = take w'+      fmt VirtualPosting = parenthesise . reverse . take (w'-2) . reverse+      fmt BalancedVirtualPosting = bracket . reverse . take (w'-2) . reverse+      w' = fromMaybe 999999 w+      parenthesise s = "("++s++")"+      bracket s = "["++s++"]" --- | Does the given transaction fall within the given date span ?-isTransactionInDateSpan :: DateSpan -> Transaction -> Bool-isTransactionInDateSpan (DateSpan Nothing Nothing)   _ = True-isTransactionInDateSpan (DateSpan Nothing (Just e))  (Transaction{tdate=d}) = d<e-isTransactionInDateSpan (DateSpan (Just b) Nothing)  (Transaction{tdate=d}) = d>=b-isTransactionInDateSpan (DateSpan (Just b) (Just e)) (Transaction{tdate=d}) = d>=b && d<e+isTransactionBalanced :: Transaction -> Bool+isTransactionBalanced (Transaction {tpostings=ps}) = +    all (isReallyZeroMixedAmount . costOfMixedAmount . sum . map pamount)+            [filter isReal ps, filter isBalancedVirtual ps]++-- | Ensure that this entry is balanced, possibly auto-filling a missing+-- amount first. We can auto-fill if there is just one non-virtual+-- transaction without an amount. The auto-filled balance will be+-- converted to cost basis if possible. If the entry can not be balanced,+-- return an error message instead.+balanceTransaction :: Transaction -> Either String Transaction+balanceTransaction t@Transaction{tpostings=ps}+    | length missingamounts' > 1 = Left $ printerr "could not balance this transaction, too many missing amounts"+    | not $ isTransactionBalanced t' = Left $ printerr nonzerobalanceerror+    | otherwise = Right t'+    where+      (withamounts, missingamounts) = partition hasAmount $ filter isReal ps+      (_, missingamounts') = partition hasAmount ps+      t' = t{tpostings=ps'}+      ps' | length missingamounts == 1 = map balance ps+          | otherwise = ps+          where +            balance p | isReal p && not (hasAmount p) = p{pamount = costOfMixedAmount (-otherstotal)}+                      | otherwise = p+                      where otherstotal = sum $ map pamount withamounts+      printerr s = printf "%s:\n%s" s (showTransactionUnelided t)++nonzerobalanceerror = "could not balance this transaction, amounts do not add up to zero"++-- | Convert the primary date to either the actual or effective date.+ledgerTransactionWithDate :: WhichDate -> Transaction -> Transaction+ledgerTransactionWithDate ActualDate t = t+ledgerTransactionWithDate EffectiveDate t = txnTieKnot t{tdate=fromMaybe (tdate t) (teffectivedate t)}+    ++-- | Ensure a transaction's postings refer back to it.+txnTieKnot :: Transaction -> Transaction+txnTieKnot t@Transaction{tpostings=ps} = t{tpostings=map (settxn t) ps}++-- | Set a posting's parent transaction.+settxn :: Transaction -> Posting -> Posting+settxn t p = p{ptransaction=Just t} 

@@ -1,26 +1,30 @@ {-# LANGUAGE DeriveDataTypeable #-} {-| -Most data types are defined here to avoid import cycles. See the-corresponding modules for each type's documentation.+Most data types are defined here to avoid import cycles.+Here is an overview of the hledger data model: -A note about entry\/transaction\/posting terminology:+> Ledger              -- hledger's ledger is a journal file plus cached/derived data+>  Journal            -- a representation of the journal file, containing..+>   [Transaction]     -- ..journal transactions, which have date, status, code, description and..+>    [Posting]        -- ..two or more account postings (account name and amount)+>  Tree AccountName   -- all account names as a tree+>  Map AccountName Account -- a map from account name to account info (postings and balances) -  - ledger 2 had Entrys containing Transactions.-  -  - hledger 0.4 had Entrys containing RawTransactions, plus Transactions-    which were a RawTransaction with its parent Entry's info added.-    The latter are what we most work with when reporting and are-    ubiquitous in the code and docs.-  -  - ledger 3 has Transactions containing Postings.-  +For more detailed documentation on each type, see the corresponding modules. -  - hledger 0.5 has LedgerTransactions containing Postings, plus-    Transactions as before (a Posting plus it's parent's info).  The-    \"transaction\" term is pretty ingrained in the code, docs and with-    users, so we've kept it. +Terminology has been in flux: +  - ledger 2 had entries containing transactions.++  - hledger 0.4 had Entrys containing RawTransactions, which were flattened to Transactions.++  - ledger 3 has transactions containing postings.++  - hledger 0.5 had LedgerTransactions containing Postings, which were flattened to Transactions.++  - hledger 0.8 has Transactions containing Postings, and no flattened type.+ -}  module Ledger.Types @@ -33,7 +37,7 @@  type SmartDate = (String,String,String) -data WhichDate = ActualDate | EffectiveDate+data WhichDate = ActualDate | EffectiveDate deriving (Eq,Show)  data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Show,Ord) @@ -69,9 +73,22 @@       paccount :: AccountName,       pamount :: MixedAmount,       pcomment :: String,-      ptype :: PostingType+      ptype :: PostingType,+      ptransaction :: Maybe Transaction  -- ^ this posting's parent transaction (co-recursive types).+                                        -- Tying this knot gets tedious, Maybe makes it easier/optional.     } deriving (Eq) +data Transaction = Transaction {+      tdate :: Day,+      teffectivedate :: Maybe Day,+      tstatus :: Bool,  -- XXX tcleared ?+      tcode :: String,+      tdescription :: String,+      tcomment :: String,+      tpostings :: [Posting],+      tpreceding_comment_lines :: String+    } deriving (Eq)+ data ModifierTransaction = ModifierTransaction {       mtvalueexpr :: String,       mtpostings :: [Posting]@@ -82,17 +99,6 @@       ptpostings :: [Posting]     } deriving (Eq) -data LedgerTransaction = LedgerTransaction {-      ltdate :: Day,-      lteffectivedate :: Maybe Day,-      ltstatus :: Bool,-      ltcode :: String,-      ltdescription :: String,-      ltcomment :: String,-      ltpostings :: [Posting],-      ltpreceding_comment_lines :: String-    } deriving (Eq)- data TimeLogCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord)   data TimeLogEntry = TimeLogEntry {@@ -107,48 +113,41 @@       hamount :: MixedAmount     } deriving (Eq) -- & Show (in Amount.hs) -data RawLedger = RawLedger {-      modifier_txns :: [ModifierTransaction],-      periodic_txns :: [PeriodicTransaction],-      ledger_txns :: [LedgerTransaction],+data Journal = Journal {+      jmodifiertxns :: [ModifierTransaction],+      jperiodictxns :: [PeriodicTransaction],+      jtxns :: [Transaction],       open_timelog_entries :: [TimeLogEntry],       historical_prices :: [HistoricalPrice],       final_comment_lines :: String,       filepath :: FilePath,-      filereadtime :: ClockTime-    } deriving (Eq)---- | A generic, pure specification of how to filter raw ledger transactions.-data FilterSpec = FilterSpec {-     datespan  :: DateSpan   -- ^ only include transactions in this date span-    ,cleared   :: Maybe Bool -- ^ only include if cleared\/uncleared\/don't care-    ,real      :: Bool       -- ^ only include if real\/don't care-    ,costbasis :: Bool       -- ^ convert all amounts to cost basis-    ,acctpats  :: [String]   -- ^ only include if matching these account patterns-    ,descpats  :: [String]   -- ^ only include if matching these description patterns-    ,whichdate :: WhichDate  -- ^ which dates to use (transaction or effective)-    }--data Transaction = Transaction {-      tnum :: Int,-      tstatus :: Bool,           -- ^ posting status-      tdate :: Day,              -- ^ transaction date-      tdescription :: String,    -- ^ ledger transaction description-      taccount :: AccountName,   -- ^ posting account-      tamount :: MixedAmount,    -- ^ posting amount-      ttype :: PostingType       -- ^ posting type+      filereadtime :: ClockTime,+      jtext :: String     } deriving (Eq)  data Account = Account {       aname :: AccountName,-      atransactions :: [Transaction], -- ^ transactions in this account-      abalance :: MixedAmount         -- ^ sum of transactions in this account and subaccounts+      apostings :: [Posting],    -- ^ transactions in this account+      abalance :: MixedAmount    -- ^ sum of transactions in this account and subaccounts     }  data Ledger = Ledger {-      rawledgertext :: String,-      rawledger :: RawLedger,+      journal :: Journal,       accountnametree :: Tree AccountName,       accountmap :: Map.Map AccountName Account     } deriving Typeable++-- | A generic, pure specification of how to filter transactions/postings.+-- This exists to keep app-specific options out of the hledger library.+data FilterSpec = FilterSpec {+     datespan  :: DateSpan   -- ^ only include if in this date span+    ,cleared   :: Maybe Bool -- ^ only include if cleared\/uncleared\/don't care+    ,real      :: Bool       -- ^ only include if real\/don't care+    ,empty     :: Bool       -- ^ include if empty (ie amount is zero)+    ,costbasis :: Bool       -- ^ convert all amounts to cost basis+    ,acctpats  :: [String]   -- ^ only include if matching these account patterns+    ,descpats  :: [String]   -- ^ only include if matching these description patterns+    ,whichdate :: WhichDate  -- ^ which dates to use (actual or effective)+    ,depth     :: Maybe Int+    } deriving (Show) 

@@ -16,6 +16,11 @@  progname      = "hledger" timeprogname  = "hours"+#ifdef CHART+chartoutput   = "hledger.png"+chartitems    = 10+chartsize     = "600x400"+#endif  usagehdr =   "Usage: hledger [OPTIONS] [COMMAND [PATTERNS]]\n" ++@@ -39,6 +44,9 @@ #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" ++   "PATTERNS are regular expressions which filter by account name.\n" ++@@ -56,6 +64,7 @@ options :: [OptDescr Opt] options = [   Option "f" ["file"]         (ReqArg File "FILE")   "use a different ledger/timelog file; - means stdin"+ ,Option ""  ["no-new-accounts"] (NoArg NoNewAccts)   "don't allow to create new accounts"  ,Option "b" ["begin"]        (ReqArg Begin "DATE")  "report on transactions on or after this date"  ,Option "e" ["end"]          (ReqArg End "DATE")    "report on transactions before this date"  ,Option "p" ["period"]       (ReqArg Period "EXPR") ("report on transactions during the specified period\n" ++@@ -81,11 +90,17 @@  ,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: "++chartoutput++")")+ ,Option ""  ["items"]  (ReqArg ChartItems "N")         ("chart: number of accounts to show (default: "++show chartitems++")")+ ,Option ""  ["size"] (ReqArg ChartSize "WIDTHxHEIGHT") ("chart: image size (default: "++chartsize++")")+#endif  ]  -- | An option value from a command-line flag. data Opt =      File    {value::String} | +    NoNewAccts |     Begin   {value::String} |      End     {value::String} |      Period  {value::String} | @@ -109,6 +124,11 @@     | BinaryFilename     | Debug     | DebugNoUI+#ifdef CHART+    | ChartOutput {value::String}+    | ChartItems  {value::String}+    | ChartSize   {value::String}+#endif     deriving (Show,Eq)  -- these make me nervous@@ -186,15 +206,15 @@       intervalopts = reverse $ filter (`elem` [WeeklyOpt,MonthlyOpt,QuarterlyOpt,YearlyOpt]) opts  -- | Get the value of the (last) depth option, if any, otherwise a large number.-depthFromOpts :: [Opt] -> Int-depthFromOpts opts = fromMaybe 9999 $ listtomaybeint $ optValuesForConstructor Depth opts+depthFromOpts :: [Opt] -> Maybe Int+depthFromOpts opts = listtomaybeint $ optValuesForConstructor Depth opts     where       listtomaybeint [] = Nothing       listtomaybeint vs = Just $ read $ last vs  -- | Get the value of the (last) display option, if any.-displayFromOpts :: [Opt] -> Maybe String-displayFromOpts opts = listtomaybe $ optValuesForConstructor Display opts+displayExprFromOpts :: [Opt] -> Maybe String+displayExprFromOpts opts = listtomaybe $ optValuesForConstructor Display opts     where       listtomaybe [] = Nothing       listtomaybe vs = Just $ last vs@@ -236,10 +256,17 @@                                 datespan=dateSpanFromOpts (localDay t) opts                                ,cleared=clearedValueFromOpts opts                                ,real=Real `elem` opts+                               ,empty=Empty `elem` opts                                ,costbasis=CostBasis `elem` opts                                ,acctpats=apats                                ,descpats=dpats                                ,whichdate = if Effective `elem` opts then EffectiveDate else ActualDate+                               ,depth = depthFromOpts opts                                }     where (apats,dpats) = parsePatternArgs args++-- currentLocalTimeFromOpts opts = listtomaybe $ optValuesForConstructor CurrentLocalTime opts+--     where+--       listtomaybe [] = Nothing+--       listtomaybe vs = Just $ last vs 

@@ -16,16 +16,17 @@  Here is a **demo_** of the web interface. +Here are ready-to-run **binaries_** for mac, windows and gnu/linux.+ Here is the **manual_**. For support and more technical info, see **`hledger for techies`_** or **`email me`_**. -Download and try **`hledger for mac`_**, **`hledger for windows`_**, or **hledger for linux (`32 bit intel`_, `64 bit intel`_)**.- .. (If you're reading this in plain text, see also README2, MANUAL etc., or http://hledger.org)  .. _hledger for techies:  README2.html .. _manual:               MANUAL.html .. _demo:                 http://demo.hledger.org+.. _binaries:             http://hledger.org/binaries/ .. _hledger for mac:      http://hledger.org/binaries/hledger-0.6-mac-i386.gz .. _hledger for windows:  http://hledger.org/binaries/hledger-0.6-win-i386.zip .. _32 bit intel:         http://hledger.org/binaries/hledger-0.6.1+9-linux-i386.gz

@@ -85,8 +85,8 @@ tests = [     "account directive" ~: -   let sameParse str1 str2 = do l1 <- rawLedgerFromString str1-                                l2 <- rawLedgerFromString str2+   let sameParse str1 str2 = do l1 <- journalFromString str1+                                l2 <- journalFromString str2                                 l1 `is` l2    in TestList    [@@ -155,7 +155,8 @@   ,"balance report tests" ~:    let (opts,args) `gives` es = do          l <- sampleledgerwithopts opts args-        showBalanceReport opts args l `is` unlines es+        t <- getCurrentLocalTime+        showBalanceReport opts (optsToFilterSpec opts args t) l `is` unlines es    in TestList    [ @@ -275,30 +276,28 @@     ]     ,"balance report with cost basis" ~: do-      rl <- rawLedgerFromString $ unlines+      j <- journalFromString $ unlines              [""              ,"2008/1/1 test           "              ,"  a:b          10h @ $50"              ,"  c:d                   "              ,""              ]-      let l = cacheLedger [] $ -              filterRawLedger (DateSpan Nothing Nothing) [] Nothing False $ -              canonicaliseAmounts True rl -- enable cost basis adjustment            -      showBalanceReport [] [] l `is` +      let j' = canonicaliseAmounts True j -- enable cost basis adjustment+      showBalanceReport [] nullfilterspec nullledger{journal=j'} `is`        unlines         ["                $500  a:b"         ,"               $-500  c:d"         ]     ,"balance report elides zero-balance root account(s)" ~: do-      l <- ledgerFromStringWithOpts [] [] sampletime+      l <- ledgerFromStringWithOpts []              (unlines               ["2008/1/1 one"               ,"  test:a  1"               ,"  test:b"               ])-      showBalanceReport [] [] l `is`+      showBalanceReport [] nullfilterspec l `is`        unlines         ["                   1  test:a"         ,"                  -1  test:b"@@ -306,36 +305,36 @@     ] -  ,"balanceLedgerTransaction" ~: do+  ,"balanceTransaction" ~: do      assertBool "detect unbalanced entry, sign error"-                    (isLeft $ balanceLedgerTransaction-                           (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "test" ""-                            [Posting False "a" (Mixed [dollars 1]) "" RegularPosting, -                             Posting False "b" (Mixed [dollars 1]) "" RegularPosting+                    (isLeft $ balanceTransaction+                           (Transaction (parsedate "2007/01/28") Nothing False "" "test" ""+                            [Posting False "a" (Mixed [dollars 1]) "" RegularPosting Nothing, +                             Posting False "b" (Mixed [dollars 1]) "" RegularPosting Nothing                             ] ""))      assertBool "detect unbalanced entry, multiple missing amounts"-                    (isLeft $ balanceLedgerTransaction-                           (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "test" ""-                            [Posting False "a" missingamt "" RegularPosting, -                             Posting False "b" missingamt "" RegularPosting+                    (isLeft $ balanceTransaction+                           (Transaction (parsedate "2007/01/28") Nothing False "" "test" ""+                            [Posting False "a" missingamt "" RegularPosting Nothing, +                             Posting False "b" missingamt "" RegularPosting Nothing                             ] ""))-     let e = balanceLedgerTransaction (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "test" ""-                           [Posting False "a" (Mixed [dollars 1]) "" RegularPosting, -                            Posting False "b" missingamt "" RegularPosting+     let e = balanceTransaction (Transaction (parsedate "2007/01/28") Nothing False "" "test" ""+                           [Posting False "a" (Mixed [dollars 1]) "" RegularPosting Nothing, +                            Posting False "b" missingamt "" RegularPosting Nothing                            ] "")      assertBool "one missing amount should be ok" (isRight e)      assertEqual "balancing amount is added"                       (Mixed [dollars (-1)])                      (case e of-                        Right e' -> (pamount $ last $ ltpostings e')+                        Right e' -> (pamount $ last $ tpostings e')                         Left _ -> error "should not happen")    ,"cacheLedger" ~:-    length (Map.keys $ accountmap $ cacheLedger [] rawledger7) `is` 15+    length (Map.keys $ accountmap $ cacheLedger journal7) `is` 15    ,"canonicaliseAmounts" ~:    "use the greatest precision" ~:-    rawLedgerPrecisions (canonicaliseAmounts False $ rawLedgerWithAmounts ["1","2.00"]) `is` [2,2]+    journalPrecisions (canonicaliseAmounts False $ journalWithAmounts ["1","2.00"]) `is` [2,2]    ,"commodities" ~:     commodities ledger7 `is` [Commodity {symbol="$", side=L, spaced=False, comma=False, precision=2}]@@ -365,7 +364,7 @@          clockin = TimeLogEntry In          mktime d = LocalTime d . fromMaybe midnight . parseTime defaultTimeLocale "%H:%M:%S"          showtime = formatTime defaultTimeLocale "%H:%M"-         assertEntriesGiveStrings name es ss = assertEqual name ss (map ltdescription $ entriesFromTimeLogEntries now es)+         assertEntriesGiveStrings name es ss = assertEqual name ss (map tdescription $ entriesFromTimeLogEntries now es)       assertEntriesGiveStrings "started yesterday, split session at midnight"                                   [clockin (mktime yesterday "23:00:00") ""]@@ -404,51 +403,44 @@     "assets" `isAccountNamePrefixOf` "assets:bank:checking" `is` True     "my assets" `isAccountNamePrefixOf` "assets:bank" `is` False -  ,"isLedgerTransactionBalanced" ~: do-     assertBool "detect balanced"-        (isLedgerTransactionBalanced-        (LedgerTransaction (parsedate "2009/01/01") Nothing False "" "a" ""-         [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting-         ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting-         ] ""))-     assertBool "detect unbalanced"-        (not $ isLedgerTransactionBalanced-        (LedgerTransaction (parsedate "2009/01/01") Nothing False "" "a" ""-         [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting-         ,Posting False "c" (Mixed [dollars (-1.01)]) "" RegularPosting-         ] ""))-     assertBool "detect unbalanced, one posting"-        (not $ isLedgerTransactionBalanced-        (LedgerTransaction (parsedate "2009/01/01") Nothing False "" "a" ""-         [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting-         ] ""))-     assertBool "one zero posting is considered balanced for now"-        (isLedgerTransactionBalanced-        (LedgerTransaction (parsedate "2009/01/01") Nothing False "" "a" ""-         [Posting False "b" (Mixed [dollars 0]) "" RegularPosting-         ] ""))-     assertBool "virtual postings don't need to balance"-        (isLedgerTransactionBalanced-        (LedgerTransaction (parsedate "2009/01/01") Nothing False "" "a" ""-         [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting-         ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting-         ,Posting False "d" (Mixed [dollars 100]) "" VirtualPosting-         ] ""))-     assertBool "balanced virtual postings need to balance among themselves"-        (not $ isLedgerTransactionBalanced-        (LedgerTransaction (parsedate "2009/01/01") Nothing False "" "a" ""-         [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting-         ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting-         ,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting-         ] ""))-     assertBool "balanced virtual postings need to balance among themselves (2)"-        (isLedgerTransactionBalanced-        (LedgerTransaction (parsedate "2009/01/01") Nothing False "" "a" ""-         [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting-         ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting-         ,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting-         ,Posting False "e" (Mixed [dollars (-100)]) "" BalancedVirtualPosting-         ] ""))+  ,"isTransactionBalanced" ~: do+     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" ""+             [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting (Just t)+             ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting (Just t)+             ] ""+     assertBool "detect balanced" (isTransactionBalanced t)+     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" ""+             [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting (Just t)+             ,Posting False "c" (Mixed [dollars (-1.01)]) "" RegularPosting (Just t)+             ] ""+     assertBool "detect unbalanced" (not $ isTransactionBalanced t)+     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" ""+             [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting (Just t)+             ] ""+     assertBool "detect unbalanced, one posting" (not $ isTransactionBalanced t)+     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" ""+             [Posting False "b" (Mixed [dollars 0]) "" RegularPosting (Just t)+             ] ""+     assertBool "one zero posting is considered balanced for now" (isTransactionBalanced t)+     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" ""+             [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting (Just t)+             ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting (Just t)+             ,Posting False "d" (Mixed [dollars 100]) "" VirtualPosting (Just t)+             ] ""+     assertBool "virtual postings don't need to balance" (isTransactionBalanced t)+     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" ""+             [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting (Just t)+             ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting (Just t)+             ,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting (Just t)+             ] ""+     assertBool "balanced virtual postings need to balance among themselves" (not $ isTransactionBalanced t)+     let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" ""+             [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting (Just t)+             ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting (Just t)+             ,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting (Just t)+             ,Posting False "e" (Mixed [dollars (-100)]) "" BalancedVirtualPosting (Just t)+             ] ""+     assertBool "balanced virtual postings need to balance among themselves (2)" (isTransactionBalanced t)    ,"isSubAccountNameOf" ~: do     "assets" `isSubAccountNameOf` "assets" `is` False@@ -457,14 +449,14 @@     "assets:bank" `isSubAccountNameOf` "my assets" `is` False    ,"default year" ~: do-    rl <- rawLedgerFromString defaultyear_ledger_str-    ltdate (head $ ledger_txns rl) `is` fromGregorian 2009 1 1+    rl <- journalFromString defaultyear_ledger_str+    tdate (head $ jtxns rl) `is` fromGregorian 2009 1 1     return ()    ,"ledgerFile" ~: do     assertBool "ledgerFile should parse an empty file" (isRight $ parseWithCtx emptyCtx ledgerFile "")-    r <- rawLedgerFromString "" -- don't know how to get it from ledgerFile-    assertBool "ledgerFile parsing an empty file should give an empty ledger" $ null $ ledger_txns r+    r <- journalFromString "" -- don't know how to get it from ledgerFile+    assertBool "ledgerFile parsing an empty file should give an empty ledger" $ null $ jtxns r    ,"ledgerHistoricalPrice" ~:     parseWithCtx emptyCtx ledgerHistoricalPrice price1_str `parseis` price1@@ -477,7 +469,7 @@                    $ isLeft $ parseWithCtx emptyCtx ledgerTransaction "2009/1/1 a\n"     let t = parseWithCtx emptyCtx ledgerTransaction "2009/1/1 a ;comment\n b 1\n"     assertBool "ledgerTransaction should not include a comment in the description"-                   $ either (const False) ((== "a") . ltdescription) t+                   $ either (const False) ((== "a") . tdescription) t    ,"ledgeraccountname" ~: do     assertBool "ledgeraccountname parses a normal accountname" (isRight $ parsewith ledgeraccountname "a:b:c")@@ -489,8 +481,8 @@     parseWithCtx emptyCtx ledgerposting rawposting1_str `parseis` rawposting1    ,"parsedate" ~: do-    parsedate "2008/02/03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" sampledate-    parsedate "2008-02-03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" sampledate+    parsedate "2008/02/03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" date1+    parsedate "2008-02-03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" date1    ,"period expressions" ~: do     let todaysdate = parsedate "2008/11/26"@@ -508,7 +500,8 @@    do      let args = ["expenses"]     l <- sampleledgerwithopts [] args-    showLedgerTransactions [] args l `is` unlines +    t <- getCurrentLocalTime+    showTransactions (optsToFilterSpec [] args t) l `is` unlines      ["2008/06/03 * eat & shop"      ,"    expenses:food                $1"      ,"    expenses:supplies            $1"@@ -519,7 +512,8 @@   , "print report with depth arg" ~:    do      l <- sampleledger-    showLedgerTransactions [Depth "2"] [] l `is` unlines+    t <- getCurrentLocalTime+    showTransactions (optsToFilterSpec [Depth "2"] [] t) l `is` unlines       ["2008/01/01 income"       ,"    income:salary           $-1"       ,""@@ -553,7 +547,7 @@    "register report with no args" ~:    do      l <- sampleledger-    showRegisterReport [] [] l `is` unlines+    showRegisterReport [] (optsToFilterSpec [] [] t1) l `is` unlines      ["2008/01/01 income               assets:bank:checking             $1           $1"      ,"                                income:salary                   $-1            0"      ,"2008/06/01 gift                 assets:bank:checking             $1           $1"@@ -567,10 +561,11 @@      ,"                                assets:bank:checking            $-1            0"      ] -  ,"register report with cleared arg" ~:+  ,"register report with cleared option" ~:    do -    l <- ledgerFromStringWithOpts [Cleared] [] sampletime sample_ledger_str-    showRegisterReport [Cleared] [] l `is` unlines+    let opts = [Cleared]+    l <- ledgerFromStringWithOpts opts sample_ledger_str+    showRegisterReport opts (optsToFilterSpec opts [] t1) l `is` unlines      ["2008/06/03 eat & shop           expenses:food                    $1           $1"      ,"                                expenses:supplies                $1           $2"      ,"                                assets:cash                     $-2            0"@@ -578,10 +573,11 @@      ,"                                assets:bank:checking            $-1            0"      ] -  ,"register report with uncleared arg" ~:+  ,"register report with uncleared option" ~:    do -    l <- ledgerFromStringWithOpts [UnCleared] [] sampletime sample_ledger_str-    showRegisterReport [UnCleared] [] l `is` unlines+    let opts = [UnCleared]+    l <- ledgerFromStringWithOpts opts sample_ledger_str+    showRegisterReport opts (optsToFilterSpec opts [] t1) l `is` unlines      ["2008/01/01 income               assets:bank:checking             $1           $1"      ,"                                income:salary                   $-1            0"      ,"2008/06/01 gift                 assets:bank:checking             $1           $1"@@ -592,7 +588,7 @@    ,"register report sorts by date" ~:    do -    l <- ledgerFromStringWithOpts [] [] sampletime $ unlines+    l <- ledgerFromStringWithOpts [] $ unlines         ["2008/02/02 a"         ,"  b  1"         ,"  c"@@ -601,19 +597,19 @@         ,"  e  1"         ,"  f"         ]-    registerdates (showRegisterReport [] [] l) `is` ["2008/01/01","2008/02/02"]+    registerdates (showRegisterReport [] (optsToFilterSpec [] [] t1) l) `is` ["2008/01/01","2008/02/02"]    ,"register report with account pattern" ~:    do     l <- sampleledger-    showRegisterReport [] ["cash"] l `is` unlines+    showRegisterReport [] (optsToFilterSpec [] ["cash"] t1) l `is` unlines      ["2008/06/03 eat & shop           assets:cash                     $-2          $-2"      ]    ,"register report with account pattern, case insensitive" ~:    do      l <- sampleledger-    showRegisterReport [] ["cAsH"] l `is` unlines+    showRegisterReport [] (optsToFilterSpec [] ["cAsH"] t1) l `is` unlines      ["2008/06/03 eat & shop           assets:cash                     $-2          $-2"      ] @@ -621,7 +617,8 @@    do      l <- sampleledger     let gives displayexpr = -            (registerdates (showRegisterReport [Display displayexpr] [] l) `is`)+            (registerdates (showRegisterReport opts (optsToFilterSpec opts [] t1) l) `is`)+                where opts = [Display displayexpr]     "d<[2008/6/2]"  `gives` ["2008/01/01","2008/06/01"]     "d<=[2008/6/2]" `gives` ["2008/01/01","2008/06/01","2008/06/02"]     "d=[2008/6/2]"  `gives` ["2008/06/02"]@@ -632,15 +629,17 @@    do      l <- sampleledger         let periodexpr `gives` dates = do-          lopts <- sampleledgerwithopts [Period periodexpr] []-          registerdates (showRegisterReport [Period periodexpr] [] lopts) `is` dates+          l' <- sampleledgerwithopts opts []+          registerdates (showRegisterReport opts (optsToFilterSpec opts [] t1) l') `is` dates+              where opts = [Period periodexpr]     ""     `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]     "2008" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]     "2007" `gives` []     "june" `gives` ["2008/06/01","2008/06/02","2008/06/03"]     "monthly" `gives` ["2008/01/01","2008/06/01","2008/12/01"]     "quarterly" `gives` ["2008/01/01","2008/04/01","2008/10/01"]-    showRegisterReport [Period "yearly"] [] l `is` unlines+    let opts = [Period "yearly"]+    showRegisterReport opts (optsToFilterSpec opts [] t1) l `is` unlines      ["2008/01/01 - 2008/12/31         assets:bank:saving               $1           $1"      ,"                                assets:cash                     $-2          $-1"      ,"                                expenses:food                    $1            0"@@ -649,15 +648,18 @@      ,"                                income:salary                   $-1          $-1"      ,"                                liabilities:debts                $1            0"      ]-    registerdates (showRegisterReport [Period "quarterly"] [] l) `is` ["2008/01/01","2008/04/01","2008/10/01"]-    registerdates (showRegisterReport [Period "quarterly",Empty] [] l) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"]+    let opts = [Period "quarterly"]+    registerdates (showRegisterReport opts (optsToFilterSpec opts [] t1) l) `is` ["2008/01/01","2008/04/01","2008/10/01"]+    let opts = [Period "quarterly",Empty]+    registerdates (showRegisterReport opts (optsToFilterSpec opts [] t1) l) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"]    ]    , "register report with depth arg" ~:    do      l <- sampleledger-    showRegisterReport [Depth "2"] [] l `is` unlines+    let opts = [Depth "2"]+    showRegisterReport opts (optsToFilterSpec opts [] t1) l `is` unlines      ["2008/01/01 income               income:salary                   $-1          $-1"      ,"2008/06/01 gift                 income:gifts                    $-1          $-2"      ,"2008/06/03 eat & shop           expenses:food                    $1          $-1"@@ -670,7 +672,7 @@    ,"show hours" ~: show (hours 1) ~?= "1.0h" -  ,"showLedgerTransaction" ~: do+  ,"showTransaction" ~: do      assertEqual "show a balanced transaction, eliding last amount"        (unlines         ["2007/01/28 coopportunity"@@ -678,11 +680,11 @@         ,"    assets:checking"         ,""         ])-       (showLedgerTransaction-        (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""-         [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting-         ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting-         ] ""))+       (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""+                [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting (Just t)+                ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting (Just t)+                ] ""+        in showTransaction t)      assertEqual "show a balanced transaction, no eliding"        (unlines         ["2007/01/28 coopportunity"@@ -690,11 +692,11 @@         ,"    assets:checking               $-47.18"         ,""         ])-       (showLedgerTransactionUnelided-        (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""-         [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting-         ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting-         ] ""))+       (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""+                [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting (Just t)+                ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting (Just t)+                ] ""+        in showTransactionUnelided t)      -- document some cases that arise in debug/testing:      assertEqual "show an unbalanced transaction, should not elide"        (unlines@@ -703,10 +705,10 @@         ,"    assets:checking               $-47.19"         ,""         ])-       (showLedgerTransaction-        (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""-         [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting-         ,Posting False "assets:checking" (Mixed [dollars (-47.19)]) "" RegularPosting+       (showTransaction+        (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""+         [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing+         ,Posting False "assets:checking" (Mixed [dollars (-47.19)]) "" RegularPosting Nothing          ] ""))      assertEqual "show an unbalanced transaction with one posting, should not elide"        (unlines@@ -714,9 +716,9 @@         ,"    expenses:food:groceries        $47.18"         ,""         ])-       (showLedgerTransaction-        (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""-         [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting+       (showTransaction+        (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""+         [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing          ] ""))      assertEqual "show a transaction with one posting and a missing amount"        (unlines@@ -724,22 +726,22 @@         ,"    expenses:food:groceries              "         ,""         ])-       (showLedgerTransaction-        (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""-         [Posting False "expenses:food:groceries" missingamt "" RegularPosting+       (showTransaction+        (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""+         [Posting False "expenses:food:groceries" missingamt "" RegularPosting Nothing          ] ""))    ,"unicode in balance layout" ~: do-    l <- ledgerFromStringWithOpts [] [] sampletime+    l <- ledgerFromStringWithOpts []       "2009/01/01 * медвежья шкура\n  расходы:покупки  100\n  актив:наличные\n"-    showBalanceReport [] [] l `is` unlines+    showBalanceReport [] (optsToFilterSpec [] [] t1) l `is` unlines       ["                -100  актив:наличные"       ,"                 100  расходы:покупки"]    ,"unicode in register layout" ~: do-    l <- ledgerFromStringWithOpts [] [] sampletime+    l <- ledgerFromStringWithOpts []       "2009/01/01 * медвежья шкура\n  расходы:покупки  100\n  актив:наличные\n"-    showRegisterReport [] [] l `is` unlines+    showRegisterReport [] (optsToFilterSpec [] [] t1) l `is` unlines       ["2009/01/01 медвежья шкура       расходы:покупки                 100          100"       ,"                                актив:наличные                 -100            0"] @@ -796,44 +798,44 @@      [mkdatespan "2008/01/01" "2008/01/01"]    ,"subAccounts" ~: do-    l <- sampleledger+    l <- liftM cacheLedger' sampleledger     let a = ledgerAccount l "assets"     map aname (ledgerSubAccounts l a) `is` ["assets:bank","assets:cash"] -  ,"summariseTransactionsInDateSpan" ~: do-    let gives (b,e,tnum,depth,showempty,ts) = -            (summariseTransactionsInDateSpan (mkdatespan b e) tnum depth showempty ts `is`)-    let ts =-            [-             nulltxn{tdescription="desc",taccount="expenses:food:groceries",tamount=Mixed [dollars 1]}-            ,nulltxn{tdescription="desc",taccount="expenses:food:dining",   tamount=Mixed [dollars 2]}-            ,nulltxn{tdescription="desc",taccount="expenses:food",          tamount=Mixed [dollars 4]}-            ,nulltxn{tdescription="desc",taccount="expenses:food:dining",   tamount=Mixed [dollars 8]}-            ]-    ("2008/01/01","2009/01/01",0,9999,False,[]) `gives` -     []-    ("2008/01/01","2009/01/01",0,9999,True,[]) `gives` -     [-      nulltxn{tdate=parsedate "2008/01/01",tdescription="- 2008/12/31"}-     ]-    ("2008/01/01","2009/01/01",0,9999,False,ts) `gives` -     [-      nulltxn{tdate=parsedate "2008/01/01",tdescription="- 2008/12/31",taccount="expenses:food",          tamount=Mixed [dollars 4]}-     ,nulltxn{tdate=parsedate "2008/01/01",tdescription="- 2008/12/31",taccount="expenses:food:dining",   tamount=Mixed [dollars 10]}-     ,nulltxn{tdate=parsedate "2008/01/01",tdescription="- 2008/12/31",taccount="expenses:food:groceries",tamount=Mixed [dollars 1]}-     ]-    ("2008/01/01","2009/01/01",0,2,False,ts) `gives` -     [-      nulltxn{tdate=parsedate "2008/01/01",tdescription="- 2008/12/31",taccount="expenses:food",tamount=Mixed [dollars 15]}-     ]-    ("2008/01/01","2009/01/01",0,1,False,ts) `gives` -     [-      nulltxn{tdate=parsedate "2008/01/01",tdescription="- 2008/12/31",taccount="expenses",tamount=Mixed [dollars 15]}-     ]-    ("2008/01/01","2009/01/01",0,0,False,ts) `gives` -     [-      nulltxn{tdate=parsedate "2008/01/01",tdescription="- 2008/12/31",taccount="",tamount=Mixed [dollars 15]}-     ]+  -- ,"summarisePostingsInDateSpan" ~: do+  --   let gives (b,e,depth,showempty,ps) =+  --           (summarisePostingsInDateSpan (mkdatespan b e) depth showempty ps `is`)+  --   let ps =+  --           [+  --            nullposting{lpdescription="desc",lpaccount="expenses:food:groceries",lpamount=Mixed [dollars 1]}+  --           ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining",   lpamount=Mixed [dollars 2]}+  --           ,nullposting{lpdescription="desc",lpaccount="expenses:food",          lpamount=Mixed [dollars 4]}+  --           ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining",   lpamount=Mixed [dollars 8]}+  --           ]+  --   ("2008/01/01","2009/01/01",0,9999,False,[]) `gives` +  --    []+  --   ("2008/01/01","2009/01/01",0,9999,True,[]) `gives` +  --    [+  --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31"}+  --    ]+  --   ("2008/01/01","2009/01/01",0,9999,False,ts) `gives` +  --    [+  --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food",          lpamount=Mixed [dollars 4]}+  --    ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:dining",   lpamount=Mixed [dollars 10]}+  --    ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:groceries",lpamount=Mixed [dollars 1]}+  --    ]+  --   ("2008/01/01","2009/01/01",0,2,False,ts) `gives` +  --    [+  --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food",lpamount=Mixed [dollars 15]}+  --    ]+  --   ("2008/01/01","2009/01/01",0,1,False,ts) `gives` +  --    [+  --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses",lpamount=Mixed [dollars 15]}+  --    ]+  --   ("2008/01/01","2009/01/01",0,0,False,ts) `gives` +  --    [+  --     nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="",lpamount=Mixed [dollars 15]}+  --    ]    ,"postingamount" ~: do     parseWithCtx emptyCtx postingamount " $47.18" `parseis` Mixed [dollars 47.18]@@ -846,11 +848,12 @@ ------------------------------------------------------------------------------ -- test data -sampledate = parsedate "2008/11/26"-sampletime = LocalTime sampledate midday-sampleledger = ledgerFromStringWithOpts [] [] sampletime sample_ledger_str-sampleledgerwithopts opts args = ledgerFromStringWithOpts opts args sampletime sample_ledger_str+date1 = parsedate "2008/11/26"+t1 = LocalTime date1 midday +sampleledger = ledgerFromStringWithOpts [] sample_ledger_str+sampleledgerwithopts opts _ = ledgerFromStringWithOpts opts sample_ledger_str+ sample_ledger_str = unlines  ["; A sample ledger file."  ,";"@@ -906,19 +909,19 @@  rawposting1_str  = "  expenses:food:dining  $10.00\n" -rawposting1 = Posting False "expenses:food:dining" (Mixed [dollars 10]) "" RegularPosting+rawposting1 = Posting False "expenses:food:dining" (Mixed [dollars 10]) "" RegularPosting Nothing  entry1_str = unlines  ["2007/01/28 coopportunity"  ,"    expenses:food:groceries                   $47.18"- ,"    assets:checking"+ ,"    assets:checking                          $-47.18"  ,""  ]  entry1 =-    LedgerTransaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""-     [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting, -      Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting] ""+    txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""+     [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing, +      Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting Nothing] ""   entry2_str = unlines@@ -1060,173 +1063,186 @@  ,""  ] -rawledger7 = RawLedger+journal7 = Journal           []            []            [-           LedgerTransaction {-             ltdate=parsedate "2007/01/01", -             lteffectivedate=Nothing,-             ltstatus=False, -             ltcode="*", -             ltdescription="opening balance", -             ltcomment="",-             ltpostings=[+           txnTieKnot $ Transaction {+             tdate=parsedate "2007/01/01",+             teffectivedate=Nothing,+             tstatus=False,+             tcode="*",+             tdescription="opening balance",+             tcomment="",+             tpostings=[               Posting {                 pstatus=False,-                paccount="assets:cash", +                paccount="assets:cash",                 pamount=(Mixed [dollars 4.82]),                 pcomment="",-                ptype=RegularPosting+                ptype=RegularPosting,+                ptransaction=Nothing               },               Posting {                 pstatus=False,-                paccount="equity:opening balances", +                paccount="equity:opening balances",                 pamount=(Mixed [dollars (-4.82)]),                 pcomment="",-                ptype=RegularPosting+                ptype=RegularPosting,+                ptransaction=Nothing               }              ],-             ltpreceding_comment_lines=""+             tpreceding_comment_lines=""            }           ,-           LedgerTransaction {-             ltdate=parsedate "2007/02/01", -             lteffectivedate=Nothing,-             ltstatus=False, -             ltcode="*", -             ltdescription="ayres suites", -             ltcomment="",-             ltpostings=[+           txnTieKnot $ Transaction {+             tdate=parsedate "2007/02/01",+             teffectivedate=Nothing,+             tstatus=False,+             tcode="*",+             tdescription="ayres suites",+             tcomment="",+             tpostings=[               Posting {                 pstatus=False,-                paccount="expenses:vacation", +                paccount="expenses:vacation",                 pamount=(Mixed [dollars 179.92]),                 pcomment="",-                ptype=RegularPosting+                ptype=RegularPosting,+                ptransaction=Nothing               },               Posting {                 pstatus=False,-                paccount="assets:checking", +                paccount="assets:checking",                 pamount=(Mixed [dollars (-179.92)]),                 pcomment="",-                ptype=RegularPosting+                ptype=RegularPosting,+                ptransaction=Nothing               }              ],-             ltpreceding_comment_lines=""+             tpreceding_comment_lines=""            }           ,-           LedgerTransaction {-             ltdate=parsedate "2007/01/02", -             lteffectivedate=Nothing,-             ltstatus=False, -             ltcode="*", -             ltdescription="auto transfer to savings", -             ltcomment="",-             ltpostings=[+           txnTieKnot $ Transaction {+             tdate=parsedate "2007/01/02",+             teffectivedate=Nothing,+             tstatus=False,+             tcode="*",+             tdescription="auto transfer to savings",+             tcomment="",+             tpostings=[               Posting {                 pstatus=False,-                paccount="assets:saving", +                paccount="assets:saving",                 pamount=(Mixed [dollars 200]),                 pcomment="",-                ptype=RegularPosting+                ptype=RegularPosting,+                ptransaction=Nothing               },               Posting {                 pstatus=False,-                paccount="assets:checking", +                paccount="assets:checking",                 pamount=(Mixed [dollars (-200)]),                 pcomment="",-                ptype=RegularPosting+                ptype=RegularPosting,+                ptransaction=Nothing               }              ],-             ltpreceding_comment_lines=""+             tpreceding_comment_lines=""            }           ,-           LedgerTransaction {-             ltdate=parsedate "2007/01/03", -             lteffectivedate=Nothing,-             ltstatus=False, -             ltcode="*", -             ltdescription="poquito mas", -             ltcomment="",-             ltpostings=[+           txnTieKnot $ Transaction {+             tdate=parsedate "2007/01/03",+             teffectivedate=Nothing,+             tstatus=False,+             tcode="*",+             tdescription="poquito mas",+             tcomment="",+             tpostings=[               Posting {                 pstatus=False,-                paccount="expenses:food:dining", +                paccount="expenses:food:dining",                 pamount=(Mixed [dollars 4.82]),                 pcomment="",-                ptype=RegularPosting+                ptype=RegularPosting,+                ptransaction=Nothing               },               Posting {                 pstatus=False,-                paccount="assets:cash", +                paccount="assets:cash",                 pamount=(Mixed [dollars (-4.82)]),                 pcomment="",-                ptype=RegularPosting+                ptype=RegularPosting,+                ptransaction=Nothing               }              ],-             ltpreceding_comment_lines=""+             tpreceding_comment_lines=""            }           ,-           LedgerTransaction {-             ltdate=parsedate "2007/01/03", -             lteffectivedate=Nothing,-             ltstatus=False, -             ltcode="*", -             ltdescription="verizon", -             ltcomment="",-             ltpostings=[+           txnTieKnot $ Transaction {+             tdate=parsedate "2007/01/03",+             teffectivedate=Nothing,+             tstatus=False,+             tcode="*",+             tdescription="verizon",+             tcomment="",+             tpostings=[               Posting {                 pstatus=False,-                paccount="expenses:phone", +                paccount="expenses:phone",                 pamount=(Mixed [dollars 95.11]),                 pcomment="",-                ptype=RegularPosting+                ptype=RegularPosting,+                ptransaction=Nothing               },               Posting {                 pstatus=False,-                paccount="assets:checking", +                paccount="assets:checking",                 pamount=(Mixed [dollars (-95.11)]),                 pcomment="",-                ptype=RegularPosting+                ptype=RegularPosting,+                ptransaction=Nothing               }              ],-             ltpreceding_comment_lines=""+             tpreceding_comment_lines=""            }           ,-           LedgerTransaction {-             ltdate=parsedate "2007/01/03", -             lteffectivedate=Nothing,-             ltstatus=False, -             ltcode="*", -             ltdescription="discover", -             ltcomment="",-             ltpostings=[+           txnTieKnot $ Transaction {+             tdate=parsedate "2007/01/03",+             teffectivedate=Nothing,+             tstatus=False,+             tcode="*",+             tdescription="discover",+             tcomment="",+             tpostings=[               Posting {                 pstatus=False,-                paccount="liabilities:credit cards:discover", +                paccount="liabilities:credit cards:discover",                 pamount=(Mixed [dollars 80]),                 pcomment="",-                ptype=RegularPosting+                ptype=RegularPosting,+                ptransaction=Nothing               },               Posting {                 pstatus=False,-                paccount="assets:checking", +                paccount="assets:checking",                 pamount=(Mixed [dollars (-80)]),                 pcomment="",-                ptype=RegularPosting+                ptype=RegularPosting,+                ptransaction=Nothing               }              ],-             ltpreceding_comment_lines=""+             tpreceding_comment_lines=""            }-          ] +          ]           []           []           ""           ""           (TOD 0 0)+          "" -ledger7 = cacheLedger [] rawledger7 +ledger7 = cacheLedger journal7  ledger8_str = unlines  ["2008/1/1 test           "@@ -1248,16 +1264,17 @@ a2 = Mixed [(hours 2){price=Just $ Mixed [Amount (comm "EUR") 10 Nothing]}] a3 = Mixed $ amounts a1 ++ amounts a2 -rawLedgerWithAmounts :: [String] -> RawLedger-rawLedgerWithAmounts as = -        RawLedger -        [] -        [] -        [nullledgertxn{ltdescription=a,ltpostings=[nullrawposting{pamount=parse a}]} | a <- as]+journalWithAmounts :: [String] -> Journal+journalWithAmounts as =+        Journal         []         []+        [t | a <- as, let t = nulltransaction{tdescription=a,tpostings=[nullposting{pamount=parse a,ptransaction=Just t}]}]+        []+        []         ""         ""         (TOD 0 0)+        ""     where parse = fromparse . parseWithCtx emptyCtx postingamount . (" "++) 

@@ -9,18 +9,20 @@ where import Control.Monad.Error import Ledger-import Options (Opt,ledgerFilePathFromOpts,optsToFilterSpec)+import Options (Opt(..),ledgerFilePathFromOpts) -- ,optsToFilterSpec) import System.Directory (doesFileExist) import System.IO (stderr) import System.IO.UTF8 (hPutStrLn) import System.Exit import System.Cmd (system) import System.Info (os)-import System.Time (getClockTime)+import System.Time (ClockTime,getClockTime)   -- | Parse the user's specified ledger file and run a hledger command on -- it, or report a parse error. This function makes the whole thing go.+-- Warning, this provides only an uncached Ledger (no accountnametree or+-- accountmap), so cmd must cacheLedger'/crunchJournal if needed. withLedgerDo :: [Opt] -> [String] -> String -> ([Opt] -> [String] -> Ledger -> IO ()) -> IO () withLedgerDo opts args cmdname cmd = do   -- We kludgily read the file before parsing to grab the full text, unless@@ -30,30 +32,37 @@   let f' = if f == "-" then "/dev/null" else f   fileexists <- doesFileExist f   let creating = not fileexists && cmdname == "add"-  rawtext <-  if creating then return "" else strictReadFile f'   t <- getCurrentLocalTime   tc <- getClockTime-  let go = cmd opts args . filterAndCacheLedgerWithOpts opts args t rawtext . (\rl -> rl{filepath=f,filereadtime=tc})-  if creating then go rawLedgerEmpty else (runErrorT . parseLedgerFile t) f-         >>= flip either go-                 (\e -> hPutStrLn stderr e >> exitWith (ExitFailure 1))+  txt <-  if creating then return "" else strictReadFile f'+  let runcmd = cmd opts args . mkLedger opts f tc txt+  if creating+   then runcmd nulljournal+   else (runErrorT . parseLedgerFile t) f >>= either parseerror runcmd+    where parseerror e = hPutStrLn stderr e >> exitWith (ExitFailure 1) +mkLedger :: [Opt] -> FilePath -> ClockTime -> String -> Journal -> Ledger+mkLedger opts f tc txt j = nullledger{journal=j'}+    where j' = (canonicaliseAmounts costbasis j){filepath=f,filereadtime=tc,jtext=txt}+          costbasis=CostBasis `elem` opts+ -- | Get a Ledger from the given string and options, or raise an error.-ledgerFromStringWithOpts :: [Opt] -> [String] -> LocalTime -> String -> IO Ledger-ledgerFromStringWithOpts opts args reftime s =-    liftM (filterAndCacheLedgerWithOpts opts args reftime s) $ rawLedgerFromString s+ledgerFromStringWithOpts :: [Opt] -> String -> IO Ledger+ledgerFromStringWithOpts opts s = do+    tc <- getClockTime+    j <- journalFromString s+    return $ mkLedger opts "" tc s j --- | Read a Ledger from the given file, filtering according to the--- options, or give an error.-readLedgerWithOpts :: [Opt] -> [String] -> FilePath -> IO Ledger-readLedgerWithOpts opts args f = do-  t <- getCurrentLocalTime-  readLedgerWithFilterSpec (optsToFilterSpec opts args t) f+-- -- | Read a Ledger from the given file, or give an error.+-- readLedgerWithOpts :: [Opt] -> [String] -> FilePath -> IO Ledger+-- readLedgerWithOpts opts args f = do+--   t <- getCurrentLocalTime+--   readLedger f            --- | Convert a RawLedger to a canonicalised, cached and filtered Ledger--- based on the command-line options/arguments and a reference time.-filterAndCacheLedgerWithOpts ::  [Opt] -> [String] -> LocalTime -> String -> RawLedger -> Ledger-filterAndCacheLedgerWithOpts opts args = filterAndCacheLedger . optsToFilterSpec opts args+-- -- | Convert a Journal to a canonicalised, cached and filtered Ledger+-- -- based on the command-line options/arguments and a reference time.+-- filterAndCacheLedgerWithOpts ::  [Opt] -> [String] -> LocalTime -> String -> Journal -> Ledger+-- filterAndCacheLedgerWithOpts opts args = filterAndCacheLedger . optsToFilterSpec opts args  -- | Attempt to open a web browser on the given url, all platforms. openBrowserOn :: String -> IO ExitCode

@@ -11,7 +11,7 @@ import Options (progname)  -- version and PATCHLEVEL are set by the makefile-version       = "0.7.0"+version       = "0.8.0"  #ifdef PATCHLEVEL patchlevel = "." ++ show PATCHLEVEL -- must be numeric !@@ -66,5 +66,8 @@ #endif #ifdef WEB   ,"web"+#endif+#ifdef CHART+  ,"chart" #endif  ]

@@ -0,0 +1,15 @@+/* hledger web ui stylesheet */++body { font-family: "helvetica","arial", "sans serif"; margin:0; }+#navbar { background-color:#eeeeee; border-bottom:2px solid #dddddd; padding:4px 4px 6px 4px; }+#navlinks { display:inline; }+.navlink { font-weight:normal; }+#searchform { font-size:small; display:inline; margin-left:1em; }+#hledgerorglink { font-size:small; float:right; }+#helplink { font-size:small; margin-left:1em; }+#resetlink { font-size:small; }+#messages { color:red; background-color:#ffeeee; margin:0.5em;}+#content { padding:0 4px 0 4px; }+#addform { margin-left:1em; font-size:small; float:right;}+#addform table { background-color:#eeeeee; border:2px solid #dddddd; }+#addform #addbuttonrow td { text-align:left; }

@@ -1,6 +1,6 @@ name:           hledger -- Version is set by the makefile-version:        0.7.0+version:        0.8 category:       Finance synopsis:       A command-line (or curses or web-based) double-entry accounting tool. description:@@ -22,7 +22,9 @@ tested-with:    GHC==6.8, GHC==6.10 cabal-version:  >= 1.2 build-type:     Custom-+data-dir:       data+data-files:+                web/style.css extra-tmp-files: extra-source-files:   README@@ -37,6 +39,10 @@   description: enable the web ui   default:     False +flag chart+  description: enable the pie chart generation+  default:     False+ library   exposed-modules:                   Ledger@@ -46,13 +52,12 @@                   Ledger.Commodity                   Ledger.Dates                   Ledger.IO-                  Ledger.LedgerTransaction-                  Ledger.RawLedger+                  Ledger.Transaction+                  Ledger.Journal                   Ledger.Ledger                   Ledger.Posting                   Ledger.Parse                   Ledger.TimeLog-                  Ledger.Transaction                   Ledger.Types                   Ledger.Utils   Build-Depends:@@ -64,7 +69,7 @@                  ,old-time                  ,parsec                  ,time-                 ,utf8-string >= 0.3 && < 0.4+                 ,utf8-string >= 0.3                  ,HUnit  executable hledger@@ -85,16 +90,16 @@                   Ledger.Commodity                   Ledger.Dates                   Ledger.IO-                  Ledger.LedgerTransaction+                  Ledger.Transaction                   Ledger.Ledger                   Ledger.Parse-                  Ledger.RawLedger+                  Ledger.Journal                   Ledger.Posting                   Ledger.TimeLog-                  Ledger.Transaction                   Ledger.Types                   Ledger.Utils                   Options+                  Paths_hledger                   Tests                   Utils                   Version@@ -114,7 +119,7 @@                  ,split                  ,testpack                  ,time-                 ,utf8-string >= 0.3 && < 0.4+                 ,utf8-string >= 0.3                  ,HUnit                  ,safe >= 0.2 @@ -125,7 +130,7 @@     cpp-options: -DVTY     other-modules:Commands.UI     build-depends:-                  vty >= 4.0.0.1 && < 4.1+                  vty >= 4.0.0.1    if flag(web)     cpp-options: -DWEB@@ -133,19 +138,25 @@     build-depends:                   hsp                  ,hsx-                 ,xhtml >= 3000.2 && < 3000.3+                 ,xhtml >= 3000.2                  ,loli                  ,io-storage                  ,hack-contrib                  ,hack                  ,hack-handler-happstack-                 ,happstack >= 0.3 && < 0.4-                 ,happstack-data >= 0.3 && < 0.4-                 ,happstack-server >= 0.3 && < 0.4-                 ,happstack-state >= 0.3 && < 0.4-                 ,HTTP >= 4000.0 && < 4000.1+                 ,happstack >= 0.3+                 ,happstack-data >= 0.3+                 ,happstack-server >= 0.3+                 ,happstack-state >= 0.3+                 ,HTTP >= 4000.0                  ,applicative-extras +  if flag(chart)+    cpp-options: -DCHART+    other-modules:Commands.Chart+    build-depends:+                  Chart >= 0.11+                 ,colour  -- source-repository head --   type:     darcs

@@ -68,5 +68,8 @@ #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