hledger 0.8 → 0.9

raw patch · 33 files changed

+546/−3402 lines, 33 filesdep +hack-handler-simpleserverdep +hledger-libdep +old-localedep −bytestringdep −haskell98dep −splitPVP ok

version bump matches the API change (PVP)

Dependencies added: hack-handler-simpleserver, hledger-lib, old-locale

Dependencies removed: bytestring, haskell98, split

API changes (from Hackage documentation)

Files

• Commands/Add.hs +15/−10
• Commands/All.hs +26/−3
• Commands/Balance.hs +4/−1
• Commands/Convert.hs +129/−61
• Commands/Histogram.hs +4/−1
• Commands/Print.hs +4/−1
• Commands/Register.hs +73/−37
• Commands/Stats.hs +13/−4
• Commands/UI.hs +5/−5
• Commands/Web.hs +130/−90
• HledgerMain.hs +47/−0
• Ledger.hs +0/−39
• Ledger/Account.hs +0/−27
• Ledger/AccountName.hs +0/−171
• Ledger/Amount.hs +0/−256
• Ledger/Commodity.hs +0/−39
• Ledger/Dates.hs +0/−428
• Ledger/IO.hs +0/−96
• Ledger/Journal.hs +0/−321
• Ledger/Ledger.hs +0/−180
• Ledger/Parse.hs +0/−587
• Ledger/Posting.hs +0/−95
• Ledger/TimeLog.hs +0/−90
• Ledger/Transaction.hs +0/−142
• Ledger/Types.hs +0/−153
• Ledger/Utils.hs +0/−270
• Options.hs +9/−4
• README +6/−4
• Tests.hs +16/−182
• Utils.hs +9/−4
• Version.hs +7/−5
• hledger.cabal +45/−56
• hledger.hs +4/−40

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-|   A history-aware add command to help with data entry.@@ -6,12 +7,16 @@  module Commands.Add where-import Prelude hiding (putStr, putStrLn, getLine, appendFile) import Ledger import Options import Commands.Register (showRegisterReport)+#if __GLASGOW_HASKELL__ <= 610+import Prelude hiding (putStr, putStrLn, getLine, appendFile) import System.IO.UTF8-import System.IO (stderr, hFlush)+import System.IO ( stderr, hFlush )+#else+import System.IO ( stderr, hFlush, hPutStrLn, hPutStr )+#endif import System.IO.Error import Text.ParserCombinators.Parsec import Utils (ledgerFromStringWithOpts)@@ -24,9 +29,9 @@ 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, press control-c."+  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, press control-c."   today <- getCurrentDay   getAndAddTransactions l opts args today `catch` (\e -> unless (isEOFError e) $ ioError e) @@ -66,10 +71,10 @@                                ,tdescription=description                                ,tpostings=ps                                }-            retry = do-              hPutStrLn stderr $ "\n" ++ nonzerobalanceerror ++ ". Re-enter:"+            retry msg = do+              hPutStrLn stderr $ "\n" ++ msg ++ "please re-enter."               getpostingsandvalidate-        either (const retry) (return . flip (,) date) $ balanceTransaction t+        either retry (return . flip (,) date) $ balanceTransaction t   unless (null historymatches)         (do          hPutStrLn stderr "Similar transactions found, using the first for defaults:\n"@@ -100,7 +105,7 @@       defaultaccount = maybe Nothing (Just . showacctname) bestmatch       showacctname p = showAccountName Nothing (ptype p) $ paccount p       defaultamount = maybe balancingamount (Just . show . pamount) bestmatch-          where balancingamount = Just $ show $ negate $ sum $ map pamount enteredrealps+          where balancingamount = Just $ show $ negate $ sumMixedAmountsPreservingHighestPrecision $ map pamount enteredrealps       postingtype ('[':_) = BalancedVirtualPosting       postingtype ('(':_) = VirtualPosting       postingtype _ = RegularPosting@@ -129,7 +134,7 @@ -- is enough to include new transactions in the history matching. ledgerAddTransaction :: Ledger -> Transaction -> IO Ledger ledgerAddTransaction l t = do-  appendToLedgerFile l $ show t+  appendToLedgerFile l $ showTransaction t   putStrLn $ printf "\nAdded transaction to %s:" (filepath $ journal l)   putStrLn =<< registerFromString (show t)   return l{journal=rl{jtxns=ts}}

@@ -18,12 +18,13 @@ #ifdef VTY                      module Commands.UI, #endif-#ifdef WEB+#if defined(WEB) || defined(WEBHAPPSTACK)                      module Commands.Web, #endif #ifdef CHART-                     module Commands.Chart+                     module Commands.Chart, #endif+                     tests_Commands               ) where import Commands.Add@@ -36,9 +37,31 @@ #ifdef VTY import Commands.UI #endif-#ifdef WEB+#if defined(WEB) || defined(WEBHAPPSTACK) import Commands.Web #endif #ifdef CHART import Commands.Chart #endif+import Test.HUnit (Test(TestList))+++tests_Commands = TestList+    [+--      Commands.Add.tests_Add+--     ,Commands.Balance.tests_Balance+     Commands.Convert.tests_Convert+--     ,Commands.Histogram.tests_Histogram+--     ,Commands.Print.tests_Print+    ,Commands.Register.tests_Register+--     ,Commands.Stats.tests_Stats+    ]+-- #ifdef VTY+--     ,Commands.UI.tests_UI+-- #endif+-- #if defined(WEB) || defined(WEBHAPPSTACK)+--     ,Commands.Web.tests_Web+-- #endif+-- #ifdef CHART+--     ,Commands.Chart.tests_Chart+-- #endif

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-|  A ledger-compatible @balance@ command.@@ -96,7 +97,6 @@  module Commands.Balance where-import Prelude hiding (putStr) import Ledger.Utils import Ledger.Types import Ledger.Amount@@ -104,7 +104,10 @@ import Ledger.Posting import Ledger.Ledger import Options+#if __GLASGOW_HASKELL__ <= 610+import Prelude hiding ( putStr ) import System.IO.UTF8+#endif   -- | Print a balance report.

@@ -7,24 +7,67 @@ import Options (Opt(Debug)) import Version (versionstr) import Ledger.Types (Ledger,AccountName,Transaction(..),Posting(..),PostingType(..))-import Ledger.Utils (strip, spacenonewline, restofline)+import Ledger.Utils (strip, spacenonewline, restofline, parseWithCtx, assertParse, assertParseEqual) import Ledger.Parse (someamount, emptyCtx, ledgeraccountname) import Ledger.Amount (nullmixedamt)+import Safe (atDef, maximumDef) import System.IO (stderr) import Text.CSV (parseCSVFromFile, printCSV) import Text.Printf (hPrintf)-import Text.RegexPR (matchRegexPR)+import Text.RegexPR (matchRegexPR, gsubRegexPR) import Data.Maybe import Ledger.Dates (firstJust, showDate, parsedate)-import Locale (defaultTimeLocale)+import System.Locale (defaultTimeLocale) import Data.Time.Format (parseTime)-import Control.Monad (when, guard)+import Control.Monad (when, guard, liftM) import Safe (readDef, readMay) import System.Directory (doesFileExist)+import System.Exit (exitFailure) import System.FilePath.Posix (takeBaseName, replaceExtension) import Text.ParserCombinators.Parsec+import Test.HUnit  +{- |+A set of data definitions and account-matching patterns sufficient to+convert a particular CSV data file into meaningful ledger transactions. See above.+-}+data CsvRules = CsvRules {+      dateField :: Maybe FieldPosition,+      statusField :: Maybe FieldPosition,+      codeField :: Maybe FieldPosition,+      descriptionField :: Maybe FieldPosition,+      amountField :: Maybe FieldPosition,+      currencyField :: Maybe FieldPosition,+      baseCurrency :: Maybe String,+      baseAccount :: AccountName,+      accountRules :: [AccountRule]+} deriving (Show, Eq)++nullrules = CsvRules {+      dateField=Nothing,+      statusField=Nothing,+      codeField=Nothing,+      descriptionField=Nothing,+      amountField=Nothing,+      currencyField=Nothing,+      baseCurrency=Nothing,+      baseAccount="unknown",+      accountRules=[]+}++type FieldPosition = Int++type AccountRule = (+   [(String, Maybe String)] -- list of regex match patterns with optional replacements+  ,AccountName              -- account name to use for a transaction matching this rule+  )++type CsvRecord = [String]+++-- | Read the CSV file named as an argument and print equivalent ledger transactions,+-- using/creating a .rules file. convert :: [Opt] -> [String] -> Ledger -> IO () convert opts args _ = do   when (null args) $ error "please specify a csv data file."@@ -41,13 +84,32 @@                   writeFile rulesfile initialRulesFileContent    else       hPrintf stderr "using conversion rules file %s\n" rulesfile-  rulesstr <- readFile rulesfile-  let rules = case parseCsvRules rulesfile rulesstr of-                  Left e -> error $ show e-                  Right r -> r+  rules <- liftM (either (error.show) id) $ parseCsvRulesFile rulesfile   when debug $ hPrintf stderr "rules: %s\n" (show rules)-  mapM_ (printTxn debug rules) records+  let requiredfields = max 2 (maxFieldIndex rules + 1)+      badrecords = take 1 $ filter ((< requiredfields).length) records+  if null badrecords+   then mapM_ (printTxn debug rules) records+   else do+     hPrintf stderr (unlines [+                      "Warning, at least one CSV record does not contain a field referenced by the"+                     ,"conversion rules file, or has less than two fields. Are you converting a"+                     ,"valid CSV file ? First bad record:\n%s"+                     ]) (show $ head badrecords)+     exitFailure +-- | The highest (0-based) field index referenced in the field+-- definitions, or -1 if no fields are defined.+maxFieldIndex :: CsvRules -> Int+maxFieldIndex r = maximumDef (-1) $ catMaybes [+                   dateField r+                  ,statusField r+                  ,codeField r+                  ,descriptionField r+                  ,amountField r+                  ,currencyField r+                  ]+ rulesFileFor :: FilePath -> FilePath rulesFileFor csvfile = replaceExtension csvfile ".rules" @@ -75,45 +137,13 @@     "(TO|FROM) SAVINGS\n" ++     "assets:bank:savings\n" -{- |-A set of data definitions and account-matching patterns sufficient to-convert a particular CSV data file into meaningful ledger transactions. See above.--}-data CsvRules = CsvRules {-      dateField :: Maybe FieldPosition,-      statusField :: Maybe FieldPosition,-      codeField :: Maybe FieldPosition,-      descriptionField :: Maybe FieldPosition,-      amountField :: Maybe FieldPosition,-      currencyField :: Maybe FieldPosition,-      baseCurrency :: Maybe String,-      baseAccount :: AccountName,-      accountRules :: [AccountRule]-} deriving (Show)--nullrules = CsvRules {-      dateField=Nothing,-      statusField=Nothing,-      codeField=Nothing,-      descriptionField=Nothing,-      amountField=Nothing,-      currencyField=Nothing,-      baseCurrency=Nothing,-      baseAccount="unknown",-      accountRules=[]-}--type FieldPosition = Int--type AccountRule = (-   [(String, Maybe String)] -- list of regex match patterns with optional replacements-  ,AccountName              -- account name to use for a transaction matching this rule-  )--type CsvRecord = [String]- -- rules file parser +parseCsvRulesFile :: FilePath -> IO (Either ParseError CsvRules)+parseCsvRulesFile f = do+  s <- readFile f+  return $ parseCsvRules f s+ parseCsvRules :: FilePath -> String -> Either ParseError CsvRules parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s @@ -204,14 +234,14 @@  accountrule :: GenParser Char CsvRules AccountRule accountrule = do-  blanklines   many blankorcommentline   pats <- many1 matchreplacepattern   guard $ length pats >= 2   let pats' = init pats       acct = either (fail.show) id $ runParser ledgeraccountname () "" $ fst $ last pats-  many commentline+  many blankorcommentline   return (pats',acct)+ <?> "account rule"  blanklines = many1 blankline >> return () @@ -232,7 +262,7 @@  printTxn :: Bool -> CsvRules -> CsvRecord -> IO () printTxn debug rules rec = do-  when debug $ hPrintf stderr "csv: %s" (printCSV [rec])+  when debug $ hPrintf stderr "record: %s" (printCSV [rec])   putStr $ show $ transactionFromCsvRecord rules rec  -- csv record conversion@@ -240,16 +270,16 @@ transactionFromCsvRecord :: CsvRules -> CsvRecord -> Transaction transactionFromCsvRecord rules fields =   let -      date = parsedate $ normaliseDate $ maybe "1900/1/1" (fields !!) (dateField rules)-      status = maybe False (null . strip . (fields !!)) (statusField rules)-      code = maybe "" (fields !!) (codeField rules)-      desc = maybe "" (fields !!) (descriptionField rules)+      date = parsedate $ normaliseDate $ maybe "1900/1/1" (atDef "" fields) (dateField rules)+      status = maybe False (null . strip . (atDef "" fields)) (statusField rules)+      code = maybe "" (atDef "" fields) (codeField rules)+      desc = maybe "" (atDef "" fields) (descriptionField rules)       comment = ""       precomment = ""-      amountstr = maybe "" (fields !!) (amountField rules)+      amountstr = maybe "" (atDef "" fields) (amountField rules)       amountstr' = strnegate amountstr where strnegate ('-':s) = s                                              strnegate s = '-':s-      currency = maybe (fromMaybe "" $ baseCurrency rules) (fields !!) (currencyField rules)+      currency = maybe (fromMaybe "" $ baseCurrency rules) (atDef "" fields) (currencyField rules)       amountstr'' = currency ++ amountstr'       amountparse = runParser someamount emptyCtx "" amountstr''       amount = either (const nullmixedamt) id amountparse@@ -307,12 +337,50 @@                             | otherwise = (acct,newdesc)     where       matchingrules = filter ismatch rules :: [AccountRule]-          where ismatch = any (isJust . flip matchregex desc . fst) . fst+          where ismatch = any (isJust . flip matchRegexPR (caseinsensitive desc) . fst) . fst       (prs,acct) = head matchingrules-      mrs = filter (isJust . fst) $ map (\(p,r) -> (matchregex p desc, r)) prs-      (m,repl) = head mrs-      matched = fst $ fst $ fromJust m-      newdesc = fromMaybe matched repl+      p_ms_r = filter (\(_,m,_) -> isJust m) $ map (\(p,r) -> (p, matchRegexPR (caseinsensitive p) desc, r)) prs+      (p,_,r) = head p_ms_r+      newdesc = case r of Just rpat -> gsubRegexPR (caseinsensitive p) rpat desc+                          Nothing   -> desc -matchregex = matchRegexPR . ("(?i)" ++)+caseinsensitive = ("(?i)"++) +tests_Convert = TestList [++   "convert rules parsing: empty file" ~: do+     -- let assertMixedAmountParse parseresult mixedamount =+     --         (either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount)+    assertParseEqual (parseCsvRules "unknown" "") nullrules++  ,"convert rules parsing: accountrule" ~: do+     assertParseEqual (parseWithCtx nullrules accountrule "A\na\n") -- leading blank line required+                 ([("A",Nothing)], "a")++  ,"convert rules parsing: trailing comments" ~: do+     assertParse (parseWithCtx nullrules csvrulesfile "A\na\n# \n#\n")++  ,"convert rules parsing: trailing blank lines" ~: do+     assertParse (parseWithCtx nullrules csvrulesfile "A\na\n\n  \n")++  -- not supported+  -- ,"convert rules parsing: no final newline" ~: do+  --    assertParse (parseWithCtx nullrules csvrulesfile "A\na")+  --    assertParse (parseWithCtx nullrules csvrulesfile "A\na\n# \n#")+  --    assertParse (parseWithCtx nullrules csvrulesfile "A\na\n\n  ")++                 -- (nullrules{+                 --   -- dateField=Maybe FieldPosition,+                 --   -- statusField=Maybe FieldPosition,+                 --   -- codeField=Maybe FieldPosition,+                 --   -- descriptionField=Maybe FieldPosition,+                 --   -- amountField=Maybe FieldPosition,+                 --   -- currencyField=Maybe FieldPosition,+                 --   -- baseCurrency=Maybe String,+                 --   -- baseAccount=AccountName,+                 --   accountRules=[+                 --        ([("A",Nothing)], "a")+                 --       ]+                 --  })++  ]

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-|   Print a histogram report.@@ -6,10 +7,12 @@  module Commands.Histogram where-import Prelude hiding (putStr) import Ledger import Options+#if __GLASGOW_HASKELL__ <= 610+import Prelude hiding ( putStr ) import System.IO.UTF8+#endif   barchar = '*'

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-|   A ledger-compatible @print@ command.@@ -6,10 +7,12 @@  module Commands.Print where-import Prelude hiding (putStr) import Ledger import Options+#if __GLASGOW_HASKELL__ <= 610+import Prelude hiding ( putStr ) import System.IO.UTF8+#endif   -- | Print ledger transactions in standard format.

@@ -1,15 +1,24 @@+{-# LANGUAGE CPP #-} {-|   A ledger-compatible @register@ command.  -} -module Commands.Register-where-import Prelude hiding (putStr)+module Commands.Register (+  register+ ,showRegisterReport+ ,showPostingWithBalance+ ,tests_Register+) where++import Safe (headMay, lastMay) import Ledger import Options+#if __GLASGOW_HASKELL__ <= 610+import Prelude hiding ( putStr ) import System.IO.UTF8+#endif   -- | Print a register report.@@ -21,27 +30,48 @@ -- | 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+showRegisterReport opts filterspec l = showPostingsWithBalance ps nullposting startbal     where+      ps | interval == NoInterval = displayableps+         | otherwise             = summarisePostings interval depth empty filterspan displayableps       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+      (precedingps,displayableps,_) =+          postingsMatchingDisplayExpr (displayExprFromOpts opts) $ journalPostings $ filterJournalPostings filterspec $ journal l+      (interval, depth, empty) = (intervalFromOpts opts, depthFromOpts opts, Empty `elem` opts)+      filterspan = datespan filterspec++-- | Convert a list of postings into summary postings, one per interval.+summarisePostings :: Interval -> Maybe Int -> Bool -> DateSpan -> [Posting] -> [Posting]+summarisePostings interval depth empty filterspan ps = concatMap summarisespan $ splitSpan interval reportspan+    where       summarisespan s = summarisePostingsInDateSpan s depth empty (postingsinspan s)-      postingsinspan s = filter (isPostingInDateSpan s) displayedps-      spans = splitSpan interval (postingsDateSpan displayedps)-      interval = intervalFromOpts opts-      empty = Empty `elem` opts-      depth = depthFromOpts opts-      dispexpr = displayExprFromOpts opts-      displayExprMatches p = case dispexpr of-                               Nothing -> True-                               Just e  -> (fromparse $ parsewith datedisplayexpr e) p+      postingsinspan s = filter (isPostingInDateSpan s) ps+      dataspan = postingsDateSpan ps+      reportspan | empty = filterspan `orDatesFrom` dataspan+                 | otherwise = dataspan++-- | Combine two datespans, filling any unspecified dates in the first+-- with dates from the second.+orDatesFrom (DateSpan a1 b1) (DateSpan a2 b2) = DateSpan a b+    where a = if isJust a1 then a1 else a2+          b = if isJust b1 then b1 else b2++-- | Date-sort and split a list of postings into three spans - postings matched+-- by the given display expression, and the preceding and following postings.+postingsMatchingDisplayExpr :: Maybe String -> [Posting] -> ([Posting],[Posting],[Posting])+postingsMatchingDisplayExpr d ps = (before, matched, after)+    where +      sorted = sortBy (comparing postingDate) ps+      (before, rest) = break (displayExprMatches d) sorted+      (matched, after) = span (displayExprMatches d) rest++-- | Does this display expression allow this posting to be displayed ?+-- Raises an error if the display expression can't be parsed.+displayExprMatches :: Maybe String -> Posting -> Bool+displayExprMatches Nothing  _ = True+displayExprMatches (Just d) p = (fromparse $ parsewith datedisplayexpr d) p                         +-- XXX confusing, refactor -- | 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@@ -57,17 +87,17 @@ -- 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 = []+    | null ps && (isNothing b || isNothing e) = []+    | null ps && showempty = [summaryp]     | otherwise = summaryps'     where-      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+      summaryp = summaryPosting b' ("- "++ showDate (addDays (-1) e'))+      b' = fromMaybe (maybe nulldate postingDate $ headMay ps) b+      e' = fromMaybe (maybe (addDays 1 nulldate) postingDate $ lastMay ps) e+      summaryPosting date desc = nullposting{ptransaction=Just nulltransaction{tdate=date,tdescription=desc}}++      summaryps' = (if showempty then id else filter (not . isZeroMixedAmount . pamount)) summaryps+      summaryps = [summaryp{paccount=a,pamount=balancetoshowfor a} | a <- clippedanames]       anames = sort $ nub $ map paccount ps       -- aggregate balances by account, like cacheLedger, then do depth-clipping       (_,_,exclbalof,inclbalof) = groupPostings ps@@ -76,7 +106,6 @@       d = fromMaybe 99999 $ depth       balancetoshowfor a =           (if isclipped a then inclbalof else exclbalof) (if null a then "top" else a)-      summaryps = [p{paccount=a,pamount=balancetoshowfor a} | a <- clippedanames]  {- | Show postings one per line, plus transaction info for the first posting of@@ -88,17 +117,17 @@                                 aaaaaaaaaaaaaaaaaaaaaa  AAAAAAAAAAA AAAAAAAAAAAA @ -}-showpostings :: [Posting] -> Posting -> MixedAmount -> String-showpostings [] _ _ = ""-showpostings (p:ps) pprev bal = this ++ showpostings ps p bal'+showPostingsWithBalance :: [Posting] -> Posting -> MixedAmount -> String+showPostingsWithBalance [] _ _ = ""+showPostingsWithBalance (p:ps) pprev bal = this ++ showPostingsWithBalance ps p bal'     where-      this = showposting isfirst p bal'+      this = showPostingWithBalance isfirst p bal'       isfirst = ptransaction p /= ptransaction pprev       bal' = bal + pamount p  -- | 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"+showPostingWithBalance :: Bool -> Posting -> MixedAmount -> String+showPostingWithBalance withtxninfo p b = concatBottomPadded [txninfo ++ pstr ++ " ", bal] ++ "\n"     where       ledger3ishlayout = False       datedescwidth = if ledger3ishlayout then 34 else 32@@ -107,8 +136,15 @@       datewidth = 10       descwidth = datedescwidth - datewidth - 2       desc = printf ("%-"++(show descwidth)++"s") $ elideRight descwidth de :: String-      pstr = showPostingWithoutPrice p+      pstr = showPostingForRegister p       bal = padleft 12 (showMixedAmountOrZeroWithoutPrice b)       (da,de) = case ptransaction p of Just (Transaction{tdate=da',tdescription=de'}) -> (da',de')                                        Nothing -> (nulldate,"") +tests_Register :: Test+tests_Register = TestList [++         "summarisePostings" ~: do+           summarisePostings Quarterly Nothing False (DateSpan Nothing Nothing) [] ~?= []++        ]

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-|  Print some statistics for the ledger.@@ -6,10 +7,12 @@  module Commands.Stats where-import Prelude hiding (putStr) import Ledger import Options+#if __GLASGOW_HASKELL__ <= 610+import Prelude hiding ( putStr ) import System.IO.UTF8+#endif   -- | Print various statistics for the ledger.@@ -29,14 +32,14 @@       stats = [          ("File", filepath $ journal l)         ,("Period", printf "%s to %s (%d days)" (start span) (end span) days)+        ,("Last transaction", maybe "none" show lastdate ++ showelapsed lastelapsed)         ,("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 tdescription ts)         ,("Accounts", show $ length $ accounts l)-        ,("Commodities", show $ length $ commodities l)+        ,("Account tree depth", show $ maximum $ map (accountNameLevel.aname) $ accounts l)+        ,("Commodities", printf "%s (%s)" (show $ length $ cs) (intercalate ", " $ sort $ map symbol cs))        -- Transactions this month     : %(monthtxns)s (last month in the same period: %(lastmonthtxns)s)       -- Uncleared transactions      : %(uncleared)s       -- Days since reconciliation   : %(reconcileelapsed)s@@ -47,6 +50,11 @@              lastdate | null ts = Nothing                       | otherwise = Just $ tdate $ last ts              lastelapsed = maybe Nothing (Just . diffDays today) lastdate+             showelapsed Nothing = ""+             showelapsed (Just days) = printf " (%d %s)" days' direction+                                       where days' = abs days+                                             direction | days >= 0 = "days ago"+                                                       | otherwise = "days from now"              tnum = length ts              span = rawdatespan l              start (DateSpan (Just d) _) = show d@@ -62,4 +70,5 @@              tnum7 = length $ filter withinlast7 ts              withinlast7 t = d >= addDays (-7) today && (d<=today) where d = tdate t              txnrate7 = fromIntegral tnum7 / 7 :: Double+             cs = commodities l 

@@ -6,6 +6,7 @@  module Commands.UI where+import Safe (headDef) import Graphics.Vty import Ledger import Options@@ -278,12 +279,11 @@ currentTransaction :: AppState -> Maybe Transaction currentTransaction a@AppState{aledger=l,abuf=buf} = ptransaction p     where-      p = safehead nullposting $ filter ismatch $ ledgerPostings l+      p = headDef 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+                  && take 70 (showPostingWithBalance False p nullmixedamt) == (datedesc ++ acctamt)+      datedesc = take 32 $ fromMaybe "" $ find (not . (" " `isPrefixOf`)) $ headDef "" rest : reverse above+      acctamt = drop 32 $ headDef "" rest       (above,rest) = splitAt y buf       y = posY a 

@@ -6,50 +6,52 @@  module Commands.Web where+#if __GLASGOW_HASKELL__ <= 610 import Codec.Binary.UTF8.String (decodeString)+#endif import Control.Applicative.Error (Failing(Success,Failure)) import Control.Concurrent import Control.Monad.Reader (ask) import Data.IORef (newIORef, atomicModifyIORef)-import HSP hiding (Request,catch)-import HSP.HTML (renderAsHTML)---import qualified HSX.XMLGenerator (XML)-import Hack.Contrib.Constants (_TextHtmlUTF8)-import Hack.Contrib.Response (set_content_type)-import Hack.Handler.Happstack (runWithConfig,ServerConf(ServerConf))-import Happstack.State.Control (waitForTermination) import Network.HTTP (urlEncode, urlDecode)-import Network.Loli (loli, io, get, post, html, text, public)---import Network.Loli.Middleware.IOConfig (ioconfig)-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) import System.Time (ClockTime, getClockTime, diffClockTimes, TimeDiff(TimeDiff)) import Text.ParserCombinators.Parsec (parse)--- import Text.XHtml hiding (dir, text, param, label)--- import Text.XHtml.Strict ((<<),(+++),(!))-import qualified HSP (Request(..))++import Hack.Contrib.Constants (_TextHtmlUTF8)+import Hack.Contrib.Response (set_content_type) import qualified Hack (Env, http) import qualified Hack.Contrib.Request (inputs, params, path) import qualified Hack.Contrib.Response (redirect)--- import qualified Text.XHtml.Strict as H+#ifdef WEBHAPPSTACK+import System.Process (readProcess)+import Hack.Handler.Happstack (runWithConfig,ServerConf(ServerConf))+#else+import Hack.Handler.SimpleServer (run)+#endif +import Network.Loli (loli, io, get, post, html, text, public)+import Network.Loli.Type (AppUnit)+import Network.Loli.Utils (update)++import HSP hiding (Request,catch)+import qualified HSP (Request(..))+import HSP.HTML (renderAsHTML)+ import Commands.Add (ledgerAddTransaction) import Commands.Balance import Commands.Histogram import Commands.Print import Commands.Register import Ledger+import Options hiding (value)+#ifdef MAKE+import Paths_hledger_make (getDataFileName)+#else+import Paths_hledger (getDataFileName)+#endif import Utils (openBrowserOn)-import Ledger.IO (readLedger)  -- import Debug.Trace -- strace :: Show a => a -> a@@ -57,31 +59,65 @@  tcpport = 5000 :: Int homeurl = printf "http://localhost:%d/" tcpport+browserdelay = 100000 -- microseconds  web :: [Opt] -> [String] -> Ledger -> IO () web opts args l = do-  if Debug `elem` opts-   then do-    -- just run the server in the foreground-    putStrLn $ printf "starting web server on port %d in debug mode" tcpport-    server opts args l-   else do-    -- start the server (in background, so we can..) then start the web browser-    printf "starting web interface on port %d\n" tcpport-    tid <- forkIO $ server opts args l-    putStrLn "starting web browser"-    openBrowserOn homeurl-    waitForTermination-    putStrLn "shutting down web server..."-    killThread tid-    putStrLn "shutdown complete"+  unless (Debug `elem` opts) $ forkIO browser >> return ()+  server opts args l +browser :: IO ()+browser = putStrLn "starting web browser" >> threadDelay browserdelay >> openBrowserOn homeurl >> return ()++server :: [Opt] -> [String] -> Ledger -> IO ()+server opts args l =+  -- server initialisation+  withStore "hledger" $ do -- IO ()+    printf "starting web server on port %d\n" tcpport+    t <- getCurrentLocalTime+    webfiles <- getDataFileName "web"+    putValue "hledger" "ledger" l+#ifdef WEBHAPPSTACK+    hostname <- readProcess "hostname" [] "" `catch` \_ -> return "hostname"+    runWithConfig (ServerConf tcpport hostname) $            -- (Env -> IO Response) -> IO ()+#else+    run tcpport $            -- (Env -> IO Response) -> IO ()+#endif+      \env -> do -- IO Response+       -- general request handler+       let a = intercalate "+" $ reqparam env "a"+           p = intercalate "+" $ reqparam env "p"+           opts' = opts ++ [Period p]+           args' = args ++ (map urlDecode $ words a)+       l' <- fromJust `fmap` getValue "hledger" "ledger"+       l'' <- reloadIfChanged opts' args' l'+       -- declare path-specific request handlers+       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  "/register"  $ command [] showRegisterReport+          get  "/histogram" $ command [] showHistogram+          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 webfiles) ["/style.css"]+          get  "/"          $ redirect ("transactions") Nothing+          ) env+ getenv = ask response = update redirect u c = response $ Hack.Contrib.Response.redirect u c  reqparam :: Hack.Env -> String -> [String]+#if __GLASGOW_HASKELL__ <= 610 reqparam env p = map snd $ filter ((==p).fst) $ Hack.Contrib.Request.params env+#else+reqparam env p = map (decodeString.snd) $ filter ((==p).fst) $ Hack.Contrib.Request.params env+#endif  ledgerFileModifiedTime :: Ledger -> IO ClockTime ledgerFileModifiedTime l@@ -113,41 +149,6 @@ -- refilter :: [Opt] -> [String] -> Ledger -> LocalTime -> IO Ledger -- 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-       let a = intercalate "+" $ reqparam env "a"-           p = intercalate "+" $ reqparam env "p"-           opts' = opts ++ [Period p]-           args' = args ++ (map urlDecode $ words a)-       l' <- fromJust `fmap` getValue "hledger" "ledger"-       l'' <- reloadIfChanged opts' args' l'-       -- declare path-specific request handlers-       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  "/register"  $ command [] showRegisterReport-          get  "/histogram" $ command [] showHistogram-          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 webfiles) ["/style.css"]-          get  "/"          $ redirect ("transactions") Nothing-          ) env- ledgerpage :: [String] -> Ledger -> (Ledger -> String) -> AppUnit ledgerpage msgs l f = do   env <- getenv@@ -171,12 +172,11 @@   html =<< (io $ do               hspenv <- hackEnvToHspEnv env               (_,xml) <- runHSP html4Strict pagehsp hspenv-              return $ addDoctype $ applyFixups $ renderAsHTML xml)+              return $ addDoctype $ renderAsHTML xml)   response $ set_content_type _TextHtmlUTF8     where       title = ""       addDoctype = ("<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">\n" ++)-      applyFixups = gsubRegexPR "\\[NBSP\\]" "&nbsp;"       hackEnvToHspEnv :: Hack.Env -> IO HSPEnv       hackEnvToHspEnv env = do           x <- newIORef 0@@ -213,7 +213,11 @@       <a href="http://hledger.org/MANUAL.html" id="helplink">help</a>     </div> +#if __GLASGOW_HASKELL__ <= 610+getParamOrNull p = (decodeString . fromMaybe "") `fmap` getParam p+#else getParamOrNull p = fromMaybe "" `fmap` getParam p+#endif  navlinks :: Hack.Env -> HSP XML navlinks _ = do@@ -232,49 +236,69 @@    a <- getParamOrNull "a"    p <- getParamOrNull "p"    let resetlink | null a && null p = <span></span>-                 | otherwise = <span id="resetlink">[NBSP]<a href=u>reset</a></span>+                 | otherwise = <span id="resetlink"><% nbsp %><a href=u>reset</a></span>                  where u = dropWhile (=='/') $ Hack.Contrib.Request.path env    <form action="" id="searchform">-      [NBSP]account pattern:[NBSP]<input name="a" size="20" value=a-      />[NBSP][NBSP]reporting period:[NBSP]<input name="p" size="20" value=p />-      <input type="submit" name="submit" value="filter" style="display:none" />+      <% nbsp %>search for:<% nbsp %><input name="a" size="20" value=a+      /><% help "filter-patterns"+      %><% nbsp %><% nbsp %>in reporting period:<% nbsp %><input name="p" size="20" value=p+      /><% help "period-expressions"+      %><input type="submit" name="submit" value="filter" style="display:none" />       <% resetlink %>     </form>  addform :: Hack.Env -> HSP XML addform env = do+  today <- io $ liftM showDate $ getCurrentDay   let inputs = Hack.Contrib.Request.inputs env-      date  = decodeString $ fromMaybe "" $ lookup "date"  inputs+#if __GLASGOW_HASKELL__ <= 610+      date  = decodeString $ fromMaybe today $ lookup "date"  inputs       desc  = decodeString $ fromMaybe "" $ lookup "desc"  inputs+#else+      date  = fromMaybe today $ lookup "date"  inputs+      desc  = fromMaybe "" $ lookup "desc"  inputs+#endif   <div>    <div id="addform">    <form action="" method="POST">     <table border="0">       <tr>         <td>-          Date: <input size="15" name="date" value=date />[NBSP]-          Description: <input size="35" name="desc" value=desc />[NBSP]+          Date: <input size="15" name="date" value=date /><% help "dates" %><% nbsp %>+          Description: <input size="35" name="desc" value=desc /><% nbsp %>         </td>       </tr>       <% transactionfields 1 env %>       <% transactionfields 2 env %>-      <tr id="addbuttonrow"><td><input type="submit" value="add transaction" /></td></tr>+      <tr id="addbuttonrow"><td><input type="submit" value="add transaction" +      /><% help "file-format" %></td></tr>     </table>    </form>    </div>    <br clear="all" />    </div> +help :: String -> HSP XML+help topic = <a href=u>?</a>+    where u = printf "http://hledger.org/MANUAL.html%s" l :: String+          l | null topic = ""+            | otherwise = '#':topic+ transactionfields :: Int -> Hack.Env -> HSP XML transactionfields n env = do   let inputs = Hack.Contrib.Request.inputs env+#if __GLASGOW_HASKELL__ <= 610       acct = decodeString $ fromMaybe "" $ lookup acctvar inputs       amt  = decodeString $ fromMaybe "" $ lookup amtvar  inputs+#else+      acct = fromMaybe "" $ lookup acctvar inputs+      amt  = fromMaybe "" $ lookup amtvar  inputs+#endif   <tr>     <td>-      [NBSP][NBSP]-      Account: <input size="35" name=acctvar value=acct />[NBSP]-      Amount: <input size="15" name=amtvar value=amt />[NBSP]+    <% nbsp %><% nbsp %>+      Account: <input size="35" name=acctvar value=acct /><% nbsp %>+      Amount: <input size="15" name=amtvar value=amt /><% nbsp %>     </td>    </tr>     where@@ -292,12 +316,21 @@     validate :: Hack.Env -> Day -> Failing Transaction     validate env today =         let inputs = Hack.Contrib.Request.inputs env+#if __GLASGOW_HASKELL__ <= 610             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+#else+            date  = fromMaybe "today" $ 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+#endif             validateDate ""  = ["missing date"]             validateDate _   = []             validateDesc ""  = ["missing description"]@@ -311,8 +344,11 @@             validateAmt2 _   = []             amt1' = either (const missingamt) id $ parse someamount "" amt1             amt2' = either (const missingamt) id $ parse someamount "" amt2+            (date', dateparseerr) = case fixSmartDateStrEither today date of+                                      Right d -> (d, [])+                                      Left e -> ("1900/01/01", [showDateParseError e])             t = Transaction {-                            tdate = parsedate $ fixSmartDateStr today date+                            tdate = parsedate date' -- date' must be parseable                            ,teffectivedate=Nothing                            ,tstatus=False                            ,tcode=""@@ -324,17 +360,19 @@                             ]                            ,tpreceding_comment_lines=""                            }-            (t', berr) = case balanceTransaction t of+            (t', balanceerr) = case balanceTransaction t of                            Right t'' -> (t'', [])-                           Left e -> (t, [e])+                           Left e -> (t, [head $ lines e]) -- show just the error not the transaction             errs = concat [                     validateDate date+                   ,dateparseerr                    ,validateDesc desc                    ,validateAcct1 acct1                    ,validateAmt1 amt1                    ,validateAcct2 acct2                    ,validateAmt2 amt2-                   ] ++ berr+                   ,balanceerr+                   ]         in         case null errs of           False -> Failure errs@@ -347,3 +385,5 @@                     ledgerpage [msg] l (showTransactions (optsToFilterSpec [] [] ti))        where msg = printf "Added transaction:\n%s" (show t) +nbsp :: XML+nbsp = cdata "&nbsp;"

@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}+{-|+The main function is in this separate module so it can be imported by+benchmark scripts. As a side benefit, this avoids a weakness of sp, which+doesn't allow both #! and \{\-\# lines.+-}++module HledgerMain where+#if __GLASGOW_HASKELL__ <= 610+import Prelude hiding (putStr, putStrLn)+import System.IO.UTF8+#endif++import Commands.All+import Ledger+import Options+import Tests+import Utils (withLedgerDo)+import Version (versionmsg, binaryfilename)++main :: IO ()+main = do+  (opts, cmd, args) <- parseArguments+  run cmd opts args+    where+      run cmd opts args+       | Help `elem` opts             = putStr usage+       | Version `elem` opts          = putStrLn versionmsg+       | BinaryFilename `elem` opts   = putStrLn binaryfilename+       | cmd `isPrefixOf` "balance"   = withLedgerDo opts args cmd balance+       | cmd `isPrefixOf` "convert"   = withLedgerDo opts args cmd convert+       | cmd `isPrefixOf` "print"     = withLedgerDo opts args cmd print'+       | cmd `isPrefixOf` "register"  = withLedgerDo opts args cmd register+       | cmd `isPrefixOf` "histogram" = withLedgerDo opts args cmd histogram+       | cmd `isPrefixOf` "add"       = withLedgerDo opts args cmd add+       | cmd `isPrefixOf` "stats"     = withLedgerDo opts args cmd stats+#ifdef VTY+       | cmd `isPrefixOf` "ui"        = withLedgerDo opts args cmd ui+#endif+#if defined(WEB) || defined(WEBHAPPSTACK)+       | 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

@@ -1,39 +0,0 @@-{-| --The Ledger library allows parsing and querying of ledger files.  It-generally provides a compatible subset of C++ ledger's functionality.-This package re-exports all the Ledger.* modules.---}--module Ledger (-               module Ledger.Account,-               module Ledger.AccountName,-               module Ledger.Amount,-               module Ledger.Commodity,-               module Ledger.Dates,-               module Ledger.IO,-               module Ledger.Transaction,-               module Ledger.Ledger,-               module Ledger.Parse,-               module Ledger.Journal,-               module Ledger.Posting,-               module Ledger.TimeLog,-               module Ledger.Types,-               module Ledger.Utils,-              )-where-import Ledger.Account-import Ledger.AccountName-import Ledger.Amount-import Ledger.Commodity-import Ledger.Dates-import Ledger.IO-import Ledger.Transaction-import Ledger.Ledger-import Ledger.Parse-import Ledger.Journal-import Ledger.Posting-import Ledger.TimeLog-import Ledger.Types-import Ledger.Utils

@@ -1,27 +0,0 @@-{-|--A compound data type for efficiency. An 'Account' stores--- an 'AccountName',--- all 'Posting's in the account, excluding subaccounts--- a 'MixedAmount' representing the account balance, including subaccounts.---}--module Ledger.Account-where-import Ledger.Utils-import Ledger.Types-import Ledger.Amount---instance Show Account where-    show (Account a ts b) = printf "Account %s with %d txns and %s balance" a (length ts) (showMixedAmount b)--instance Eq Account where-    (==) (Account n1 t1 b1) (Account n2 t2 b2) = n1 == n2 && t1 == t2 && b1 == b2--nullacct = Account "" [] nullmixedamt-

@@ -1,171 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction#-}-{-|--'AccountName's are strings like @assets:cash:petty@.-From a set of these we derive the account hierarchy.---}--module Ledger.AccountName-where-import Ledger.Utils-import Ledger.Types-import Data.Map (Map)-import qualified Data.Map as M------ change to use a different separator for nested accounts-acctsepchar = ':'--accountNameComponents :: AccountName -> [String]-accountNameComponents = splitAtElement acctsepchar--accountNameFromComponents :: [String] -> AccountName-accountNameFromComponents = concat . intersperse [acctsepchar]--accountLeafName :: AccountName -> String-accountLeafName = last . accountNameComponents--accountNameLevel :: AccountName -> Int-accountNameLevel "" = 0-accountNameLevel a = length (filter (==acctsepchar) a) + 1---- | ["a:b:c","d:e"] -> ["a","a:b","a:b:c","d","d:e"]-expandAccountNames :: [AccountName] -> [AccountName]-expandAccountNames as = nub $ concatMap expand as-    where expand = map accountNameFromComponents . tail . inits . accountNameComponents---- | ["a:b:c","d:e"] -> ["a","d"]-topAccountNames :: [AccountName] -> [AccountName]-topAccountNames as = [a | a <- expandAccountNames as, accountNameLevel a == 1]--parentAccountName :: AccountName -> AccountName-parentAccountName = accountNameFromComponents . init . accountNameComponents--parentAccountNames :: AccountName -> [AccountName]-parentAccountNames a = parentAccountNames' $ parentAccountName a-    where-      parentAccountNames' "" = []-      parentAccountNames' a = a : parentAccountNames' (parentAccountName a)--isAccountNamePrefixOf :: AccountName -> AccountName -> Bool-isAccountNamePrefixOf = isPrefixOf . (++ [acctsepchar])--isSubAccountNameOf :: AccountName -> AccountName -> Bool-s `isSubAccountNameOf` p = -    (p `isAccountNamePrefixOf` s) && (accountNameLevel s == (accountNameLevel p + 1))---- | From a list of account names, select those which are direct--- subaccounts of the given account name.-subAccountNamesFrom :: [AccountName] -> AccountName -> [AccountName]-subAccountNamesFrom accts a = filter (`isSubAccountNameOf` a) accts---- | Convert a list of account names to a tree.-accountNameTreeFrom :: [AccountName] -> Tree AccountName-accountNameTreeFrom = accountNameTreeFrom1--accountNameTreeFrom1 accts = -    Node "top" (accounttreesfrom (topAccountNames accts))-        where-          accounttreesfrom :: [AccountName] -> [Tree AccountName]-          accounttreesfrom [] = []-          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-          subs = subAccountNamesFrom allaccts-          allaccts = expandAccountNames accts-          -- subs' a = subsmap ! a-          -- subsmap :: Map AccountName [AccountName]-          -- subsmap = Data.Map.fromList [(a, subAccountNamesFrom allaccts a) | a <- allaccts]--accountNameTreeFrom3 accts = -    Node "top" $ forestfrom allaccts $ topAccountNames accts-        where-          -- drop accts from the list of potential subs as we add them to the tree-          forestfrom :: [AccountName] -> [AccountName] -> Forest AccountName-          forestfrom subaccts accts = -              [let subaccts' = subaccts \\ accts in Node a $ forestfrom subaccts' (subAccountNamesFrom subaccts' a) | a <- accts]-          allaccts = expandAccountNames accts-          ---- a more efficient tree builder from Cale Gibbard-newtype Tree' a = T (Map a (Tree' a))-  deriving (Show, Eq, Ord)--mergeTrees :: (Ord a) => Tree' a -> Tree' a -> Tree' a-mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m')--emptyTree = T M.empty--pathtree :: [a] -> Tree' a-pathtree []     = T M.empty-pathtree (x:xs) = T (M.singleton x (pathtree xs))--fromPaths :: (Ord a) => [[a]] -> Tree' a-fromPaths = foldl' mergeTrees emptyTree . map pathtree---- the above, but trying to build Tree directly---- mergeTrees' :: (Ord a) => Tree a -> Tree a -> Tree a--- mergeTrees' (Node m ms) (Node m' ms') = Node undefined (ms `union` ms')---- emptyTree' = Node "top" []---- pathtree' :: [a] -> Tree a--- pathtree' []     = Node undefined []--- pathtree' (x:xs) = Node x [pathtree' xs]---- fromPaths' :: (Ord a) => [[a]] -> Tree a--- fromPaths' = foldl' mergeTrees' emptyTree' . map pathtree'----- converttree :: [AccountName] -> Tree' AccountName -> [Tree AccountName]--- converttree parents (T m) = [Node (accountNameFromComponents $ parents ++ [a]) (converttree (parents++[a]) b) | (a,b) <- M.toList m]---- accountNameTreeFrom4 :: [AccountName] -> Tree AccountName--- accountNameTreeFrom4 accts = Node "top" (converttree [] $ fromPaths $ map accountNameComponents accts)--converttree :: Tree' AccountName -> [Tree AccountName]-converttree (T m) = [Node a (converttree b) | (a,b) <- M.toList m]--expandTreeNames :: Tree AccountName -> Tree AccountName-expandTreeNames (Node x ts) = Node x (map (treemap (\n -> accountNameFromComponents [x,n]) . expandTreeNames) ts)--accountNameTreeFrom4 :: [AccountName] -> Tree AccountName-accountNameTreeFrom4 = Node "top" . map expandTreeNames . converttree . fromPaths . map accountNameComponents----- | Elide an account name to fit in the specified width.--- From the ledger 2.6 news:--- --- @---   What Ledger now does is that if an account name is too long, it will---   start abbreviating the first parts of the account name down to two---   letters in length.  If this results in a string that is still too---   long, the front will be elided -- not the end.  For example:------     Expenses:Cash           ; OK, not too long---     Ex:Wednesday:Cash       ; "Expenses" was abbreviated to fit---     Ex:We:Afternoon:Cash    ; "Expenses" and "Wednesday" abbreviated---     ; Expenses:Wednesday:Afternoon:Lunch:Snack:Candy:Chocolate:Cash---     ..:Af:Lu:Sn:Ca:Ch:Cash  ; Abbreviated and elided!--- @-elideAccountName :: Int -> AccountName -> AccountName-elideAccountName width s = -    elideLeft width $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s-      where-        elideparts :: Int -> [String] -> [String] -> [String]-        elideparts width done ss-          | length (accountNameFromComponents $ done++ss) <= width = done++ss-          | 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-

@@ -1,256 +0,0 @@-{-# LANGUAGE StandaloneDeriving #-}-{-|-An 'Amount' is some quantity of money, shares, or anything else.--A simple amount is a 'Commodity', quantity pair:--@-  $1 -  £-50-  EUR 3.44 -  GOOG 500-  1.5h-  90 apples-  0 -@--An amount may also have a per-unit price, or conversion rate, in terms-of some other commodity. If present, this is displayed after \@:--@-  EUR 3 \@ $1.35-@--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.):--@-  $50 + EUR 3-  16h + $13.55 + AAPL 500 + 6 oranges-  0-@--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.---}--module Ledger.Amount-where-import Ledger.Utils-import Ledger.Types-import Ledger.Commodity---instance Show Amount where show = showAmount-instance Show MixedAmount where show = showMixedAmount-deriving instance Show HistoricalPrice--instance Num Amount where-    abs (Amount c q p) = Amount c (abs q) p-    signum (Amount c q p) = Amount c (signum q) p-    fromInteger i = Amount (comm "") (fromInteger i) Nothing-    (+) = amountop (+)-    (-) = amountop (-)-    (*) = amountop (*)--instance Ord Amount where-    compare (Amount ac aq ap) (Amount bc bq bp) = compare (ac,aq,ap) (bc,bq,bp)--instance Num MixedAmount where-    fromInteger i = Mixed [Amount (comm "") (fromInteger i) Nothing]-    negate (Mixed as) = Mixed $ map negateAmountPreservingPrice as-    (+) (Mixed as) (Mixed bs) = normaliseMixedAmount $ Mixed $ as ++ bs-    (*)    = error "programming error, mixed amounts do not support multiplication"-    abs    = error "programming error, mixed amounts do not support abs"-    signum = error "programming error, mixed amounts do not support signum"--instance Ord MixedAmount where-    compare (Mixed as) (Mixed bs) = compare as bs--negateAmountPreservingPrice a = (-a){price=price a}---- | Apply a binary arithmetic operator to two amounts, converting to the--- second one's commodity (and display precision), discarding any price--- information. (Using the second commodity is best since sum and other--- folds start with a no-commodity amount.)-amountop :: (Double -> Double -> Double) -> Amount -> Amount -> Amount-amountop op a@(Amount _ _ _) (Amount bc bq _) = -    Amount bc (quantity (convertAmountTo bc a) `op` bq) Nothing---- | Convert an amount to the specified commodity using the appropriate--- 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-costOfAmount a@(Amount _ _ Nothing) = a-costOfAmount (Amount _ q (Just price))-    | isZeroMixedAmount price = nullamt-    | otherwise = Amount pc (pq*q) Nothing-    where (Amount pc pq _) = head $ amounts price---- | Get the string representation of an amount, based on its commodity's--- display settings.-showAmount :: Amount -> String-showAmount (Amount (Commodity {symbol="AUTO"}) _ _) = "" -- can appear in an error message-showAmount a@(Amount (Commodity {symbol=sym,side=side,spaced=spaced}) _ pri) =-    case side of-      L -> printf "%s%s%s%s" sym space quantity price-      R -> printf "%s%s%s%s" quantity space sym price-    where -      space = if spaced then " " else ""-      quantity = showAmount' a-      price = case pri of (Just pamt) -> " @ " ++ showMixedAmount pamt-                          Nothing -> ""---- | Get the string representation of an amount, without any \@ price.-showAmountWithoutPrice :: Amount -> String-showAmountWithoutPrice a = showAmount a{price=Nothing}---- | Get the string representation (of the number part of) of an amount-showAmount' :: Amount -> String-showAmount' (Amount (Commodity {comma=comma,precision=p}) q _) = quantity-  where-    quantity = commad $ printf ("%."++show p++"f") q-    commad = if comma then punctuatethousands else id---- | Add thousands-separating commas to a decimal number string-punctuatethousands :: String -> String-punctuatethousands s =-    sign ++ addcommas int ++ frac-    where -      (sign,num) = break isDigit s-      (int,frac) = break (=='.') num-      addcommas = reverse . concat . intersperse "," . triples . reverse-      triples [] = []-      triples l  = take 3 l : triples (drop 3 l)---- | Does this amount appear to be zero when displayed with its given precision ?-isZeroAmount :: Amount -> Bool-isZeroAmount = null . filter (`elem` "123456789") . showAmountWithoutPrice---- | Is this amount "really" zero, regardless of the display precision ?--- Since we are using floating point, for now just test to some high precision.-isReallyZeroAmount :: Amount -> Bool-isReallyZeroAmount = null . filter (`elem` "123456789") . printf "%.10f" . quantity---- | Access a mixed amount's components.-amounts :: MixedAmount -> [Amount]-amounts (Mixed as) = as---- | Does this mixed amount appear to be zero - empty, or--- containing only simple amounts which appear to be zero ?-isZeroMixedAmount :: MixedAmount -> Bool-isZeroMixedAmount = all isZeroAmount . amounts . normaliseMixedAmount---- | Is this mixed amount "really" zero ? See isReallyZeroAmount.-isReallyZeroMixedAmount :: MixedAmount -> Bool-isReallyZeroMixedAmount = all isReallyZeroAmount . amounts . normaliseMixedAmount---- | MixedAmount derives Eq in Types.hs, but that doesn't know that we--- want $0 = EUR0 = 0. Yet we don't want to drag all this code in there.--- When zero equality is important, use this, for now; should be used--- everywhere.-mixedAmountEquals :: MixedAmount -> MixedAmount -> Bool-mixedAmountEquals a b = amounts a' == amounts b' || (isZeroMixedAmount a' && isZeroMixedAmount b')-    where a' = normaliseMixedAmount a-          b' = normaliseMixedAmount b---- | Get the string representation of a mixed amount, showing each of--- its component amounts. NB a mixed amount can have an empty amounts--- list in which case it shows as \"\".-showMixedAmount :: MixedAmount -> String-showMixedAmount m = concat $ intersperse "\n" $ map showfixedwidth as-    where -      (Mixed as) = normaliseMixedAmount m-      width = maximum $ map (length . show) as-      showfixedwidth = printf (printf "%%%ds" width) . show---- | Get the string representation of a mixed amount, but without--- any \@ prices.-showMixedAmountWithoutPrice :: MixedAmount -> String-showMixedAmountWithoutPrice m = concat $ intersperse "\n" $ map showfixedwidth as-    where-      (Mixed as) = normaliseMixedAmountIgnoringPrice m-      width = maximum $ map (length . show) as-      showfixedwidth = printf (printf "%%%ds" width) . showAmountWithoutPrice---- | Get the string representation of a mixed amount, and if it--- appears to be all zero just show a bare 0, ledger-style.-showMixedAmountOrZero :: MixedAmount -> String-showMixedAmountOrZero a-    | isZeroMixedAmount a = "0"-    | otherwise = showMixedAmount a---- | Get the string representation of a mixed amount, or a bare 0,--- without any \@ prices.-showMixedAmountOrZeroWithoutPrice :: MixedAmount -> String-showMixedAmountOrZeroWithoutPrice a-    | isZeroMixedAmount a = "0"-    | otherwise = showMixedAmountWithoutPrice a---- | Simplify a mixed amount by combining any component amounts which have--- the same commodity and the same price. Also removes zero amounts,--- or adds a single zero amount if there are no amounts at all.-normaliseMixedAmount :: MixedAmount -> MixedAmount-normaliseMixedAmount (Mixed as) = Mixed as''-    where -      as'' = map sumSamePricedAmountsPreservingPrice $ group $ sort as'-      sort = sortBy cmpsymbolandprice-      cmpsymbolandprice a1 a2 = compare (sym a1,price a1) (sym a2,price a2)-      group = groupBy samesymbolandprice -      samesymbolandprice a1 a2 = (sym a1 == sym a2) && (price a1 == price a2)-      sym = symbol . commodity-      as' | null nonzeros = [head $ zeros ++ [nullamt]]-          | otherwise = nonzeros-      (zeros,nonzeros) = partition isReallyZeroAmount as--sumSamePricedAmountsPreservingPrice [] = nullamt-sumSamePricedAmountsPreservingPrice as = (sum as){price=price $ head as}---- | Simplify a mixed amount by combining any component amounts which have--- the same commodity, ignoring and discarding their unit prices if any.--- Also removes zero amounts, or adds a single zero amount if there are no--- amounts at all.-normaliseMixedAmountIgnoringPrice :: MixedAmount -> MixedAmount-normaliseMixedAmountIgnoringPrice (Mixed as) = Mixed as''-    where-      as'' = map sumAmountsDiscardingPrice $ group $ sort as'-      group = groupBy samesymbol where samesymbol a1 a2 = sym a1 == sym a2-      sort = sortBy (comparing sym)-      sym = symbol . commodity-      as' | null nonzeros = [head $ zeros ++ [nullamt]]-          | otherwise = nonzeros-          where (zeros,nonzeros) = partition isZeroAmount as--sumAmountsDiscardingPrice [] = nullamt-sumAmountsDiscardingPrice as = (sum as){price=Nothing}---- | Convert a mixed amount's component amounts to the commodity of their--- saved price, if any.-costOfMixedAmount :: MixedAmount -> MixedAmount-costOfMixedAmount (Mixed as) = Mixed $ map costOfAmount as---- | The empty simple amount.-nullamt :: Amount-nullamt = Amount unknown 0 Nothing---- | The empty mixed amount.-nullmixedamt :: MixedAmount-nullmixedamt = Mixed []---- | A temporary value for parsed transactions which had no amount specified.-missingamt :: MixedAmount-missingamt = Mixed [Amount Commodity {symbol="AUTO",side=L,spaced=False,comma=False,precision=0} 0 Nothing]-

@@ -1,39 +0,0 @@-{-|--A 'Commodity' is a symbol representing a currency or some other kind of-thing we are tracking, and some display preferences that tell how to-display 'Amount's of the commodity - is the symbol on the left or right,-are thousands separated by comma, significant decimal places and so on.---}-module Ledger.Commodity-where-import Ledger.Utils-import Ledger.Types----- convenient amount and commodity constructors, for tests etc.--unknown = Commodity {symbol="",   side=L,spaced=False,comma=False,precision=0}-dollar  = Commodity {symbol="$",  side=L,spaced=False,comma=False,precision=2}-euro    = Commodity {symbol="EUR",side=L,spaced=False,comma=False,precision=2}-pound   = Commodity {symbol="£",  side=L,spaced=False,comma=False,precision=2}-hour    = Commodity {symbol="h",  side=R,spaced=False,comma=False,precision=1}--dollars n = Amount dollar n Nothing-euros n   = Amount euro n Nothing-pounds n  = Amount pound n Nothing-hours n   = Amount hour n Nothing--defaultcommodities = [dollar,  euro,  pound, hour, unknown]---- | Look up one of the hard-coded default commodities. For use in tests.-comm :: String -> Commodity-comm sym = fromMaybe -              (error "commodity lookup failed") -              $ find (\(Commodity{symbol=s}) -> s==sym) defaultcommodities---- | Find the conversion rate between two commodities. Currently returns 1.-conversionRate :: Commodity -> Commodity -> Double-conversionRate _ _ = 1-

@@ -1,428 +0,0 @@-{-|--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.-We represent these as a triple of strings like (\"2008\",\"12\",\"\"),-(\"\",\"\",\"tomorrow\"), (\"\",\"last\",\"week\").--A 'DateSpan' is the span of time between two specific calendar dates, or-an open-ended span where one or both dates are unspecified. (A date span-with both ends unspecified matches all dates.)--An 'Interval' is ledger's "reporting interval" - weekly, monthly,-quarterly, etc.---}--module Ledger.Dates-where--import Data.Time.Format-import Data.Time.Calendar.OrdinalDate-import Locale (defaultTimeLocale)-import Text.ParserCombinators.Parsec-import Text.ParserCombinators.Parsec.Char-import Text.ParserCombinators.Parsec.Combinator-import Ledger.Types-import Ledger.Utils---showDate :: Day -> String-showDate = formatTime defaultTimeLocale "%Y/%m/%d"--getCurrentDay :: IO Day-getCurrentDay = do-    t <- getZonedTime-    return $ localDay (zonedTimeToLocalTime t)--elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a-elapsedSeconds t1 = realToFrac . diffUTCTime t1---- | Split a DateSpan into one or more consecutive spans at the specified interval.-splitSpan :: Interval -> DateSpan -> [DateSpan]-splitSpan _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing]-splitSpan NoInterval s = [s]-splitSpan Daily s      = splitspan startofday     nextday     s-splitSpan Weekly s     = splitspan startofweek    nextweek    s-splitSpan Monthly s    = splitspan startofmonth   nextmonth   s-splitSpan Quarterly s  = splitspan startofquarter nextquarter s-splitSpan Yearly s     = splitspan startofyear    nextyear    s--splitspan :: (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]-splitspan _ _ (DateSpan Nothing Nothing) = []-splitspan start next (DateSpan Nothing (Just e)) = [DateSpan (Just $ start e) (Just $ next $ start e)]-splitspan start next (DateSpan (Just b) Nothing) = [DateSpan (Just $ start b) (Just $ next $ start b)]-splitspan start next span@(DateSpan (Just b) (Just e))-    | b == e = [span]-    | otherwise = splitspan' start next span-    where-      splitspan' start next (DateSpan (Just b) (Just e))-          | b >= e = []-          | otherwise = DateSpan (Just s) (Just n)-                        : splitspan' start next (DateSpan (Just n) (Just e))-          where s = start b-                n = next s-      splitspan' _ _ _ = error "won't happen, avoids warnings"---- | Count the days in a DateSpan, or if it is open-ended return Nothing.-daysInSpan :: DateSpan -> Maybe Integer-daysInSpan (DateSpan (Just d1) (Just d2)) = Just $ diffDays d2 d1-daysInSpan _ = Nothing-    --- | Parse a period expression to an Interval and overall DateSpan using--- the provided reference date.-parsePeriodExpr :: Day -> String -> (Interval, DateSpan)-parsePeriodExpr refdate expr = (interval,span)-    where (interval,span) = fromparse $ parsewith (periodexpr refdate) expr-    --- | Convert a single smart date string to a date span using the provided--- reference date.-spanFromSmartDateString :: Day -> String -> DateSpan-spanFromSmartDateString refdate s = spanFromSmartDate refdate sdate-    where-      sdate = fromparse $ parsewith smartdate s--spanFromSmartDate :: Day -> SmartDate -> DateSpan-spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e)-    where-      (ry,rm,_) = toGregorian refdate-      (b,e) = span sdate-      span :: SmartDate -> (Day,Day)-      span ("","","today")       = (refdate, nextday refdate)-      span ("","this","day")     = (refdate, nextday refdate)-      span ("","","yesterday")   = (prevday refdate, refdate)-      span ("","last","day")     = (prevday refdate, refdate)-      span ("","","tomorrow")    = (nextday refdate, addDays 2 refdate)-      span ("","next","day")     = (nextday refdate, addDays 2 refdate)-      span ("","last","week")    = (prevweek refdate, thisweek refdate)-      span ("","this","week")    = (thisweek refdate, nextweek refdate)-      span ("","next","week")    = (nextweek refdate, startofweek $ addDays 14 refdate)-      span ("","last","month")   = (prevmonth refdate, thismonth refdate)-      span ("","this","month")   = (thismonth refdate, nextmonth refdate)-      span ("","next","month")   = (nextmonth refdate, startofmonth $ addGregorianMonthsClip 2 refdate)-      span ("","last","quarter") = (prevquarter refdate, thisquarter refdate)-      span ("","this","quarter") = (thisquarter refdate, nextquarter refdate)-      span ("","next","quarter") = (nextquarter refdate, startofquarter $ addGregorianMonthsClip 6 refdate)-      span ("","last","year")    = (prevyear refdate, thisyear refdate)-      span ("","this","year")    = (thisyear refdate, nextyear refdate)-      span ("","next","year")    = (nextyear refdate, startofyear $ addGregorianYearsClip 2 refdate)-      span ("","",d)             = (day, nextday day) where day = fromGregorian ry rm (read d)-      span ("",m,"")             = (startofmonth day, nextmonth day) where day = fromGregorian ry (read m) 1-      span ("",m,d)              = (day, nextday day) where day = fromGregorian ry (read m) (read d)-      span (y,"","")             = (startofyear day, nextyear day) where day = fromGregorian (read y) 1 1-      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--- the provided reference date.-fixSmartDateStr :: Day -> String -> String-fixSmartDateStr t s = printf "%04d/%02d/%02d" y m d-    where-      (y,m,d) = toGregorian $ fixSmartDate t sdate-      sdate = fromparse $ parsewith smartdate $ lowercase s---- | Convert a SmartDate to an absolute date using the provided reference date.-fixSmartDate :: Day -> SmartDate -> Day-fixSmartDate refdate sdate = fix sdate-    where-      fix :: SmartDate -> Day-      fix ("","","today")       = fromGregorian ry rm rd-      fix ("","this","day")     = fromGregorian ry rm rd-      fix ("","","yesterday")   = prevday refdate-      fix ("","last","day")     = prevday refdate-      fix ("","","tomorrow")    = nextday refdate-      fix ("","next","day")     = nextday refdate-      fix ("","last","week")    = prevweek refdate-      fix ("","this","week")    = thisweek refdate-      fix ("","next","week")    = nextweek refdate-      fix ("","last","month")   = prevmonth refdate-      fix ("","this","month")   = thismonth refdate-      fix ("","next","month")   = nextmonth refdate-      fix ("","last","quarter") = prevquarter refdate-      fix ("","this","quarter") = thisquarter refdate-      fix ("","next","quarter") = nextquarter refdate-      fix ("","last","year")    = prevyear refdate-      fix ("","this","year")    = thisyear refdate-      fix ("","next","year")    = nextyear refdate-      fix ("","",d)             = fromGregorian ry rm (read d)-      fix ("",m,"")             = fromGregorian ry (read m) 1-      fix ("",m,d)              = fromGregorian ry (read m) (read d)-      fix (y,"","")             = fromGregorian (read y) 1 1-      fix (y,m,"")              = fromGregorian (read y) (read m) 1-      fix (y,m,d)               = fromGregorian (read y) (read m) (read d)-      (ry,rm,rd) = toGregorian refdate--prevday :: Day -> Day-prevday = addDays (-1)-nextday = addDays 1-startofday = id--thisweek = startofweek-prevweek = startofweek . addDays (-7)-nextweek = startofweek . addDays 7-startofweek day = fromMondayStartWeek y w 1-    where-      (y,_,_) = toGregorian day-      (w,_) = mondayStartWeek day--thismonth = startofmonth-prevmonth = startofmonth . addGregorianMonthsClip (-1)-nextmonth = startofmonth . addGregorianMonthsClip 1-startofmonth day = fromGregorian y m 1 where (y,m,_) = toGregorian day--thisquarter = startofquarter-prevquarter = startofquarter . addGregorianMonthsClip (-3)-nextquarter = startofquarter . addGregorianMonthsClip 3-startofquarter day = fromGregorian y (firstmonthofquarter m) 1-    where-      (y,m,_) = toGregorian day-      firstmonthofquarter m = ((m-1) `div` 3) * 3 + 1--thisyear = startofyear-prevyear = startofyear . addGregorianYearsClip (-1)-nextyear = startofyear . addGregorianYearsClip 1-startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day--------------------------------------------------------------------------- parsing--firstJust ms = case dropWhile (==Nothing) ms of-    [] -> Nothing-    (md:_) -> md--parsedatetimeM :: String -> Maybe LocalTime-parsedatetimeM s = firstJust [-    parseTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" s,-    parseTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" s-    ]---- | Parse a date-time string to a time type, or raise an error.-parsedatetime :: String -> LocalTime-parsedatetime s = fromMaybe (error $ "could not parse timestamp \"" ++ s ++ "\"")-                            (parsedatetimeM s)---- | Parse a date string to a time type, or raise an error.-parsedateM :: String -> Maybe Day-parsedateM s = firstJust [ -     parseTime defaultTimeLocale "%Y/%m/%d" s,-     parseTime defaultTimeLocale "%Y-%m-%d" s -     ]---- | Parse a date string to a time type, or raise an error.-parsedate :: String -> Day-parsedate s =  fromMaybe (error $ "could not parse date \"" ++ s ++ "\"")-                         (parsedateM s)---- | Parse a time string to a time type using the provided pattern, or--- return the default.-parsetimewith :: ParseTime t => String -> String -> t -> t-parsetimewith pat s def = fromMaybe def $ parseTime defaultTimeLocale pat s--{-| -Parse a date in any of the formats allowed in ledger's period expressions,-and maybe some others:--> 2004-> 2004/10-> 2004/10/1-> 10/1-> 21-> october, oct-> yesterday, today, tomorrow-> (not yet) this/next/last week/day/month/quarter/year--Returns a SmartDate, to be converted to a full date later (see fixSmartDate).-Assumes any text in the parse stream has been lowercased.--}-smartdate :: GenParser Char st SmartDate-smartdate = do-  let dateparsers = [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow,-                     lastthisnextthing-                    ]-  (y,m,d) <- choice $ map try dateparsers-  return (y,m,d)--datesepchar = oneOf "/-."--yyyymmdd :: GenParser Char st SmartDate-yyyymmdd = do-  y <- count 4 digit-  m <- count 2 digit-  guard (read m <= 12)-  d <- count 2 digit-  guard (read d <= 31)-  return (y,m,d)--ymd :: GenParser Char st SmartDate-ymd = do-  y <- many1 digit-  datesepchar-  m <- try (count 2 digit) <|> count 1 digit-  guard (read m >= 1 && (read m <= 12))-  -- when (read m < 1 || (read m > 12)) $ fail "bad month number specified"-  datesepchar-  d <- try (count 2 digit) <|> count 1 digit-  when (read d < 1 || (read d > 31)) $ fail "bad day number specified"-  return $ (y,m,d)--ym :: GenParser Char st SmartDate-ym = do-  y <- many1 digit-  guard (read y > 12)-  datesepchar-  m <- try (count 2 digit) <|> count 1 digit-  guard (read m >= 1 && (read m <= 12))-  return (y,m,"")--y :: GenParser Char st SmartDate-y = do-  y <- many1 digit-  guard (read y >= 1000)-  return (y,"","")--d :: GenParser Char st SmartDate-d = do-  d <- many1 digit-  guard (read d <= 31)-  return ("","",d)--md :: GenParser Char st SmartDate-md = do-  m <- try (count 2 digit) <|> count 1 digit-  guard (read m >= 1 && (read m <= 12))-  datesepchar-  d <- try (count 2 digit) <|> count 1 digit-  when (read d < 1 || (read d > 31)) $ fail "bad day number specified"-  return ("",m,d)--months         = ["january","february","march","april","may","june",-                  "july","august","september","october","november","december"]-monthabbrevs   = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"]-weekdays       = ["monday","tuesday","wednesday","thursday","friday","saturday","sunday"]-weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"]--monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months-monIndex s   = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs--month :: GenParser Char st SmartDate-month = do-  m <- choice $ map (try . string) months-  let i = monthIndex m-  return ("",show i,"")--mon :: GenParser Char st SmartDate-mon = do-  m <- choice $ map (try . string) monthabbrevs-  let i = monIndex m-  return ("",show i,"")--today,yesterday,tomorrow :: GenParser Char st SmartDate-today     = string "today"     >> return ("","","today")-yesterday = string "yesterday" >> return ("","","yesterday")-tomorrow  = string "tomorrow"  >> return ("","","tomorrow")--lastthisnextthing :: GenParser Char st SmartDate-lastthisnextthing = do-  r <- choice [-        string "last"-       ,string "this"-       ,string "next"-      ]-  many spacenonewline  -- make the space optional for easier scripting-  p <- choice [-        string "day"-       ,string "week"-       ,string "month"-       ,string "quarter"-       ,string "year"-      ]--- XXX support these in fixSmartDate---       ++ (map string $ months ++ monthabbrevs ++ weekdays ++ weekdayabbrevs)-            -  return ("",r,p)--periodexpr :: Day -> GenParser Char st (Interval, DateSpan)-periodexpr rdate = choice $ map try [-                    intervalanddateperiodexpr rdate,-                    intervalperiodexpr,-                    dateperiodexpr rdate,-                    (return (NoInterval,DateSpan Nothing Nothing))-                   ]--intervalanddateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan)-intervalanddateperiodexpr rdate = do-  many spacenonewline-  i <- periodexprinterval-  many spacenonewline-  s <- periodexprdatespan rdate-  return (i,s)--intervalperiodexpr :: GenParser Char st (Interval, DateSpan)-intervalperiodexpr = do-  many spacenonewline-  i <- periodexprinterval-  return (i, DateSpan Nothing Nothing)--dateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan)-dateperiodexpr rdate = do-  many spacenonewline-  s <- periodexprdatespan rdate-  return (NoInterval, s)--periodexprinterval :: GenParser Char st Interval-periodexprinterval = -    choice $ map try [-                tryinterval "day" "daily" Daily,-                tryinterval "week" "weekly" Weekly,-                tryinterval "month" "monthly" Monthly,-                tryinterval "quarter" "quarterly" Quarterly,-                tryinterval "year" "yearly" Yearly-               ]-    where-      tryinterval s1 s2 v = -          choice [try (string $ "every "++s1), try (string s2)] >> return v--periodexprdatespan :: Day -> GenParser Char st DateSpan-periodexprdatespan rdate = choice $ map try [-                            doubledatespan rdate,-                            fromdatespan rdate,-                            todatespan rdate,-                            justdatespan rdate-                           ]--doubledatespan :: Day -> GenParser Char st DateSpan-doubledatespan rdate = do-  optional (string "from" >> many spacenonewline)-  b <- smartdate-  many spacenonewline-  optional (string "to" >> many spacenonewline)-  e <- smartdate-  return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e)--fromdatespan :: Day -> GenParser Char st DateSpan-fromdatespan rdate = do-  string "from" >> many spacenonewline-  b <- smartdate-  return $ DateSpan (Just $ fixSmartDate rdate b) Nothing--todatespan :: Day -> GenParser Char st DateSpan-todatespan rdate = do-  string "to" >> many spacenonewline-  e <- smartdate-  return $ DateSpan Nothing (Just $ fixSmartDate rdate e)--justdatespan :: Day -> GenParser Char st DateSpan-justdatespan rdate = do-  optional (string "in" >> many spacenonewline)-  d <- smartdate-  return $ spanFromSmartDate rdate d--nulldatespan = DateSpan Nothing Nothing--mkdatespan b = DateSpan (Just $ parsedate b) . Just . parsedate--nulldate = parsedate "1900/01/01"

@@ -1,96 +0,0 @@-{-|-Utilities for doing I/O with ledger files.--}--module Ledger.IO-where-import Control.Monad.Error-import Ledger.Ledger (cacheLedger', nullledger)-import Ledger.Parse (parseLedger)-import Ledger.Types (FilterSpec(..),WhichDate(..),Journal(..),Ledger(..))-import Ledger.Utils (getCurrentLocalTime)-import Ledger.Dates (nulldatespan)-import System.Directory (getHomeDirectory)-import System.Environment (getEnv)-import Prelude hiding (readFile)-import System.IO.UTF8-import System.FilePath ((</>))-import System.Time (getClockTime)---ledgerenvvar           = "LEDGER"-timelogenvvar          = "TIMELOG"-ledgerdefaultfilename  = ".ledger"-timelogdefaultfilename = ".timelog"--nullfilterspec = FilterSpec {-     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-myLedgerPath = -    getEnv ledgerenvvar `catch` -               (\_ -> do-                  home <- getHomeDirectory `catch` (\_ -> return "")-                  return $ home </> ledgerdefaultfilename)-  --- | Get the user's default timelog file path.-myTimelogPath :: IO String-myTimelogPath =-    getEnv timelogenvvar `catch`-               (\_ -> do-                  home <- getHomeDirectory-                  return $ home </> timelogdefaultfilename)---- | Read the user's default ledger file, or give an error.-myLedger :: IO Ledger-myLedger = myLedgerPath >>= readLedger---- | Read the user's default timelog file, or give an error.-myTimelog :: IO Ledger-myTimelog = myTimelogPath >>= readLedger---- | Read a ledger from this file, with no filtering, or give an error.-readLedger :: FilePath -> IO Ledger-readLedger f = do-  t <- getClockTime-  s <- readFile f-  j <- journalFromString s-  return $ cacheLedger' $ nullledger{journal=j{filepath=f,filereadtime=t,jtext=s}}---- -- | 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.-journalFromString :: String -> IO Journal-journalFromString s = do-  t <- getCurrentLocalTime-  liftM (either error id) $ runErrorT $ parseLedger t "(string)" s---- -- | Expand ~ in a file path (does not handle ~name).--- tildeExpand :: FilePath -> IO FilePath--- tildeExpand ('~':[])     = getHomeDirectory--- tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs))--- --handle ~name, requires -fvia-C or ghc 6.8:--- --import System.Posix.User--- -- tildeExpand ('~':xs)     =  do let (user, path) = span (/= '/') xs--- --                                pw <- getUserEntryForName user--- --                                return (homeDirectory pw ++ path)--- tildeExpand xs           =  return xs-

@@ -1,321 +0,0 @@-{-|--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,180 +0,0 @@-{-|--A compound data type for efficiency. A 'Ledger' caches information derived-from a 'Journal' for easier querying. Also it typically has had-uninteresting 'Transaction's and 'Posting's filtered out. It-contains:--- the original unfiltered 'Journal'--- a tree of 'AccountName's--- a map from account names to 'Account's--- the full text of the journal file, when available--This is the main object you'll deal with as a user of the Ledger-library. The most useful functions also have shorter, lower-case-aliases for easier interaction. Here's an example:--> > import Ledger-> > l <- readLedger "sample.ledger"-> > accountnames l-> ["assets","assets:bank","assets:bank:checking","assets:bank:saving",...-> > accounts l-> [Account assets with 0 txns and $-1 balance,Account assets:bank with...-> > topaccounts l-> [Account assets with 0 txns and $-1 balance,Account expenses with...-> > account l "assets"-> Account assets with 0 txns and $-1 balance-> > accountsmatching ["ch"] l-> accountsmatching ["ch"] l-> [Account assets:bank:checking with 4 txns and $0 balance]-> > subaccounts l (account l "assets")-> subaccounts l (account l "assets")-> [Account assets:bank with 0 txns and $1 balance,Account assets:cash...-> > head $ transactions l-> 2008/01/01 income assets:bank:checking $1 RegularPosting-> > accounttree 2 l-> Node {rootLabel = Account top with 0 txns and 0 balance, subForest = [...-> > accounttreeat l (account l "assets")-> Just (Node {rootLabel = Account assets with 0 txns and $-1 balance, ...-> > datespan l -- disabled-> DateSpan (Just 2008-01-01) (Just 2009-01-01)-> > rawdatespan l-> DateSpan (Just 2008-01-01) (Just 2009-01-01)-> > ledgeramounts l-> [$1,$-1,$1,$-1,$1,$-1,$1,$1,$-2,$1,$-1]-> > commodities l-> [Commodity {symbol = "$", side = L, spaced = False, comma = False, ...----}--module Ledger.Ledger-where-import qualified Data.Map as Map-import Data.Map (findWithDefault, fromList)-import Ledger.Utils-import Ledger.Types-import Ledger.Account (nullacct)-import Ledger.AccountName-import Ledger.Journal-import Ledger.Posting---instance Show Ledger where-    show l = printf "Ledger with %d transactions, %d accounts\n%s"-             (length (jtxns $ journal l) +-              length (jmodifiertxns $ journal l) +-              length (jperiodictxns $ journal l))-             (length $ accountnames l)-             (showtree $ accountnametree l)--nullledger :: Ledger-nullledger = Ledger{-      journal = nulljournal,-      accountnametree = nullaccountnametree,-      accountmap = fromList []-    }---- | 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 (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---- | 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--type CachedLedger = Ledger---- | List a ledger's account names.-ledgerAccountNames :: Ledger -> [AccountName]-ledgerAccountNames = drop 1 . flatten . accountnametree---- | 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 l a = findWithDefault nullacct a $ accountmap l---- | List a ledger's accounts, in tree order-ledgerAccounts :: Ledger -> [Account]-ledgerAccounts = drop 1 . flatten . ledgerAccountTree 9999---- | List a ledger's top-level accounts, in tree order-ledgerTopAccounts :: Ledger -> [Account]-ledgerTopAccounts = map root . branches . ledgerAccountTree 9999---- | Accounts in ledger whose name matches the pattern, in tree order.-ledgerAccountsMatching :: [String] -> Ledger -> [Account]-ledgerAccountsMatching pats = filter (matchpats pats . aname) . accounts---- | List a ledger account's immediate subaccounts-ledgerSubAccounts :: Ledger -> Account -> [Account]-ledgerSubAccounts l Account{aname=a} = -    map (ledgerAccount l) $ filter (`isSubAccountNameOf` a) $ accountnames l---- | 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-ledgerAccountTree depth l = treemap (ledgerAccount l) $ treeprune depth $ accountnametree l---- | Get a ledger's tree of accounts rooted at the specified account.-ledgerAccountTreeAt :: Ledger -> Account -> Maybe (Tree Account)-ledgerAccountTreeAt l acct = subtreeat acct $ ledgerAccountTree 9999 l---- | The (fully specified) date span containing all the ledger's (filtered) transactions,--- or DateSpan Nothing Nothing if there are none.-ledgerDateSpan :: Ledger -> DateSpan-ledgerDateSpan = postingsDateSpan . ledgerPostings---- | Convenience aliases.-accountnames :: Ledger -> [AccountName]-accountnames = ledgerAccountNames--account :: Ledger -> AccountName -> Account-account = ledgerAccount--accounts :: Ledger -> [Account]-accounts = ledgerAccounts--topaccounts :: Ledger -> [Account]-topaccounts = ledgerTopAccounts--accountsmatching :: [String] -> Ledger -> [Account]-accountsmatching = ledgerAccountsMatching--subaccounts :: Ledger -> Account -> [Account]-subaccounts = ledgerSubAccounts--postings :: Ledger -> [Posting]-postings = ledgerPostings--commodities :: Ledger -> [Commodity]-commodities = nub . journalCommodities . journal--accounttree :: Int -> Ledger -> Tree Account-accounttree = ledgerAccountTree--accounttreeat :: Ledger -> Account -> Maybe (Tree Account)-accounttreeat = ledgerAccountTreeAt---- datespan :: Ledger -> DateSpan--- datespan = ledgerDateSpan--rawdatespan :: Ledger -> DateSpan-rawdatespan = journalDateSpan . journal--ledgeramounts :: Ledger -> [MixedAmount]-ledgeramounts = journalAmounts . journal

@@ -1,587 +0,0 @@-{-|--Parsers for standard ledger and timelog files.---}--module Ledger.Parse-where-import Prelude hiding (readFile, putStr, putStrLn, print, getContents)-import Control.Monad.Error (ErrorT(..), MonadIO, liftIO, throwError, catchError)-import Text.ParserCombinators.Parsec-import Text.ParserCombinators.Parsec.Char-import Text.ParserCombinators.Parsec.Combinator-import System.Directory-import System.IO.UTF8-import Ledger.Utils-import Ledger.Types-import Ledger.Dates-import Ledger.AccountName (accountNameFromComponents,accountNameComponents)-import Ledger.Amount-import Ledger.Transaction-import Ledger.Posting-import Ledger.Journal-import System.FilePath(takeDirectory,combine)----- utils---- | Some context kept during parsing.-data LedgerFileCtx = Ctx {-      ctxYear     :: !(Maybe Integer)  -- ^ the default year most recently specified with Y-    , ctxCommod   :: !(Maybe String)   -- ^ I don't know-    , ctxAccount  :: ![String]         -- ^ the current stack of "container" accounts specified by !account-    } deriving (Read, Show)--emptyCtx :: LedgerFileCtx-emptyCtx = Ctx { ctxYear = Nothing, ctxCommod = Nothing, ctxAccount = [] }---- containing accounts "nest" hierarchically--pushParentAccount :: String -> GenParser tok LedgerFileCtx ()-pushParentAccount parent = updateState addParentAccount-    where addParentAccount ctx0 = ctx0 { ctxAccount = normalize parent : ctxAccount ctx0 }-          normalize = (++ ":") --popParentAccount :: GenParser tok LedgerFileCtx ()-popParentAccount = do ctx0 <- getState-                      case ctxAccount ctx0 of-                        [] -> unexpected "End of account block with no beginning"-                        (_:rest) -> setState $ ctx0 { ctxAccount = rest }--getParentAccount :: GenParser tok LedgerFileCtx String-getParentAccount = liftM (concat . reverse . ctxAccount) getState--setYear :: Integer -> GenParser tok LedgerFileCtx ()-setYear y = updateState (\ctx -> ctx{ctxYear=Just y})--getYear :: GenParser tok LedgerFileCtx (Maybe Integer)-getYear = liftM ctxYear getState--printParseError :: (Show a) => a -> IO ()-printParseError e = do putStr "ledger parse error at "; print e---- let's get to it--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 Journal-parseLedger reftime inname intxt =-  case runParser ledgerFile emptyCtx inname intxt of-    Right m  -> liftM (journalConvertTimeLog reftime) $ m `ap` return nulljournal-    Left err -> throwError $ show err---ledgerFile :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal))-ledgerFile = do items <- many ledgerItem-                eof-                return $ liftM (foldr (.) id) $ sequence items-    where -      -- As all ledger line types can be distinguished by the first-      -- character, excepting transactions versus empty (blank or-      -- comment-only) lines, can use choice w/o try-      ledgerItem = choice [ ledgerDirective-                          , liftM (return . addTransaction) ledgerTransaction-                          , liftM (return . addModifierTransaction) ledgerModifierTransaction-                          , liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction-                          , liftM (return . addHistoricalPrice) ledgerHistoricalPrice-                          , ledgerDefaultYear-                          , emptyLine >> return (return id)-                          , liftM (return . addTimeLogEntry)  timelogentry-                          ]--ledgerDirective :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal))-ledgerDirective = do char '!' <?> "directive"-                     directive <- many nonspace-                     case directive of-                       "include" -> ledgerInclude-                       "account" -> ledgerAccountBegin-                       "end"     -> ledgerAccountEnd-                       _         -> mzero--ledgerInclude :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal))-ledgerInclude = do many1 spacenonewline-                   filename <- restofline-                   outerState <- getState-                   outerPos <- getPosition-                   let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"-                   return $ do contents <- expandPath outerPos filename >>= readFileE outerPos-                               case runParser ledgerFile outerState filename contents of-                                 Right l   -> l `catchError` (throwError . (inIncluded ++))-                                 Left perr -> throwError $ inIncluded ++ show perr-    where readFileE outerPos filename = ErrorT $ liftM Right (readFile filename) `catch` leftError-              where leftError err = return $ Left $ currentPos ++ whileReading ++ show err-                    currentPos = show outerPos-                    whileReading = " reading " ++ show filename ++ ":\n"--expandPath :: (MonadIO m) => SourcePos -> FilePath -> m FilePath-expandPath pos fp = liftM mkRelative (expandHome fp)-  where-    mkRelative = combine (takeDirectory (sourceName pos))-    expandHome inname | "~/" `isPrefixOf` inname = do homedir <- liftIO getHomeDirectory-                                                      return $ homedir ++ drop 1 inname-                      | otherwise                = return inname--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 (Journal -> Journal))-ledgerAccountEnd = popParentAccount >> return (return id)---- parsers---- | 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.--{-| Parse a ledger file. Here is the ledger grammar from the ledger 2.5 manual:--@-The ledger file format is quite simple, but also very flexible. It supports-many options, though typically the user can ignore most of them. They are-summarized below.  The initial character of each line determines what the-line means, and how it should be interpreted. Allowable initial characters-are:--NUMBER      A line beginning with a number denotes an entry. It may be followed by any-            number of lines, each beginning with whitespace, to denote the entry’s account-            transactions. The format of the first line is:--                    DATE[=EDATE] [*|!] [(CODE)] DESC--            If ‘*’ appears after the date (with optional effective date), it indicates the entry-            is “cleared”, which can mean whatever the user wants it t omean. If ‘!’ appears-            after the date, it indicates d the entry is “pending”; i.e., tentatively cleared from-            the user’s point of view, but not yet actually cleared. If a ‘CODE’ appears in-            parentheses, it may be used to indicate a check number, or the type of the-            transaction. Following these is the payee, or a description of the transaction.-            The format of each following transaction is:--                      ACCOUNT     AMOUNT    [; NOTE]--            The ‘ACCOUNT’ may be surrounded by parentheses if it is a virtual-            transactions, or square brackets if it is a virtual transactions that must-            balance. The ‘AMOUNT’ can be followed by a per-unit transaction cost,-            by specifying ‘ AMOUNT’, or a complete transaction cost with ‘\@ AMOUNT’.-            Lastly, the ‘NOTE’ may specify an actual and/or effective date for the-            transaction by using the syntax ‘[ACTUAL_DATE]’ or ‘[=EFFECTIVE_DATE]’ or-            ‘[ACTUAL_DATE=EFFECtIVE_DATE]’.--=           An automated entry. A value expression must appear after the equal sign.-            After this initial line there should be a set of one or more transactions, just as-            if it were normal entry. If the amounts of the transactions have no commodity,-            they will be applied as modifiers to whichever real transaction is matched by-            the value expression.- -~           A period entry. A period expression must appear after the tilde.-            After this initial line there should be a set of one or more transactions, just as-            if it were normal entry.--!           A line beginning with an exclamation mark denotes a command directive. It-            must be immediately followed by the command word. The supported commands-            are:--           ‘!include’-                        Include the stated ledger file.-           ‘!account’-                        The account name is given is taken to be the parent of all transac--                        tions that follow, until ‘!end’ is seen.-           ‘!end’       Ends an account block.- -;          A line beginning with a colon indicates a comment, and is ignored.- -Y          If a line begins with a capital Y, it denotes the year used for all subsequent-           entries that give a date without a year. The year should appear immediately-           after the Y, for example: ‘Y2004’. This is useful at the beginning of a file, to-           specify the year for that file. If all entries specify a year, however, this command-           has no effect.-           - -P          Specifies a historical price for a commodity. These are usually found in a pricing-           history file (see the ‘-Q’ option). The syntax is:--                  P DATE SYMBOL PRICE--N SYMBOL   Indicates that pricing information is to be ignored for a given symbol, nor will-           quotes ever be downloaded for that symbol. Useful with a home currency, such-           as the dollar ($). It is recommended that these pricing options be set in the price-           database file, which defaults to ‘~/.pricedb’. The syntax for this command is:--                  N SYMBOL--        -D AMOUNT   Specifies the default commodity to use, by specifying an amount in the expected-           format. The entry command will use this commodity as the default when none-           other can be determined. This command may be used multiple times, to set-           the default flags for different commodities; whichever is seen last is used as the-           default commodity. For example, to set US dollars as the default commodity,-           while also setting the thousands flag and decimal flag for that commodity, use:--                  D $1,000.00--C AMOUNT1 = AMOUNT2-           Specifies a commodity conversion, where the first amount is given to be equiv--           alent to the second amount. The first amount should use the decimal precision-           desired during reporting:--                  C 1.00 Kb = 1024 bytes--i, o, b, h-           These four relate to timeclock support, which permits ledger to read timelog-           files. See the timeclock’s documentation for more info on the syntax of its-           timelog files.-@--See "Tests" for sample data.--}--emptyLine :: GenParser Char st ()-emptyLine = do many spacenonewline-               optional $ (char ';' <?> "comment") >> many (noneOf "\n")-               newline-               return ()--ledgercomment :: GenParser Char st String-ledgercomment = do-  many1 $ char ';'-  many spacenonewline-  many (noneOf "\n")-  <?> "comment"--ledgercommentline :: GenParser Char st String-ledgercommentline = do-  many spacenonewline-  s <- ledgercomment-  optional newline-  eof-  return s-  <?> "comment"--ledgerModifierTransaction :: GenParser Char LedgerFileCtx ModifierTransaction-ledgerModifierTransaction = do-  char '=' <?> "modifier transaction"-  many spacenonewline-  valueexpr <- restofline-  postings <- ledgerpostings-  return $ ModifierTransaction valueexpr postings--ledgerPeriodicTransaction :: GenParser Char LedgerFileCtx PeriodicTransaction-ledgerPeriodicTransaction = do-  char '~' <?> "periodic transaction"-  many spacenonewline-  periodexpr <- restofline-  postings <- ledgerpostings-  return $ PeriodicTransaction periodexpr postings--ledgerHistoricalPrice :: GenParser Char LedgerFileCtx HistoricalPrice-ledgerHistoricalPrice = do-  char 'P' <?> "historical price"-  many spacenonewline-  date <- try (do {LocalTime d _ <- ledgerdatetime; return d}) <|> ledgerdate -- a time is ignored-  many1 spacenonewline-  symbol <- commoditysymbol-  many spacenonewline-  price <- someamount-  restofline-  return $ HistoricalPrice date symbol price---- like ledgerAccountBegin, updates the LedgerFileCtx-ledgerDefaultYear :: GenParser Char LedgerFileCtx (ErrorT String IO (Journal -> Journal))-ledgerDefaultYear = do-  char 'Y' <?> "default year"-  many spacenonewline-  y <- many1 digit-  let y' = read y-  guard (y' >= 1000)-  setYear y'-  return $ return id---- | 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 Transaction-ledgerTransaction = do-  date <- ledgerdate <?> "transaction"-  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 = txnTieKnot $ Transaction date edate status code description comment postings ""-  case balanceTransaction t of-    Right t' -> return t'-    Left err -> fail err--ledgerdate :: GenParser Char LedgerFileCtx Day-ledgerdate = (try ledgerfulldate <|> ledgerpartialdate) <?> "full or partial date"--ledgerfulldate :: GenParser Char LedgerFileCtx Day-ledgerfulldate = do-  (y,m,d) <- ymd-  return $ fromGregorian (read y) (read m) (read d)---- | Match a partial M/D date in a ledger. Warning, this terminates the--- program if it finds a match when there is no default year specified.-ledgerpartialdate :: GenParser Char LedgerFileCtx Day-ledgerpartialdate = do-  (_,m,d) <- md-  y <- getYear-  when (y==Nothing) $ fail "partial date found, but no default year specified"-  return $ fromGregorian (fromJust y) (read m) (read d)--ledgerdatetime :: GenParser Char LedgerFileCtx LocalTime-ledgerdatetime = do -  day <- ledgerdate-  many1 spacenonewline-  h <- many1 digit-  char ':'-  m <- many1 digit-  s <- optionMaybe $ do-      char ':'-      many1 digit-  let tod = TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s)-  return $ LocalTime day tod--ledgereffectivedate :: Day -> GenParser Char LedgerFileCtx (Maybe Day)-ledgereffectivedate actualdate = do-  char '='-  -- 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-ledgerstatus = try (do { many1 spacenonewline; char '*' <?> "status"; return True } ) <|> return False--ledgercode :: GenParser Char st String-ledgercode = try (do { many1 spacenonewline; char '(' <?> "code"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""---- Complicated to handle intermixed comment lines.. please make me better.-ledgerpostings :: GenParser Char LedgerFileCtx [Posting]-ledgerpostings = do-  ctx <- getState-  let parses p = isRight . parseWithCtx ctx p-  ls <- many1 $ try linebeginningwithspaces-  let ls' = filter (not . (ledgercommentline `parses`)) ls-  guard (not $ null ls')-  return $ map (fromparse . parseWithCtx ctx ledgerposting) ls'-  <?> "postings"--linebeginningwithspaces :: GenParser Char st String-linebeginningwithspaces = do-  sp <- many1 spacenonewline-  c <- nonspace-  cs <- restofline-  return $ sp ++ (c:cs) ++ "\n"--ledgerposting :: GenParser Char LedgerFileCtx Posting-ledgerposting = do-  many1 spacenonewline-  status <- ledgerstatus-  account <- transactionaccountname-  let (ptype, account') = (postingTypeFromAccountName account, unbracket account)-  amount <- postingamount-  many spacenonewline-  comment <- ledgercomment <|> return ""-  restofline-  return (Posting status account' amount comment ptype Nothing)---- Qualify with the parent account from parsing context-transactionaccountname :: GenParser Char LedgerFileCtx AccountName-transactionaccountname = liftM2 (++) getParentAccount ledgeraccountname---- | Account names may have single spaces inside them, and are terminated--- by two or more spaces. They should have one or more components of at--- least one character, separated by the account separator char.--ledgeraccountname :: GenParser Char st String-ledgeraccountname = do-    a <- many1 (nonspace <|> singlespace)-    let a' = striptrailingspace a-    when (accountNameFromComponents (accountNameComponents a') /= a')-         (fail $ "accountname seems ill-formed: "++a')-    return a'-    where -      singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}})-      -- couldn't avoid consuming a final space sometimes, harmless-      striptrailingspace s = if last s == ' ' then init s else s---- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace---     <?> "account name character (non-bracket, non-parenthesis, non-whitespace)"--postingamount :: GenParser Char st MixedAmount-postingamount =-  try (do-        many1 spacenonewline-        someamount <|> return missingamt-      ) <|> return missingamt--someamount :: GenParser Char st MixedAmount-someamount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount --leftsymbolamount :: GenParser Char st MixedAmount-leftsymbolamount = do-  sym <- commoditysymbol -  sp <- many spacenonewline-  (q,p,comma) <- amountquantity-  pri <- priceamount-  let c = Commodity {symbol=sym,side=L,spaced=not $ null sp,comma=comma,precision=p}-  return $ Mixed [Amount c q pri]-  <?> "left-symbol amount"--rightsymbolamount :: GenParser Char st MixedAmount-rightsymbolamount = do-  (q,p,comma) <- amountquantity-  sp <- many spacenonewline-  sym <- commoditysymbol-  pri <- priceamount-  let c = Commodity {symbol=sym,side=R,spaced=not $ null sp,comma=comma,precision=p}-  return $ Mixed [Amount c q pri]-  <?> "right-symbol amount"--nosymbolamount :: GenParser Char st MixedAmount-nosymbolamount = do-  (q,p,comma) <- amountquantity-  pri <- priceamount-  let c = Commodity {symbol="",side=L,spaced=False,comma=comma,precision=p}-  return $ Mixed [Amount c q pri]-  <?> "no-symbol amount"--commoditysymbol :: GenParser Char st String-commoditysymbol = many1 (noneOf "-.0123456789;\n ") <?> "commodity symbol"--priceamount :: GenParser Char st (Maybe MixedAmount)-priceamount =-    try (do-          many spacenonewline-          char '@'-          many spacenonewline-          a <- someamount-          return $ Just a-          ) <|> return Nothing---- gawd.. trying to parse a ledger number without error:---- | parse a ledger-style numeric quantity and also return the number of--- digits to the right of the decimal point and whether thousands are--- separated by comma.-amountquantity :: GenParser Char st (Double, Int, Bool)-amountquantity = do-  sign <- optionMaybe $ string "-"-  (intwithcommas,frac) <- numberparts-  let comma = ',' `elem` intwithcommas-  let precision = length frac-  -- read the actual value. We expect this read to never fail.-  let int = filter (/= ',') intwithcommas-  let int' = if null int then "0" else int-  let frac' = if null frac then "0" else frac-  let sign' = fromMaybe "" sign-  let quantity = read $ sign'++int'++"."++frac'-  return (quantity, precision, comma)-  <?> "commodity quantity"---- | parse the two strings of digits before and after a possible decimal--- point.  The integer part may contain commas, or either part may be--- empty, or there may be no point.-numberparts :: GenParser Char st (String,String)-numberparts = numberpartsstartingwithdigit <|> numberpartsstartingwithpoint--numberpartsstartingwithdigit :: GenParser Char st (String,String)-numberpartsstartingwithdigit = do-  let digitorcomma = digit <|> char ','-  first <- digit-  rest <- many digitorcomma-  frac <- try (do {char '.'; many digit}) <|> return ""-  return (first:rest,frac)-                     -numberpartsstartingwithpoint :: GenParser Char st (String,String)-numberpartsstartingwithpoint = do-  char '.'-  frac <- many1 digit-  return ("",frac)-                     --{-| Parse a timelog entry. Here is the timelog grammar from timeclock.el 2.6:--@-A timelog contains data in the form of a single entry per line.-Each entry has the form:--  CODE YYYY/MM/DD HH:MM:SS [COMMENT]--CODE is one of: b, h, i, o or O.  COMMENT is optional when the code is-i, o or O.  The meanings of the codes are:--  b  Set the current time balance, or \"time debt\".  Useful when-     archiving old log data, when a debt must be carried forward.-     The COMMENT here is the number of seconds of debt.--  h  Set the required working time for the given day.  This must-     be the first entry for that day.  The COMMENT in this case is-     the number of hours in this workday.  Floating point amounts-     are allowed.--  i  Clock in.  The COMMENT in this case should be the name of the-     project worked on.--  o  Clock out.  COMMENT is unnecessary, but can be used to provide-     a description of how the period went, for example.--  O  Final clock out.  Whatever project was being worked on, it is-     now finished.  Useful for creating summary reports.-@--Example:--i 2007/03/10 12:26:00 hledger-o 2007/03/10 17:26:02---}-timelogentry :: GenParser Char LedgerFileCtx TimeLogEntry-timelogentry = do-  code <- oneOf "bhioO"-  many1 spacenonewline-  datetime <- ledgerdatetime-  comment <- optionMaybe (many1 spacenonewline >> liftM2 (++) getParentAccount restofline)-  return $ TimeLogEntry (read [code]) datetime (fromMaybe "" comment)----- misc parsing---- | Parse a --display expression which is a simple date predicate, like--- "d>[DATE]" or "d<=[DATE]", and return a posting-matching predicate.-datedisplayexpr :: GenParser Char st (Posting -> Bool)-datedisplayexpr = do-  char 'd'-  op <- compareop-  char '['-  (y,m,d) <- smartdate-  char ']'-  let date    = parsedate $ printf "%04s/%02s/%02s" y m d-      test op = return $ (`op` date) . postingDate-  case op of-    "<"  -> test (<)-    "<=" -> test (<=)-    "="  -> test (==)-    "==" -> test (==)-    ">=" -> test (>=)-    ">"  -> test (>)-    _    -> mzero--compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"]-

@@ -1,95 +0,0 @@-{-|--A 'Posting' represents a 'MixedAmount' being added to or subtracted from a-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).---}--module Ledger.Posting-where-import Ledger.Utils-import Ledger.Types-import Ledger.Amount-import Ledger.AccountName-import Ledger.Dates (nulldate)---instance Show Posting where show = showPosting--nullposting = Posting False "" nullmixedamt "" RegularPosting Nothing--showPosting :: Posting -> String-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 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{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 t of-                          BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2)-                          VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2)-                          _ -> (id,acctnamewidth)-      showamount = padleft 12 . showMixedAmountOrZeroWithoutPrice-      comment = if null com then "" else "  ; " ++ com--isReal :: Posting -> Bool-isReal p = ptype p == RegularPosting--isVirtual :: Posting -> Bool-isVirtual p = ptype p == VirtualPosting--isBalancedVirtual :: Posting -> Bool-isBalancedVirtual p = ptype p == BalancedVirtualPosting--hasAmount :: Posting -> Bool-hasAmount = (/= missingamt) . pamount--postingTypeFromAccountName a-    | 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,90 +0,0 @@-{-|--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 'Transactions' and queried like a ledger.---}--module Ledger.TimeLog-where-import Ledger.Utils-import Ledger.Types-import Ledger.Dates-import Ledger.Commodity-import Ledger.Transaction--instance Show TimeLogEntry where -    show t = printf "%s %s %s" (show $ tlcode t) (show $ tldatetime t) (tlcomment t)--instance Show TimeLogCode where -    show SetBalance = "b"-    show SetRequiredHours = "h"-    show In = "i"-    show Out = "o"-    show FinalOut = "O"--instance Read TimeLogCode where -    readsPrec _ ('b' : xs) = [(SetBalance, xs)]-    readsPrec _ ('h' : xs) = [(SetRequiredHours, xs)]-    readsPrec _ ('i' : xs) = [(In, xs)]-    readsPrec _ ('o' : xs) = [(Out, xs)]-    readsPrec _ ('O' : xs) = [(FinalOut, xs)]-    readsPrec _ _ = []---- | 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] -> [Transaction]-entriesFromTimeLogEntries _ [] = []-entriesFromTimeLogEntries now [i]-    | odate > idate = entryFromTimeLogInOut i o' : entriesFromTimeLogEntries now [i',o]-    | otherwise = [entryFromTimeLogInOut i o]-    where-      o = TimeLogEntry Out end ""-      end = if itime > now then itime else now-      (itime,otime) = (tldatetime i,tldatetime o)-      (idate,odate) = (localDay itime,localDay otime)-      o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}-      i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}}-entriesFromTimeLogEntries now (i:o:rest)-    | odate > idate = entryFromTimeLogInOut i o' : entriesFromTimeLogEntries now (i':o:rest)-    | otherwise = entryFromTimeLogInOut i o : entriesFromTimeLogEntries now rest-    where-      (itime,otime) = (tldatetime i,tldatetime o)-      (idate,odate) = (localDay itime,localDay otime)-      o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}-      i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}}---- | 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 -> Transaction-entryFromTimeLogInOut i o-    | otime >= itime = t-    | otherwise = -        error $ "clock-out time less than clock-in time in:\n" ++ showTransaction t-    where-      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-      itime    = tldatetime i-      otime    = tldatetime o-      itod     = localTimeOfDay itime-      otod     = localTimeOfDay otime-      idate    = localDay itime-      hrs      = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc-      amount   = Mixed [hours hrs]-      ps       = [Posting{pstatus=False,paccount=acctname,pamount=amount,-                          pcomment="",ptype=RegularPosting,ptransaction=Just t}-                 --,Posting "assets:time" (-amount) "" RegularPosting-                 ]

@@ -1,142 +0,0 @@-{-|--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.Utils-import Ledger.Types-import Ledger.Dates-import Ledger.Posting-import Ledger.Amount---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 = showTransaction' True False--showTransactionUnelided :: Transaction -> String-showTransactionUnelided = showTransaction' False False--showTransactionForPrint :: Bool -> Transaction -> String-showTransactionForPrint effective = showTransaction' False effective--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 ""---- | 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++"]"--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,153 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-|--Most data types are defined here to avoid import cycles.-Here is an overview of the hledger data model:--> 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)--For more detailed documentation on each type, see the corresponding modules.--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 -where-import Ledger.Utils-import qualified Data.Map as Map-import System.Time (ClockTime)-import Data.Typeable (Typeable)---type SmartDate = (String,String,String)--data WhichDate = ActualDate | EffectiveDate deriving (Eq,Show)--data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Show,Ord)--data Interval = NoInterval | Daily | Weekly | Monthly | Quarterly | Yearly -                deriving (Eq,Show,Ord)--type AccountName = String--data Side = L | R deriving (Eq,Show,Ord) --data Commodity = Commodity {-      symbol :: String,  -- ^ the commodity's symbol-      -- display preferences for amounts of this commodity-      side :: Side,      -- ^ should the symbol appear on the left or the right-      spaced :: Bool,    -- ^ should there be a space between symbol and quantity-      comma :: Bool,     -- ^ should thousands be comma-separated-      precision :: Int   -- ^ number of decimal places to display-    } deriving (Eq,Show,Ord)--data Amount = Amount {-      commodity :: Commodity,-      quantity :: Double,-      price :: Maybe MixedAmount  -- ^ unit price/conversion rate for this amount at posting time-    } deriving (Eq)--newtype MixedAmount = Mixed [Amount] deriving (Eq)--data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting-                   deriving (Eq,Show)--data Posting = Posting {-      pstatus :: Bool,-      paccount :: AccountName,-      pamount :: MixedAmount,-      pcomment :: String,-      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]-    } deriving (Eq)--data PeriodicTransaction = PeriodicTransaction {-      ptperiodicexpr :: String,-      ptpostings :: [Posting]-    } deriving (Eq)--data TimeLogCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord) --data TimeLogEntry = TimeLogEntry {-      tlcode :: TimeLogCode,-      tldatetime :: LocalTime,-      tlcomment :: String-    } deriving (Eq,Ord)--data HistoricalPrice = HistoricalPrice {-      hdate :: Day,-      hsymbol :: String,-      hamount :: MixedAmount-    } deriving (Eq) -- & Show (in Amount.hs)--data Journal = Journal {-      jmodifiertxns :: [ModifierTransaction],-      jperiodictxns :: [PeriodicTransaction],-      jtxns :: [Transaction],-      open_timelog_entries :: [TimeLogEntry],-      historical_prices :: [HistoricalPrice],-      final_comment_lines :: String,-      filepath :: FilePath,-      filereadtime :: ClockTime,-      jtext :: String-    } deriving (Eq)--data Account = Account {-      aname :: AccountName,-      apostings :: [Posting],    -- ^ transactions in this account-      abalance :: MixedAmount    -- ^ sum of transactions in this account and subaccounts-    }--data Ledger = Ledger {-      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)-

@@ -1,270 +0,0 @@-{-|--Provide standard imports and utilities which are useful everywhere, or-needed low in the module hierarchy. This is the bottom of the dependency graph.---}--module Ledger.Utils (-module Char,-module Control.Monad,-module Data.List,---module Data.Map,-module Data.Maybe,-module Data.Ord,-module Data.Tree,-module Data.Time.Clock,-module Data.Time.Calendar,-module Data.Time.LocalTime,-module Debug.Trace,-module Ledger.Utils,-module Text.Printf,-module Text.RegexPR,-module Test.HUnit,-)-where-import Prelude hiding (readFile)-import Char-import Control.Exception-import Control.Monad-import Data.List---import qualified Data.Map as Map-import Data.Maybe-import Data.Ord-import Data.Tree-import Data.Time.Clock-import Data.Time.Calendar-import Data.Time.LocalTime-import Debug.Trace-import System.IO.UTF8-import Test.HUnit-import Text.Printf-import Text.RegexPR-import Text.ParserCombinators.Parsec----- strings--lowercase = map toLower-uppercase = map toUpper--strip = lstrip . rstrip-lstrip = dropws-rstrip = reverse . dropws . reverse-dropws = dropWhile (`elem` " \t")--elideLeft width s =-    if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s--elideRight width s =-    if length s > width then take (width - 2) s ++ ".." else s--underline :: String -> String-underline s = s' ++ replicate (length s) '-' ++ "\n"-    where s'-            | last s == '\n' = s-            | otherwise = s ++ "\n"--unbracket :: String -> String-unbracket s-    | (head s == '[' && last s == ']') || (head s == '(' && last s == ')') = init $ tail s-    | otherwise = s---- | Join multi-line strings as side-by-side rectangular strings of the same height, top-padded.-concatTopPadded :: [String] -> String-concatTopPadded strs = intercalate "\n" $ map concat $ transpose padded-    where-      lss = map lines strs-      h = maximum $ map length lss-      ypad ls = replicate (difforzero h (length ls)) "" ++ ls-      xpad ls = map (padleft w) ls where w | null ls = 0-                                           | otherwise = maximum $ map length ls-      padded = map (xpad . ypad) lss---- | Join multi-line strings as side-by-side rectangular strings of the same height, bottom-padded.-concatBottomPadded :: [String] -> String-concatBottomPadded strs = intercalate "\n" $ map concat $ transpose padded-    where-      lss = map lines strs-      h = maximum $ map length lss-      ypad ls = ls ++ replicate (difforzero h (length ls)) ""-      xpad ls = map (padleft w) ls where w | null ls = 0-                                           | otherwise = maximum $ map length ls-      padded = map (xpad . ypad) lss---- | Convert a multi-line string to a rectangular string top-padded to the specified height.-padtop :: Int -> String -> String-padtop h s = intercalate "\n" xpadded-    where-      ls = lines s-      sh = length ls-      sw | null ls = 0-         | otherwise = maximum $ map length ls-      ypadded = replicate (difforzero h sh) "" ++ ls-      xpadded = map (padleft sw) ypadded---- | Convert a multi-line string to a rectangular string bottom-padded to the specified height.-padbottom :: Int -> String -> String-padbottom h s = intercalate "\n" xpadded-    where-      ls = lines s-      sh = length ls-      sw | null ls = 0-         | otherwise = maximum $ map length ls-      ypadded = ls ++ replicate (difforzero h sh) ""-      xpadded = map (padleft sw) ypadded---- | Convert a multi-line string to a rectangular string left-padded to the specified width.-padleft :: Int -> String -> String-padleft w "" = concat $ replicate w " "-padleft w s = intercalate "\n" $ map (printf (printf "%%%ds" w)) $ lines s---- | Convert a multi-line string to a rectangular string right-padded to the specified width.-padright :: Int -> String -> String-padright w "" = concat $ replicate w " "-padright w s = intercalate "\n" $ map (printf (printf "%%-%ds" w)) $ lines s---- | Clip a multi-line string to the specified width and height from the top left.-cliptopleft :: Int -> Int -> String -> String-cliptopleft w h = intercalate "\n" . take h . map (take w) . lines---- | Clip and pad a multi-line string to fill the specified width and height.-fitto :: Int -> Int -> String -> String-fitto w h s = intercalate "\n" $ take h $ rows ++ repeat blankline-    where-      rows = map (fit w) $ lines s-      fit w = take w . (++ repeat ' ')-      blankline = replicate w ' '---- math--difforzero :: (Num a, Ord a) => a -> a -> a-difforzero a b = maximum [(a - b), 0]---- regexps--containsRegex :: String -> String -> Bool-containsRegex r s = case matchRegexPR ("(?i)"++r) s of-                      Just _ -> True-                      _ -> False----- lists--splitAtElement :: Eq a => a -> [a] -> [[a]]-splitAtElement e l = -    case dropWhile (e==) l of-      [] -> []-      l' -> first : splitAtElement e rest-        where-          (first,rest) = break (e==) l'---- trees--root = rootLabel-subs = subForest-branches = subForest---- | List just the leaf nodes of a tree-leaves :: Tree a -> [a]-leaves (Node v []) = [v]-leaves (Node _ branches) = concatMap leaves branches---- | get the sub-tree rooted at the first (left-most, depth-first) occurrence--- of the specified node value-subtreeat :: Eq a => a -> Tree a -> Maybe (Tree a)-subtreeat v t-    | root t == v = Just t-    | otherwise = subtreeinforest v $ subs t---- | get the sub-tree for the specified node value in the first tree in--- forest in which it occurs.-subtreeinforest :: Eq a => a -> [Tree a] -> Maybe (Tree a)-subtreeinforest _ [] = Nothing-subtreeinforest v (t:ts) = case (subtreeat v t) of-                             Just t' -> Just t'-                             Nothing -> subtreeinforest v ts-          --- | remove all nodes past a certain depth-treeprune :: Int -> Tree a -> Tree a-treeprune 0 t = Node (root t) []-treeprune d t = Node (root t) (map (treeprune $ d-1) $ branches t)---- | apply f to all tree nodes-treemap :: (a -> b) -> Tree a -> Tree b-treemap f t = Node (f $ root t) (map (treemap f) $ branches t)---- | remove all subtrees whose nodes do not fulfill predicate-treefilter :: (a -> Bool) -> Tree a -> Tree a-treefilter f t = Node -                 (root t) -                 (map (treefilter f) $ filter (treeany f) $ branches t)-    --- | is predicate true in any node of tree ?-treeany :: (a -> Bool) -> Tree a -> Bool-treeany f t = f (root t) || any (treeany f) (branches t)-    --- treedrop -- remove the leaves which do fulfill predicate. --- treedropall -- do this repeatedly.---- | show a compact ascii representation of a tree-showtree :: Show a => Tree a -> String-showtree = unlines . filter (containsRegex "[^ \\|]") . lines . drawTree . treemap show---- | show a compact ascii representation of a forest-showforest :: Show a => Forest a -> String-showforest = concatMap showtree---- debugging---- | trace (print on stdout at runtime) a showable expression--- (for easily tracing in the middle of a complex expression)-strace :: Show a => a -> a-strace a = trace (show a) a---- | labelled trace - like strace, with a newline and a label prepended-ltrace :: Show a => String -> a -> a-ltrace l a = trace (l ++ ": " ++ show a) a---- | trace an expression using a custom show function-tracewith f e = trace (f e) e---- parsing--parsewith :: Parser a -> String -> Either ParseError a-parsewith p = parse p ""--parseWithCtx :: b -> GenParser Char b a -> String -> Either ParseError a-parseWithCtx ctx p = runParser p ctx ""--fromparse :: Either ParseError a -> a-fromparse = either (\e -> error $ "parse error at "++ show e) id--nonspace :: GenParser Char st Char-nonspace = satisfy (not . isSpace)--spacenonewline :: GenParser Char st Char-spacenonewline = satisfy (`elem` " \v\f\t")--restofline :: GenParser Char st String-restofline = anyChar `manyTill` newline---- time--getCurrentLocalTime :: IO LocalTime-getCurrentLocalTime = do-  t <- getCurrentTime-  tz <- getCurrentTimeZone-  return $ utcToLocalTime tz t---- misc--isLeft :: Either a b -> Bool-isLeft (Left _) = True-isLeft _        = False--isRight :: Either a b -> Bool-isRight = not . isLeft--strictReadFile :: FilePath -> IO String-strictReadFile f = readFile f >>= \s -> Control.Exception.evaluate (length s) >> return s

@@ -11,7 +11,9 @@ import Ledger.Utils import Ledger.Types import Ledger.Dates+#if __GLASGOW_HASKELL__ <= 610 import Codec.Binary.UTF8.String (decodeString)+#endif import Control.Monad (liftM)  progname      = "hledger"@@ -24,11 +26,10 @@  usagehdr =   "Usage: hledger [OPTIONS] [COMMAND [PATTERNS]]\n" ++-  "       hours   [OPTIONS] [COMMAND [PATTERNS]]\n" ++-  "       hledger convert CSVFILE\n" +++  "       hledger [OPTIONS] convert CSVFILE\n" +++  "       hledger [OPTIONS] stats\n" ++   "\n" ++-  "hledger uses your ~/.ledger or $LEDGER file (or another specified with -f),\n" ++-  "while hours uses your ~/.timelog or $TIMELOG file.\n" +++  "hledger uses your ~/.ledger or $LEDGER file, or another specified with -f\n" ++   "\n" ++   "COMMAND is one of (may be abbreviated):\n" ++   "  add       - prompt for new transactions and add them to the ledger\n" ++@@ -149,7 +150,11 @@ -- YYYY/MM/DD format based on the current time. parseArguments :: IO ([Opt], String, [String]) parseArguments = do+#if __GLASGOW_HASKELL__ <= 610   args <- liftM (map decodeString) getArgs+#else+  args <- getArgs+#endif   let (os,as,es) = getOpt Permute options args --  istimequery <- usingTimeProgramName --  let os' = if istimequery then (Period "today"):os else os

@@ -14,12 +14,13 @@ - get accurate numbers for client billing and tax filing - track invoices -Here is a **demo_** of the web interface.+Here is a demo_ of the web interface. -Here are ready-to-run **binaries_** for mac, windows and gnu/linux.+Here are ready-to-run binaries_ for mac, windows and gnu/linux.+They are not always the `latest release`_, sorry about that. -Here is the **manual_**.-For support and more technical info, see **`hledger for techies`_** or **`email me`_**.+Here is the manual_.+For support and more technical info, see `hledger for techies`_ or `email me`_.  .. (If you're reading this in plain text, see also README2, MANUAL etc., or http://hledger.org) @@ -32,3 +33,4 @@ .. _32 bit intel:         http://hledger.org/binaries/hledger-0.6.1+9-linux-i386.gz .. _64 bit intel:         http://hledger.org/binaries/hledger-0.6-linux-x86_64.gz .. _email me:             mailto:simon@joyful.com+.. _latest release:       http://hledger.org/MANUAL.html#installing

@@ -30,18 +30,19 @@ where import qualified Data.Map as Map import Data.Time.Format-import Locale (defaultTimeLocale)-import Text.ParserCombinators.Parsec+import System.Locale (defaultTimeLocale) import Test.HUnit.Tools (runVerboseTests) import System.Exit (exitFailure, exitWith, ExitCode(ExitSuccess)) -- base 3 compatible import System.Time (ClockTime(TOD))  import Commands.All-import Ledger+import Ledger  -- including testing utils in Ledger.Utils import Options import Utils  +-- | Run unit tests.+runtests :: [Opt] -> [String] -> IO () runtests opts args = do   (counts,_) <- runner ts   if errors counts > 0 || (failures counts > 0)@@ -50,41 +51,18 @@     where       runner | Verbose `elem` opts = runVerboseTests              | otherwise = liftM (flip (,) 0) . runTestTT-      ts = TestList $ filter matchname $ concatMap tflatten tests-      --ts = tfilter matchname $ TestList tests -- unflattened+      ts = TestList $ filter matchname $ tflatten tests  -- show flat test names+      -- ts = tfilter matchname $ TestList tests -- show hierarchical test names       matchname = matchpats args . tname --- | Get a Test's label, or the empty string.-tname :: Test -> String-tname (TestLabel n _) = n-tname _ = ""---- | Flatten a Test containing TestLists into a list of single tests.-tflatten :: Test -> [Test]-tflatten (TestLabel _ t@(TestList _)) = tflatten t-tflatten (TestList ts) = concatMap tflatten ts-tflatten t = [t]---- | Filter TestLists in a Test, recursively, preserving the structure.-tfilter :: (Test -> Bool) -> Test -> Test-tfilter p (TestLabel l ts) = TestLabel l (tfilter p ts)-tfilter p (TestList ts) = TestList $ filter (any p . tflatten) $ map (tfilter p) ts-tfilter _ t = t---- | Simple way to assert something is some expected value, with no label.-is :: (Eq a, Show a) => a -> a -> Assertion-a `is` e = assertEqual "" e a---- | Assert a parse result is some expected value, or print a parse error.-parseis :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion-parse `parseis` expected = either printParseError (`is` expected) parse----------------------------------------------------------------------------------- | Tests for any function or topic. Mostly ordered by test name.-tests :: [Test]-tests = [+-- | unit tests, augmenting the ones defined in each module. Where that is+-- inconvenient due to import cycles or whatever, we define them here.+tests :: Test+tests = TestList [+   tests_Ledger,+   tests_Commands, -   "account directive" ~: +   "account directive" ~:    let sameParse str1 str2 = do l1 <- journalFromString str1                                 l2 <- journalFromString str2                                 l1 `is` l2@@ -129,29 +107,6 @@     accountNameTreeFrom ["a","a:b"] `is` Node "top" [Node "a" [Node "a:b" []]]     accountNameTreeFrom ["a:b:c"]   `is` Node "top" [Node "a" [Node "a:b" [Node "a:b:c" []]]] -  ,"amount arithmetic" ~: do-    let a1 = dollars 1.23-    let a2 = Amount (comm "$") (-1.23) Nothing-    let a3 = Amount (comm "$") (-1.23) Nothing-    (a1 + a2) `is` Amount (comm "$") 0 Nothing-    (a1 + a3) `is` Amount (comm "$") 0 Nothing-    (a2 + a3) `is` Amount (comm "$") (-2.46) Nothing-    (a3 + a3) `is` Amount (comm "$") (-2.46) Nothing-    sum [a2,a3] `is` Amount (comm "$") (-2.46) Nothing-    sum [a3,a3] `is` Amount (comm "$") (-2.46) Nothing-    sum [a1,a2,a3,-a3] `is` Amount (comm "$") 0 Nothing-    let dollar0 = dollar{precision=0}-    (sum [Amount dollar 1.25 Nothing, Amount dollar0 (-1) Nothing, Amount dollar (-0.25) Nothing])-      `is` (Amount dollar 0 Nothing)--  ,"mixed amount arithmetic" ~: do-    let dollar0 = dollar{precision=0}-    (sum $ map (Mixed . (\a -> [a]))-             [Amount dollar 1.25 Nothing,-              Amount dollar0 (-1) Nothing,-              Amount dollar (-0.25) Nothing])-      `is` Mixed [Amount dollar 0 Nothing]-   ,"balance report tests" ~:    let (opts,args) `gives` es = do          l <- sampleledgerwithopts opts args@@ -458,27 +413,8 @@     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--  ,"ledgerTransaction" ~: do-    parseWithCtx emptyCtx ledgerTransaction entry1_str `parseis` entry1-    assertBool "ledgerTransaction should not parse just a date"-                   $ isLeft $ parseWithCtx emptyCtx ledgerTransaction "2009/1/1\n"-    assertBool "ledgerTransaction should require some postings"-                   $ 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") . tdescription) t--  ,"ledgeraccountname" ~: do-    assertBool "ledgeraccountname parses a normal accountname" (isRight $ parsewith ledgeraccountname "a:b:c")-    assertBool "ledgeraccountname rejects an empty inner component" (isLeft $ parsewith ledgeraccountname "a::c")-    assertBool "ledgeraccountname rejects an empty leading component" (isLeft $ parsewith ledgeraccountname ":b:c")-    assertBool "ledgeraccountname rejects an empty trailing component" (isLeft $ parsewith ledgeraccountname "a:b:")--  ,"ledgerposting" ~:-    parseWithCtx emptyCtx ledgerposting rawposting1_str `parseis` rawposting1+  ,"normaliseMixedAmount" ~: do+     normaliseMixedAmount (Mixed []) ~?= Mixed [nullamt]    ,"parsedate" ~: do     parsedate "2008/02/03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" date1@@ -672,65 +608,6 @@    ,"show hours" ~: show (hours 1) ~?= "1.0h" -  ,"showTransaction" ~: do-     assertEqual "show a balanced transaction, eliding last amount"-       (unlines-        ["2007/01/28 coopportunity"-        ,"    expenses:food:groceries        $47.18"-        ,"    assets:checking"-        ,""-        ])-       (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"-        ,"    expenses:food:groceries        $47.18"-        ,"    assets:checking               $-47.18"-        ,""-        ])-       (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-        ["2007/01/28 coopportunity"-        ,"    expenses:food:groceries        $47.18"-        ,"    assets:checking               $-47.19"-        ,""-        ])-       (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-        ["2007/01/28 coopportunity"-        ,"    expenses:food:groceries        $47.18"-        ,""-        ])-       (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-        ["2007/01/28 coopportunity"-        ,"    expenses:food:groceries              "-        ,""-        ])-       (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 []       "2009/01/01 * медвежья шкура\n  расходы:покупки  100\n  актив:наличные\n"@@ -780,23 +657,6 @@ --     "next friday"  `gives` "2008/11/28" --     "next january" `gives` "2009/01/01" -  ,"splitSpan" ~: do-    let gives (interval, span) = (splitSpan interval span `is`)-    (NoInterval,mkdatespan "2008/01/01" "2009/01/01") `gives`-     [mkdatespan "2008/01/01" "2009/01/01"]-    (Quarterly,mkdatespan "2008/01/01" "2009/01/01") `gives`-     [mkdatespan "2008/01/01" "2008/04/01"-     ,mkdatespan "2008/04/01" "2008/07/01"-     ,mkdatespan "2008/07/01" "2008/10/01"-     ,mkdatespan "2008/10/01" "2009/01/01"-     ]-    (Quarterly,nulldatespan) `gives`-     [nulldatespan]-    (Daily,mkdatespan "2008/01/01" "2008/01/01") `gives`-     [mkdatespan "2008/01/01" "2008/01/01"]-    (Quarterly,mkdatespan "2008/01/01" "2008/01/01") `gives`-     [mkdatespan "2008/01/01" "2008/01/01"]-   ,"subAccounts" ~: do     l <- liftM cacheLedger' sampleledger     let a = ledgerAccount l "assets"@@ -837,16 +697,10 @@   --     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]-    parseWithCtx emptyCtx postingamount " $1." `parseis` -     Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing]-   ]    ---------------------------------------------------------------------------------- test data+-- fixtures/test data  date1 = parsedate "2008/11/26" t1 = LocalTime date1 midday@@ -907,23 +761,6 @@  write_sample_ledger = writeFile "sample.ledger" sample_ledger_str -rawposting1_str  = "  expenses:food:dining  $10.00\n"--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                          $-47.18"- ,""- ]--entry1 =-    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  ["2007/01/27 * joes diner"  ,"    expenses:food:dining                      $10.00"@@ -1256,9 +1093,6 @@  timelogentry2_str  = "o 2007/03/11 16:30:00\n" timelogentry2 = TimeLogEntry Out (parsedatetime "2007/03/11 16:30:00") ""--price1_str = "P 2004/05/01 XYZ $55.00\n"-price1 = HistoricalPrice (parsedate "2004/05/01") "XYZ" $ Mixed [dollars 55]  a1 = Mixed [(hours 1){price=Just $ Mixed [Amount (comm "$") 10 Nothing]}] a2 = Mixed [(hours 2){price=Just $ Mixed [Amount (comm "EUR") 10 Nothing]}]

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-|  Utilities for top-level modules and ghci. See also "Ledger.IO" and@@ -12,9 +13,13 @@ import Options (Opt(..),ledgerFilePathFromOpts) -- ,optsToFilterSpec) import System.Directory (doesFileExist) import System.IO (stderr)+#if __GLASGOW_HASKELL__ <= 610 import System.IO.UTF8 (hPutStrLn)+#else+import System.IO (hPutStrLn)+#endif import System.Exit-import System.Cmd (system)+import System.Process (readProcessWithExitCode) import System.Info (os) import System.Time (ClockTime,getClockTime) @@ -69,7 +74,7 @@ openBrowserOn u = trybrowsers browsers u     where       trybrowsers (b:bs) u = do-        e <- system $ printf "%s %s" b u+        (e,_,_) <- readProcessWithExitCode b [u] ""         case e of           ExitSuccess -> return ExitSuccess           ExitFailure _ -> trybrowsers bs u@@ -78,8 +83,8 @@         putStrLn $ printf "Please open your browser and visit %s" u         return $ ExitFailure 127       browsers | os=="darwin"  = ["open"]-               | os=="mingw32" = ["start","firefox","safari","opera","iexplore"]-               | otherwise     = ["sensible-browser","firefox"]+               | os=="mingw32" = ["start"]+               | otherwise     = ["sensible-browser","gnome-www-browser","firefox"]     -- jeffz: write a ffi binding for it using the Win32 package as a basis     -- start by adding System/Win32/Shell.hsc and follow the style of any     -- other module in that directory for types, headers, error handling and

@@ -61,13 +61,15 @@               | otherwise = " with " ++ intercalate ", " configflags  configflags   = tail [""+#ifdef CHART+  ,"chart"+#endif #ifdef VTY   ,"vty" #endif-#ifdef WEB-  ,"web"-#endif-#ifdef CHART-  ,"chart"+#if defined(WEB)+  ,"web (using simpleserver)"+#elif defined(WEBHAPPSTACK)+  ,"web (using happstack)" #endif  ]

@@ -1,6 +1,5 @@ name:           hledger--- Version is set by the makefile-version:        0.8+version:        0.9 category:       Finance synopsis:       A command-line (or curses or web-based) double-entry accounting tool. description:@@ -19,7 +18,7 @@ homepage:       http://hledger.org bug-reports:    http://code.google.com/p/hledger/issues stability:      experimental-tested-with:    GHC==6.8, GHC==6.10+tested-with:    GHC==6.10 cabal-version:  >= 1.2 build-type:     Custom data-dir:       data@@ -36,45 +35,41 @@   default:     False  flag web-  description: enable the web ui+  description: enable the web ui (using simpleserver)   default:     False +flag webhappstack+  description: enable the web ui (using happstack)+  default:     False+ flag chart   description: enable the pie chart generation   default:     False +-- minimal library so cabal list and ghc-pkg list will show this package library   exposed-modules:-                  Ledger-                  Ledger.Account-                  Ledger.AccountName-                  Ledger.Amount-                  Ledger.Commodity-                  Ledger.Dates-                  Ledger.IO-                  Ledger.Transaction-                  Ledger.Journal-                  Ledger.Ledger-                  Ledger.Posting-                  Ledger.Parse-                  Ledger.TimeLog-                  Ledger.Types-                  Ledger.Utils-  Build-Depends:-                  base >= 3 && < 5-                 ,containers-                 ,directory-                 ,filepath-                 ,haskell98-                 ,old-time-                 ,parsec-                 ,time-                 ,utf8-string >= 0.3-                 ,HUnit+                  Version+--   Build-Depends:+--                   base >= 3 && < 5+--                  ,containers+--                  ,directory+--                  ,filepath+--                  ,old-time+--                  ,parsec+--                  ,time+--                  ,utf8-string >= 0.3+--                  ,HUnit  executable hledger   main-is:        hledger.hs   other-modules:+                  HledgerMain+                  Options+                  Paths_hledger+                  Tests+                  Utils+                  Version                   Commands.Add                   Commands.All                   Commands.Balance@@ -83,45 +78,24 @@                   Commands.Print                   Commands.Register                   Commands.Stats-                  Ledger-                  Ledger.Account-                  Ledger.AccountName-                  Ledger.Amount-                  Ledger.Commodity-                  Ledger.Dates-                  Ledger.IO-                  Ledger.Transaction-                  Ledger.Ledger-                  Ledger.Parse-                  Ledger.Journal-                  Ledger.Posting-                  Ledger.TimeLog-                  Ledger.Types-                  Ledger.Utils-                  Options-                  Paths_hledger-                  Tests-                  Utils-                  Version   build-depends:-                  base >= 3 && < 5-                 ,bytestring+                  hledger-lib == 0.9+                 ,HUnit+                 ,base >= 3 && < 5                  ,containers                  ,csv                  ,directory                  ,filepath-                 ,haskell98                  ,mtl+                 ,old-locale                  ,old-time                  ,parsec                  ,process                  ,regexpr >= 0.5.1-                 ,split+                 ,safe >= 0.2                  ,testpack                  ,time                  ,utf8-string >= 0.3-                 ,HUnit-                 ,safe >= 0.2    -- should set patchlevel here as in Makefile   cpp-options:    -DPATCHLEVEL=0@@ -134,6 +108,21 @@    if flag(web)     cpp-options: -DWEB+    other-modules:Commands.Web+    build-depends:+                  hsp+                 ,hsx+                 ,xhtml >= 3000.2+                 ,loli+                 ,io-storage+                 ,hack-contrib+                 ,hack+                 ,hack-handler-simpleserver+                 ,HTTP >= 4000.0+                 ,applicative-extras++  if flag(webhappstack)+    cpp-options: -DWEBHAPPSTACK     other-modules:Commands.Web     build-depends:                   hsp

@@ -1,9 +1,8 @@--- #!/usr/bin/env runhaskell  <- sp doesn't like-{-# LANGUAGE CPP #-}+#!/usr/bin/env runhaskell {-| hledger - a ledger-compatible text-based accounting tool. -Copyright (c) 2007-2009 Simon Michael <simon@joyful.com>+Copyright (c) 2007-2010 Simon Michael <simon@joyful.com> Released under GPL version 3 or later.  hledger is a partial haskell clone of John Wiegley's "ledger" text-based@@ -33,43 +32,8 @@ > > t <- myTimelog  See "Ledger.Ledger" for more examples.+ -}  module Main where-import Prelude hiding (putStr, putStrLn)-import System.IO.UTF8--import Commands.All-import Ledger-import Options-import Tests-import Utils (withLedgerDo)-import Version (versionmsg, binaryfilename)--main :: IO ()-main = do-  (opts, cmd, args) <- parseArguments-  run cmd opts args-    where-      run cmd opts args-       | Help `elem` opts             = putStr usage-       | Version `elem` opts          = putStrLn versionmsg-       | BinaryFilename `elem` opts   = putStrLn binaryfilename-       | cmd `isPrefixOf` "balance"   = withLedgerDo opts args cmd balance-       | cmd `isPrefixOf` "convert"   = withLedgerDo opts args cmd convert-       | cmd `isPrefixOf` "print"     = withLedgerDo opts args cmd print'-       | cmd `isPrefixOf` "register"  = withLedgerDo opts args cmd register-       | cmd `isPrefixOf` "histogram" = withLedgerDo opts args cmd histogram-       | cmd `isPrefixOf` "add"       = withLedgerDo opts args cmd add-       | cmd `isPrefixOf` "stats"     = withLedgerDo opts args cmd stats-#ifdef VTY-       | cmd `isPrefixOf` "ui"        = withLedgerDo opts args cmd ui-#endif-#ifdef WEB-       | cmd `isPrefixOf` "web"       = withLedgerDo opts args cmd web-#endif-#ifdef CHART-       | cmd `isPrefixOf` "chart"       = withLedgerDo opts args cmd chart-#endif-       | cmd `isPrefixOf` "test"      = runtests opts args >> return ()-       | otherwise                    = putStr usage+import HledgerMain (main)