diff --git a/Commands/Add.hs b/Commands/Add.hs index 0ab91c474..59b4ace05 100644 --- a/Commands/Add.hs +++ b/Commands/Add.hs @@ -21,7 +21,7 @@ import Utils (ledgerFromStringWithOpts) -- and append them to the ledger file. If the ledger came from stdin, this -- command has no effect. add :: [Opt] -> [String] -> Ledger -> IO () -add opts args l +add _ args l | filepath (rawledger l) == "-" = return () | otherwise = do hPutStrLn stderr @@ -90,7 +90,6 @@ getPostings historicalps enteredps = do getPostings historicalps $ enteredps ++ [p] where n = length enteredps + 1 - realn = length enteredrealps + 1 enteredrealps = filter isReal enteredps bestmatch | isNothing historicalps = Nothing | n <= length ps = Just $ ps !! (n-1) @@ -164,8 +163,8 @@ registerFromString s = do -- with a modification for short strings. compareStrings :: String -> String -> Float compareStrings "" "" = 1 -compareStrings (a:[]) "" = 0 -compareStrings "" (b:[]) = 0 +compareStrings (_:[]) "" = 0 +compareStrings "" (_:[]) = 0 compareStrings (a:[]) (b:[]) = if toUpper a == toUpper b then 1 else 0 compareStrings s1 s2 = 2.0 * (fromIntegral i) / (fromIntegral u) where diff --git a/Commands/Balance.hs b/Commands/Balance.hs index 1d42fd077..e29c05d4a 100644 --- a/Commands/Balance.hs +++ b/Commands/Balance.hs @@ -103,9 +103,7 @@ import Ledger.Amount import Ledger.AccountName import Ledger.Transaction import Ledger.Ledger -import Ledger.Parse import Options -import Utils import System.IO.UTF8 @@ -115,7 +113,7 @@ balance opts args l = putStr $ showBalanceReport opts args l -- | Generate a balance report with the specified options for this ledger. showBalanceReport :: [Opt] -> [String] -> Ledger -> String -showBalanceReport opts args l = acctsstr ++ totalstr +showBalanceReport opts _ l = acctsstr ++ totalstr where acctsstr = unlines $ map showacct interestingaccts where diff --git a/Commands/Convert.hs b/Commands/Convert.hs index 73ee49856..a8d7a697a 100644 --- a/Commands/Convert.hs +++ b/Commands/Convert.hs @@ -37,14 +37,12 @@ optional rule saving. -} module Commands.Convert where -import Data.Maybe (isJust) import Data.List.Split (splitOn) import Options -- (Opt,Debug) import Ledger.Types (Ledger,AccountName) import Ledger.Utils (strip) -import System (getArgs) import System.IO (stderr, hPutStrLn) -import Text.CSV (parseCSVFromFile, Record) +import Text.CSV (parseCSVFromFile) import Text.Printf (printf) import Text.RegexPR (matchRegexPR) import Data.Maybe @@ -55,7 +53,7 @@ import Control.Monad (when) convert :: [Opt] -> [String] -> Ledger -> IO () -convert opts args l = do +convert opts args _ = do when (length args /= 3) (error "please specify a csv file, base account, and import rules file.") let [csvfile,baseacct,rulesfile] = args rulesstr <- readFile rulesfile @@ -83,10 +81,11 @@ parseRules s = do parsePatRepl :: String -> (String, Maybe String) parsePatRepl l = case splitOn "=" l of (p:r:_) -> (p, Just r) - (p:_) -> (p, Nothing) + _ -> (l, Nothing) -print_ledger_txn debug (baseacct,fieldpositions,rules) record@(a:b:c:d:e) = do - let [date,cleared,number,description,amount] = map (record !!) fieldpositions +print_ledger_txn :: Bool -> (String,[Int],[Rule]) -> [String] -> IO () +print_ledger_txn debug (baseacct,fieldpositions,rules) record@(_:_:_:_:_:[]) = do + let [date,_,number,description,amount] = map (record !!) fieldpositions amount' = strnegate amount where strnegate ('-':s) = s strnegate s = '-':s unknownacct | (read amount' :: Double) < 0 = "income:unknown" diff --git a/Commands/Histogram.hs b/Commands/Histogram.hs index 498991461..a992e3943 100644 --- a/Commands/Histogram.hs +++ b/Commands/Histogram.hs @@ -7,8 +7,6 @@ Print a histogram report. module Commands.Histogram where import Prelude hiding (putStr) -import qualified Data.Map as Map -import Data.Map ((!)) import Ledger import Options import System.IO.UTF8 diff --git a/Commands/Register.hs b/Commands/Register.hs index a372403e4..c768b0ace 100644 --- a/Commands/Register.hs +++ b/Commands/Register.hs @@ -7,8 +7,6 @@ A ledger-compatible @register@ command. module Commands.Register where import Prelude hiding (putStr) -import qualified Data.Map as Map -import Data.Map ((!)) import Ledger import Options import System.IO.UTF8 @@ -46,7 +44,7 @@ showRegisterReport opts args l startbal = sumTransactions precedingts matchapats t = matchpats apats $ taccount t (apats,_) = parsePatternArgs args - matchdisplayopt Nothing t = True + matchdisplayopt Nothing _ = True matchdisplayopt (Just e) t = (fromparse $ parsewith datedisplayexpr e) t dopt = displayFromOpts opts empty = Empty `elem` opts @@ -99,7 +97,7 @@ clipAccountNames d as = nub $ map (clip d) as -- | Show transactions one per line, with each date/description appearing -- only once, and a running balance. showtxns [] _ _ = "" -showtxns (t@Transaction{tamount=a}:ts) tprev bal = this ++ showtxns ts t bal' +showtxns (t:ts) tprev bal = this ++ showtxns ts t bal' where this = showtxn (t `issame` tprev) t bal' issame t1 t2 = tnum t1 == tnum t2 diff --git a/Commands/Stats.hs b/Commands/Stats.hs index c08aa327d..462c3de42 100644 --- a/Commands/Stats.hs +++ b/Commands/Stats.hs @@ -7,12 +7,9 @@ Print some statistics for the ledger. module Commands.Stats where import Prelude hiding (putStr) -import qualified Data.Map as Map -import Data.Map ((!)) import Ledger import Options import System.IO.UTF8 -import Utils (filterAndCacheLedgerWithOpts) -- | Print various statistics for the ledger. @@ -22,7 +19,7 @@ stats opts args l = do putStr $ showStats opts args l today showStats :: [Opt] -> [String] -> Ledger -> Day -> String -showStats opts args l today = +showStats _ _ l today = heading ++ (unlines $ map (\(a,b) -> printf fmt a b) stats) where heading = underline $ printf "Ledger statistics as of %s" (show today) diff --git a/Commands/UI.hs b/Commands/UI.hs index 3d18b8eea..559e1ecfb 100644 --- a/Commands/UI.hs +++ b/Commands/UI.hs @@ -6,8 +6,6 @@ A simple text UI for hledger, based on the vty library. module Commands.UI where -import qualified Data.Map as Map -import Data.Map ((!)) import Graphics.Vty import qualified Data.ByteString.Char8 as B import Ledger @@ -19,7 +17,7 @@ import Commands.Print helpmsg = "(b)alance, (r)egister, (p)rint, (right) to drill down, (left) to back up, (q)uit" -instance Show Vty where show v = "a Vty" +instance Show Vty where show = const "a Vty" -- | The application state when running the ui command. data AppState = AppState { @@ -46,7 +44,7 @@ data Loc = Loc { data Screen = BalanceScreen -- ^ like hledger balance, shows accounts | RegisterScreen -- ^ like hledger register, shows transaction-postings | PrintScreen -- ^ like hledger print, shows ledger transactions - | LedgerScreen -- ^ shows the raw ledger + -- | LedgerScreen -- ^ shows the raw ledger deriving (Eq,Show) -- | Run the interactive text ui. @@ -71,7 +69,7 @@ ui opts args l = do -- | Update the screen, wait for the next event, repeat. go :: AppState -> IO () -go a@AppState{av=av,aw=aw,ah=ah,abuf=buf,amsg=amsg,aopts=opts,aargs=args,aledger=l} = do +go a@AppState{av=av,aw=_,ah=_,abuf=_,amsg=_,aopts=opts,aargs=_,aledger=_} = do when (not $ DebugNoUI `elem` opts) $ update av (renderScreen a) k <- getEvent av case k of @@ -100,9 +98,6 @@ go a@AppState{av=av,aw=aw,ah=ah,abuf=buf,amsg=amsg,aopts=opts,aargs=args,aledger EvKey (KASCII 'q') [] -> shutdown av >> return () -- EvKey KEsc [] -> shutdown av >> return () _ -> go a - where - bh = length buf - y = posY a -- app state modifiers @@ -120,8 +115,13 @@ scrollY = sy . loc posY a = scrollY a + cursorY a setCursorY, setScrollY, setPosY :: Int -> AppState -> AppState +setCursorY _ AppState{alocs=[]} = error "shouldn't happen" -- silence warnings setCursorY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)} where l' = setLocCursorY y l + +setScrollY _ AppState{alocs=[]} = error "shouldn't happen" -- silence warnings setScrollY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)} where l' = setLocScrollY y l + +setPosY _ AppState{alocs=[]} = error "shouldn't happen" -- silence warnings setPosY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)} where l' = setLocScrollY sy $ setLocCursorY cy l @@ -129,6 +129,7 @@ setPosY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)} cy = y `mod` ph sy = y - cy + updateCursorY, updateScrollY, updatePosY :: (Int -> Int) -> AppState -> AppState updateCursorY f a = setCursorY (f $ cursorY a) a updateScrollY f a = setScrollY (f $ scrollY a) a @@ -147,17 +148,19 @@ moveToBottom :: AppState -> AppState moveToBottom a = setPosY (length $ abuf a) a moveUpAndPushEdge :: AppState -> AppState -moveUpAndPushEdge a@AppState{alocs=(Loc{sy=sy,cy=cy}:_)} +moveUpAndPushEdge a | cy > 0 = updateCursorY (subtract 1) a | sy > 0 = updateScrollY (subtract 1) a | otherwise = a + where Loc{sy=sy,cy=cy} = head $ alocs a moveDownAndPushEdge :: AppState -> AppState -moveDownAndPushEdge a@AppState{alocs=(Loc{sy=sy,cy=cy}:_)} +moveDownAndPushEdge a | sy+cy >= bh = a | cy < ph-1 = updateCursorY (+1) a | otherwise = updateScrollY (+1) a where + Loc{sy=sy,cy=cy} = head $ alocs a ph = pageHeight a bh = length $ abuf a @@ -178,7 +181,7 @@ nextpage (a@AppState{abuf=b}) -- without moving the cursor, or if we are scrolled as far as possible -- then move the cursor to the first line. prevpage :: AppState -> AppState -prevpage (a@AppState{abuf=b}) +prevpage a | sy > 0 = setScrollY sy' a | otherwise = setCursorY 0 a where @@ -212,31 +215,30 @@ enter :: Screen -> AppState -> AppState enter scr@BalanceScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a enter scr@RegisterScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a enter scr@PrintScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a -enter scr@LedgerScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a +-- enter scr@LedgerScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a resetTrailAndEnter scr a = enter scr $ clearLocs a -- | Regenerate the display data appropriate for the current screen. updateData :: AppState -> AppState -updateData a@AppState{aopts=opts,aargs=args,aledger=l} - | scr == BalanceScreen = a{abuf=lines $ showBalanceReport opts [] l, aargs=[]} - | scr == RegisterScreen = a{abuf=lines $ showRegisterReport opts args l} - | scr == PrintScreen = a{abuf=lines $ showLedgerTransactions opts args l} - | scr == LedgerScreen = a{abuf=lines $ rawledgertext l} - where scr = screen a +updateData a@AppState{aopts=opts,aargs=args,aledger=l} = + case screen a of + BalanceScreen -> a{abuf=lines $ showBalanceReport opts [] l, aargs=[]} + RegisterScreen -> a{abuf=lines $ showRegisterReport opts args l} + PrintScreen -> a{abuf=lines $ showLedgerTransactions opts args l} + -- LedgerScreen -> a{abuf=lines $ rawledgertext l} backout :: AppState -> AppState -backout a - | screen a == BalanceScreen = a - | otherwise = updateData $ popLoc a +backout a | screen a == BalanceScreen = a + | otherwise = updateData $ popLoc a drilldown :: AppState -> AppState -drilldown a - | screen a == BalanceScreen = enter RegisterScreen a{aargs=[currentAccountName a]} - | screen a == RegisterScreen = scrollToLedgerTransaction e $ enter PrintScreen a - | screen a == PrintScreen = a - -- screen a == PrintScreen = enter LedgerScreen a - -- screen a == LedgerScreen = a +drilldown a = + case screen a of + BalanceScreen -> enter RegisterScreen a{aargs=[currentAccountName a]} + RegisterScreen -> scrollToLedgerTransaction e $ enter PrintScreen a + PrintScreen -> a + -- LedgerScreen -> a{abuf=lines $ rawledgertext l} where e = currentLedgerTransaction a -- | Get the account name currently highlighted by the cursor on the @@ -350,28 +352,26 @@ renderStatus w s = renderBS statusattr (B.pack $ take w (s ++ repeat ' ')) -- the all-important theming engine -theme = 1 +theme = Restrained + +data UITheme = Restrained | Colorful | Blood (defaultattr, currentlineattr, statusattr - ) = - case theme of - 1 -> ( -- restrained - attr - ,setBold attr - ,setRV attr - ) - 2 -> ( -- colorful - setRV attr - ,setFG white $ setBG red $ attr - ,setFG black $ setBG green $ attr - ) - 3 -> ( -- - setRV attr - ,setFG white $ setBG red $ attr - ,setRV attr - ) + ) = case theme of + Restrained -> (attr + ,setBold attr + ,setRV attr + ) + Colorful -> (setRV attr + ,setFG white $ setBG red $ attr + ,setFG black $ setBG green $ attr + ) + Blood -> (setRV attr + ,setFG white $ setBG red $ attr + ,setRV attr + ) halfbrightattr = setHalfBright attr reverseattr = setRV attr diff --git a/Commands/Web.hs b/Commands/Web.hs index 64e4b8603..c56ef91e2 100644 --- a/Commands/Web.hs +++ b/Commands/Web.hs @@ -4,23 +4,13 @@ A happs-based web UI for hledger. module Commands.Web where -import Control.Monad.Trans (liftIO) -import Data.ByteString.Lazy.UTF8 (toString) -import qualified Data.Map as M --- import Data.Map ((!)) -import Data.Time.Clock -import Data.Time.Format -import Locale import Control.Concurrent -import qualified Data.ByteString.Lazy.Char8 as B -import Happstack.Data (defaultValue) import Happstack.Server -import Happstack.Server.HTTP.FileServe (fileServe) import Happstack.State.Control (waitForTermination) import System.Cmd (system) import System.Info (os) import System.Exit -import Network.HTTP (urlEncode, urlDecode, urlEncodeVars) +import Network.HTTP (urlEncode, urlDecode) import Text.XHtml hiding (dir) import Ledger @@ -122,7 +112,7 @@ searchform r a p' = | otherwise = spaceHtml +++ anchor ! [href u] << stringToHtml "reset" navlinks :: Request -> String -> String -> Html -navlinks r a p' = +navlinks _ a p' = concatHtml $ intersperse sep $ map linkto ["balance", "register", "print", "histogram"] where sep = stringToHtml " | " diff --git a/Ledger/AccountName.hs b/Ledger/AccountName.hs index b2b0854c1..59eb04540 100644 --- a/Ledger/AccountName.hs +++ b/Ledger/AccountName.hs @@ -10,7 +10,7 @@ module Ledger.AccountName where import Ledger.Utils import Ledger.Types -import Data.Map ((!), fromList, Map) +import Data.Map (Map) import qualified Data.Map as M diff --git a/Ledger/Amount.hs b/Ledger/Amount.hs index 97dadde2d..ea271927b 100644 --- a/Ledger/Amount.hs +++ b/Ledger/Amount.hs @@ -39,7 +39,6 @@ examples: module Ledger.Amount where -import qualified Data.Map as Map import Ledger.Utils import Ledger.Types import Ledger.Commodity @@ -77,13 +76,13 @@ negateAmountPreservingPrice a = (-a){price=price a} -- 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 ac aq ap) b@(Amount bc bq bp) = +amountop op a@(Amount _ _ _) (Amount bc bq _) = Amount bc ((quantity $ convertAmountTo bc a) `op` bq) Nothing -- | Convert an amount to the commodity of its saved price, if any. costOfAmount :: Amount -> Amount costOfAmount a@(Amount _ _ Nothing) = a -costOfAmount a@(Amount _ q (Just price)) +costOfAmount (Amount _ q (Just price)) | isZeroMixedAmount price = nullamt | otherwise = Amount pc (pq*q) Nothing where (Amount pc pq _) = head $ amounts price @@ -91,15 +90,16 @@ costOfAmount a@(Amount _ q (Just price)) -- | 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 p) = Amount c2 (q * conversionRate c1 c2) Nothing +convertAmountTo c2 (Amount c1 q _) = Amount c2 (q * conversionRate c1 c2) Nothing -- | Get the string representation of an amount, based on its commodity's -- display settings. showAmount :: Amount -> String -showAmount a@(Amount (Commodity {symbol=sym,side=side,spaced=spaced}) q pri) - | sym=="AUTO" = "" -- can display one of these in an error message - | side==L = printf "%s%s%s%s" sym space quantity price - | side==R = printf "%s%s%s%s" quantity space sym price +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 diff --git a/Ledger/Commodity.hs b/Ledger/Commodity.hs index 056f1224e..8d8a17794 100644 --- a/Ledger/Commodity.hs +++ b/Ledger/Commodity.hs @@ -8,7 +8,6 @@ are thousands separated by comma, significant decimal places and so on. -} module Ledger.Commodity where -import qualified Data.Map as Map import Ledger.Utils import Ledger.Types @@ -36,5 +35,5 @@ comm sym = fromMaybe -- | Find the conversion rate between two commodities. Currently returns 1. conversionRate :: Commodity -> Commodity -> Double -conversionRate oldc newc = 1 +conversionRate _ _ = 1 diff --git a/Ledger/Dates.hs b/Ledger/Dates.hs index 80f636e5d..7c47b8983 100644 --- a/Ledger/Dates.hs +++ b/Ledger/Dates.hs @@ -19,16 +19,9 @@ quarterly, etc. module Ledger.Dates where -import Data.Time.Clock import Data.Time.Format -import Data.Time.Calendar -import Data.Time.Calendar.MonthDay import Data.Time.Calendar.OrdinalDate -import Data.Time.Calendar.WeekDate -import Data.Time.LocalTime import Locale (defaultTimeLocale) -import Text.Printf -import Data.Maybe import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Char import Text.ParserCombinators.Parsec.Combinator @@ -49,24 +42,29 @@ elapsedSeconds t1 t2 = realToFrac $ diffUTCTime t1 t2 -- | Split a DateSpan into one or more consecutive spans at the specified interval. splitSpan :: Interval -> DateSpan -> [DateSpan] -splitSpan i (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing] +splitSpan _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing] splitSpan NoInterval s = [s] -splitSpan Daily s = splitspan start next s where (start,next) = (startofday,nextday) -splitSpan Weekly s = splitspan start next s where (start,next) = (startofweek,nextweek) -splitSpan Monthly s = splitspan start next s where (start,next) = (startofmonth,nextmonth) -splitSpan Quarterly s = splitspan start next s where (start,next) = (startofquarter,nextquarter) -splitSpan Yearly s = splitspan start next s where (start,next) = (startofyear,nextyear) +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 startof next (DateSpan Nothing (Just e)) = [DateSpan (Just $ startof e) (Just $ next $ startof e)] -splitspan startof next (DateSpan (Just b) Nothing) = [DateSpan (Just $ startof b) (Just $ next $ startof b)] -splitspan startof next s@(DateSpan (Just b) (Just e)) - | b == e = [s] - | otherwise = splitspan' startof next s - where splitspan' startof next (DateSpan (Just b) (Just e)) - | b >= e = [] - | otherwise = [DateSpan (Just $ startof b) (Just $ next $ startof b)] - ++ splitspan' startof next (DateSpan (Just $ next $ startof b) (Just e)) +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 @@ -89,7 +87,7 @@ spanFromSmartDateString refdate s = spanFromSmartDate refdate sdate spanFromSmartDate :: Day -> SmartDate -> DateSpan spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e) where - (ry,rm,rd) = toGregorian refdate + (ry,rm,_) = toGregorian refdate (b,e) = span sdate span :: SmartDate -> (Day,Day) span ("","","today") = (refdate, nextday refdate) diff --git a/Ledger/IO.hs b/Ledger/IO.hs index b654bab94..8057c3a73 100644 --- a/Ledger/IO.hs +++ b/Ledger/IO.hs @@ -5,8 +5,6 @@ Utilities for doing I/O with ledger files. module Ledger.IO where import Control.Monad.Error -import Data.Time.Clock -import Data.Time.LocalTime (LocalTime) import Ledger.Ledger (cacheLedger) import Ledger.Parse (parseLedger) import Ledger.RawLedger (canonicaliseAmounts,filterRawLedger) @@ -15,8 +13,6 @@ import Ledger.Utils (getCurrentLocalTime) import System.Directory (getHomeDirectory) import System.Environment (getEnv) import System.IO -import Text.ParserCombinators.Parsec -import qualified Data.Map as Map (lookup) import System.FilePath (()) @@ -81,7 +77,6 @@ readLedger = readLedgerWithIOArgs noioargs -- | or give an error. readLedgerWithIOArgs :: IOArgs -> FilePath -> IO Ledger readLedgerWithIOArgs ioargs f = do - t <- getCurrentLocalTime s <- readFile f rl <- rawLedgerFromString s return $ filterAndCacheLedger ioargs s rl diff --git a/Ledger/Ledger.hs b/Ledger/Ledger.hs index 0a9e5ab01..e0b2076a3 100644 --- a/Ledger/Ledger.hs +++ b/Ledger/Ledger.hs @@ -57,12 +57,10 @@ import qualified Data.Map as Map import Data.Map ((!)) import Ledger.Utils import Ledger.Types -import Ledger.Amount +import Ledger.Account () import Ledger.AccountName -import Ledger.Account import Ledger.Transaction import Ledger.RawLedger -import Ledger.LedgerTransaction instance Show Ledger where diff --git a/Ledger/LedgerTransaction.hs b/Ledger/LedgerTransaction.hs index 5fc064298..48afd532b 100644 --- a/Ledger/LedgerTransaction.hs +++ b/Ledger/LedgerTransaction.hs @@ -57,15 +57,13 @@ showLedgerTransactionUnelided = showLedgerTransaction' False showLedgerTransaction' :: Bool -> LedgerTransaction -> String showLedgerTransaction' elide t = - unlines $ [{-precedingcomment ++ -}description] ++ (showpostings $ ltpostings t) ++ [""] + unlines $ [description] ++ (showpostings $ ltpostings t) ++ [""] where - precedingcomment = ltpreceding_comment_lines t description = concat [date, status, code, desc] -- , comment] date = showdate $ ltdate t status = if ltstatus t then " *" else "" code = if (length $ ltcode t) > 0 then (printf " (%s)" $ ltcode t) else "" desc = " " ++ ltdescription t - comment = if (length $ ltcomment t) > 0 then " ; "++(ltcomment t) else "" showdate d = printf "%-10s" (showDate d) showpostings ps | elide && length ps > 1 && isLedgerTransactionBalanced t diff --git a/Ledger/Parse.hs b/Ledger/Parse.hs index 4c37492ab..7a77578ca 100644 --- a/Ledger/Parse.hs +++ b/Ledger/Parse.hs @@ -7,28 +7,19 @@ Parsers for standard ledger and timelog files. module Ledger.Parse where import Prelude hiding (readFile, putStr, print) -import Control.Monad import Control.Monad.Error import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Char -import Text.ParserCombinators.Parsec.Language import Text.ParserCombinators.Parsec.Combinator -import qualified Text.ParserCombinators.Parsec.Token as P import System.Directory import System.IO.UTF8 import System.IO (stdin) -import qualified Data.Map as Map -import Data.Time.LocalTime -import Data.Time.Calendar import Ledger.Utils import Ledger.Types import Ledger.Dates -import Ledger.AccountName import Ledger.Amount import Ledger.LedgerTransaction import Ledger.Posting -import Ledger.Commodity -import Ledger.TimeLog import Ledger.RawLedger import System.FilePath(takeDirectory,combine) @@ -111,6 +102,7 @@ ledgerDirective = do char '!' "directive" "include" -> ledgerInclude "account" -> ledgerAccountBegin "end" -> ledgerAccountEnd + _ -> mzero ledgerInclude :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger)) ledgerInclude = do many1 spacenonewline @@ -291,9 +283,9 @@ ledgerHistoricalPrice = do many spacenonewline symbol1 <- commoditysymbol many spacenonewline - (Mixed [Amount c price pri]) <- someamount + (Mixed [Amount c q _]) <- someamount restofline - return $ HistoricalPrice date symbol1 (symbol c) price + return $ HistoricalPrice date symbol1 (symbol c) q -- like ledgerAccountBegin, updates the LedgerFileCtx ledgerDefaultYear :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger)) @@ -373,7 +365,6 @@ ledgerposting = do many spacenonewline comment <- ledgercomment restofline - parent <- getParentAccount return (Posting status account' amount comment ptype) -- Qualify with the parent account from parsing context @@ -542,16 +533,16 @@ datedisplayexpr = do char '[' (y,m,d) <- smartdate char ']' - let ltdate = parsedate $ printf "%04s/%02s/%02s" y m d - let matcher = \(Transaction{tdate=d}) -> - case op of - "<" -> d < ltdate - "<=" -> d <= ltdate - "=" -> d == ltdate - "==" -> d == ltdate -- just in case - ">=" -> d >= ltdate - ">" -> d > ltdate - return matcher + let date = parsedate $ printf "%04s/%02s/%02s" y m d + test op = return $ (`op` date) . tdate + case op of + "<" -> test (<) + "<=" -> test (<=) + "=" -> test (==) + "==" -> test (==) + ">=" -> test (>=) + ">" -> test (>) + _ -> mzero compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"] diff --git a/Ledger/Posting.hs b/Ledger/Posting.hs index 4e8320e1b..f7db51d6c 100644 --- a/Ledger/Posting.hs +++ b/Ledger/Posting.hs @@ -22,14 +22,14 @@ instance Show Posting where show = showPosting nullrawposting = Posting False "" nullmixedamt "" RegularPosting showPosting :: Posting -> String -showPosting (Posting s a amt _ ttype) = +showPosting (Posting _ a amt _ ttype) = concatTopPadded [showaccountname a ++ " ", showamount amt] where showaccountname = printf "%-22s" . bracket . elideAccountName width (bracket,width) = case ttype of - BalancedVirtualPosting -> (\s -> "["++s++"]", 20) - VirtualPosting -> (\s -> "("++s++")", 20) - otherwise -> (id,22) + BalancedVirtualPosting -> (\s -> "["++s++"]", 20) + VirtualPosting -> (\s -> "("++s++")", 20) + _ -> (id,22) showamount = padleft 12 . showMixedAmountOrZero isReal :: Posting -> Bool diff --git a/Ledger/RawLedger.hs b/Ledger/RawLedger.hs index d64071ca3..08fda1c10 100644 --- a/Ledger/RawLedger.hs +++ b/Ledger/RawLedger.hs @@ -13,7 +13,6 @@ import Ledger.Utils import Ledger.Types import Ledger.AccountName import Ledger.Amount -import Ledger.LedgerTransaction import Ledger.Transaction import Ledger.Posting import Ledger.TimeLog diff --git a/Ledger/TimeLog.hs b/Ledger/TimeLog.hs index e5d5541dc..03bd5a91a 100644 --- a/Ledger/TimeLog.hs +++ b/Ledger/TimeLog.hs @@ -12,7 +12,6 @@ import Ledger.Utils import Ledger.Types import Ledger.Dates import Ledger.Commodity -import Ledger.Amount import Ledger.LedgerTransaction instance Show TimeLogEntry where @@ -82,7 +81,6 @@ entryFromTimeLogInOut i o itod = localTimeOfDay itime otod = localTimeOfDay otime idate = localDay itime - odate = localDay otime hrs = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc amount = Mixed [hours hrs] ps = [Posting False acctname amount "" RegularPosting diff --git a/Ledger/Transaction.hs b/Ledger/Transaction.hs index 1e326347e..45d44faa7 100644 --- a/Ledger/Transaction.hs +++ b/Ledger/Transaction.hs @@ -15,14 +15,13 @@ import Ledger.Utils import Ledger.Types import Ledger.Dates import Ledger.LedgerTransaction (showAccountName) -import Ledger.Posting import Ledger.Amount instance Show Transaction where show=showTransaction showTransaction :: Transaction -> String -showTransaction (Transaction eno stat d desc a amt ttype) = +showTransaction (Transaction _ stat d desc a amt ttype) = s ++ unwords [showDate d,desc,a',show amt,show ttype] where s = if stat then " *" else "" a' = showAccountName Nothing ttype a diff --git a/Ledger/Utils.hs b/Ledger/Utils.hs index 8a335097e..0590176fa 100644 --- a/Ledger/Utils.hs +++ b/Ledger/Utils.hs @@ -150,7 +150,7 @@ difforzero a b = maximum [(a - b), 0] containsRegex :: String -> String -> Bool containsRegex r s = case matchRegexPR ("(?i)"++r) s of Just _ -> True - otherwise -> False + _ -> False -- lists @@ -184,7 +184,7 @@ subtreeat v 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 v [] = Nothing +subtreeinforest _ [] = Nothing subtreeinforest v (t:ts) = case (subtreeat v t) of Just t' -> Just t' Nothing -> subtreeinforest v ts diff --git a/Options.hs b/Options.hs index e473e2ae3..94941ac3c 100644 --- a/Options.hs +++ b/Options.hs @@ -5,15 +5,9 @@ Command-line options for the application. module Options where -import System import System.Console.GetOpt import System.Environment -import Text.Printf -import Data.Char (toLower) -import Ledger.IO (IOArgs, - ledgerenvvar,myLedgerPath, - timelogenvvar,myTimelogPath) -import Ledger.Parse +import Ledger.IO (IOArgs,myLedgerPath,myTimelogPath) import Ledger.Utils import Ledger.Types import Ledger.Dates @@ -176,19 +170,17 @@ dateSpanFromOpts refdate opts -- | Figure out the reporting interval, if any, specified by the options. -- If there is a period option, the others are ignored. intervalFromOpts :: [Opt] -> Interval -intervalFromOpts opts - | not $ null popts = fst $ parsePeriodExpr refdate $ last popts - | null otheropts = NoInterval - | otherwise = case last otheropts of - WeeklyOpt -> Weekly - MonthlyOpt -> Monthly - QuarterlyOpt -> Quarterly - YearlyOpt -> Yearly +intervalFromOpts opts = + case (periodopts, intervalopts) of + ((p:_), _) -> fst $ parsePeriodExpr d p where d = parsedate "0001/01/01" -- unused + (_, (WeeklyOpt:_)) -> Weekly + (_, (MonthlyOpt:_)) -> Monthly + (_, (QuarterlyOpt:_)) -> Quarterly + (_, (YearlyOpt:_)) -> Yearly + (_, _) -> NoInterval where - popts = optValuesForConstructor Period opts - otheropts = filter (`elem` [WeeklyOpt,MonthlyOpt,QuarterlyOpt,YearlyOpt]) opts - -- doesn't affect the interval, but parsePeriodExpr needs something - refdate = parsedate "0001/01/01" + periodopts = reverse $ optValuesForConstructor Period opts + intervalopts = reverse $ filter (`elem` [WeeklyOpt,MonthlyOpt,QuarterlyOpt,YearlyOpt]) opts -- | Get the value of the (last) depth option, if any, otherwise a large number. depthFromOpts :: [Opt] -> Int diff --git a/Tests.hs b/Tests.hs index 1052edd59..0e92952aa 100644 --- a/Tests.hs +++ b/Tests.hs @@ -171,8 +171,7 @@ import qualified Data.Map as Map import Data.Time.Format import Locale (defaultTimeLocale) import Text.ParserCombinators.Parsec -import Test.HUnit -import Test.HUnit.Tools (assertRaises, runVerboseTests) +import Test.HUnit.Tools (runVerboseTests) import Commands.All import Ledger @@ -180,12 +179,12 @@ import Options import Utils -runtests opts args = runner flattests +runtests opts args = runner ts where runner | (Verbose `elem` opts) = runVerboseTests | otherwise = \t -> runTestTT t >>= return . (flip (,) 0) - flattests = TestList $ filter matchname $ concatMap tflatten tests - deeptests = tfilter matchname $ TestList tests + ts = TestList $ filter matchname $ concatMap tflatten tests + --ts = tfilter matchname $ TestList tests -- unflattened matchname = matchpats args . tname -- | Get a Test's label, or the empty string. @@ -482,7 +481,6 @@ tests = [ nowstr = showtime now yesterday = prevday today clockin t a = TimeLogEntry In t a - clockout t = TimeLogEntry Out t "" mktime d s = LocalTime d $ fromMaybe midnight $ parseTime defaultTimeLocale "%H:%M:%S" s showtime t = formatTime defaultTimeLocale "%H:%M" t assertEntriesGiveStrings name es ss = assertEqual name ss (map ltdescription $ entriesFromTimeLogEntries now es) @@ -582,7 +580,6 @@ tests = [ return () ,"ledgerFile" ~: do - let now = getCurrentLocalTime assertBool "ledgerFile should parse an empty file" $ (isRight $ parseWithCtx ledgerFile "") r <- rawLedgerFromString "" -- don't know how to get it from ledgerFile assertBool "ledgerFile parsing an empty file should give an empty ledger" $ null $ ledger_txns r diff --git a/Utils.hs b/Utils.hs index c04bb97fb..f974bca1b 100644 --- a/Utils.hs +++ b/Utils.hs @@ -8,13 +8,10 @@ Utilities for top-level modules and ghci. See also "Ledger.IO" and module Utils where import Control.Monad.Error -import Data.Time.Clock import Ledger import Options (Opt,ledgerFilePathFromOpts,optsToIOArgs) import System.Directory (doesFileExist) import System.IO -import Text.ParserCombinators.Parsec -import qualified Data.Map as Map (lookup) -- | Parse the user's specified ledger file and run a hledger command on diff --git a/Version.hs b/Version.hs index a3338f103..e0a803b21 100644 --- a/Version.hs +++ b/Version.hs @@ -42,6 +42,8 @@ binaryfilename = prettify $ splitAtElement '.' buildversion :: String prettify (major:minor:bugfix:[]) = prettify (major:minor:bugfix:"0":[]) prettify (major:minor:[]) = prettify (major:minor:"0":"0":[]) prettify (major:[]) = prettify (major:"0":"0":"0":[]) + prettify [] = error "VERSION is empty, please fix" + prettify _ = error "VERSION has too many components, please fix" versionstr = prettify $ splitAtElement '.' buildversion :: String where diff --git a/hledger.hs b/hledger.hs index 6d5589c3a..e719451f1 100644 --- a/hledger.hs +++ b/hledger.hs @@ -36,11 +36,8 @@ See "Ledger.Ledger" for more examples. -} module Main where -import Control.Monad.Error import Prelude hiding (putStr, putStrLn) -import System.IO (stderr) import System.IO.UTF8 -import qualified Data.Map as Map (lookup) import Commands.All import Ledger