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

lib: textification: parse stream

Browse Source 
10% more allocation, but 35% lower maximum residency, and slightly quicker.

hledger -f data/100x100x10.journal stats
<<ghc: 39327768 bytes, 77 GCs, 196834/269496 avg/max bytes residency (3 samples), 2M in use, 0.000 INIT (0.010 elapsed), 0.020 MUT (0.092 elapsed), 0.014 GC (0.119 elapsed) :ghc>>
<<ghc: 42842136 bytes, 84 GCs, 194010/270912 avg/max bytes residency (3 samples), 2M in use, 0.000 INIT (0.009 elapsed), 0.016 MUT (0.029 elapsed), 0.012 GC (0.120 elapsed) :ghc>>

hledger -f data/1000x1000x10.journal stats
<<ghc: 314291440 bytes, 612 GCs, 2070776/6628048 avg/max bytes residency (7 samples), 16M in use, 0.000 INIT (0.000 elapsed), 0.128 MUT (0.144 elapsed), 0.059 GC (0.070 elapsed) :ghc>>
<<ghc: 349558872 bytes, 681 GCs, 1397597/4106384 avg/max bytes residency (7 samples), 11M in use, 0.000 INIT (0.004 elapsed), 0.124 MUT (0.133 elapsed), 0.047 GC (0.053 elapsed) :ghc>>

hledger -f data/10000x1000x10.journal stats
<<ghc: 3070026824 bytes, 5973 GCs, 12698030/62951784 avg/max bytes residency (10 samples), 124M in use, 0.000 INIT (0.002 elapsed), 1.268 MUT (1.354 elapsed), 0.514 GC (0.587 elapsed) :ghc>>
<<ghc: 3424013128 bytes, 6658 GCs, 11405501/41071624 avg/max bytes residency (11 samples), 111M in use, 0.000 INIT (0.001 elapsed), 1.343 MUT (1.406 elapsed), 0.511 GC (0.573 elapsed) :ghc>>

hledger -f data/100000x1000x10.journal stats
<<ghc: 30753387392 bytes, 59811 GCs, 117615462/666703600 avg/max bytes residency (14 samples), 1588M in use, 0.000 INIT (0.000 elapsed), 12.068 MUT (12.238 elapsed), 6.015 GC (7.190 elapsed) :ghc>>
<<ghc: 34306530696 bytes, 66727 GCs, 76806196/414629312 avg/max bytes residency (14 samples), 1009M in use, 0.000 INIT (0.010 elapsed), 14.357 MUT (16.370 elapsed), 5.298 GC (6.534 elapsed) :ghc>>
This commit is contained in:
Simon Michael 2016-05-24 15:58:23 -07:00
parent 58c3362908
commit c89c33b36e
16 changed files with 197 additions and 159 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
hledger-lib/Hledger/Data/Dates.hs
View File

@ -579,14 +579,14 @@ and maybe some others:
Returns a SmartDate, to be converted to a full date later (see fixSmartDate). Returns a SmartDate, to be converted to a full date later (see fixSmartDate).
Assumes any text in the parse stream has been lowercased. Assumes any text in the parse stream has been lowercased.
-} -}
smartdate :: Stream [Char] m Char => ParsecT [Char] st m SmartDate smartdate :: Stream s m Char => ParsecT s st m SmartDate
smartdate = do smartdate = do
-- XXX maybe obscures date errors ? see ledgerdate -- XXX maybe obscures date errors ? see ledgerdate
(y,m,d) <- choice' [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing] (y,m,d) <- choice' [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing]
return (y,m,d) return (y,m,d)
-- | Like smartdate, but there must be nothing other than whitespace after the date. -- | Like smartdate, but there must be nothing other than whitespace after the date.
smartdateonly :: Stream [Char] m Char => ParsecT [Char] st m SmartDate smartdateonly :: Stream s m Char => ParsecT s st m SmartDate
smartdateonly = do smartdateonly = do
d <- smartdate d <- smartdate
many spacenonewline many spacenonewline
@ -594,7 +594,7 @@ smartdateonly = do
return d return d
datesepchars = "/-." datesepchars = "/-."
datesepchar :: Stream [Char] m Char => ParsecT [Char] st m Char datesepchar :: Stream s m Char => ParsecT s st m Char
datesepchar = oneOf datesepchars datesepchar = oneOf datesepchars
validYear, validMonth, validDay :: String -> Bool validYear, validMonth, validDay :: String -> Bool
@ -607,7 +607,7 @@ failIfInvalidYear s = unless (validYear s) $ fail $ "bad year number: " ++ s
failIfInvalidMonth s = unless (validMonth s) $ fail $ "bad month number: " ++ s failIfInvalidMonth s = unless (validMonth s) $ fail $ "bad month number: " ++ s
failIfInvalidDay s = unless (validDay s) $ fail $ "bad day number: " ++ s failIfInvalidDay s = unless (validDay s) $ fail $ "bad day number: " ++ s
yyyymmdd :: Stream [Char] m Char => ParsecT [Char] st m SmartDate yyyymmdd :: Stream s m Char => ParsecT s st m SmartDate
yyyymmdd = do yyyymmdd = do
y <- count 4 digit y <- count 4 digit
m <- count 2 digit m <- count 2 digit
@ -616,7 +616,7 @@ yyyymmdd = do
failIfInvalidDay d failIfInvalidDay d
return (y,m,d) return (y,m,d)
ymd :: Stream [Char] m Char => ParsecT [Char] st m SmartDate ymd :: Stream s m Char => ParsecT s st m SmartDate
ymd = do ymd = do
y <- many1 digit y <- many1 digit
failIfInvalidYear y failIfInvalidYear y
@ -628,7 +628,7 @@ ymd = do
failIfInvalidDay d failIfInvalidDay d
return $ (y,m,d) return $ (y,m,d)
ym :: Stream [Char] m Char => ParsecT [Char] st m SmartDate ym :: Stream s m Char => ParsecT s st m SmartDate
ym = do ym = do
y <- many1 digit y <- many1 digit
failIfInvalidYear y failIfInvalidYear y
@ -637,19 +637,19 @@ ym = do
failIfInvalidMonth m failIfInvalidMonth m
return (y,m,"") return (y,m,"")
y :: Stream [Char] m Char => ParsecT [Char] st m SmartDate y :: Stream s m Char => ParsecT s st m SmartDate
y = do y = do
y <- many1 digit y <- many1 digit
failIfInvalidYear y failIfInvalidYear y
return (y,"","") return (y,"","")
d :: Stream [Char] m Char => ParsecT [Char] st m SmartDate d :: Stream s m Char => ParsecT s st m SmartDate
d = do d = do
d <- many1 digit d <- many1 digit
failIfInvalidDay d failIfInvalidDay d
return ("","",d) return ("","",d)
md :: Stream [Char] m Char => ParsecT [Char] st m SmartDate md :: Stream s m Char => ParsecT s st m SmartDate
md = do md = do
m <- many1 digit m <- many1 digit
failIfInvalidMonth m failIfInvalidMonth m
@ -667,24 +667,24 @@ monthabbrevs = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","n
monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months
monIndex s = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs monIndex s = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs
month :: Stream [Char] m Char => ParsecT [Char] st m SmartDate month :: Stream s m Char => ParsecT s st m SmartDate
month = do month = do
m <- choice $ map (try . string) months m <- choice $ map (try . string) months
let i = monthIndex m let i = monthIndex m
return ("",show i,"") return ("",show i,"")
mon :: Stream [Char] m Char => ParsecT [Char] st m SmartDate mon :: Stream s m Char => ParsecT s st m SmartDate
mon = do mon = do
m <- choice $ map (try . string) monthabbrevs m <- choice $ map (try . string) monthabbrevs
let i = monIndex m let i = monIndex m
return ("",show i,"") return ("",show i,"")
today,yesterday,tomorrow :: Stream [Char] m Char => ParsecT [Char] st m SmartDate today,yesterday,tomorrow :: Stream s m Char => ParsecT s st m SmartDate
today = string "today" >> return ("","","today") today = string "today" >> return ("","","today")
yesterday = string "yesterday" >> return ("","","yesterday") yesterday = string "yesterday" >> return ("","","yesterday")
tomorrow = string "tomorrow" >> return ("","","tomorrow") tomorrow = string "tomorrow" >> return ("","","tomorrow")
lastthisnextthing :: Stream [Char] m Char => ParsecT [Char] st m SmartDate lastthisnextthing :: Stream s m Char => ParsecT s st m SmartDate
lastthisnextthing = do lastthisnextthing = do
r <- choice [ r <- choice [
string "last" string "last"
@ -716,7 +716,7 @@ lastthisnextthing = do
-- Right (Days 1,DateSpan 2008/08/01-) -- Right (Days 1,DateSpan 2008/08/01-)
-- >>> p "every week to 2009" -- >>> p "every week to 2009"
-- Right (Weeks 1,DateSpan -2008/12/31) -- Right (Weeks 1,DateSpan -2008/12/31)
periodexpr :: Stream [Char] m Char => Day -> ParsecT [Char] st m (Interval, DateSpan) periodexpr :: Stream s m Char => Day -> ParsecT s st m (Interval, DateSpan)
periodexpr rdate = choice $ map try [ periodexpr rdate = choice $ map try [
intervalanddateperiodexpr rdate, intervalanddateperiodexpr rdate,
intervalperiodexpr, intervalperiodexpr,
@ -724,7 +724,7 @@ periodexpr rdate = choice $ map try [
(return (NoInterval,DateSpan Nothing Nothing)) (return (NoInterval,DateSpan Nothing Nothing))
] ]
intervalanddateperiodexpr :: Stream [Char] m Char => Day -> ParsecT [Char] st m (Interval, DateSpan) intervalanddateperiodexpr :: Stream s m Char => Day -> ParsecT s st m (Interval, DateSpan)
intervalanddateperiodexpr rdate = do intervalanddateperiodexpr rdate = do
many spacenonewline many spacenonewline
i <- reportinginterval i <- reportinginterval
@ -732,20 +732,20 @@ intervalanddateperiodexpr rdate = do
s <- periodexprdatespan rdate s <- periodexprdatespan rdate
return (i,s) return (i,s)
intervalperiodexpr :: Stream [Char] m Char => ParsecT [Char] st m (Interval, DateSpan) intervalperiodexpr :: Stream s m Char => ParsecT s st m (Interval, DateSpan)
intervalperiodexpr = do intervalperiodexpr = do
many spacenonewline many spacenonewline
i <- reportinginterval i <- reportinginterval
return (i, DateSpan Nothing Nothing) return (i, DateSpan Nothing Nothing)
dateperiodexpr :: Stream [Char] m Char => Day -> ParsecT [Char] st m (Interval, DateSpan) dateperiodexpr :: Stream s m Char => Day -> ParsecT s st m (Interval, DateSpan)
dateperiodexpr rdate = do dateperiodexpr rdate = do
many spacenonewline many spacenonewline
s <- periodexprdatespan rdate s <- periodexprdatespan rdate
return (NoInterval, s) return (NoInterval, s)
-- Parse a reporting interval. -- Parse a reporting interval.
reportinginterval :: Stream [Char] m Char => ParsecT [Char] st m Interval reportinginterval :: Stream s m Char => ParsecT s st m Interval
reportinginterval = choice' [ reportinginterval = choice' [
tryinterval "day" "daily" Days, tryinterval "day" "daily" Days,
tryinterval "week" "weekly" Weeks, tryinterval "week" "weekly" Weeks,
@ -785,7 +785,7 @@ reportinginterval = choice' [
thsuffix = choice' $ map string ["st","nd","rd","th"] thsuffix = choice' $ map string ["st","nd","rd","th"]
-- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days". -- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days".
tryinterval :: Stream [Char] m Char => String -> String -> (Int -> Interval) -> ParsecT [Char] st m Interval tryinterval :: Stream s m Char => String -> String -> (Int -> Interval) -> ParsecT s st m Interval
tryinterval singular compact intcons = tryinterval singular compact intcons =
choice' [ choice' [
do string compact do string compact
@ -803,7 +803,7 @@ reportinginterval = choice' [
] ]
where plural = singular ++ "s" where plural = singular ++ "s"
periodexprdatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan periodexprdatespan :: Stream s m Char => Day -> ParsecT s st m DateSpan
periodexprdatespan rdate = choice $ map try [ periodexprdatespan rdate = choice $ map try [
doubledatespan rdate, doubledatespan rdate,
fromdatespan rdate, fromdatespan rdate,
@ -811,7 +811,7 @@ periodexprdatespan rdate = choice $ map try [
justdatespan rdate justdatespan rdate
] ]
doubledatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan doubledatespan :: Stream s m Char => Day -> ParsecT s st m DateSpan
doubledatespan rdate = do doubledatespan rdate = do
optional (string "from" >> many spacenonewline) optional (string "from" >> many spacenonewline)
b <- smartdate b <- smartdate
@ -820,7 +820,7 @@ doubledatespan rdate = do
e <- smartdate e <- smartdate
return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e) return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e)
fromdatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan fromdatespan :: Stream s m Char => Day -> ParsecT s st m DateSpan
fromdatespan rdate = do fromdatespan rdate = do
b <- choice [ b <- choice [
do do
@ -834,13 +834,13 @@ fromdatespan rdate = do
] ]
return $ DateSpan (Just $ fixSmartDate rdate b) Nothing return $ DateSpan (Just $ fixSmartDate rdate b) Nothing
todatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan todatespan :: Stream s m Char => Day -> ParsecT s st m DateSpan
todatespan rdate = do todatespan rdate = do
choice [string "to", string "-"] >> many spacenonewline choice [string "to", string "-"] >> many spacenonewline
e <- smartdate e <- smartdate
return $ DateSpan Nothing (Just $ fixSmartDate rdate e) return $ DateSpan Nothing (Just $ fixSmartDate rdate e)
justdatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan justdatespan :: Stream s m Char => Day -> ParsecT s st m DateSpan
justdatespan rdate = do justdatespan rdate = do
optional (string "in" >> many spacenonewline) optional (string "in" >> many spacenonewline)
d <- smartdate d <- smartdate

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

@ -277,9 +277,9 @@ data Reader = Reader {
-- name of the format this reader handles -- name of the format this reader handles
rFormat :: StorageFormat rFormat :: StorageFormat
-- quickly check if this reader can probably handle the given file path and file content -- quickly check if this reader can probably handle the given file path and file content
,rDetector :: FilePath -> String -> Bool ,rDetector :: FilePath -> Text -> Bool
-- parse the given string, using the given parse rules file if any, returning a journal or error aware of the given file path -- parse the given string, using the given parse rules file if any, returning a journal or error aware of the given file path
,rParser :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal ,rParser :: Maybe FilePath -> Bool -> FilePath -> Text -> ExceptT String IO Journal
} }
instance Show Reader where show r = rFormat r ++ " reader" instance Show Reader where show r = rFormat r ++ " reader"

59
hledger-lib/Hledger/Read.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-| {-|
This is the entry point to hledger's reading system, which can read This is the entry point to hledger's reading system, which can read
@ -8,6 +7,8 @@ to import modules below this one.
-} -}
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
module Hledger.Read module Hledger.Read
( (
module Hledger.Read.Common, module Hledger.Read.Common,
@ -39,11 +40,13 @@ import qualified Control.Exception as C
import Control.Monad.Except import Control.Monad.Except
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import System.Directory (doesFileExist, getHomeDirectory) import System.Directory (doesFileExist, getHomeDirectory)
import System.Environment (getEnv) import System.Environment (getEnv)
import System.Exit (exitFailure) import System.Exit (exitFailure)
import System.FilePath ((</>)) import System.FilePath ((</>))
import System.IO (IOMode(..), openFile, stdin, stderr, hSetNewlineMode, universalNewlineMode) import System.IO (stderr)
import Test.HUnit import Test.HUnit
import Text.Printf import Text.Printf
@ -56,7 +59,7 @@ import Hledger.Read.TimeclockReader as TimeclockReader
import Hledger.Read.CsvReader as CsvReader import Hledger.Read.CsvReader as CsvReader
import Hledger.Utils import Hledger.Utils
import Prelude hiding (getContents, writeFile) import Prelude hiding (getContents, writeFile)
import Hledger.Utils.UTF8IOCompat (hGetContents, writeFile) import Hledger.Utils.UTF8IOCompat (writeFile)
-- The available data file readers, each one handling a particular data -- The available data file readers, each one handling a particular data
@ -77,14 +80,14 @@ journalEnvVar2 = "LEDGER"
journalDefaultFilename = ".hledger.journal" journalDefaultFilename = ".hledger.journal"
-- | Which readers are worth trying for this (possibly unspecified) format, filepath, and data ? -- | Which readers are worth trying for this (possibly unspecified) format, filepath, and data ?
readersFor :: (Maybe StorageFormat, Maybe FilePath, String) -> [Reader] readersFor :: (Maybe StorageFormat, Maybe FilePath, Text) -> [Reader]
readersFor (format,path,s) = readersFor (format,path,t) =
dbg1 ("possible readers for "++show (format,path,elideRight 30 s)) $ dbg1 ("possible readers for "++show (format,path,textElideRight 30 t)) $
case format of case format of
Just f -> case readerForStorageFormat f of Just r -> [r] Just f -> case readerForStorageFormat f of Just r -> [r]
Nothing -> [] Nothing -> []
Nothing -> case path of Nothing -> readers Nothing -> case path of Nothing -> readers
Just p -> case readersForPathAndData (p,s) of [] -> readers Just p -> case readersForPathAndData (p,t) of [] -> readers
rs -> rs rs -> rs
-- | Find the (first) reader which can handle the given format, if any. -- | Find the (first) reader which can handle the given format, if any.
@ -95,18 +98,18 @@ readerForStorageFormat s | null rs = Nothing
rs = filter ((s==).rFormat) readers :: [Reader] rs = filter ((s==).rFormat) readers :: [Reader]
-- | Find the readers which think they can handle the given file path and data, if any. -- | Find the readers which think they can handle the given file path and data, if any.
readersForPathAndData :: (FilePath,String) -> [Reader] readersForPathAndData :: (FilePath,Text) -> [Reader]
readersForPathAndData (f,s) = filter (\r -> (rDetector r) f s) readers readersForPathAndData (f,t) = filter (\r -> (rDetector r) f t) readers
-- try each reader in turn, returning the error of the first if all fail -- try each reader in turn, returning the error of the first if all fail
tryReaders :: [Reader] -> Maybe FilePath -> Bool -> Maybe FilePath -> String -> IO (Either String Journal) tryReaders :: [Reader] -> Maybe FilePath -> Bool -> Maybe FilePath -> Text -> IO (Either String Journal)
tryReaders readers mrulesfile assrt path s = firstSuccessOrBestError [] readers tryReaders readers mrulesfile assrt path t = firstSuccessOrBestError [] readers
where where
firstSuccessOrBestError :: [String] -> [Reader] -> IO (Either String Journal) firstSuccessOrBestError :: [String] -> [Reader] -> IO (Either String Journal)
firstSuccessOrBestError [] [] = return $ Left "no readers found" firstSuccessOrBestError [] [] = return $ Left "no readers found"
firstSuccessOrBestError errs (r:rs) = do firstSuccessOrBestError errs (r:rs) = do
dbg1IO "trying reader" (rFormat r) dbg1IO "trying reader" (rFormat r)
result <- (runExceptT . (rParser r) mrulesfile assrt path') s result <- (runExceptT . (rParser r) mrulesfile assrt path') t
dbg1IO "reader result" $ either id show result dbg1IO "reader result" $ either id show result
case result of Right j -> return $ Right j -- success! case result of Right j -> return $ Right j -- success!
Left e -> firstSuccessOrBestError (errs++[e]) rs -- keep trying Left e -> firstSuccessOrBestError (errs++[e]) rs -- keep trying
@ -124,8 +127,8 @@ tryReaders readers mrulesfile assrt path s = firstSuccessOrBestError [] readers
-- --
-- A CSV conversion rules file may also be specified for use by the CSV reader. -- A CSV conversion rules file may also be specified for use by the CSV reader.
-- Also there is a flag specifying whether to check or ignore balance assertions in the journal. -- Also there is a flag specifying whether to check or ignore balance assertions in the journal.
readJournal :: Maybe StorageFormat -> Maybe FilePath -> Bool -> Maybe FilePath -> String -> IO (Either String Journal) readJournal :: Maybe StorageFormat -> Maybe FilePath -> Bool -> Maybe FilePath -> Text -> IO (Either String Journal)
readJournal mformat mrulesfile assrt mpath s = tryReaders (readersFor (mformat, mpath, s)) mrulesfile assrt mpath s readJournal mformat mrulesfile assrt mpath t = tryReaders (readersFor (mformat, mpath, t)) mrulesfile assrt mpath t
-- | Read a Journal from this file (or stdin if the filename is -) or give -- | Read a Journal from this file (or stdin if the filename is -) or give
-- an error message, using the specified data format or trying all known -- an error message, using the specified data format or trying all known
@ -133,20 +136,9 @@ readJournal mformat mrulesfile assrt mpath s = tryReaders (readersFor (mformat,
-- conversion of that format. Also there is a flag specifying whether -- conversion of that format. Also there is a flag specifying whether
-- to check or ignore balance assertions in the journal. -- to check or ignore balance assertions in the journal.
readJournalFile :: Maybe StorageFormat -> Maybe FilePath -> Bool -> FilePath -> IO (Either String Journal) readJournalFile :: Maybe StorageFormat -> Maybe FilePath -> Bool -> FilePath -> IO (Either String Journal)
readJournalFile mformat mrulesfile assrt f = readJournalFile mformat mrulesfile assrt f = do
readFileOrStdinAnyNewline f >>= readJournal mformat mrulesfile assrt (Just f) -- requireJournalFileExists f -- XXX ?
readFileOrStdinAnyLineEnding f >>= readJournal mformat mrulesfile assrt (Just f)
-- | Read the given file, or standard input if the path is "-", using
-- universal newline mode.
readFileOrStdinAnyNewline :: String -> IO String
readFileOrStdinAnyNewline f = do
requireJournalFileExists f
h <- fileHandle f
hSetNewlineMode h universalNewlineMode
hGetContents h
where
fileHandle "-" = return stdin
fileHandle f = openFile f ReadMode
-- | Call readJournalFile on each specified file path, and combine the -- | Call readJournalFile on each specified file path, and combine the
-- resulting journals into one. If there are any errors, the first is -- resulting journals into one. If there are any errors, the first is
@ -165,12 +157,13 @@ requireJournalFileExists :: FilePath -> IO ()
requireJournalFileExists "-" = return () requireJournalFileExists "-" = return ()
requireJournalFileExists f = do requireJournalFileExists f = do
exists <- doesFileExist f exists <- doesFileExist f
when (not exists) $ do when (not exists) $ do -- XXX might not be a journal file
hPrintf stderr "The hledger journal file \"%s\" was not found.\n" f hPrintf stderr "The hledger journal file \"%s\" was not found.\n" f
hPrintf stderr "Please create it first, eg with \"hledger add\" or a text editor.\n" hPrintf stderr "Please create it first, eg with \"hledger add\" or a text editor.\n"
hPrintf stderr "Or, specify an existing journal file with -f or LEDGER_FILE.\n" hPrintf stderr "Or, specify an existing journal file with -f or LEDGER_FILE.\n"
exitFailure exitFailure
-- | Ensure there is a journal file at the given path, creating an empty one if needed. -- | Ensure there is a journal file at the given path, creating an empty one if needed.
ensureJournalFileExists :: FilePath -> IO () ensureJournalFileExists :: FilePath -> IO ()
ensureJournalFileExists f = do ensureJournalFileExists f = do
@ -211,9 +204,9 @@ defaultJournalPath = do
defaultJournal :: IO Journal defaultJournal :: IO Journal
defaultJournal = defaultJournalPath >>= readJournalFile Nothing Nothing True >>= either error' return defaultJournal = defaultJournalPath >>= readJournalFile Nothing Nothing True >>= either error' return
-- | Read a journal from the given string, trying all known formats, or simply throw an error. -- | Read a journal from the given text, trying all known formats, or simply throw an error.
readJournal' :: String -> IO Journal readJournal' :: Text -> IO Journal
readJournal' s = readJournal Nothing Nothing True Nothing s >>= either error' return readJournal' t = readJournal Nothing Nothing True Nothing t >>= either error' return
tests_readJournal' = [ tests_readJournal' = [
"readJournal' parses sample journal" ~: do "readJournal' parses sample journal" ~: do
@ -223,7 +216,7 @@ tests_readJournal' = [
-- tests -- tests
samplejournal = readJournal' $ unlines samplejournal = readJournal' $ T.unlines
["2008/01/01 income" ["2008/01/01 income"
," assets:bank:checking $1" ," assets:bank:checking $1"
," income:salary" ," income:salary"

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

@ -27,6 +27,7 @@ import Data.Functor.Identity
import Data.List.Compat import Data.List.Compat
import Data.List.Split (wordsBy) import Data.List.Split (wordsBy)
import Data.Maybe import Data.Maybe
-- import Data.Monoid
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Calendar import Data.Time.Calendar
@ -44,8 +45,11 @@ import Hledger.Utils
-- | A parser of strings with generic user state, monad and return type. -- | A parser of strings with generic user state, monad and return type.
type StringParser u m a = ParsecT String u m a type StringParser u m a = ParsecT String u m a
-- | A string parser with journal-parsing state. -- | A parser of strict text with generic user state, monad and return type.
type JournalParser m a = StringParser Journal m a type TextParser u m a = ParsecT Text u m a
-- | A text parser with journal-parsing state.
type JournalParser m a = TextParser Journal m a
-- | A journal parser that runs in IO and can throw an error mid-parse. -- | A journal parser that runs in IO and can throw an error mid-parse.
type ErroringJournalParser a = JournalParser (ExceptT String IO) a type ErroringJournalParser a = JournalParser (ExceptT String IO) a
@ -55,14 +59,19 @@ runStringParser, rsp :: StringParser () Identity a -> String -> Either ParseErro
runStringParser p s = runIdentity $ runParserT p () "" s runStringParser p s = runIdentity $ runParserT p () "" s
rsp = runStringParser rsp = runStringParser
-- | Run a string parser with no state in the identity monad.
runTextParser, rtp :: TextParser () Identity a -> Text -> Either ParseError a
runTextParser p t = runIdentity $ runParserT p () "" t
rtp = runTextParser
-- | Run a journal parser with a null journal-parsing state. -- | Run a journal parser with a null journal-parsing state.
runJournalParser, rjp :: Monad m => JournalParser m a -> String -> m (Either ParseError a) runJournalParser, rjp :: Monad m => JournalParser m a -> Text -> m (Either ParseError a)
runJournalParser p s = runParserT p mempty "" s runJournalParser p t = runParserT p mempty "" t
rjp = runJournalParser rjp = runJournalParser
-- | Run an error-raising journal parser with a null journal-parsing state. -- | Run an error-raising journal parser with a null journal-parsing state.
runErroringJournalParser, rejp :: ErroringJournalParser a -> String -> IO (Either String a) runErroringJournalParser, rejp :: ErroringJournalParser a -> Text -> IO (Either String a)
runErroringJournalParser p s = runExceptT $ runJournalParser p s >>= either (throwError.show) return runErroringJournalParser p t = runExceptT $ runJournalParser p t >>= either (throwError.show) return
rejp = runErroringJournalParser rejp = runErroringJournalParser
genericSourcePos :: SourcePos -> GenericSourcePos genericSourcePos :: SourcePos -> GenericSourcePos
@ -70,13 +79,13 @@ genericSourcePos p = GenericSourcePos (sourceName p) (sourceLine p) (sourceColum
-- | Given a parsec ParsedJournal parser, file path and data string, -- | Given a parsec ParsedJournal parser, file path and data string,
-- parse and post-process a ready-to-use Journal, or give an error. -- parse and post-process a ready-to-use Journal, or give an error.
parseAndFinaliseJournal :: ErroringJournalParser ParsedJournal -> Bool -> FilePath -> String -> ExceptT String IO Journal parseAndFinaliseJournal :: ErroringJournalParser ParsedJournal -> Bool -> FilePath -> Text -> ExceptT String IO Journal
parseAndFinaliseJournal parser assrt f s = do parseAndFinaliseJournal parser assrt f txt = do
t <- liftIO getClockTime t <- liftIO getClockTime
y <- liftIO getCurrentYear y <- liftIO getCurrentYear
ep <- runParserT parser nulljournal{jparsedefaultyear=Just y} f s ep <- runParserT parser nulljournal{jparsedefaultyear=Just y} f txt
case ep of case ep of
Right pj -> case journalFinalise t f (T.pack s) assrt pj of Right pj -> case journalFinalise t f txt assrt pj of
Right j -> return j Right j -> return j
Left e -> throwError e Left e -> throwError e
Left e -> throwError $ show e Left e -> throwError $ show e
@ -271,7 +280,7 @@ modifiedaccountnamep = do
-- spaces (or end of input). Also they have one or more components of -- spaces (or end of input). Also they have one or more components of
-- at least one character, separated by the account separator char. -- at least one character, separated by the account separator char.
-- (This parser will also consume one following space, if present.) -- (This parser will also consume one following space, if present.)
accountnamep :: Monad m => StringParser u m AccountName accountnamep :: Monad m => TextParser u m AccountName
accountnamep = do accountnamep = do
astr <- do astr <- do
c <- nonspace c <- nonspace
@ -338,8 +347,8 @@ test_amountp = do
-- | Parse an amount from a string, or get an error. -- | Parse an amount from a string, or get an error.
amountp' :: String -> Amount amountp' :: String -> Amount
amountp' s = amountp' s =
case runParser (amountp <* eof) mempty "" s of case runParser (amountp <* eof) mempty "" (T.pack s) of
Right t -> t Right amt -> amt
Left err -> error' $ show err -- XXX should throwError Left err -> error' $ show err -- XXX should throwError
-- | Parse a mixed amount from a string, or get an error. -- | Parse a mixed amount from a string, or get an error.
@ -585,7 +594,7 @@ followingcommentandtagsp mdefdate = do
-- Save the starting position and preserve all whitespace for the subsequent re-parsing, -- Save the starting position and preserve all whitespace for the subsequent re-parsing,
-- to get good error positions. -- to get good error positions.
startpos <- getPosition startpos <- getPosition
commentandwhitespace <- do commentandwhitespace :: String <- do
let semicoloncommentp' = (:) <$> char ';' <*> anyChar `manyTill` eolof let semicoloncommentp' = (:) <$> char ';' <*> anyChar `manyTill` eolof
sp1 <- many spacenonewline sp1 <- many spacenonewline
l1 <- try semicoloncommentp' <|> (newline >> return "") l1 <- try semicoloncommentp' <|> (newline >> return "")
@ -596,13 +605,13 @@ followingcommentandtagsp mdefdate = do
-- pdbg 0 $ "comment:"++show comment -- pdbg 0 $ "comment:"++show comment
-- Reparse the comment for any tags. -- Reparse the comment for any tags.
tags <- case runStringParser (setPosition startpos >> tagsp) commentandwhitespace of tags <- case runTextParser (setPosition startpos >> tagsp) $ T.pack commentandwhitespace of
Right ts -> return ts Right ts -> return ts
Left e -> throwError $ show e Left e -> throwError $ show e
-- pdbg 0 $ "tags: "++show tags -- pdbg 0 $ "tags: "++show tags
-- Reparse the comment for any posting dates. Use the transaction date for defaults, if provided. -- Reparse the comment for any posting dates. Use the transaction date for defaults, if provided.
epdates <- liftIO $ rejp (setPosition startpos >> postingdatesp mdefdate) commentandwhitespace epdates <- liftIO $ rejp (setPosition startpos >> postingdatesp mdefdate) $ T.pack commentandwhitespace
pdates <- case epdates of pdates <- case epdates of
Right ds -> return ds Right ds -> return ds
Left e -> throwError e Left e -> throwError e
@ -645,14 +654,14 @@ commentStartingWithp cs = do
-- >>> commentTags "\na b:, \nd:e, f" -- >>> commentTags "\na b:, \nd:e, f"
-- [("b",""),("d","e")] -- [("b",""),("d","e")]
-- --
commentTags :: String -> [Tag] commentTags :: Text -> [Tag]
commentTags s = commentTags s =
case runStringParser tagsp s of case runTextParser tagsp s of
Right r -> r Right r -> r
Left _ -> [] -- shouldn't happen Left _ -> [] -- shouldn't happen
-- | Parse all tags found in a string. -- | Parse all tags found in a string.
tagsp :: StringParser u Identity [Tag] tagsp :: TextParser u Identity [Tag]
tagsp = -- do tagsp = -- do
-- pdbg 0 $ "tagsp" -- pdbg 0 $ "tagsp"
many (try (nontagp >> tagp)) many (try (nontagp >> tagp))
@ -661,7 +670,7 @@ tagsp = -- do
-- --
-- >>> rsp nontagp "\na b:, \nd:e, f" -- >>> rsp nontagp "\na b:, \nd:e, f"
-- Right "\na " -- Right "\na "
nontagp :: StringParser u Identity String nontagp :: TextParser u Identity String
nontagp = -- do nontagp = -- do
-- pdbg 0 "nontagp" -- pdbg 0 "nontagp"
-- anyChar `manyTill` (lookAhead (try (tagorbracketeddatetagsp Nothing >> return ()) <|> eof)) -- anyChar `manyTill` (lookAhead (try (tagorbracketeddatetagsp Nothing >> return ()) <|> eof))
@ -675,7 +684,7 @@ nontagp = -- do
-- >>> rsp tagp "a:b b , c AuxDate: 4/2" -- >>> rsp tagp "a:b b , c AuxDate: 4/2"
-- Right ("a","b b") -- Right ("a","b b")
-- --
tagp :: Monad m => StringParser u m Tag tagp :: Monad m => TextParser u m Tag
tagp = do tagp = do
-- pdbg 0 "tagp" -- pdbg 0 "tagp"
n <- tagnamep n <- tagnamep
@ -685,12 +694,12 @@ tagp = do
-- | -- |
-- >>> rsp tagnamep "a:" -- >>> rsp tagnamep "a:"
-- Right "a" -- Right "a"
tagnamep :: Monad m => StringParser u m String tagnamep :: Monad m => TextParser u m String
tagnamep = -- do tagnamep = -- do
-- pdbg 0 "tagnamep" -- pdbg 0 "tagnamep"
many1 (noneOf ": \t\n") <* char ':' many1 (noneOf ": \t\n") <* char ':'
tagvaluep :: Monad m => StringParser u m String tagvaluep :: Monad m => TextParser u m String
tagvaluep = do tagvaluep = do
-- ptrace "tagvalue" -- ptrace "tagvalue"
v <- anyChar `manyTill` (void (try (char ',')) <|> eolof) v <- anyChar `manyTill` (void (try (char ',')) <|> eolof)
@ -746,14 +755,14 @@ datetagp mdefdate = do
(do (do
setPosition startpos setPosition startpos
datep) -- <* eof) datep) -- <* eof)
v (T.pack v)
case ep case ep
of Left e -> throwError $ show e of Left e -> throwError $ show e
Right d -> return ("date"++n, d) Right d -> return ("date"++n, d)
--- ** bracketed dates --- ** bracketed dates
-- tagorbracketeddatetagsp :: Monad m => Maybe Day -> StringParser u m [Tag] -- tagorbracketeddatetagsp :: Monad m => Maybe Day -> TextParser u m [Tag]
-- tagorbracketeddatetagsp mdefdate = -- tagorbracketeddatetagsp mdefdate =
-- bracketeddatetagsp mdefdate <|> ((:[]) <$> tagp) -- bracketeddatetagsp mdefdate <|> ((:[]) <$> tagp)
@ -807,7 +816,7 @@ bracketeddatetagsp mdefdate = do
eof eof
return (md1,md2) return (md1,md2)
) )
s (T.pack s)
case ep case ep
of Left e -> throwError $ show e of Left e -> throwError $ show e
Right (md1,md2) -> return $ catMaybes Right (md1,md2) -> return $ catMaybes

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

@ -30,7 +30,7 @@ import Data.Char (toLower, isDigit, isSpace)
import Data.List.Compat import Data.List.Compat
import Data.Maybe import Data.Maybe
import Data.Ord import Data.Ord
-- import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Calendar (Day) import Data.Time.Calendar (Day)
#if MIN_VERSION_time(1,5,0) #if MIN_VERSION_time(1,5,0)
@ -63,16 +63,16 @@ format :: String
format = "csv" format = "csv"
-- | Does the given file path and data look like it might be CSV ? -- | Does the given file path and data look like it might be CSV ?
detect :: FilePath -> String -> Bool detect :: FilePath -> Text -> Bool
detect f s detect f t
| f /= "-" = takeExtension f == '.':format -- from a file: yes if the extension is .csv | f /= "-" = takeExtension f == '.':format -- from a file: yes if the extension is .csv
| otherwise = length (filter (==',') s) >= 2 -- from stdin: yes if there are two or more commas | otherwise = T.length (T.filter (==',') t) >= 2 -- from stdin: yes if there are two or more commas
-- | Parse and post-process a "Journal" from CSV data, or give an error. -- | Parse and post-process a "Journal" from CSV data, or give an error.
-- XXX currently ignores the string and reads from the file path -- XXX currently ignores the string and reads from the file path
parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal parse :: Maybe FilePath -> Bool -> FilePath -> Text -> ExceptT String IO Journal
parse rulesfile _ f s = do parse rulesfile _ f t = do
r <- liftIO $ readJournalFromCsv rulesfile f s r <- liftIO $ readJournalFromCsv rulesfile f t
case r of Left e -> throwError e case r of Left e -> throwError e
Right j -> return j Right j -> return j
@ -87,7 +87,7 @@ parse rulesfile _ f s = do
-- 4. parse the rules file -- 4. parse the rules file
-- 5. convert the CSV records to a journal using the rules -- 5. convert the CSV records to a journal using the rules
-- @ -- @
readJournalFromCsv :: Maybe FilePath -> FilePath -> String -> IO (Either String Journal) readJournalFromCsv :: Maybe FilePath -> FilePath -> Text -> IO (Either String Journal)
readJournalFromCsv Nothing "-" _ = return $ Left "please use --rules-file when reading CSV from stdin" readJournalFromCsv Nothing "-" _ = return $ Left "please use --rules-file when reading CSV from stdin"
readJournalFromCsv mrulesfile csvfile csvdata = readJournalFromCsv mrulesfile csvfile csvdata =
handle (\e -> return $ Left $ show (e :: IOException)) $ do handle (\e -> return $ Left $ show (e :: IOException)) $ do
@ -117,7 +117,7 @@ readJournalFromCsv mrulesfile csvfile csvdata =
records <- (either throwerr id . records <- (either throwerr id .
dbg2 "validateCsv" . validateCsv skip . dbg2 "validateCsv" . validateCsv skip .
dbg2 "parseCsv") dbg2 "parseCsv")
`fmap` parseCsv parsecfilename csvdata `fmap` parseCsv parsecfilename (T.unpack csvdata)
dbg1IO "first 3 csv records" $ take 3 records dbg1IO "first 3 csv records" $ take 3 records
-- identify header lines -- identify header lines
@ -607,7 +607,7 @@ transactionFromCsvRecord sourcepos rules record = t
status = status =
case mfieldtemplate "status" of case mfieldtemplate "status" of
Nothing -> Uncleared Nothing -> Uncleared
Just str -> either statuserror id $ runParser (statusp <* eof) mempty "" $ render str Just str -> either statuserror id $ runParser (statusp <* eof) mempty "" $ T.pack $ render str
where where
statuserror err = error' $ unlines statuserror err = error' $ unlines
["error: could not parse \""++str++"\" as a cleared status (should be *, ! or empty)" ["error: could not parse \""++str++"\" as a cleared status (should be *, ! or empty)"
@ -619,7 +619,7 @@ transactionFromCsvRecord sourcepos rules record = t
precomment = maybe "" render $ mfieldtemplate "precomment" precomment = maybe "" render $ mfieldtemplate "precomment"
currency = maybe (fromMaybe "" mdefaultcurrency) render $ mfieldtemplate "currency" currency = maybe (fromMaybe "" mdefaultcurrency) render $ mfieldtemplate "currency"
amountstr = (currency++) $ negateIfParenthesised $ getAmountStr rules record amountstr = (currency++) $ negateIfParenthesised $ getAmountStr rules record
amount = either amounterror (Mixed . (:[])) $ runParser (amountp <* eof) mempty "" amountstr amount = either amounterror (Mixed . (:[])) $ runParser (amountp <* eof) mempty "" $ T.pack amountstr
amounterror err = error' $ unlines amounterror err = error' $ unlines
["error: could not parse \""++amountstr++"\" as an amount" ["error: could not parse \""++amountstr++"\" as an amount"
,showRecord record ,showRecord record

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

@ -82,7 +82,7 @@ import Control.Monad
import Control.Monad.Except (ExceptT(..), liftIO, runExceptT, throwError) import Control.Monad.Except (ExceptT(..), liftIO, runExceptT, throwError)
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Monoid import Data.Monoid
-- import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Calendar import Data.Time.Calendar
import Data.Time.LocalTime import Data.Time.LocalTime
@ -112,14 +112,14 @@ format :: String
format = "journal" format = "journal"
-- | Does the given file path and data look like it might be hledger's journal format ? -- | Does the given file path and data look like it might be hledger's journal format ?
detect :: FilePath -> String -> Bool detect :: FilePath -> Text -> Bool
detect f s detect f t
| f /= "-" = takeExtension f `elem` ['.':format, ".j"] -- from a known file name: yes if the extension is this format's name or .j | f /= "-" = takeExtension f `elem` ['.':format, ".j"] -- from a known file name: yes if the extension is this format's name or .j
| otherwise = regexMatches "(^|\n)[0-9]+.*\n[ \t]+" s -- from stdin: yes if we can see something that looks like a journal entry (digits in column 0 with the next line indented) | otherwise = regexMatches "(^|\n)[0-9]+.*\n[ \t]+" $ T.unpack t -- from stdin: yes if we can see something that looks like a journal entry (digits in column 0 with the next line indented)
-- | Parse and post-process a "Journal" from hledger's journal file -- | Parse and post-process a "Journal" from hledger's journal file
-- format, or give an error. -- format, or give an error.
parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal parse :: Maybe FilePath -> Bool -> FilePath -> Text -> ExceptT String IO Journal
parse _ = parseAndFinaliseJournal journalp parse _ = parseAndFinaliseJournal journalp
--- * parsers --- * parsers
@ -190,7 +190,7 @@ includedirectivep = do
liftIO $ runExceptT $ do liftIO $ runExceptT $ do
let curdir = takeDirectory (sourceName parentpos) let curdir = takeDirectory (sourceName parentpos)
filepath <- expandPath curdir filename `orRethrowIOError` (show parentpos ++ " locating " ++ filename) filepath <- expandPath curdir filename `orRethrowIOError` (show parentpos ++ " locating " ++ filename)
txt <- readFile' filepath `orRethrowIOError` (show parentpos ++ " reading " ++ filepath) txt <- readFileAnyLineEnding filepath `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)
(ej1::Either ParseError ParsedJournal) <- (ej1::Either ParseError ParsedJournal) <-
runParserT runParserT
(choice' [journalp (choice' [journalp
@ -203,7 +203,7 @@ includedirectivep = do
(throwError (throwError
. ((show parentpos ++ " in included file " ++ show filename ++ ":\n") ++) . ((show parentpos ++ " in included file " ++ show filename ++ ":\n") ++)
. show) . show)
(return . journalAddFile (filepath, T.pack txt)) (return . journalAddFile (filepath, txt))
ej1 ej1
case ej of case ej of
Left e -> throwError e Left e -> throwError e
@ -311,10 +311,10 @@ aliasdirectivep = do
alias <- accountaliasp alias <- accountaliasp
addAccountAlias alias addAccountAlias alias
accountaliasp :: Monad m => StringParser u m AccountAlias accountaliasp :: Monad m => TextParser u m AccountAlias
accountaliasp = regexaliasp <|> basicaliasp accountaliasp = regexaliasp <|> basicaliasp
basicaliasp :: Monad m => StringParser u m AccountAlias basicaliasp :: Monad m => TextParser u m AccountAlias
basicaliasp = do basicaliasp = do
-- pdbg 0 "basicaliasp" -- pdbg 0 "basicaliasp"
old <- rstrip <$> many1 (noneOf "=") old <- rstrip <$> many1 (noneOf "=")
@ -323,7 +323,7 @@ basicaliasp = do
new <- rstrip <$> anyChar `manyTill` eolof -- don't require a final newline, good for cli options new <- rstrip <$> anyChar `manyTill` eolof -- don't require a final newline, good for cli options
return $ BasicAlias (T.pack old) (T.pack new) return $ BasicAlias (T.pack old) (T.pack new)
regexaliasp :: Monad m => StringParser u m AccountAlias regexaliasp :: Monad m => TextParser u m AccountAlias
regexaliasp = do regexaliasp = do
-- pdbg 0 "regexaliasp" -- pdbg 0 "regexaliasp"
char '/' char '/'
@ -433,7 +433,7 @@ transactionp = do
code <- codep <?> "transaction code" code <- codep <?> "transaction code"
description <- strip <$> descriptionp description <- strip <$> descriptionp
comment <- try followingcommentp <|> (newline >> return "") comment <- try followingcommentp <|> (newline >> return "")
let tags = commentTags comment let tags = commentTags $ T.pack comment
postings <- postingsp (Just date) postings <- postingsp (Just date)
n <- incrementTransactionCount n <- incrementTransactionCount
return $ txnTieKnot $ Transaction n sourcepos date edate status code description comment tags postings "" return $ txnTieKnot $ Transaction n sourcepos date edate status code description comment tags postings ""

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

@ -57,8 +57,8 @@ import Control.Monad
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Except (ExceptT) import Control.Monad.Except (ExceptT)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
-- import Data.Text (Text) import Data.Text (Text)
-- import qualified Data.Text as T import qualified Data.Text as T
import Test.HUnit import Test.HUnit
import Text.Parsec hiding (parse) import Text.Parsec hiding (parse)
import System.FilePath import System.FilePath
@ -76,15 +76,15 @@ format :: String
format = "timeclock" format = "timeclock"
-- | Does the given file path and data look like it might be timeclock.el's timeclock format ? -- | Does the given file path and data look like it might be timeclock.el's timeclock format ?
detect :: FilePath -> String -> Bool detect :: FilePath -> Text -> Bool
detect f s detect f t
| f /= "-" = takeExtension f == '.':format -- from a known file name: yes if the extension is this format's name | f /= "-" = takeExtension f == '.':format -- from a known file name: yes if the extension is this format's name
| otherwise = regexMatches "(^|\n)[io] " s -- from stdin: yes if any line starts with "i " or "o " | otherwise = regexMatches "(^|\n)[io] " $ T.unpack t -- from stdin: yes if any line starts with "i " or "o "
-- | Parse and post-process a "Journal" from timeclock.el's timeclock -- | Parse and post-process a "Journal" from timeclock.el's timeclock
-- format, saving the provided file path and the current time, or give an -- format, saving the provided file path and the current time, or give an
-- error. -- error.
parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal parse :: Maybe FilePath -> Bool -> FilePath -> Text -> ExceptT String IO Journal
parse _ = parseAndFinaliseJournal timeclockfilep parse _ = parseAndFinaliseJournal timeclockfilep
timeclockfilep :: ErroringJournalParser ParsedJournal timeclockfilep :: ErroringJournalParser ParsedJournal

10
hledger-lib/Hledger/Read/TimedotReader.hs
View File

@ -37,6 +37,8 @@ import Control.Monad.Except (ExceptT)
import Data.Char (isSpace) import Data.Char (isSpace)
import Data.List (foldl') import Data.List (foldl')
import Data.Maybe import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Test.HUnit import Test.HUnit
import Text.Parsec hiding (parse) import Text.Parsec hiding (parse)
import System.FilePath import System.FilePath
@ -57,13 +59,13 @@ format :: String
format = "timedot" format = "timedot"
-- | Does the given file path and data look like it might contain this format ? -- | Does the given file path and data look like it might contain this format ?
detect :: FilePath -> String -> Bool detect :: FilePath -> Text -> Bool
detect f s detect f t
| f /= "-" = takeExtension f == '.':format -- from a file: yes if the extension matches the format name | f /= "-" = takeExtension f == '.':format -- from a file: yes if the extension matches the format name
| otherwise = regexMatches "(^|\n)[0-9]" s -- from stdin: yes if we can see a possible timedot day entry (digits in column 0) | otherwise = regexMatches "(^|\n)[0-9]" $ T.unpack t -- from stdin: yes if we can see a possible timedot day entry (digits in column 0)
-- | Parse and post-process a "Journal" from the timedot format, or give an error. -- | Parse and post-process a "Journal" from the timedot format, or give an error.
parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal parse :: Maybe FilePath -> Bool -> FilePath -> Text -> ExceptT String IO Journal
parse _ = parseAndFinaliseJournal timedotfilep parse _ = parseAndFinaliseJournal timedotfilep
timedotfilep :: ErroringJournalParser ParsedJournal timedotfilep :: ErroringJournalParser ParsedJournal

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

@ -37,6 +37,8 @@ import Control.Monad (liftM)
-- import Data.List -- import Data.List
-- import Data.Maybe -- import Data.Maybe
-- import Data.PPrint -- import Data.PPrint
import Data.Text (Text)
import qualified Data.Text.IO as T
import Data.Time.Clock import Data.Time.Clock
import Data.Time.LocalTime import Data.Time.LocalTime
-- import Data.Text (Text) -- import Data.Text (Text)
@ -134,13 +136,31 @@ firstJust ms = case dropWhile (==Nothing) ms of
[] -> Nothing [] -> Nothing
(md:_) -> md (md:_) -> md
-- | Read a file in universal newline mode, handling whatever newline convention it may contain. -- | Read a file in universal newline mode, handling any of the usual line ending conventions.
readFile' :: FilePath -> IO String readFile' :: FilePath -> IO String
readFile' name = do readFile' name = do
h <- openFile name ReadMode h <- openFile name ReadMode
hSetNewlineMode h universalNewlineMode hSetNewlineMode h universalNewlineMode
hGetContents h hGetContents h
-- | Read a file in universal newline mode, handling any of the usual line ending conventions.
readFileAnyLineEnding :: FilePath -> IO Text
readFileAnyLineEnding path = do
h <- openFile path ReadMode
hSetNewlineMode h universalNewlineMode
T.hGetContents h
-- | Read the given file, or standard input if the path is "-", using
-- universal newline mode.
readFileOrStdinAnyLineEnding :: String -> IO Text
readFileOrStdinAnyLineEnding f = do
h <- fileHandle f
hSetNewlineMode h universalNewlineMode
T.hGetContents h
where
fileHandle "-" = return stdin
fileHandle f = openFile f ReadMode
-- | Total version of maximum, for integral types, giving 0 for an empty list. -- | Total version of maximum, for integral types, giving 0 for an empty list.
maximum' :: Integral a => [a] -> a maximum' :: Integral a => [a] -> a
maximum' [] = 0 maximum' [] = 0

10
hledger-lib/Hledger/Utils/Parse.hs
View File

@ -3,6 +3,8 @@ module Hledger.Utils.Parse where
import Data.Char import Data.Char
import Data.List import Data.List
-- import Data.Text (Text)
-- import qualified Data.Text as T
import Text.Parsec import Text.Parsec
import Text.Printf import Text.Printf
@ -31,15 +33,15 @@ showParseError e = "parse error at " ++ show e
showDateParseError :: ParseError -> String showDateParseError :: ParseError -> String
showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e) showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e)
nonspace :: (Stream [Char] m Char) => ParsecT [Char] st m Char nonspace :: (Stream s m Char) => ParsecT s st m Char
nonspace = satisfy (not . isSpace) nonspace = satisfy (not . isSpace)
spacenonewline :: (Stream [Char] m Char) => ParsecT [Char] st m Char spacenonewline :: (Stream s m Char) => ParsecT s st m Char
spacenonewline = satisfy (`elem` " \v\f\t") spacenonewline = satisfy (`elem` " \v\f\t")
restofline :: (Stream [Char] m Char) => ParsecT [Char] st m String restofline :: (Stream s m Char) => ParsecT s st m String
restofline = anyChar `manyTill` newline restofline = anyChar `manyTill` newline
eolof :: (Stream [Char] m Char) => ParsecT [Char] st m () eolof :: (Stream s m Char) => ParsecT s st m ()
eolof = (newline >> return ()) <|> eof eolof = (newline >> return ()) <|> eof

24
hledger-lib/Hledger/Utils/Text.hs
View File

@ -71,17 +71,17 @@ import Hledger.Utils.String (charWidth)
-- lowercase = map toLower -- lowercase = map toLower
-- uppercase = map toUpper -- uppercase = map toUpper
-- -- | Remove leading and trailing whitespace. -- | Remove leading and trailing whitespace.
-- strip :: String -> String textstrip :: Text -> Text
-- strip = lstrip . rstrip textstrip = textlstrip . textrstrip
-- -- | Remove leading whitespace. -- | Remove leading whitespace.
-- lstrip :: String -> String textlstrip :: Text -> Text
-- lstrip = dropWhile (`elem` " \t") :: String -> String -- XXX isSpace ? textlstrip = T.dropWhile (`elem` " \t") :: Text -> Text -- XXX isSpace ?
-- -- | Remove trailing whitespace. -- | Remove trailing whitespace.
-- rstrip :: String -> String textrstrip = T.reverse . textlstrip . T.reverse
-- rstrip = reverse . lstrip . reverse textrstrip :: Text -> Text
-- -- | Remove trailing newlines/carriage returns. -- -- | Remove trailing newlines/carriage returns.
-- chomp :: String -> String -- chomp :: String -> String
@ -94,9 +94,9 @@ import Hledger.Utils.String (charWidth)
-- elideLeft width s = -- elideLeft width s =
-- if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s -- if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s
-- elideRight :: Int -> String -> String textElideRight :: Int -> Text -> Text
-- elideRight width s = textElideRight width t =
-- if length s > width then take (width - 2) s ++ ".." else s if T.length t > width then T.take (width - 2) t <> ".." else t
-- -- | Clip and pad a string to a minimum & maximum width, and/or left/right justify it. -- -- | 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). -- -- Works on multi-line strings too (but will rewrite non-unix line endings).

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

@ -95,8 +95,8 @@ postAddForm = do
| map fst acctparams == [1..num] && | map fst acctparams == [1..num] &&
map fst amtparams `elem` [[1..num], [1..num-1]] = [] map fst amtparams `elem` [[1..num], [1..num-1]] = []
| otherwise = ["the posting parameters are malformed"] | otherwise = ["the posting parameters are malformed"]
eaccts = map (parsewith (accountnamep <* eof) . strip . T.unpack . snd) acctparams eaccts = map (runParser (accountnamep <* eof) () "" . T.pack . strip . T.unpack . snd) acctparams
eamts = map (runParser (amountp <* eof) mempty "" . strip . T.unpack . snd) amtparams eamts = map (runParser (amountp <* eof) mempty "" . T.pack . strip . T.unpack . snd) amtparams
(accts, acctErrs) = (rights eaccts, map show $ lefts eaccts) (accts, acctErrs) = (rights eaccts, map show $ lefts eaccts)
(amts', amtErrs) = (rights eamts, map show $ lefts eamts) (amts', amtErrs) = (rights eamts, map show $ lefts eamts)
amts | length amts' == num = amts' amts | length amts' == num = amts'

25
hledger/Hledger/Cli.hs
View File

@ -32,6 +32,9 @@ module Hledger.Cli (
module System.Console.CmdArgs.Explicit module System.Console.CmdArgs.Explicit
) )
where where
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar import Data.Time.Calendar
import System.Console.CmdArgs.Explicit import System.Console.CmdArgs.Explicit
import Test.HUnit import Test.HUnit
@ -80,16 +83,16 @@ tests_Hledger_Cli = TestList
in TestList in TestList
[ [
"apply account directive 1" ~: sameParse "apply account directive 1" ~: sameParse
("2008/12/07 One\n alpha $-1\n beta $1\n" ++ ("2008/12/07 One\n alpha $-1\n beta $1\n" <>
"apply account outer\n2008/12/07 Two\n aigh $-2\n bee $2\n" ++ "apply account outer\n2008/12/07 Two\n aigh $-2\n bee $2\n" <>
"apply account inner\n2008/12/07 Three\n gamma $-3\n delta $3\n" ++ "apply account inner\n2008/12/07 Three\n gamma $-3\n delta $3\n" <>
"end apply account\n2008/12/07 Four\n why $-4\n zed $4\n" ++ "end apply account\n2008/12/07 Four\n why $-4\n zed $4\n" <>
"end apply account\n2008/12/07 Five\n foo $-5\n bar $5\n" "end apply account\n2008/12/07 Five\n foo $-5\n bar $5\n"
) )
("2008/12/07 One\n alpha $-1\n beta $1\n" ++ ("2008/12/07 One\n alpha $-1\n beta $1\n" <>
"2008/12/07 Two\n outer:aigh $-2\n outer:bee $2\n" ++ "2008/12/07 Two\n outer:aigh $-2\n outer:bee $2\n" <>
"2008/12/07 Three\n outer:inner:gamma $-3\n outer:inner:delta $3\n" ++ "2008/12/07 Three\n outer:inner:gamma $-3\n outer:inner:delta $3\n" <>
"2008/12/07 Four\n outer:why $-4\n outer:zed $4\n" ++ "2008/12/07 Four\n outer:why $-4\n outer:zed $4\n" <>
"2008/12/07 Five\n foo $-5\n bar $5\n" "2008/12/07 Five\n foo $-5\n bar $5\n"
) )
@ -124,7 +127,7 @@ tests_Hledger_Cli = TestList
-- `is` "aa:aa:aaaaaaaaaaaaaa") -- `is` "aa:aa:aaaaaaaaaaaaaa")
,"default year" ~: do ,"default year" ~: do
j <- readJournal Nothing Nothing True Nothing defaultyear_journal_str >>= either error' return j <- readJournal Nothing Nothing True Nothing defaultyear_journal_txt >>= either error' return
tdate (head $ jtxns j) `is` fromGregorian 2009 1 1 tdate (head $ jtxns j) `is` fromGregorian 2009 1 1
return () return ()
@ -187,8 +190,8 @@ sample_journal_str = unlines
] ]
-} -}
defaultyear_journal_str :: String defaultyear_journal_txt :: Text
defaultyear_journal_str = unlines defaultyear_journal_txt = T.unlines
["Y2009" ["Y2009"
,"" ,""
,"01/01 A" ,"01/01 A"

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

@ -17,7 +17,7 @@ import Data.Char (toUpper, toLower)
import Data.List.Compat import Data.List.Compat
import qualified Data.Set as S import qualified Data.Set as S
import Data.Maybe import Data.Maybe
-- import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Calendar (Day) import Data.Time.Calendar (Day)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
@ -183,7 +183,7 @@ dateAndCodeWizard EntryState{..} = do
where where
parseSmartDateAndCode refdate s = either (const Nothing) (\(d,c) -> return (fixSmartDate refdate d, c)) edc parseSmartDateAndCode refdate s = either (const Nothing) (\(d,c) -> return (fixSmartDate refdate d, c)) edc
where where
edc = runParser (dateandcodep <* eof) mempty "" $ lowercase s edc = runParser (dateandcodep <* eof) mempty "" $ T.pack $ lowercase s
dateandcodep :: Monad m => JournalParser m (SmartDate, String) dateandcodep :: Monad m => JournalParser m (SmartDate, String)
dateandcodep = do dateandcodep = do
d <- smartdate d <- smartdate
@ -244,13 +244,18 @@ accountWizard EntryState{..} = do
line $ green $ printf "Account %d%s%s: " pnum (endmsg::String) (showDefault def) line $ green $ printf "Account %d%s%s: " pnum (endmsg::String) (showDefault def)
where where
canfinish = not (null esPostings) && postingsBalanced esPostings canfinish = not (null esPostings) && postingsBalanced esPostings
parseAccountOrDotOrNull :: String -> Bool -> String -> Maybe String
parseAccountOrDotOrNull _ _ "." = dbg1 $ Just "." -- . always signals end of txn 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 "" 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 def@(_:_) _ "" = dbg1 $ Just def -- when there's a default, "" means use that
parseAccountOrDotOrNull _ _ s = dbg1 $ either (const Nothing) ((T.unpack <$>) . validateAccount) $ runParser (accountnamep <* eof) esJournal "" s -- otherwise, try to parse the input as an accountname parseAccountOrDotOrNull _ _ s = dbg1 $ fmap T.unpack $
either (const Nothing) validateAccount $
runParser (accountnamep <* eof) esJournal "" (T.pack s) -- otherwise, try to parse the input as an accountname
where
validateAccount :: Text -> Maybe Text
validateAccount t | no_new_accounts_ esOpts && not (t `elem` journalAccountNames esJournal) = Nothing
| otherwise = Just t
dbg1 = id -- strace dbg1 = id -- strace
validateAccount s | no_new_accounts_ esOpts && not (s `elem` journalAccountNames esJournal) = Nothing
| otherwise = Just s
amountAndCommentWizard EntryState{..} = do amountAndCommentWizard EntryState{..} = do
let pnum = length esPostings + 1 let pnum = length esPostings + 1
@ -271,8 +276,8 @@ amountAndCommentWizard EntryState{..} = do
maybeRestartTransaction $ maybeRestartTransaction $
line $ green $ printf "Amount %d%s: " pnum (showDefault def) line $ green $ printf "Amount %d%s: " pnum (showDefault def)
where where
parseAmountAndComment = either (const Nothing) Just . runParser (amountandcommentp <* eof) noDefCommodityJPS "" parseAmountAndComment = either (const Nothing) Just . runParser (amountandcommentp <* eof) nodefcommodityj "" . T.pack
noDefCommodityJPS = esJournal{jparsedefaultcommodity=Nothing} nodefcommodityj = esJournal{jparsedefaultcommodity=Nothing}
amountandcommentp :: Monad m => JournalParser m (Amount, String) amountandcommentp :: Monad m => JournalParser m (Amount, String)
amountandcommentp = do amountandcommentp = do
a <- amountp a <- amountp
@ -378,7 +383,7 @@ ensureOneNewlineTerminated = (++"\n") . reverse . dropWhile (=='\n') . reverse
registerFromString :: String -> IO String registerFromString :: String -> IO String
registerFromString s = do registerFromString s = do
d <- getCurrentDay d <- getCurrentDay
j <- readJournal' s j <- readJournal' $ T.pack s
return $ postingsReportAsText opts $ postingsReport ropts (queryFromOpts d ropts) j return $ postingsReportAsText opts $ postingsReport ropts (queryFromOpts d ropts) j
where where
ropts = defreportopts{empty_=True} ropts = defreportopts{empty_=True}

7
hledger/Hledger/Cli/CliOptions.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, FlexibleContexts #-}
{-| {-|
Common cmdargs modes and flags, a command-line options type, and Common cmdargs modes and flags, a command-line options type, and
@ -6,6 +5,8 @@ related utilities used by hledger commands.
-} -}
{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, FlexibleContexts #-}
module Hledger.Cli.CliOptions ( module Hledger.Cli.CliOptions (
-- * cmdargs flags & modes -- * cmdargs flags & modes
@ -71,6 +72,8 @@ import Data.Functor.Compat ((<$>))
import Data.List.Compat import Data.List.Compat
import Data.List.Split (splitOneOf) import Data.List.Split (splitOneOf)
import Data.Maybe import Data.Maybe
-- import Data.Text (Text)
import qualified Data.Text as T
import Safe import Safe
import System.Console.CmdArgs import System.Console.CmdArgs
import System.Console.CmdArgs.Explicit import System.Console.CmdArgs.Explicit
@ -384,7 +387,7 @@ getCliOpts mode' = do
-- | Get the account name aliases from options, if any. -- | Get the account name aliases from options, if any.
aliasesFromOpts :: CliOpts -> [AccountAlias] aliasesFromOpts :: CliOpts -> [AccountAlias]
aliasesFromOpts = map (\a -> fromparse $ runParser accountaliasp () ("--alias "++quoteIfNeeded a) a) aliasesFromOpts = map (\a -> fromparse $ runParser accountaliasp () ("--alias "++quoteIfNeeded a) $ T.pack a)
. alias_ . alias_
-- | Get the (tilde-expanded, absolute) journal file path from -- | Get the (tilde-expanded, absolute) journal file path from

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

@ -1,10 +1,11 @@
{-# LANGUAGE CPP #-}
{-| {-|
A ledger-compatible @register@ command. A ledger-compatible @register@ command.
-} -}
{-# LANGUAGE CPP, OverloadedStrings #-}
module Hledger.Cli.Register ( module Hledger.Cli.Register (
registermode registermode
,register ,register