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

lib: textification begins! account names

Browse Source 
The first of several conversions from String to (strict) Text, hopefully
reducing space and time usage.

This one shows a small improvement, with GHC 7.10.3 and text-1.2.2.1:

hledger -f data/100x100x10.journal stats
string: <<ghc: 39471064 bytes, 77 GCs, 198421/275048 avg/max bytes residency (3 samples), 2M in use, 0.000 INIT (0.001 elapsed), 0.015 MUT (0.020 elapsed), 0.010 GC (0.014 elapsed) :ghc>>
text:   <<ghc: 39268024 bytes, 77 GCs, 197018/270840 avg/max bytes residency (3 samples), 2M in use, 0.000 INIT (0.002 elapsed), 0.016 MUT (0.022 elapsed), 0.009 GC (0.011 elapsed) :ghc>>

hledger -f data/1000x100x10.journal stats
string: <<ghc: 318555920 bytes, 617 GCs, 2178997/7134472 avg/max bytes residency (7 samples), 16M in use, 0.000 INIT (0.001 elapsed), 0.129 MUT (0.136 elapsed), 0.067 GC (0.077 elapsed) :ghc>>
text:   <<ghc: 314248496 bytes, 612 GCs, 2074045/6617960 avg/max bytes residency (7 samples), 16M in use, 0.000 INIT (0.003 elapsed), 0.137 MUT (0.145 elapsed), 0.067 GC (0.079 elapsed) :ghc>>

hledger -f data/10000x100x10.journal stats
string: <<ghc: 3114763608 bytes, 6026 GCs, 18858950/75552024 avg/max bytes residency (11 samples), 201M in use, 0.000 INIT (0.000 elapsed), 1.331 MUT (1.372 elapsed), 0.699 GC (0.812 elapsed) :ghc>>
text:   <<ghc: 3071468920 bytes, 5968 GCs, 14120344/62951360 avg/max bytes residency (9 samples), 124M in use, 0.000 INIT (0.003 elapsed), 1.272 MUT (1.349 elapsed), 0.513 GC (0.578 elapsed) :ghc>>

hledger -f data/100000x100x10.journal stats
string: <<ghc: 31186579432 bytes, 60278 GCs, 135332581/740228992 avg/max bytes residency (13 samples), 1697M in use, 0.000 INIT (0.008 elapsed), 14.677 MUT (15.508 elapsed), 7.081 GC (8.074 elapsed) :ghc>>
text:   <<ghc: 30753427672 bytes, 59763 GCs, 117595958/666457240 avg/max bytes residency (14 samples), 1588M in use, 0.000 INIT (0.008 elapsed), 13.713 MUT (13.966 elapsed), 6.220 GC (7.108 elapsed) :ghc>>
This commit is contained in:
Simon Michael 2016-05-23 18:16:21 -07:00
parent 097c9e09b6
commit 2538d14ea7
40 changed files with 626 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
hledger-lib/Hledger/Data/Account.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE RecordWildCards, StandaloneDeriving #-}
{-# LANGUAGE RecordWildCards, StandaloneDeriving, OverloadedStrings #-}
{-|

63
hledger-lib/Hledger/Data/AccountName.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE NoMonomorphismRestriction#-}
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}
{-|
'AccountName's are strings like @assets:cash:petty@, with multiple
@ -10,7 +10,9 @@ hierarchy.
module Hledger.Data.AccountName
where
import Data.List
import Data.List.Split (splitOn)
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Data.Tree
import Test.HUnit
import Text.Printf
@ -19,24 +21,29 @@ import Hledger.Data.Types
import Hledger.Utils
-- change to use a different separator for nested accounts
acctsepchar :: Char
acctsepchar = ':'
accountNameComponents :: AccountName -> [String]
accountNameComponents = splitAtElement acctsepchar
acctsep :: Text
acctsep = T.pack [acctsepchar]
accountNameFromComponents :: [String] -> AccountName
accountNameFromComponents = concat . intersperse [acctsepchar]
-- accountNameComponents :: AccountName -> [String]
-- accountNameComponents = splitAtElement acctsepchar
accountLeafName :: AccountName -> String
accountNameComponents :: AccountName -> [Text]
accountNameComponents = T.splitOn acctsep
accountNameFromComponents :: [Text] -> AccountName
accountNameFromComponents = T.intercalate acctsep
accountLeafName :: AccountName -> Text
accountLeafName = last . accountNameComponents
-- | Truncate all account name components but the last to two characters.
accountSummarisedName :: AccountName -> String
accountSummarisedName :: AccountName -> Text
accountSummarisedName a
-- length cs > 1 = take 2 (head cs) ++ ":" ++ a'
| length cs > 1 = intercalate ":" (map (take 2) $ init cs) ++ ":" ++ a'
| length cs > 1 = (T.intercalate ":" (map (T.take 2) $ init cs)) <> ":" <> a'
| otherwise = a'
where
cs = accountNameComponents a
@ -44,7 +51,7 @@ accountSummarisedName a
accountNameLevel :: AccountName -> Int
accountNameLevel "" = 0
accountNameLevel a = length (filter (==acctsepchar) a) + 1
accountNameLevel a = T.length (T.filter (==acctsepchar) a) + 1
accountNameDrop :: Int -> AccountName -> AccountName
accountNameDrop n = accountNameFromComponents . drop n . accountNameComponents
@ -72,7 +79,7 @@ parentAccountNames a = parentAccountNames' $ parentAccountName a
-- | Is the first account a parent or other ancestor of (and not the same as) the second ?
isAccountNamePrefixOf :: AccountName -> AccountName -> Bool
isAccountNamePrefixOf = isPrefixOf . (++ [acctsepchar])
isAccountNamePrefixOf = T.isPrefixOf . (<> acctsep)
isSubAccountNameOf :: AccountName -> AccountName -> Bool
s `isSubAccountNameOf` p =
@ -113,22 +120,22 @@ nullaccountnametree = Node "root" []
elideAccountName :: Int -> AccountName -> AccountName
elideAccountName width s
-- XXX special case for transactions register's multi-account pseudo-names
| " (split)" `isSuffixOf` s =
| " (split)" `T.isSuffixOf` s =
let
names = splitOn ", " $ take (length s - 8) s
names = T.splitOn ", " $ T.take (T.length s - 8) s
widthpername = (max 0 (width - 8 - 2 * (max 1 (length names) - 1))) `div` length names
in
fitString Nothing (Just width) True False $
(++" (split)") $
intercalate ", " $
fitText Nothing (Just width) True False $
(<>" (split)") $
T.intercalate ", " $
[accountNameFromComponents $ elideparts widthpername [] $ accountNameComponents s' | s' <- names]
| otherwise =
fitString Nothing (Just width) True False $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s
fitText Nothing (Just width) True False $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s
where
elideparts :: Int -> [String] -> [String] -> [String]
elideparts :: Int -> [Text] -> [Text] -> [Text]
elideparts width done ss
| strWidth (accountNameFromComponents $ done++ss) <= width = done++ss
| length ss > 1 = elideparts width (done++[takeWidth 2 $ head ss]) (tail ss)
| textWidth (accountNameFromComponents $ done++ss) <= width = done++ss
| length ss > 1 = elideparts width (done++[textTakeWidth 2 $ head ss]) (tail ss)
| otherwise = done++ss
-- | Keep only the first n components of an account name, where n
@ -143,18 +150,18 @@ clipOrEllipsifyAccountName 0 = const "..."
clipOrEllipsifyAccountName n = accountNameFromComponents . take n . accountNameComponents
-- | Convert an account name to a regular expression matching it and its subaccounts.
accountNameToAccountRegex :: String -> String
accountNameToAccountRegex :: AccountName -> Regexp
accountNameToAccountRegex "" = ""
accountNameToAccountRegex a = printf "^%s(:|$)" a
accountNameToAccountRegex a = printf "^%s(:|$)" (T.unpack a)
-- | Convert an account name to a regular expression matching it but not its subaccounts.
accountNameToAccountOnlyRegex :: String -> String
accountNameToAccountOnlyRegex :: AccountName -> Regexp
accountNameToAccountOnlyRegex "" = ""
accountNameToAccountOnlyRegex a = printf "^%s$" a
accountNameToAccountOnlyRegex a = printf "^%s$" $ T.unpack a -- XXX pack
-- | Convert an exact account-matching regular expression to a plain account name.
accountRegexToAccountName :: String -> String
accountRegexToAccountName = regexReplace "^\\^(.*?)\\(:\\|\\$\\)$" "\\1"
accountRegexToAccountName :: Regexp -> AccountName
accountRegexToAccountName = T.pack . regexReplace "^\\^(.*?)\\(:\\|\\$\\)$" "\\1" -- XXX pack
-- | Does this string look like an exact account-matching regular expression ?
isAccountRegex :: String -> Bool

8
hledger-lib/Hledger/Data/Journal.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneDeriving, OverloadedStrings #-}
{-|
A 'Journal' is a set of transactions, plus optional related data. This is
@ -63,6 +63,8 @@ import Data.List
import Data.Maybe
import Data.Monoid
import Data.Ord
-- import Data.Text (Text)
import qualified Data.Text as T
import Safe (headMay, headDef)
import Data.Time.Calendar
import Data.Tree
@ -520,7 +522,7 @@ checkBalanceAssertion (errs,startbal) ps
"%s"
])
(showDate $ postingDate p)
(paccount p)
(T.unpack $ paccount p) -- XXX pack
assertedcomm
(showMixedAmount assertedbal)
(showMixedAmount finalsinglebal)
@ -528,7 +530,7 @@ checkBalanceAssertion (errs,startbal) ps
(showPostingLine p)
(case ptransaction p of
Nothing -> ""
Just t -> printf "in transaction at %s line %d:\n%s" f l (show t)
Just t -> printf "in transaction at %s line %d:\n%s" f l (show t) :: String
where GenericSourcePos f l _ = tsourcepos t
)

4
hledger-lib/Hledger/Data/Ledger.hs
View File

@ -10,6 +10,8 @@ balances, and postings in each account.
module Hledger.Data.Ledger
where
import qualified Data.Map as M
-- import Data.Text (Text)
import qualified Data.Text as T
import Safe (headDef)
import Test.HUnit
import Text.Printf
@ -72,7 +74,7 @@ ledgerLeafAccounts = filter (null.asubs) . laccounts
-- | Accounts in ledger whose name matches the pattern, in tree order.
ledgerAccountsMatching :: [String] -> Ledger -> [Account]
ledgerAccountsMatching pats = filter (matchpats pats . aname) . laccounts
ledgerAccountsMatching pats = filter (matchpats pats . T.unpack . aname) . laccounts -- XXX pack
-- | List a ledger's postings, in the order parsed.
ledgerPostings :: Ledger -> [Posting]

29
hledger-lib/Hledger/Data/Posting.hs
View File

@ -7,6 +7,8 @@ look up the date or description there.
-}
{-# LANGUAGE OverloadedStrings #-}
module Hledger.Data.Posting (
-- * Posting
nullposting,
@ -50,7 +52,10 @@ where
import Data.List
import Data.Maybe
import Data.MemoUgly (memo)
import Data.Monoid
import Data.Ord
-- import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar
import Safe
import Test.HUnit
@ -89,7 +94,7 @@ showPosting p@Posting{paccount=a,pamount=amt,ptype=t} =
where
ledger3ishlayout = False
acctnamewidth = if ledger3ishlayout then 25 else 22
showaccountname = fitString (Just acctnamewidth) Nothing False False . bracket . elideAccountName width
showaccountname = fitString (Just acctnamewidth) Nothing False False . bracket . T.unpack . elideAccountName width
(bracket,width) = case t of
BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2)
VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2)
@ -192,32 +197,32 @@ postingsDateSpan' wd ps = DateSpan (Just $ postingdate $ head ps') (Just $ addDa
accountNamePostingType :: AccountName -> PostingType
accountNamePostingType a
| null a = RegularPosting
| head a == '[' && last a == ']' = BalancedVirtualPosting
| head a == '(' && last a == ')' = VirtualPosting
| T.null a = RegularPosting
| T.head a == '[' && T.last a == ']' = BalancedVirtualPosting
| T.head a == '(' && T.last a == ')' = VirtualPosting
| otherwise = RegularPosting
accountNameWithoutPostingType :: AccountName -> AccountName
accountNameWithoutPostingType a = case accountNamePostingType a of
BalancedVirtualPosting -> init $ tail a
VirtualPosting -> init $ tail a
BalancedVirtualPosting -> T.init $ T.tail a
VirtualPosting -> T.init $ T.tail a
RegularPosting -> a
accountNameWithPostingType :: PostingType -> AccountName -> AccountName
accountNameWithPostingType BalancedVirtualPosting a = "["++accountNameWithoutPostingType a++"]"
accountNameWithPostingType VirtualPosting a = "("++accountNameWithoutPostingType a++")"
accountNameWithPostingType BalancedVirtualPosting a = "["<>accountNameWithoutPostingType a<>"]"
accountNameWithPostingType VirtualPosting a = "("<>accountNameWithoutPostingType a<>")"
accountNameWithPostingType RegularPosting a = accountNameWithoutPostingType a
-- | Prefix one account name to another, preserving posting type
-- indicators like concatAccountNames.
joinAccountNames :: AccountName -> AccountName -> AccountName
joinAccountNames a b = concatAccountNames $ filter (not . null) [a,b]
joinAccountNames a b = concatAccountNames $ filter (not . T.null) [a,b]
-- | Join account names into one. If any of them has () or [] posting type
-- indicators, these (the first type encountered) will also be applied to
-- the resulting account name.
concatAccountNames :: [AccountName] -> AccountName
concatAccountNames as = accountNameWithPostingType t $ intercalate ":" $ map accountNameWithoutPostingType as
concatAccountNames as = accountNameWithPostingType t $ T.intercalate ":" $ map accountNameWithoutPostingType as
where t = headDef RegularPosting $ filter (/= RegularPosting) $ map accountNamePostingType as
-- | Rewrite an account name using all matching aliases from the given list, in sequence.
@ -241,9 +246,9 @@ accountNameApplyAliasesMemo aliases = memo (accountNameApplyAliases aliases)
aliasReplace :: AccountAlias -> AccountName -> AccountName
aliasReplace (BasicAlias old new) a
| old `isAccountNamePrefixOf` a || old == a = new ++ drop (length old) a
| old `isAccountNamePrefixOf` a || old == a = new <> T.drop (T.length old) a
| otherwise = a
aliasReplace (RegexAlias re repl) a = regexReplaceCIMemo re repl a
aliasReplace (RegexAlias re repl) a = T.pack $ regexReplaceCIMemo re repl $ T.unpack a -- XXX
tests_Hledger_Data_Posting = TestList [

5
hledger-lib/Hledger/Data/Timeclock.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-|
A 'TimeclockEntry' is a clock-in, clock-out, or other directive in a timeclock
@ -7,9 +6,13 @@ converted to 'Transactions' and queried like a ledger.
-}
{-# LANGUAGE CPP, OverloadedStrings #-}
module Hledger.Data.Timeclock
where
import Data.Maybe
-- import Data.Text (Text)
-- import qualified Data.Text as T
import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.Format

28
hledger-lib/Hledger/Data/Transaction.hs
View File

@ -7,11 +7,15 @@ tags.
-}
{-# LANGUAGE OverloadedStrings #-}
module Hledger.Data.Transaction (
-- * Transaction
nullsourcepos,
nulltransaction,
txnTieKnot,
txnUntieKnot,
journalUntieKnots,
-- settxn,
-- * operations
showAccountName,
@ -38,6 +42,8 @@ module Hledger.Data.Transaction (
where
import Data.List
import Data.Maybe
-- import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar
import Test.HUnit
import Text.Printf
@ -188,7 +194,7 @@ postingAsLines elideamount onelineamounts ps p =
showstatus p ++ fitString (Just acctwidth) Nothing False True (showAccountName Nothing (ptype p) (paccount p))
where
showstatus p = if pstatus p == Cleared then "* " else ""
acctwidth = maximum $ map (strWidth . paccount) ps
acctwidth = maximum $ map (textWidth . paccount) ps
-- currently prices are considered part of the amount string when right-aligning amounts
amount
@ -239,11 +245,15 @@ indent = (" "++)
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
fmt RegularPosting = take w' . T.unpack
fmt VirtualPosting = parenthesise . reverse . take (w'-2) . reverse . T.unpack
fmt BalancedVirtualPosting = bracket . reverse . take (w'-2) . reverse . T.unpack
w' = fromMaybe 999999 w
parenthesise :: String -> String
parenthesise s = "("++s++")"
bracket :: String -> String
bracket s = "["++s++"]"
hasRealPostings :: Transaction -> Bool
@ -414,6 +424,16 @@ transactionDate2 t = fromMaybe (tdate t) $ tdate2 t
txnTieKnot :: Transaction -> Transaction
txnTieKnot t@Transaction{tpostings=ps} = t{tpostings=map (settxn t) ps}
-- | Ensure a transaction's postings do not refer back to it, so that eg
-- recursiveSize and GHCI's :sprint work right.
txnUntieKnot :: Transaction -> Transaction
txnUntieKnot t@Transaction{tpostings=ps} = t{tpostings=map (\p -> p{ptransaction=Nothing}) ps}
-- | Untie all transaction-posting knots in this journal, so that eg
-- recursiveSize and GHCI's :sprint can work on it.
journalUntieKnots :: Transaction -> Transaction
journalUntieKnots t@Transaction{tpostings=ps} = t{tpostings=map (\p -> p{ptransaction=Nothing}) ps}
-- | Set a posting's parent transaction.
settxn :: Transaction -> Posting -> Posting
settxn t p = p{ptransaction=Just t}

6
hledger-lib/Hledger/Data/Types.hs
View File

@ -27,6 +27,8 @@ import Data.Data
import Data.Decimal
import Text.Blaze (ToMarkup(..))
import qualified Data.Map as M
import Data.Text (Text)
-- import qualified Data.Text as T
import Data.Time.Calendar
import Data.Time.LocalTime
import System.Time (ClockTime(..))
@ -50,7 +52,7 @@ data Interval = NoInterval
instance NFData Interval
type AccountName = String
type AccountName = Text
data AccountAlias = BasicAlias AccountName AccountName
| RegexAlias Regexp Replacement
@ -206,7 +208,7 @@ data TimeclockEntry = TimeclockEntry {
tlsourcepos :: GenericSourcePos,
tlcode :: TimeclockCode,
tldatetime :: LocalTime,
tlaccount :: String,
tlaccount :: AccountName,
tldescription :: String
} deriving (Eq,Ord,Typeable,Data,Generic)

13
hledger-lib/Hledger/Query.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-|
A general query system for matching things (accounts, postings,
@ -6,6 +5,8 @@ transactions..) by various criteria, and a parser for query expressions.
-}
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
module Hledger.Query (
-- * Query and QueryOpt
Query(..),
@ -45,6 +46,8 @@ import Data.Data
import Data.Either
import Data.List
import Data.Maybe
-- import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar
import Safe (readDef, headDef)
import Test.HUnit
@ -236,8 +239,8 @@ defaultprefix = "acct"
-- | Parse a single query term as either a query or a query option,
-- or raise an error if it has invalid syntax.
parseQueryTerm :: Day -> String -> Either Query QueryOpt
parseQueryTerm _ ('i':'n':'a':'c':'c':'t':'o':'n':'l':'y':':':s) = Right $ QueryOptInAcctOnly s
parseQueryTerm _ ('i':'n':'a':'c':'c':'t':':':s) = Right $ QueryOptInAcct s
parseQueryTerm _ ('i':'n':'a':'c':'c':'t':'o':'n':'l':'y':':':s) = Right $ QueryOptInAcctOnly $ T.pack s
parseQueryTerm _ ('i':'n':'a':'c':'c':'t':':':s) = Right $ QueryOptInAcct $ T.pack s
parseQueryTerm d ('n':'o':'t':':':s) = case parseQueryTerm d s of
Left m -> Left $ Not m
Right _ -> Left Any -- not:somequeryoption will be ignored
@ -573,7 +576,7 @@ matchesAccount (None) _ = False
matchesAccount (Not m) a = not $ matchesAccount m a
matchesAccount (Or ms) a = any (`matchesAccount` a) ms
matchesAccount (And ms) a = all (`matchesAccount` a) ms
matchesAccount (Acct r) a = regexMatchesCI r a
matchesAccount (Acct r) a = regexMatchesCI r (T.unpack a) -- XXX pack
matchesAccount (Depth d) a = accountNameLevel a <= d
matchesAccount (Tag _ _) _ = False
matchesAccount _ _ = True
@ -634,7 +637,7 @@ matchesPosting (Or qs) p = any (`matchesPosting` p) qs
matchesPosting (And qs) p = all (`matchesPosting` p) qs
matchesPosting (Code r) p = regexMatchesCI r $ maybe "" tcode $ ptransaction p
matchesPosting (Desc r) p = regexMatchesCI r $ maybe "" tdescription $ ptransaction p
matchesPosting (Acct r) p = regexMatchesCI r $ paccount p
matchesPosting (Acct r) p = regexMatchesCI r $ T.unpack $ paccount p -- XXX pack
matchesPosting (Date span) p = span `spanContainsDate` postingDate p
matchesPosting (Date2 span) p = span `spanContainsDate` postingDate2 p
matchesPosting (Status Uncleared) p = postingStatus p /= Cleared

9
hledger-lib/Hledger/Read/Common.hs
View File

@ -27,6 +27,8 @@ import Data.Functor.Identity
import Data.List.Compat
import Data.List.Split (wordsBy)
import Data.Maybe
-- import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar
import Data.Time.LocalTime
import Safe
@ -104,7 +106,7 @@ popParentAccount = do
[] -> unexpected "End of apply account block with no beginning"
(_:rest) -> setState j{jparseparentaccounts=rest}
getParentAccount :: Monad m => JournalParser m String
getParentAccount :: Monad m => JournalParser m AccountName
getParentAccount = fmap (concatAccountNames . reverse . jparseparentaccounts) getState
addAccountAlias :: Monad m => AccountAlias -> JournalParser m ()
@ -271,12 +273,13 @@ modifiedaccountnamep = do
-- (This parser will also consume one following space, if present.)
accountnamep :: Monad m => StringParser u m AccountName
accountnamep = do
a <- do
astr <- do
c <- nonspace
cs <- striptrailingspace <$> many (nonspace <|> singlespace)
return $ c:cs
let a = T.pack astr
when (accountNameFromComponents (accountNameComponents a) /= a)
(fail $ "account name seems ill-formed: "++a)
(fail $ "account name seems ill-formed: "++astr)
return a
where
singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}})

6
hledger-lib/Hledger/Read/CsvReader.hs
View File

@ -30,6 +30,8 @@ import Data.Char (toLower, isDigit, isSpace)
import Data.List.Compat
import Data.Maybe
import Data.Ord
-- import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day)
#if MIN_VERSION_time(1,5,0)
import Data.Time.Format (parseTimeM, defaultTimeLocale)
@ -638,8 +640,8 @@ transactionFromCsvRecord sourcepos rules record = t
defaccount2 = case isNegativeMixedAmount amount2 of
Just True -> "income:unknown"
_ -> "expenses:unknown"
account1 = maybe "" render (mfieldtemplate "account1") `or` defaccount1
account2 = maybe "" render (mfieldtemplate "account2") `or` defaccount2
account1 = T.pack $ maybe "" render (mfieldtemplate "account1") `or` defaccount1
account2 = T.pack $ maybe "" render (mfieldtemplate "account2") `or` defaccount2
-- build the transaction
t = nulltransaction{

6
hledger-lib/Hledger/Read/JournalReader.hs
View File

@ -82,6 +82,8 @@ import Control.Monad
import Control.Monad.Except (ExceptT(..), liftIO, runExceptT, throwError)
import qualified Data.Map.Strict as M
import Data.Monoid
-- import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar
import Data.Time.LocalTime
import Safe
@ -319,7 +321,7 @@ basicaliasp = do
char '='
many spacenonewline
new <- rstrip <$> anyChar `manyTill` eolof -- don't require a final newline, good for cli options
return $ BasicAlias old new
return $ BasicAlias (T.pack old) (T.pack new)
regexaliasp :: Monad m => StringParser u m AccountAlias
regexaliasp = do
@ -550,7 +552,7 @@ postingp mtdate = do
status <- statusp
many spacenonewline
account <- modifiedaccountnamep
let (ptype, account') = (accountNamePostingType account, unbracket account)
let (ptype, account') = (accountNamePostingType account, textUnbracket account)
amount <- spaceandamountormissingp
massertion <- partialbalanceassertionp
_ <- fixedlotpricep

4
hledger-lib/Hledger/Read/TimeclockReader.hs
View File

@ -40,6 +40,8 @@ i, o or O. The meanings of the codes are:
-}
{-# LANGUAGE OverloadedStrings #-}
module Hledger.Read.TimeclockReader (
-- * Reader
reader,
@ -55,6 +57,8 @@ import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Except (ExceptT)
import Data.Maybe (fromMaybe)
-- import Data.Text (Text)
-- import qualified Data.Text as T
import Test.HUnit
import Text.Parsec hiding (parse)
import System.FilePath

2
hledger-lib/Hledger/Reports/BalanceReport.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables, OverloadedStrings #-}
{-|
Balance report, used by the balance command.

2
hledger-lib/Hledger/Reports/PostingsReport.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances, TupleSections #-}
{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances, TupleSections, OverloadedStrings #-}
{-|
Postings report, used by the register command.

4
hledger-lib/Hledger/Reports/TransactionsReports.hs
View File

@ -30,6 +30,8 @@ where
import Data.List
import Data.Ord
-- import Data.Text (Text)
import qualified Data.Text as T
-- import Test.HUnit
import Hledger.Data
@ -204,7 +206,7 @@ accountTransactionsReportItems query thisacctquery bal signfn (torig:ts) =
-- To reduce noise, if there are both real and virtual postings, show only the real ones.
summarisePostingAccounts :: [Posting] -> String
summarisePostingAccounts ps =
(intercalate ", " . map accountSummarisedName . nub . map paccount) displayps
(intercalate ", " . map (T.unpack . accountSummarisedName) . nub . map paccount) displayps -- XXX pack
where
realps = filter isReal ps
displayps | null realps = ps

6
hledger-lib/Hledger/Utils.hs
View File

@ -22,6 +22,7 @@ module Hledger.Utils (---- provide these frequently used modules - or not, for c
module Hledger.Utils.Parse,
module Hledger.Utils.Regex,
module Hledger.Utils.String,
module Hledger.Utils.Text,
module Hledger.Utils.Test,
module Hledger.Utils.Tree,
-- Debug.Trace.trace,
@ -38,6 +39,8 @@ import Control.Monad (liftM)
-- import Data.PPrint
import Data.Time.Clock
import Data.Time.LocalTime
-- import Data.Text (Text)
-- import qualified Data.Text as T
import System.Directory (getHomeDirectory)
import System.FilePath((</>), isRelative)
import System.IO
@ -48,6 +51,7 @@ import Hledger.Utils.Debug
import Hledger.Utils.Parse
import Hledger.Utils.Regex
import Hledger.Utils.String
import Hledger.Utils.Text
import Hledger.Utils.Test
import Hledger.Utils.Tree
-- import Prelude hiding (readFile,writeFile,appendFile,getContents,putStr,putStrLn)
@ -91,6 +95,8 @@ splitAtElement x l =
split es = let (first,rest) = break (x==) es
in first : splitAtElement x rest
-- text
-- time
getCurrentLocalTime :: IO LocalTime

1
hledger-lib/Hledger/Utils/String.hs
View File

@ -42,6 +42,7 @@ module Hledger.Utils.String (
cliptopleft,
fitto,
-- * wide-character-aware layout
charWidth,
strWidth,
takeWidth,
fitString,

404
hledger-lib/Hledger/Utils/Text.hs Normal file
View File

@ -0,0 +1,404 @@
-- | Text formatting helpers, ported from String as needed.
-- There may be better alternatives out there.
{-# LANGUAGE OverloadedStrings #-}
module Hledger.Utils.Text
-- (
-- -- * misc
-- lowercase,
-- uppercase,
-- underline,
-- stripbrackets,
-- unbracket,
-- -- quoting
-- quoteIfSpaced,
-- quoteIfNeeded,
-- singleQuoteIfNeeded,
-- -- quotechars,
-- -- whitespacechars,
-- escapeDoubleQuotes,
-- escapeSingleQuotes,
-- escapeQuotes,
-- words',
-- unwords',
-- stripquotes,
-- isSingleQuoted,
-- isDoubleQuoted,
-- -- * single-line layout
-- strip,
-- lstrip,
-- rstrip,
-- chomp,
-- elideLeft,
-- elideRight,
-- formatString,
-- -- * multi-line layout
-- concatTopPadded,
-- concatBottomPadded,
-- concatOneLine,
-- vConcatLeftAligned,
-- vConcatRightAligned,
-- padtop,
-- padbottom,
-- padleft,
-- padright,
-- cliptopleft,
-- fitto,
-- -- * wide-character-aware layout
-- strWidth,
-- textTakeWidth,
-- fitString,
-- fitStringMulti,
-- padLeftWide,
-- padRightWide
-- )
where
-- import Data.Char
import Data.List
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
-- import Text.Parsec
-- import Text.Printf (printf)
-- import Hledger.Utils.Parse
-- import Hledger.Utils.Regex
import Hledger.Utils.String (charWidth)
-- lowercase, uppercase :: String -> String
-- lowercase = map toLower
-- uppercase = map toUpper
-- -- | Remove leading and trailing whitespace.
-- strip :: String -> String
-- strip = lstrip . rstrip
-- -- | Remove leading whitespace.
-- lstrip :: String -> String
-- lstrip = dropWhile (`elem` " \t") :: String -> String -- XXX isSpace ?
-- -- | Remove trailing whitespace.
-- rstrip :: String -> String
-- rstrip = reverse . lstrip . reverse
-- -- | Remove trailing newlines/carriage returns.
-- chomp :: String -> String
-- chomp = reverse . dropWhile (`elem` "\r\n") . reverse
-- stripbrackets :: String -> String
-- stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse :: String -> String
-- elideLeft :: Int -> String -> String
-- elideLeft width s =
-- if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s
-- elideRight :: Int -> String -> String
-- elideRight width s =
-- if length s > width then take (width - 2) s ++ ".." else s
-- -- | Clip and pad a string to a minimum & maximum width, and/or left/right justify it.
-- -- Works on multi-line strings too (but will rewrite non-unix line endings).
-- formatString :: Bool -> Maybe Int -> Maybe Int -> String -> String
-- formatString leftJustified minwidth maxwidth s = intercalate "\n" $ map (printf fmt) $ lines s
-- where
-- justify = if leftJustified then "-" else ""
-- minwidth' = maybe "" show minwidth
-- maxwidth' = maybe "" (("."++).show) maxwidth
-- fmt = "%" ++ justify ++ minwidth' ++ maxwidth' ++ "s"
-- underline :: String -> String
-- underline s = s' ++ replicate (length s) '-' ++ "\n"
-- where s'
-- | last s == '\n' = s
-- | otherwise = s ++ "\n"
-- -- | Wrap a string in double quotes, and \-prefix any embedded single
-- -- quotes, if it contains whitespace and is not already single- or
-- -- double-quoted.
-- quoteIfSpaced :: String -> String
-- quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s
-- | not $ any (`elem` s) whitespacechars = s
-- | otherwise = "'"++escapeSingleQuotes s++"'"
-- -- | Double-quote this string if it contains whitespace, single quotes
-- -- or double-quotes, escaping the quotes as needed.
-- quoteIfNeeded :: String -> String
-- quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = "\"" ++ escapeDoubleQuotes s ++ "\""
-- | otherwise = s
-- -- | Single-quote this string if it contains whitespace or double-quotes.
-- -- No good for strings containing single quotes.
-- singleQuoteIfNeeded :: String -> String
-- singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'"
-- | otherwise = s
-- quotechars, whitespacechars :: [Char]
-- quotechars = "'\""
-- whitespacechars = " \t\n\r"
-- escapeDoubleQuotes :: String -> String
-- escapeDoubleQuotes = regexReplace "\"" "\""
-- escapeSingleQuotes :: String -> String
-- escapeSingleQuotes = regexReplace "'" "\'"
-- escapeQuotes :: String -> String
-- escapeQuotes = regexReplace "([\"'])" "\\1"
-- -- | Quote-aware version of words - don't split on spaces which are inside quotes.
-- -- NB correctly handles "a'b" but not "''a''". Can raise an error if parsing fails.
-- words' :: String -> [String]
-- words' "" = []
-- words' s = map stripquotes $ fromparse $ parsewith p s
-- where
-- p = do ss <- (singleQuotedPattern <|> doubleQuotedPattern <|> pattern) `sepBy` many1 spacenonewline
-- -- eof
-- return ss
-- pattern = many (noneOf whitespacechars)
-- singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf "'")
-- doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"")
-- -- | Quote-aware version of unwords - single-quote strings which contain whitespace
-- unwords' :: [String] -> String
-- unwords' = unwords . map quoteIfNeeded
-- -- | Strip one matching pair of single or double quotes on the ends of a string.
-- stripquotes :: String -> String
-- stripquotes s = if isSingleQuoted s || isDoubleQuoted s then init $ tail s else s
-- isSingleQuoted s@(_:_:_) = head s == '\'' && last s == '\''
-- isSingleQuoted _ = False
-- isDoubleQuoted s@(_:_:_) = head s == '"' && last s == '"'
-- isDoubleQuoted _ = False
textUnbracket :: Text -> Text
textUnbracket s
| (T.head s == '[' && T.last s == ']') || (T.head s == '(' && T.last s == ')') = T.init $ T.tail s
| otherwise = s
-- | Join several multi-line strings as side-by-side rectangular strings of the same height, top-padded.
-- Treats wide characters as double width.
textConcatTopPadded :: [Text] -> Text
textConcatTopPadded ts = T.intercalate "\n" $ map T.concat $ transpose padded
where
lss = map T.lines ts :: [[Text]]
h = maximum $ map length lss
ypad ls = replicate (difforzero h (length ls)) "" ++ ls
xpad ls = map (textPadLeftWide w) ls
where w | null ls = 0
| otherwise = maximum $ map textWidth ls
padded = map (xpad . ypad) lss :: [[Text]]
-- -- | Join several multi-line strings as side-by-side rectangular strings of the same height, bottom-padded.
-- -- Treats wide characters as double width.
-- 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 (padRightWide w) ls where w | null ls = 0
-- | otherwise = maximum $ map strWidth ls
-- padded = map (xpad . ypad) lss
-- -- | Join multi-line strings horizontally, after compressing each of
-- -- them to a single line with a comma and space between each original line.
-- concatOneLine :: [String] -> String
-- concatOneLine strs = concat $ map ((intercalate ", ").lines) strs
-- -- | Join strings vertically, left-aligned and right-padded.
-- vConcatLeftAligned :: [String] -> String
-- vConcatLeftAligned ss = intercalate "\n" $ map showfixedwidth ss
-- where
-- showfixedwidth = printf (printf "%%-%ds" width)
-- width = maximum $ map length ss
-- -- | Join strings vertically, right-aligned and left-padded.
-- vConcatRightAligned :: [String] -> String
-- vConcatRightAligned ss = intercalate "\n" $ map showfixedwidth ss
-- where
-- showfixedwidth = printf (printf "%%%ds" width)
-- width = maximum $ map length ss
-- -- | 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
difforzero :: (Num a, Ord a) => a -> a -> a
difforzero a b = maximum [(a - b), 0]
-- -- | Convert a multi-line string to a rectangular string left-padded to the specified width.
-- -- Treats wide characters as double 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.
-- -- Treats wide characters as double 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 ' '
-- -- Functions below treat wide (eg CJK) characters as double-width.
-- | General-purpose wide-char-aware single-line text layout function.
-- It can left- or right-pad a short string to a minimum width.
-- It can left- or right-clip a long string to a maximum width, optionally inserting an ellipsis (the third argument).
-- It clips and pads on the right when the fourth argument is true, otherwise on the left.
-- It treats wide characters as double width.
fitText :: Maybe Int -> Maybe Int -> Bool -> Bool -> Text -> Text
fitText mminwidth mmaxwidth ellipsify rightside s = (clip . pad) s
where
clip :: Text -> Text
clip s =
case mmaxwidth of
Just w
| textWidth s > w ->
case rightside of
True -> textTakeWidth (w - T.length ellipsis) s <> ellipsis
False -> ellipsis <> T.reverse (textTakeWidth (w - T.length ellipsis) $ T.reverse s)
| otherwise -> s
where
ellipsis = if ellipsify then ".." else ""
Nothing -> s
pad :: Text -> Text
pad s =
case mminwidth of
Just w
| sw < w ->
case rightside of
True -> s <> T.replicate (w - sw) " "
False -> T.replicate (w - sw) " " <> s
| otherwise -> s
Nothing -> s
where sw = textWidth s
-- -- | A version of fitString that works on multi-line strings,
-- -- separate for now to avoid breakage.
-- -- This will rewrite any line endings to unix newlines.
-- fitStringMulti :: Maybe Int -> Maybe Int -> Bool -> Bool -> String -> String
-- fitStringMulti mminwidth mmaxwidth ellipsify rightside s =
-- (intercalate "\n" . map (fitString mminwidth mmaxwidth ellipsify rightside) . lines) s
-- | Left-pad a text to the specified width.
-- Treats wide characters as double width.
-- Works on multi-line texts too (but will rewrite non-unix line endings).
textPadLeftWide :: Int -> Text -> Text
textPadLeftWide w "" = T.replicate w " "
textPadLeftWide w s = T.intercalate "\n" $ map (fitText (Just w) Nothing False False) $ T.lines s
-- XXX not yet replaceable by
-- padLeftWide w = fitStringMulti (Just w) Nothing False False
-- | Right-pad a string to the specified width.
-- Treats wide characters as double width.
-- Works on multi-line strings too (but will rewrite non-unix line endings).
textPadRightWide :: Int -> Text -> Text
textPadRightWide w "" = T.replicate w " "
textPadRightWide w s = T.intercalate "\n" $ map (fitText (Just w) Nothing False True) $ T.lines s
-- XXX not yet replaceable by
-- padRightWide w = fitStringMulti (Just w) Nothing False True
-- | Double-width-character-aware string truncation. Take as many
-- characters as possible from a string without exceeding the
-- specified width. Eg textTakeWidth 3 "りんご" = "り".
textTakeWidth :: Int -> Text -> Text
textTakeWidth _ "" = ""
textTakeWidth 0 _ = ""
textTakeWidth w t | not (T.null t),
let c = T.head t,
let cw = charWidth c,
cw <= w
= T.cons c $ textTakeWidth (w-cw) (T.tail t)
| otherwise = ""
-- -- from Pandoc (copyright John MacFarlane, GPL)
-- -- see also http://unicode.org/reports/tr11/#Description
-- | Calculate the designated render width of a string, taking into
-- account wide characters and line breaks (the longest line within a
-- multi-line string determines the width ).
textWidth :: Text -> Int
textWidth "" = 0
textWidth s = maximum $ map (T.foldr (\a b -> charWidth a + b) 0) $ T.lines s
-- -- | Get the designated render width of a character: 0 for a combining
-- -- character, 1 for a regular character, 2 for a wide character.
-- -- (Wide characters are rendered as exactly double width in apps and
-- -- fonts that support it.) (From Pandoc.)
-- charWidth :: Char -> Int
-- charWidth c =
-- case c of
-- _ | c < '\x0300' -> 1
-- | c >= '\x0300' && c <= '\x036F' -> 0 -- combining
-- | c >= '\x0370' && c <= '\x10FC' -> 1
-- | c >= '\x1100' && c <= '\x115F' -> 2
-- | c >= '\x1160' && c <= '\x11A2' -> 1
-- | c >= '\x11A3' && c <= '\x11A7' -> 2
-- | c >= '\x11A8' && c <= '\x11F9' -> 1
-- | c >= '\x11FA' && c <= '\x11FF' -> 2
-- | c >= '\x1200' && c <= '\x2328' -> 1
-- | c >= '\x2329' && c <= '\x232A' -> 2
-- | c >= '\x232B' && c <= '\x2E31' -> 1
-- | c >= '\x2E80' && c <= '\x303E' -> 2
-- | c == '\x303F' -> 1
-- | c >= '\x3041' && c <= '\x3247' -> 2
-- | c >= '\x3248' && c <= '\x324F' -> 1 -- ambiguous
-- | c >= '\x3250' && c <= '\x4DBF' -> 2
-- | c >= '\x4DC0' && c <= '\x4DFF' -> 1
-- | c >= '\x4E00' && c <= '\xA4C6' -> 2
-- | c >= '\xA4D0' && c <= '\xA95F' -> 1
-- | c >= '\xA960' && c <= '\xA97C' -> 2
-- | c >= '\xA980' && c <= '\xABF9' -> 1
-- | c >= '\xAC00' && c <= '\xD7FB' -> 2
-- | c >= '\xD800' && c <= '\xDFFF' -> 1
-- | c >= '\xE000' && c <= '\xF8FF' -> 1 -- ambiguous
-- | c >= '\xF900' && c <= '\xFAFF' -> 2
-- | c >= '\xFB00' && c <= '\xFDFD' -> 1
-- | c >= '\xFE00' && c <= '\xFE0F' -> 1 -- ambiguous
-- | c >= '\xFE10' && c <= '\xFE19' -> 2
-- | c >= '\xFE20' && c <= '\xFE26' -> 1
-- | c >= '\xFE30' && c <= '\xFE6B' -> 2
-- | c >= '\xFE70' && c <= '\xFEFF' -> 1
-- | c >= '\xFF01' && c <= '\xFF60' -> 2
-- | c >= '\xFF61' && c <= '\x16A38' -> 1
-- | c >= '\x1B000' && c <= '\x1B001' -> 2
-- | c >= '\x1D000' && c <= '\x1F1FF' -> 1
-- | c >= '\x1F200' && c <= '\x1F251' -> 2
-- | c >= '\x1F300' && c <= '\x1F773' -> 1
-- | c >= '\x20000' && c <= '\x3FFFD' -> 2
-- | otherwise -> 1

1
hledger-lib/future-package.yaml
View File

@ -81,6 +81,7 @@ dependencies:
- regex-tdfa
- safe >= 0.2
- split >= 0.1 && < 0.3
- text >= 1.2 && < 1.3
- transformers >= 0.2 && < 0.6
- uglymemo
- utf8-string >= 0.3.5 && < 1.1

3
hledger-lib/hledger-lib.cabal
View File

@ -82,6 +82,7 @@ library
, regex-tdfa
, safe >= 0.2
, split >= 0.1 && < 0.3
, text >= 1.2 && < 1.3
, transformers >= 0.2 && < 0.6
, uglymemo
, utf8-string >= 0.3.5 && < 1.1
@ -132,6 +133,7 @@ library
Hledger.Utils.Regex
Hledger.Utils.String
Hledger.Utils.Test
Hledger.Utils.Text
Hledger.Utils.Tree
Hledger.Utils.UTF8IOCompat
default-language: Haskell2010
@ -161,6 +163,7 @@ test-suite hunittests
, regex-tdfa
, safe >= 0.2
, split >= 0.1 && < 0.3
, text >= 1.2 && < 1.3
, transformers >= 0.2 && < 0.6
, uglymemo
, utf8-string >= 0.3.5 && < 1.1

10
hledger-ui/Hledger/UI/AccountsScreen.hs
View File

@ -17,6 +17,8 @@ import Control.Monad.IO.Class (liftIO)
import Data.List
import Data.Maybe
import Data.Monoid
-- import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day)
import System.FilePath (takeFileName)
import qualified Data.Vector as V
@ -57,7 +59,7 @@ initAccountsScreen d st@AppState{
l = list (Name "accounts") (V.fromList displayitems) 1
-- keep the selection near the last known selected account if possible
l' | null selacct = l
l' | T.null selacct = l
| otherwise = maybe l (flip listMoveTo l) midx
where
midx = findIndex (\((a,_,_),_) -> a==selacctclipped) items
@ -147,7 +149,7 @@ drawAccountsScreen _st@AppState{aopts=uopts, ajournal=j, aScreen=AccountsScreen{
maxacctwidthseen =
-- ltrace "maxacctwidthseen" $
V.maximum $
V.map (\(indent,_,displayacct,_) -> indent*2 + strWidth displayacct) $
V.map (\(indent,_,displayacct,_) -> indent*2 + textWidth displayacct) $
-- V.filter (\(indent,_,_,_) -> (indent-1) <= fromMaybe 99999 mdepth) $
displayitems
maxbalwidthseen =
@ -175,14 +177,14 @@ drawAccountsScreen _st@AppState{aopts=uopts, ajournal=j, aScreen=AccountsScreen{
drawAccountsScreen _ = error "draw function called with wrong screen type, should not happen"
drawAccountsItem :: (Int,Int) -> Bool -> (Int, String, String, [String]) -> Widget
drawAccountsItem :: (Int,Int) -> Bool -> (Int, AccountName, AccountName, [String]) -> Widget
drawAccountsItem (acctwidth, balwidth) selected (indent, _fullacct, displayacct, balamts) =
Widget Greedy Fixed $ do
-- c <- getContext
-- let showitem = intercalate "\n" . balanceReportItemAsText defreportopts fmt
render $
addamts balamts $
str (fitString (Just acctwidth) (Just acctwidth) True True $ replicate (2*indent) ' ' ++ displayacct) <+>
str (T.unpack $ fitText (Just acctwidth) (Just acctwidth) True True $ T.replicate (2*indent) " " <> displayacct) <+>
str " " <+>
str (balspace balamts)
where

4
hledger-ui/Hledger/UI/Main.hs
View File

@ -17,6 +17,8 @@ import Control.Monad
-- import Data.Monoid --
import Data.List
import Data.Maybe
-- import Data.Text (Text)
import qualified Data.Text as T
-- import Data.Time.Calendar
import Safe
import System.Exit
@ -100,7 +102,7 @@ runBrickUi uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} j = do
where
acct = headDef
(error' $ "--register "++apat++" did not match any account")
$ filter (regexMatches apat) $ journalAccountNames j
$ filter (regexMatches apat . T.unpack) $ journalAccountNames j
-- Initialising the accounts screen is awkward, requiring
-- another temporary AppState value..
ascr' = aScreen $

4
hledger-ui/Hledger/UI/RegisterScreen.hs
View File

@ -14,6 +14,8 @@ import Data.List
import Data.List.Split (splitOn)
import Data.Monoid
-- import Data.Maybe
-- import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day)
import qualified Data.Vector as V
import Graphics.Vty as Vty
@ -86,7 +88,7 @@ drawRegisterScreen :: AppState -> [Widget]
drawRegisterScreen AppState{aopts=uopts -- @UIOpts{cliopts_=_copts@CliOpts{reportopts_=_ropts@ReportOpts{query_=querystr}}
,aScreen=RegisterScreen{rsState=(l,acct)}} = [ui]
where
toplabel = withAttr ("border" <> "bold") (str acct)
toplabel = withAttr ("border" <> "bold") (str $ T.unpack acct)
<+> cleared
<+> str " transactions"
-- <+> borderQueryStr querystr -- no, account transactions report shows all transactions in the acct ?

4
hledger-ui/Hledger/UI/TransactionScreen.hs
View File

@ -14,6 +14,8 @@ import Control.Monad.IO.Class (liftIO)
-- import Data.Ord
import Data.Monoid
-- import Data.Maybe
-- import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day)
-- import qualified Data.Vector as V
import Graphics.Vty as Vty
@ -56,7 +58,7 @@ drawTransactionScreen AppState{ -- aopts=_uopts@UIOpts{cliopts_=_copts@CliOpts{r
<+> (str $ "#" ++ show (tindex t))
<+> str " ("
<+> withAttr ("border" <> "bold") (str $ show i)
<+> str (" of "++show (length nts)++" in "++acct++")")
<+> str (" of "++show (length nts)++" in "++T.unpack acct++")")
bottomlabel = borderKeysStr [
("left", "back")
,("up/down", "prev/next")

2
hledger-ui/Hledger/UI/UITypes.hs
View File

@ -28,7 +28,7 @@ data AppState = AppState {
-- This type causes partial functions, so take care.
data Screen =
AccountsScreen {
asState :: (List (Int,String,String,[String]), AccountName) -- ^ list widget holding (indent level, full account name, full or short account name to display, rendered amounts);
asState :: (List (Int,AccountName,AccountName,[String]), AccountName) -- ^ list widget holding (indent level, full account name, full or short account name to display, rendered amounts);
-- the full name of the currently selected account (or "")
,sInitFn :: Day -> AppState -> AppState -- ^ function to initialise the screen's state on entry
,sHandleFn :: AppState -> V.Event -> EventM (Next AppState) -- ^ brick event handler to use for this screen

1
hledger-ui/future-package.yaml
View File

@ -83,6 +83,7 @@ executables:
- microlens >= 0.3.5.1 && < 0.5
- safe >= 0.2
- split >= 0.1 && < 0.3
- text >= 1.2 && < 1.3
- transformers
- vector
- vty >= 5.2 && < 5.5

1
hledger-ui/hledger-ui.cabal
View File

@ -74,6 +74,7 @@ executable hledger-ui
, microlens >= 0.3.5.1 && < 0.5
, safe >= 0.2
, split >= 0.1 && < 0.3
, text >= 1.2 && < 1.3
, transformers
, vector
, vty >= 5.2 && < 5.6

13
hledger-web/Handler/Common.hs
View File

@ -7,7 +7,8 @@ module Handler.Common where
import Import
import Data.List
import Data.Text(pack)
-- import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar
import System.FilePath (takeFileName)
#if BLAZE_HTML_0_4
@ -221,17 +222,17 @@ balanceReportAsHtml _ vd@VD{..} (items',total) =
Just m' -> if m' `matchesAccount` acct then "inacct" else "notinacct"
Nothing -> "" :: String
indent = preEscapedString $ concat $ replicate (2 * (1+aindent)) "&nbsp;"
acctquery = (RegisterR, [("q", pack $ accountQuery acct)])
acctonlyquery = (RegisterR, [("q", pack $ accountOnlyQuery acct)])
acctquery = (RegisterR, [("q", T.pack $ accountQuery acct)])
acctonlyquery = (RegisterR, [("q", T.pack $ accountOnlyQuery acct)])
accountQuery :: AccountName -> String
accountQuery a = "inacct:" ++ quoteIfSpaced a -- (accountNameToAccountRegex a)
accountQuery a = "inacct:" ++ quoteIfSpaced (T.unpack a) -- (accountNameToAccountRegex a)
accountOnlyQuery :: AccountName -> String
accountOnlyQuery a = "inacctonly:" ++ quoteIfSpaced a -- (accountNameToAccountRegex a)
accountOnlyQuery a = "inacctonly:" ++ quoteIfSpaced (T.unpack a) -- (accountNameToAccountRegex a)
accountUrl :: AppRoute -> AccountName -> (AppRoute, [(Text, Text)])
accountUrl r a = (r, [("q", pack $ accountQuery a)])
accountUrl r a = (r, [("q", T.pack $ accountQuery a)])
-- stringIfLongerThan :: Int -> String -> String
-- stringIfLongerThan n s = if length s > n then s else ""

9
hledger-web/Handler/JournalR.hs
View File

@ -3,7 +3,8 @@
module Handler.JournalR where
import Data.Text (pack)
-- import Data.Text (Text)
import qualified Data.Text as T
import Import
import Handler.AddForm
@ -27,7 +28,7 @@ getJournalR = do
-- showlastcolumn = if injournal && not filtering then False else True
title = case inacct of
Nothing -> "General Journal"++s2
Just (a,inclsubs) -> "Transactions in "++a++s1++s2
Just (a,inclsubs) -> "Transactions in "++T.unpack a++s1++s2
where s1 = if inclsubs then "" else " (excluding subaccounts)"
where
s2 = if filtering then ", filtered" else ""
@ -82,12 +83,12 @@ journalTransactionsReportAsHtml _ vd (_,items) = [hamlet|
<td>
|]
where
acctlink a = (RegisterR, [("q", pack $ accountQuery a)])
acctlink a = (RegisterR, [("q", T.pack $ accountQuery a)])
evenodd = if even n then "even" else "odd" :: String
-- datetransition | newm = "newmonth"
-- | newd = "newday"
-- | otherwise = "" :: String
(firstposting, date, desc) = (False, show $ tdate torig, tdescription torig)
-- acctquery = (here, [("q", pack $ accountQuery acct)])
-- acctquery = (here, [("q", T.pack $ accountQuery acct)])
showamt = not split || not (isZeroMixedAmount amt)

4
hledger-web/Handler/RegisterR.hs
View File

@ -7,6 +7,8 @@ import Import
import Data.List
import Data.Maybe
-- import Data.Text (Text)
import qualified Data.Text as T
import Safe
import Handler.AddForm
@ -28,7 +30,7 @@ getRegisterR = do
let -- injournal = isNothing inacct
filtering = m /= Any
-- title = "Transactions in "++a++s1++s2
title = a++s1++s2
title = T.unpack a++s1++s2
where
(a,inclsubs) = fromMaybe ("all accounts",True) $ inAccount qopts
s1 = if inclsubs then "" else " (excluding subaccounts)"

1
hledger-web/future-package.yaml
View File

@ -100,6 +100,7 @@ dependencies:
- shakespeare >= 2.0
- template-haskell
- text
- text >= 1.2 && < 1.3
- transformers
- wai
- wai-extra

6
hledger-web/hledger-web.cabal
View File

@ -105,7 +105,7 @@ library
, safe >= 0.2
, shakespeare >= 2.0
, template-haskell
, text
, text >= 1.2 && < 1.3
, transformers
, wai
, wai-extra
@ -178,7 +178,7 @@ executable hledger-web
, safe >= 0.2
, shakespeare >= 2.0
, template-haskell
, text
, text >= 1.2 && < 1.3
, transformers
, wai
, wai-extra
@ -231,7 +231,7 @@ test-suite test
, safe >= 0.2
, shakespeare >= 2.0
, template-haskell
, text
, text >= 1.2 && < 1.3
, transformers
, wai
, wai-extra

2
hledger/Hledger/Cli.hs
View File

@ -7,6 +7,8 @@ adds some more which are easier to define here.
-}
{-# LANGUAGE OverloadedStrings #-}
module Hledger.Cli (
module Hledger.Cli.Accounts,
module Hledger.Cli.Add,

11
hledger/Hledger/Cli/Accounts.hs
View File

@ -10,6 +10,8 @@ The @accounts@ command lists account names:
-}
{-# LANGUAGE OverloadedStrings #-}
module Hledger.Cli.Accounts (
accountsmode
,accounts
@ -17,6 +19,9 @@ module Hledger.Cli.Accounts (
) where
import Data.List
import Data.Monoid
-- import Data.Text (Text)
import qualified Data.Text as T
import System.Console.CmdArgs.Explicit as C
import Test.HUnit
@ -52,11 +57,11 @@ accounts CliOpts{reportopts_=ropts} j = do
nodepthq = dbg1 "nodepthq" $ filterQuery (not . queryIsDepth) q
depth = dbg1 "depth" $ queryDepth $ filterQuery queryIsDepth q
ps = dbg1 "ps" $ journalPostings $ filterJournalPostings nodepthq j
as = dbg1 "as" $ nub $ filter (not . null) $ map (clipAccountName depth) $ sort $ map paccount ps
as = dbg1 "as" $ nub $ filter (not . T.null) $ map (clipAccountName depth) $ sort $ map paccount ps
as' | tree_ ropts = expandAccountNames as
| otherwise = as
render a | tree_ ropts = replicate (2 * (accountNameLevel a - 1)) ' ' ++ accountLeafName a
render a | tree_ ropts = T.replicate (2 * (accountNameLevel a - 1)) " " <> accountLeafName a
| otherwise = maybeAccountNameDrop ropts a
mapM_ (putStrLn . render) as'
mapM_ (putStrLn . T.unpack . render) as'
tests_Hledger_Cli_Accounts = TestList []

14
hledger/Hledger/Cli/Add.hs
View File

@ -3,7 +3,7 @@ A history-aware add command to help with data entry.
|-}
{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind #-}
{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, RecordWildCards, TypeOperators, FlexibleContexts #-}
{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, RecordWildCards, TypeOperators, FlexibleContexts, OverloadedStrings #-}
module Hledger.Cli.Add
where
@ -17,6 +17,8 @@ import Data.Char (toUpper, toLower)
import Data.List.Compat
import qualified Data.Set as S
import Data.Maybe
-- import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day)
import Data.Typeable (Typeable)
import Safe (headDef, headMay)
@ -216,10 +218,10 @@ postingWizard es@EntryState{..} = do
else do
let es1 = es{esArgs=drop 1 esArgs}
(amt,comment) <- amountAndCommentWizard es1
return $ Just nullposting{paccount=stripbrackets acct
return $ Just nullposting{paccount=T.pack $ stripbrackets acct
,pamount=Mixed [amt]
,pcomment=comment
,ptype=accountNamePostingType acct
,ptype=accountNamePostingType $ T.pack acct
}
postingsBalanced :: [Posting] -> Bool
@ -245,7 +247,7 @@ accountWizard EntryState{..} = do
parseAccountOrDotOrNull _ _ "." = dbg1 $ Just "." -- . always signals end of txn
parseAccountOrDotOrNull "" True "" = dbg1 $ Just "" -- when there's no default and txn is balanced, "" also signals end of txn
parseAccountOrDotOrNull def@(_:_) _ "" = dbg1 $ Just def -- when there's a default, "" means use that
parseAccountOrDotOrNull _ _ s = dbg1 $ either (const Nothing) validateAccount $ runParser (accountnamep <* eof) esJournal "" s -- otherwise, try to parse the input as an accountname
parseAccountOrDotOrNull _ _ s = dbg1 $ either (const Nothing) ((T.unpack <$>) . validateAccount) $ runParser (accountnamep <* eof) esJournal "" s -- otherwise, try to parse the input as an accountname
dbg1 = id -- strace
validateAccount s | no_new_accounts_ esOpts && not (s `elem` journalAccountNames esJournal) = Nothing
| otherwise = Just s
@ -315,7 +317,7 @@ descriptionCompleter :: Journal -> String -> CompletionFunc IO
descriptionCompleter j = completer (journalDescriptions j)
accountCompleter :: Journal -> String -> CompletionFunc IO
accountCompleter j = completer (journalAccountNamesUsed j)
accountCompleter j = completer (map T.unpack $ journalAccountNamesUsed j)
amountCompleter :: String -> CompletionFunc IO
amountCompleter = completer []
@ -407,7 +409,7 @@ compareDescriptions :: String -> String -> Double
compareDescriptions s t = compareStrings s' t'
where s' = simplify s
t' = simplify t
simplify = filter (not . (`elem` "0123456789"))
simplify = filter (not . (`elem` ("0123456789" :: String)))
-- | Return a similarity measure, from 0 to 1, for two strings. This
-- was based on Simon White's string similarity algorithm

31
hledger/Hledger/Cli/Balance.hs
View File

@ -232,6 +232,8 @@ Currently, empty cells show 0.
-}
{-# LANGUAGE OverloadedStrings #-}
module Hledger.Cli.Balance (
balancemode
,balance
@ -245,6 +247,9 @@ module Hledger.Cli.Balance (
import Data.List (intercalate)
import Data.Maybe (fromMaybe, isJust)
import Data.Monoid
-- import Data.Text (Text)
import qualified Data.Text as T
import System.Console.CmdArgs.Explicit as C
import Text.CSV
import Test.HUnit
@ -327,7 +332,7 @@ balance opts@CliOpts{reportopts_=ropts} j = do
balanceReportAsCsv :: ReportOpts -> BalanceReport -> CSV
balanceReportAsCsv opts (items, total) =
["account","balance"] :
[[a, showMixedAmountOneLineWithoutPrice b] | ((a, _, _), b) <- items]
[[T.unpack a, showMixedAmountOneLineWithoutPrice b] | ((a, _, _), b) <- items]
++
if no_total_ opts
then []
@ -348,8 +353,8 @@ balanceReportAsText opts ((items, total)) = unlines $ concat lines ++ t
Right fmt ->
let
-- abuse renderBalanceReportItem to render the total with similar format
acctcolwidth = maximum' [length fullname | ((fullname, _, _), _) <- items]
totallines = map rstrip $ renderBalanceReportItem fmt (replicate (acctcolwidth+1) ' ', 0, total)
acctcolwidth = maximum' [T.length fullname | ((fullname, _, _), _) <- items]
totallines = map rstrip $ renderBalanceReportItem fmt (T.replicate (acctcolwidth+1) " ", 0, total)
-- with a custom format, extend the line to the full report width;
-- otherwise show the usual 20-char line for compatibility
overlinewidth | isJust (format_ opts) = maximum' $ map length $ concat lines
@ -417,7 +422,7 @@ renderComponent (acctname, depth, total) (FormatField ljust min max field) = cas
where d = case min of
Just m -> depth * m
Nothing -> depth
AccountField -> formatString ljust min max acctname
AccountField -> formatString ljust min max (T.unpack acctname)
TotalField -> fitStringMulti min max True False $ showMixedAmountWithoutPrice total
_ -> ""
@ -428,7 +433,7 @@ renderComponent (acctname, depth, total) (FormatField ljust min max field) = cas
renderComponent1 :: (AccountName, Int, MixedAmount) -> StringFormatComponent -> String
renderComponent1 _ (FormatLiteral s) = s
renderComponent1 (acctname, depth, total) (FormatField ljust min max field) = case field of
AccountField -> formatString ljust min max ((intercalate ", " . lines) (indented acctname))
AccountField -> formatString ljust min max ((intercalate ", " . lines) (indented (T.unpack acctname)))
where
-- better to indent the account name here rather than use a DepthField component
-- so that it complies with width spec. Uses a fixed indent step size.
@ -445,7 +450,7 @@ multiBalanceReportAsCsv opts (MultiBalanceReport (colspans, items, (coltotals,to
++ (if row_total_ opts then ["total"] else [])
++ (if average_ opts then ["average"] else [])
) :
[a : a' : show i :
[T.unpack a : T.unpack a' : show i :
map showMixedAmountOneLineWithoutPrice
(amts
++ (if row_total_ opts then [rowtot] else [])
@ -470,7 +475,7 @@ periodBalanceReportAsText opts r@(MultiBalanceReport (colspans, items, (coltotal
render id (" "++) showMixedAmountOneLineWithoutPrice $
addtotalrow $
Table
(T.Group NoLine $ map (Header . padRightWide acctswidth) accts)
(T.Group NoLine $ map (Header . padRightWide acctswidth . T.unpack) accts)
(T.Group NoLine $ map Header colheadings)
(map rowvals items')
where
@ -482,9 +487,9 @@ periodBalanceReportAsText opts r@(MultiBalanceReport (colspans, items, (coltotal
| otherwise = items -- dbg1 "2" $ filter (any (not . isZeroMixedAmount) . snd) $ dbg1 "1" items
accts = map renderacct items'
renderacct ((a,a',i),_,_,_)
| tree_ opts = replicate ((i-1)*2) ' ' ++ a'
| tree_ opts = T.replicate ((i-1)*2) " " <> a'
| otherwise = maybeAccountNameDrop opts a
acctswidth = maximum' $ map strWidth accts
acctswidth = maximum' $ map textWidth accts
rowvals (_,as,rowtot,rowavg) = as
++ (if row_total_ opts then [rowtot] else [])
++ (if average_ opts then [rowavg] else [])
@ -514,8 +519,8 @@ cumulativeBalanceReportAsText opts r@(MultiBalanceReport (colspans, items, (colt
++ (if average_ opts then ["Average"] else [])
accts = map renderacct items
renderacct ((a,a',i),_,_,_)
| tree_ opts = replicate ((i-1)*2) ' ' ++ a'
| otherwise = maybeAccountNameDrop opts a
| tree_ opts = replicate ((i-1)*2) ' ' ++ T.unpack a'
| otherwise = T.unpack $ maybeAccountNameDrop opts a
acctswidth = maximum' $ map strWidth accts
rowvals (_,as,rowtot,rowavg) = as
++ (if row_total_ opts then [rowtot] else [])
@ -546,8 +551,8 @@ historicalBalanceReportAsText opts r@(MultiBalanceReport (colspans, items, (colt
++ (if average_ opts then ["Average"] else [])
accts = map renderacct items
renderacct ((a,a',i),_,_,_)
| tree_ opts = replicate ((i-1)*2) ' ' ++ a'
| otherwise = maybeAccountNameDrop opts a
| tree_ opts = replicate ((i-1)*2) ' ' ++ T.unpack a'
| otherwise = T.unpack $ maybeAccountNameDrop opts a
acctswidth = maximum' $ map strWidth accts
rowvals (_,as,rowtot,rowavg) = as
++ (if row_total_ opts then [rowtot] else [])

6
hledger/Hledger/Cli/Register.hs
View File

@ -16,6 +16,8 @@ module Hledger.Cli.Register (
import Data.List
import Data.Maybe
-- import Data.Text (Text)
import qualified Data.Text as T
import System.Console.CmdArgs.Explicit
import Text.CSV
import Test.HUnit
@ -70,7 +72,7 @@ postingsReportItemAsCsvRecord (_, _, _, p, b) = [date,desc,acct,amt,bal]
where
date = showDate $ postingDate p -- XXX csv should show date2 with --date2
desc = maybe "" tdescription $ ptransaction p
acct = bracket $ paccount p
acct = bracket $ T.unpack $ paccount p
where
bracket = case ptype p of
BalancedVirtualPosting -> (\s -> "["++s++"]")
@ -173,7 +175,7 @@ postingsReportItemAsText opts preferredamtwidth preferredbalwidth (mdate, mendda
-- gather content
desc = fromMaybe "" mdesc
acct = parenthesise $ elideAccountName awidth $ paccount p
acct = parenthesise $ T.unpack $ elideAccountName awidth $ paccount p
where
(parenthesise, awidth) =
case ptype p of

4
hledger/Hledger/Cli/Tests.hs
View File

@ -13,6 +13,8 @@ module Hledger.Cli.Tests (
where
import Control.Monad
-- import Data.Text (Text)
import qualified Data.Text as T
import System.Exit
import Test.HUnit
@ -61,7 +63,7 @@ runTests = liftM (fst . flip (,) 0) . runTestTT . flatTests
-- -- firstproblem = find (\counts -> )
-- | All or pattern-matched tests, as a flat list to show simple names.
flatTests opts = TestList $ filter (matchesAccount (queryFromOpts nulldate $ reportopts_ opts) . testName) $ flattenTests tests_Hledger_Cli
flatTests opts = TestList $ filter (matchesAccount (queryFromOpts nulldate $ reportopts_ opts) . T.pack . testName) $ flattenTests tests_Hledger_Cli
-- -- | All or pattern-matched tests, in the original suites to show hierarchical names.
-- hierarchicalTests opts = filterTests (matchesAccount (queryFromOpts nulldate $ reportopts_ opts) . testName) tests_Hledger_Cli

4
hledger/Hledger/Cli/Utils.hs
View File

@ -25,6 +25,8 @@ where
import Control.Exception as C
import Data.List
import Data.Maybe
-- import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (Day)
import Safe (readMay)
import System.Console.CmdArgs
@ -85,7 +87,7 @@ pivot tag j = j{jtxns = map pivotTrans . jtxns $ j}
where
pivotTrans t = t{tpostings = map pivotPosting . tpostings $ t}
pivotPosting p
| Just (_ , value) <- tagTuple = p{paccount = joinAccountNames tag value}
| Just (_ , value) <- tagTuple = p{paccount = joinAccountNames (T.pack tag) (T.pack value)}
| _ <- tagTuple = p
where tagTuple = find ((tag ==) . fst) . ptags $ p