slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix warnings all over - hledger is now -W-clean

Browse Source
This commit is contained in:
Simon Michael 2009-06-05 09:44:20 +00:00
parent 92d67926f5
commit cb8ea69dfc
26 changed files with 130 additions and 191 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
Commands/Add.hs
View File

@ -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

4
Commands/Balance.hs
View File

@ -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

13
Commands/Convert.hs
View File

@ -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"

2
Commands/Histogram.hs
View File

@ -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

6
Commands/Register.hs
View File

@ -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

5
Commands/Stats.hs
View File

@ -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)

90
Commands/UI.hs
View File

@ -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

14
Commands/Web.hs
View File

@ -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 " | "

2
Ledger/AccountName.hs
View File

@ -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

16
Ledger/Amount.hs
View File

@ -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

3
Ledger/Commodity.hs
View File

@ -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

44
Ledger/Dates.hs
View File

@ -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)

5
Ledger/IO.hs
View File

@ -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

4
Ledger/Ledger.hs
View File

@ -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

4
Ledger/LedgerTransaction.hs
View File

@ -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

35
Ledger/Parse.hs
View File

@ -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) ["<=",">=","==","<","=",">"]

8
Ledger/Posting.hs
View File

@ -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

1
Ledger/RawLedger.hs
View File

@ -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

2
Ledger/TimeLog.hs
View File

@ -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

3
Ledger/Transaction.hs
View File

@ -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

4
Ledger/Utils.hs
View File

@ -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

30
Options.hs
View File

@ -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

11
Tests.hs
View File

@ -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

3
Utils.hs
View File

@ -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

2
Version.hs
View File

@ -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

3
hledger.hs
View File

@ -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