Merge branch 'rdesfo-0.23'

Conflicts:
	.version
	hledger-lib/Hledger/Read/CsvReader.hs
	hledger-lib/hledger-lib.cabal
	hledger-web/hledger-web.cabal
	hledger/hledger.cabal
This commit is contained in:
Simon Michael 2014-05-22 16:15:35 -07:00
commit 6b059aeb5e
12 changed files with 64 additions and 36 deletions

View File

@ -115,7 +115,7 @@ instance Yesod App where
addScript $ StaticR hledger_js addScript $ StaticR hledger_js
$(widgetFile "default-layout") $(widgetFile "default-layout")
hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet") giveUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
-- This is done to provide an optimization for serving static files from -- This is done to provide an optimization for serving static files from
-- a separate domain. Please see the staticRoot setting in Settings.hs -- a separate domain. Please see the staticRoot setting in Settings.hs

View File

@ -181,7 +181,7 @@ addform _ vd@VD{..} = [hamlet|
acctnames = sort $ journalAccountNamesUsed j acctnames = sort $ journalAccountNamesUsed j
-- Construct data for select2. Text must be quoted in a json string. -- Construct data for select2. Text must be quoted in a json string.
toSelectData as = preEscapedString $ encode $ JSArray $ map (\a -> JSObject $ toJSObject [("text", showJSON a)]) as toSelectData as = preEscapedString $ encode $ JSArray $ map (\a -> JSObject $ toJSObject [("text", showJSON a)]) as
manyfiles = (length $ files j) > 1 manyfiles = length (files j) > 1
postingfields :: ViewData -> Int -> HtmlUrl AppRoute postingfields :: ViewData -> Int -> HtmlUrl AppRoute
postingfields _ n = [hamlet| postingfields _ n = [hamlet|
<tr#postingrow> <tr#postingrow>
@ -247,7 +247,7 @@ editform VD{..} = [hamlet|
|] |]
where where
title = "Edit journal" :: String title = "Edit journal" :: String
manyfiles = (length $ files j) > 1 manyfiles = length (files j) > 1
formathelp = helplink "file-format" "file format help" formathelp = helplink "file-format" "file format help"
-- | Import journal form. -- | Import journal form.
@ -293,10 +293,10 @@ balanceReportAsHtml _ vd@VD{..} (items',total) =
<a#accounts-toggle-link.togglelink href="#" title="Toggle sidebar">[+] <a#accounts-toggle-link.togglelink href="#" title="Toggle sidebar">[+]
<div#accounts> <div#accounts>
<table.balancereport> <table.balancereport>
<tr> <tr.item :allaccts:.inacct>
<td.add colspan=3> <td.register colspan=3>
<br> <br>
<a#addformlink href="#" onclick="return addformToggle(event)" title="Add a new transaction to the journal">Add a transaction.. <a href=@{RegisterR} title="Show current register">Register
<tr.item :allaccts:.inacct> <tr.item :allaccts:.inacct>
<td.journal colspan=3> <td.journal colspan=3>
@ -309,6 +309,11 @@ balanceReportAsHtml _ vd@VD{..} (items',total) =
<a#editformlink href="#" onclick="return editformToggle(event)" title="Edit the journal"> <a#editformlink href="#" onclick="return editformToggle(event)" title="Edit the journal">
edit edit
<tr>
<td.add colspan=3>
<br>
<a#addformlink href="#" onclick="return addformToggle(event)" title="Add a new transaction to the journal">Add a transaction..
<tr> <tr>
<td colspan=3> <td colspan=3>
<br> <br>
@ -527,7 +532,7 @@ numberTransactionsReportItems items = number 0 nulldate items
where where
number :: Int -> Day -> [TransactionsReportItem] -> [(Int,Bool,Bool,Bool,TransactionsReportItem)] number :: Int -> Day -> [TransactionsReportItem] -> [(Int,Bool,Bool,Bool,TransactionsReportItem)]
number _ _ [] = [] number _ _ [] = []
number n prevd (i@(Transaction{tdate=d},_,_,_,_,_):rest) = (n+1,newday,newmonth,newyear,i):(number (n+1) d rest) number n prevd (i@(Transaction{tdate=d},_,_,_,_,_):rest) = (n+1,newday,newmonth,newyear,i): number (n+1) d rest
where where
newday = d/=prevd newday = d/=prevd
newmonth = dm/=prevdm || dy/=prevdy newmonth = dm/=prevdm || dy/=prevdy

View File

@ -10,12 +10,12 @@ import Handler.Utils
-- | The journal editform, no sidebar. -- | The journal editform, no sidebar.
getJournalEditR :: Handler RepHtml getJournalEditR :: Handler Html
getJournalEditR = do getJournalEditR = do
vd <- getViewData vd <- getViewData
defaultLayout $ do defaultLayout $ do
setTitle "hledger-web journal edit form" setTitle "hledger-web journal edit form"
toWidget $ editform vd toWidget $ editform vd
postJournalEditR :: Handler RepHtml postJournalEditR :: Handler Html
postJournalEditR = handlePost postJournalEditR = handlePost

View File

@ -16,7 +16,7 @@ import Hledger.Web.Options
-- | The journal entries view, with sidebar. -- | The journal entries view, with sidebar.
getJournalEntriesR :: Handler RepHtml getJournalEntriesR :: Handler Html
getJournalEntriesR = do getJournalEntriesR = do
vd@VD{..} <- getViewData vd@VD{..} <- getViewData
staticRootUrl <- (staticRoot . settings) <$> getYesod staticRootUrl <- (staticRoot . settings) <$> getYesod
@ -41,6 +41,6 @@ getJournalEntriesR = do
^{importform} ^{importform}
|] |]
postJournalEntriesR :: Handler RepHtml postJournalEntriesR :: Handler Html
postJournalEntriesR = handlePost postJournalEntriesR = handlePost

View File

@ -14,7 +14,7 @@ import Hledger.Cli.Options
import Hledger.Web.Options import Hledger.Web.Options
-- | The formatted journal view, with sidebar. -- | The formatted journal view, with sidebar.
getJournalR :: Handler RepHtml getJournalR :: Handler Html
getJournalR = do getJournalR = do
vd@VD{..} <- getViewData vd@VD{..} <- getViewData
staticRootUrl <- (staticRoot . settings) <$> getYesod staticRootUrl <- (staticRoot . settings) <$> getYesod
@ -48,6 +48,6 @@ getJournalR = do
^{importform} ^{importform}
|] |]
postJournalR :: Handler RepHtml postJournalR :: Handler Html
postJournalR = handlePost postJournalR = handlePost

View File

@ -20,7 +20,7 @@ import Hledger.Cli
-- | Handle a post from any of the edit forms. -- | Handle a post from any of the edit forms.
handlePost :: Handler RepHtml handlePost :: Handler Html
handlePost = do handlePost = do
action <- lookupPostParam "action" action <- lookupPostParam "action"
case action of Just "add" -> handleAdd case action of Just "add" -> handleAdd
@ -29,7 +29,7 @@ handlePost = do
_ -> invalidArgs ["invalid action"] _ -> invalidArgs ["invalid action"]
-- | Handle a post from the transaction add form. -- | Handle a post from the transaction add form.
handleAdd :: Handler RepHtml handleAdd :: Handler Html
handleAdd = do handleAdd = do
VD{..} <- getViewData VD{..} <- getViewData
-- get form input values. M means a Maybe value. -- get form input values. M means a Maybe value.
@ -91,7 +91,7 @@ handleAdd = do
redirect (RegisterR, [("add","1")]) redirect (RegisterR, [("add","1")])
-- | Handle a post from the journal edit form. -- | Handle a post from the journal edit form.
handleEdit :: Handler RepHtml handleEdit :: Handler Html
handleEdit = do handleEdit = do
VD{..} <- getViewData VD{..} <- getViewData
-- get form input values, or validation errors. -- get form input values, or validation errors.
@ -137,7 +137,7 @@ handleEdit = do
jE jE
-- | Handle a post from the journal import form. -- | Handle a post from the journal import form.
handleImport :: Handler RepHtml handleImport :: Handler Html
handleImport = do handleImport = do
setMessage "can't handle file upload yet" setMessage "can't handle file upload yet"
redirect JournalR redirect JournalR

View File

@ -16,7 +16,7 @@ import Hledger.Cli.Options
import Hledger.Web.Options import Hledger.Web.Options
-- | The main journal/account register view, with accounts sidebar. -- | The main journal/account register view, with accounts sidebar.
getRegisterR :: Handler RepHtml getRegisterR :: Handler Html
getRegisterR = do getRegisterR = do
vd@VD{..} <- getViewData vd@VD{..} <- getViewData
staticRootUrl <- (staticRoot . settings) <$> getYesod staticRootUrl <- (staticRoot . settings) <$> getYesod
@ -46,5 +46,5 @@ getRegisterR = do
^{importform} ^{importform}
|] |]
postRegisterR :: Handler RepHtml postRegisterR :: Handler Html
postRegisterR = handlePost postRegisterR = handlePost

View File

@ -4,5 +4,5 @@ module Handler.RootR where
import Import import Import
getRootR :: Handler RepHtml getRootR :: Handler Html
getRootR = redirect defaultroute where defaultroute = RegisterR getRootR = redirect defaultroute where defaultroute = RegisterR

View File

@ -16,8 +16,8 @@ import Yesod.Default.Config --(fromArgs)
import Settings -- (parseExtra) import Settings -- (parseExtra)
import Application (makeApplication) import Application (makeApplication)
import Data.String import Data.String
import Data.Conduit.Network import Data.Conduit.Network hiding (setPort)
import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsPort) import Network.Wai.Handler.Warp (runSettings, defaultSettings, setPort)
import Network.Wai.Handler.Launch (runUrlPort) import Network.Wai.Handler.Launch (runUrlPort)
-- --
import Prelude hiding (putStrLn) import Prelude hiding (putStrLn)
@ -61,19 +61,19 @@ web opts j = do
let j' = filterJournalTransactions (queryFromOpts d $ reportopts_ $ cliopts_ opts) j let j' = filterJournalTransactions (queryFromOpts d $ reportopts_ $ cliopts_ opts) j
p = port_ opts p = port_ opts
u = base_url_ opts u = base_url_ opts
staticRoot = pack <$> static_root_ opts staticRoot' = pack <$> static_root_ opts
_ <- printf "Starting web app on port %d with base url %s\n" p u _ <- printf "Starting web app on port %d with base url %s\n" p u
app <- makeApplication opts j' AppConfig{appEnv = Development app <- makeApplication opts j' AppConfig{appEnv = Development
,appPort = p ,appPort = p
,appRoot = pack u ,appRoot = pack u
,appHost = fromString "*4" ,appHost = fromString "*4"
,appExtra = Extra "" Nothing staticRoot ,appExtra = Extra "" Nothing staticRoot'
} }
if server_ opts if server_ opts
then do then do
putStrLn "Press ctrl-c to quit" putStrLn "Press ctrl-c to quit"
hFlush stdout hFlush stdout
runSettings defaultSettings{settingsPort=p} app runSettings (setPort p defaultSettings) app
else do else do
putStrLn "Starting web browser if possible" putStrLn "Starting web browser if possible"
putStrLn "Web app will auto-exit after a few minutes with no browsers (or press ctrl-c)" putStrLn "Web app will auto-exit after a few minutes with no browsers (or press ctrl-c)"

View File

@ -97,8 +97,8 @@ tests_Hledger_Cli = TestList
,"account directive should preserve \"virtual\" posting type" ~: do ,"account directive should preserve \"virtual\" posting type" ~: do
j <- readJournal Nothing Nothing Nothing "!account test\n2008/12/07 One\n (from) $-1\n (to) $1\n" >>= either error' return j <- readJournal Nothing Nothing Nothing "!account test\n2008/12/07 One\n (from) $-1\n (to) $1\n" >>= either error' return
let p = head $ tpostings $ head $ jtxns j let p = head $ tpostings $ head $ jtxns j
assertBool "" $ (paccount p) == "test:from" assertBool "" $ paccount p == "test:from"
assertBool "" $ (ptype p) == VirtualPosting assertBool "" $ ptype p == VirtualPosting
] ]
@ -188,6 +188,7 @@ sample_journal_str = unlines
] ]
-} -}
defaultyear_journal_str :: String
defaultyear_journal_str = unlines defaultyear_journal_str = unlines
["Y2009" ["Y2009"
,"" ,""
@ -337,9 +338,10 @@ defaultyear_journal_str = unlines
-- ,"" -- ,""
-- ] -- ]
journal7 :: Journal
journal7 = nulljournal {jtxns = journal7 = nulljournal {jtxns =
[ [
txnTieKnot $ Transaction { txnTieKnot Transaction {
tdate=parsedate "2007/01/01", tdate=parsedate "2007/01/01",
tdate2=Nothing, tdate2=Nothing,
tstatus=False, tstatus=False,
@ -354,7 +356,7 @@ journal7 = nulljournal {jtxns =
tpreceding_comment_lines="" tpreceding_comment_lines=""
} }
, ,
txnTieKnot $ Transaction { txnTieKnot Transaction {
tdate=parsedate "2007/02/01", tdate=parsedate "2007/02/01",
tdate2=Nothing, tdate2=Nothing,
tstatus=False, tstatus=False,
@ -369,7 +371,7 @@ journal7 = nulljournal {jtxns =
tpreceding_comment_lines="" tpreceding_comment_lines=""
} }
, ,
txnTieKnot $ Transaction { txnTieKnot Transaction {
tdate=parsedate "2007/01/02", tdate=parsedate "2007/01/02",
tdate2=Nothing, tdate2=Nothing,
tstatus=False, tstatus=False,
@ -384,7 +386,7 @@ journal7 = nulljournal {jtxns =
tpreceding_comment_lines="" tpreceding_comment_lines=""
} }
, ,
txnTieKnot $ Transaction { txnTieKnot Transaction {
tdate=parsedate "2007/01/03", tdate=parsedate "2007/01/03",
tdate2=Nothing, tdate2=Nothing,
tstatus=False, tstatus=False,
@ -399,7 +401,7 @@ journal7 = nulljournal {jtxns =
tpreceding_comment_lines="" tpreceding_comment_lines=""
} }
, ,
txnTieKnot $ Transaction { txnTieKnot Transaction {
tdate=parsedate "2007/01/03", tdate=parsedate "2007/01/03",
tdate2=Nothing, tdate2=Nothing,
tstatus=False, tstatus=False,
@ -414,7 +416,7 @@ journal7 = nulljournal {jtxns =
tpreceding_comment_lines="" tpreceding_comment_lines=""
} }
, ,
txnTieKnot $ Transaction { txnTieKnot Transaction {
tdate=parsedate "2007/01/03", tdate=parsedate "2007/01/03",
tdate2=Nothing, tdate2=Nothing,
tstatus=False, tstatus=False,
@ -431,4 +433,5 @@ journal7 = nulljournal {jtxns =
] ]
} }
ledger7 :: Ledger
ledger7 = ledgerFromJournal Any journal7 ledger7 = ledgerFromJournal Any journal7

View File

@ -6,6 +6,7 @@ Print a histogram report. (The "activity" command).
module Hledger.Cli.Histogram module Hledger.Cli.Histogram
where where
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.Ord import Data.Ord
@ -19,7 +20,7 @@ import Hledger.Query
import Prelude hiding (putStr) import Prelude hiding (putStr)
import Hledger.Utils.UTF8IOCompat (putStr) import Hledger.Utils.UTF8IOCompat (putStr)
activitymode :: Mode RawOpts
activitymode = (defCommandMode $ ["activity"] ++ aliases) { activitymode = (defCommandMode $ ["activity"] ++ aliases) {
modeHelp = "show an ascii barchart of posting counts per interval (default: daily)" `withAliases` aliases modeHelp = "show an ascii barchart of posting counts per interval (default: daily)" `withAliases` aliases
,modeHelpSuffix = [] ,modeHelpSuffix = []
@ -31,6 +32,7 @@ activitymode = (defCommandMode $ ["activity"] ++ aliases) {
} }
where aliases = [] where aliases = []
barchar :: Char
barchar = '*' barchar = '*'
-- | Print a histogram of some statistic per reporting interval, such as -- | Print a histogram of some statistic per reporting interval, such as
@ -46,8 +48,8 @@ showHistogram opts q j = concatMap (printDayWith countBar) spanps
i = intervalFromOpts opts i = intervalFromOpts opts
interval | i == NoInterval = Days 1 interval | i == NoInterval = Days 1
| otherwise = i | otherwise = i
span = queryDateSpan (date2_ opts) q `spanDefaultsFrom` journalDateSpan (date2_ opts) j span' = queryDateSpan (date2_ opts) q `spanDefaultsFrom` journalDateSpan (date2_ opts) j
spans = filter (DateSpan Nothing Nothing /=) $ splitSpan interval span spans = filter (DateSpan Nothing Nothing /=) $ splitSpan interval span'
spanps = [(s, filter (isPostingInDateSpan s) ps) | s <- spans] spanps = [(s, filter (isPostingInDateSpan s) ps) | s <- spans]
-- same as Register -- same as Register
-- should count transactions, not postings ? -- should count transactions, not postings ?

View File

@ -197,3 +197,21 @@ test-suite tests
, wizards == 1.0.* , wizards == 1.0.*
if impl(ghc >= 7.4) if impl(ghc >= 7.4)
build-depends: pretty-show >= 1.6.4 build-depends: pretty-show >= 1.6.4
benchmark bench
type: exitcode-stdio-1.0
-- hs-source-dirs: src
main-is: ../tools/simplebench.hs
ghc-options: -Wall
default-language: Haskell2010
build-depends: hledger-lib,
hledger,
base >= 4.3 && < 5,
old-locale,
time,
html,
tabular >= 0.2 && < 0.3,
process,
filepath,
directory