From 1ec1f7c4ea5a2629618597f5fe7cacb60a8e1fea Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Mon, 31 May 2010 01:15:18 +0000 Subject: [PATCH] more file reading cleanup, try each known format in turn Currently this is just the journal and timelog file formats. This is more scalable, but when things go wrong there is no longer just a single parse error. For now we'll just show the first error, the one from the journal file parser. --- Hledger/Cli/Commands/Web.hs | 1 + Hledger/Cli/Tests.hs | 3 +- hledger-lib/Hledger/Data/Utils.hs | 12 ++++++ hledger-lib/Hledger/Read.hs | 64 ++++++++++++++++++----------- hledger-lib/Hledger/Read/Common.hs | 16 +++++++- hledger-lib/Hledger/Read/Journal.hs | 36 +++++++--------- hledger-lib/Hledger/Read/Timelog.hs | 20 ++++----- 7 files changed, 90 insertions(+), 62 deletions(-) diff --git a/Hledger/Cli/Commands/Web.hs b/Hledger/Cli/Commands/Web.hs index e9d7fb0df..8256de09a 100644 --- a/Hledger/Cli/Commands/Web.hs +++ b/Hledger/Cli/Commands/Web.hs @@ -37,6 +37,7 @@ import Hledger.Cli.Commands.Print import Hledger.Cli.Commands.Register import Hledger.Data import Hledger.Read +import Hledger.Read.Journal (someamount) import Hledger.Cli.Options hiding (value) #ifdef MAKE import Paths_hledger_make (getDataFileName) diff --git a/Hledger/Cli/Tests.hs b/Hledger/Cli/Tests.hs index 428ba8fda..8b54c11b8 100644 --- a/Hledger/Cli/Tests.hs +++ b/Hledger/Cli/Tests.hs @@ -36,7 +36,8 @@ import System.Time (ClockTime(TOD)) import Hledger.Cli.Commands.All import Hledger.Data -- including testing utils in Hledger.Data.Utils import Hledger.Read.Common (emptyCtx) -import Hledger.Read (someamount,readJournal) +import Hledger.Read (readJournal) +import Hledger.Read.Journal (someamount) import Hledger.Cli.Options import Hledger.Cli.Utils diff --git a/hledger-lib/Hledger/Data/Utils.hs b/hledger-lib/Hledger/Data/Utils.hs index 359b0cc35..bb900ca1c 100644 --- a/hledger-lib/Hledger/Data/Utils.hs +++ b/hledger-lib/Hledger/Data/Utils.hs @@ -321,3 +321,15 @@ isRight = not . isLeft strictReadFile :: FilePath -> IO String strictReadFile f = readFile f >>= \s -> Control.Exception.evaluate (length s) >> return s + +-- -- | Expand ~ in a file path (does not handle ~name). +-- tildeExpand :: FilePath -> IO FilePath +-- tildeExpand ('~':[]) = getHomeDirectory +-- tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs)) +-- --handle ~name, requires -fvia-C or ghc 6.8: +-- --import System.Posix.User +-- -- tildeExpand ('~':xs) = do let (user, path) = span (/= '/') xs +-- -- pw <- getUserEntryForName user +-- -- return (homeDirectory pw ++ path) +-- tildeExpand xs = return xs + diff --git a/hledger-lib/Hledger/Read.hs b/hledger-lib/Hledger/Read.hs index 8e75e465e..168e23224 100644 --- a/hledger-lib/Hledger/Read.hs +++ b/hledger-lib/Hledger/Read.hs @@ -7,35 +7,50 @@ Read hledger data from various data formats, and related utilities. module Hledger.Read ( tests_Hledger_Read, - module Hledger.Read.Common, - Hledger.Read.Journal.someamount, - readJournalFile, - readJournal, myLedgerPath, myTimelogPath, myJournal, myTimelog, + readJournalFile, + readJournal, ) where import Hledger.Data.Types (Journal(..)) import Hledger.Data.Utils import Hledger.Read.Common -import qualified Hledger.Read.Journal (parseJournal,parseJournalFile,ledgerFile,someamount,tests_Journal) -import qualified Hledger.Read.Timelog (tests_Timelog) --parseJournal +import qualified Hledger.Read.Journal (parseJournal,ledgerFile,tests_Journal) +import qualified Hledger.Read.Timelog (parseJournal,tests_Timelog) import Control.Monad.Error +import Data.Either (partitionEithers) import System.Directory (getHomeDirectory) import System.Environment (getEnv) import System.FilePath (()) import System.Exit import System.IO (stderr) #if __GLASGOW_HASKELL__ <= 610 -import System.IO.UTF8 (hPutStrLn) +import Prelude hiding (readFile, putStr, putStrLn, print, getContents) +import System.IO.UTF8 #else import System.IO (hPutStrLn) #endif +formats = [ + "journal" + ,"timelog" +-- ,"csv" + ] + +unknownformatmsg fp = printf "could not recognise %sdata in %s" (fmt formats) fp + where fmt [] = "" + fmt [f] = f ++ " " + fmt fs = intercalate ", " (init fs) ++ " or " ++ last fs ++ " " + +parsers = [Hledger.Read.Journal.parseJournal + ,Hledger.Read.Timelog.parseJournal + ] + ledgerenvvar = "LEDGER" timelogenvvar = "TIMELOG" ledgerdefaultfilename = ".ledger" @@ -65,27 +80,28 @@ myJournal = myLedgerPath >>= readJournalFile myTimelog :: IO Journal myTimelog = myTimelogPath >>= readJournalFile --- | Read a journal from this file, or throw an error. +-- | Read a journal from this file, trying all known data formats, +-- or give an error. readJournalFile :: FilePath -> IO Journal -readJournalFile f = - (runErrorT . Hledger.Read.Journal.parseJournalFile) f >>= either printerror return - where printerror e = hPutStrLn stderr e >> exitWith (ExitFailure 1) +readJournalFile "-" = getContents >>= journalFromPathAndString "(stdin)" +readJournalFile f = readFile f >>= journalFromPathAndString f --- | Read a Journal from this string, or throw an error. +-- | Read a Journal from this string, trying all known data formats, or +-- give an error. readJournal :: String -> IO Journal -readJournal s = - (runErrorT . Hledger.Read.Journal.parseJournal "(from string)") s >>= either error return +readJournal = journalFromPathAndString "(string)" --- -- | Expand ~ in a file path (does not handle ~name). --- tildeExpand :: FilePath -> IO FilePath --- tildeExpand ('~':[]) = getHomeDirectory --- tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs)) --- --handle ~name, requires -fvia-C or ghc 6.8: --- --import System.Posix.User --- -- tildeExpand ('~':xs) = do let (user, path) = span (/= '/') xs --- -- pw <- getUserEntryForName user --- -- return (homeDirectory pw ++ path) --- tildeExpand xs = return xs +-- | Read a Journal from this string, trying each known data format in +-- turn, or give an error. The file path is also required. +journalFromPathAndString :: FilePath -> String -> IO Journal +journalFromPathAndString f s = do + (errors, journals) <- partitionEithers `fmap` mapM try parsers + case journals of j:_ -> return j + _ -> hPutStrLn stderr (errmsg errors) >> exitWith (ExitFailure 1) + where + try p = (runErrorT . p f) s + errmsg [] = unknownformatmsg f + errmsg (e:_) = unlines [unknownformatmsg f, e] tests_Hledger_Read = TestList [ diff --git a/hledger-lib/Hledger/Read/Common.hs b/hledger-lib/Hledger/Read/Common.hs index 6bf102c39..81ced5be5 100644 --- a/hledger-lib/Hledger/Read/Common.hs +++ b/hledger-lib/Hledger/Read/Common.hs @@ -9,17 +9,29 @@ module Hledger.Read.Common where import Control.Monad.Error -import Data.List +import Hledger.Data.Utils import Hledger.Data.Types (Journal) -import Text.ParserCombinators.Parsec +import Hledger.Data.Journal import System.Directory (getHomeDirectory) import System.FilePath(takeDirectory,combine) +import System.Time (getClockTime) +import Text.ParserCombinators.Parsec -- | A JournalUpdate is some transformation of a "Journal". It can do I/O -- or raise an error. type JournalUpdate = ErrorT String IO (Journal -> Journal) +-- | Given a JournalUpdate-generating parsec parser, file path and data string, +-- parse and post-process a Journal so that it's ready to use, or give an error. +parseJournalWith :: (GenParser Char LedgerFileCtx JournalUpdate) -> FilePath -> String -> ErrorT String IO Journal +parseJournalWith p f s = do + tc <- liftIO getClockTime + tl <- liftIO getCurrentLocalTime + case runParser p emptyCtx f s of + Right updates -> liftM (journalFinalise tc tl f s) $ updates `ap` return nulljournal + Left err -> throwError $ show err -- XXX raises an uncaught exception if we have a parsec user error, eg from many ? + -- | Some context kept during parsing. data LedgerFileCtx = Ctx { ctxYear :: !(Maybe Integer) -- ^ the default year most recently specified with Y diff --git a/hledger-lib/Hledger/Read/Journal.hs b/hledger-lib/Hledger/Read/Journal.hs index 17f227936..ee2352087 100644 --- a/hledger-lib/Hledger/Read/Journal.hs +++ b/hledger-lib/Hledger/Read/Journal.hs @@ -103,15 +103,20 @@ i, o, b, h -} -module Hledger.Read.Journal {- ( +module Hledger.Read.Journal ( + tests_Journal, parseJournal, - parseJournalFile, + ledgerFile, someamount, - emptyCtx, - ledgeraccountname -) -} + ledgeraccountname, + ledgerExclamationDirective, + ledgerHistoricalPrice, + ledgerDefaultYear, + emptyLine, + ledgerdatetime, +) where -import Control.Monad.Error (ErrorT(..), MonadIO, liftIO, throwError, catchError) +import Control.Monad.Error (ErrorT(..), throwError, catchError) import Text.ParserCombinators.Parsec #if __GLASGOW_HASKELL__ <= 610 import Prelude hiding (readFile, putStr, putStrLn, print, getContents) @@ -127,27 +132,14 @@ import Hledger.Data.Posting import Hledger.Data.Journal import Hledger.Data.Commodity (dollars,dollar,unknown,nonsimplecommoditychars) import Hledger.Read.Common -import System.Time (getClockTime) -- let's get to it --- | Parse and post-process a journal file or timelog file to a "Journal", --- or give an error. -parseJournalFile :: FilePath -> ErrorT String IO Journal -parseJournalFile "-" = liftIO getContents >>= parseJournal "-" -parseJournalFile f = liftIO (readFile f) >>= parseJournal f - -- | Parse and post-process a "Journal" from hledger's journal file --- format, saving the provided file path and the current time, or give an --- error. +-- format, or give an error. parseJournal :: FilePath -> String -> ErrorT String IO Journal -parseJournal f s = do - tc <- liftIO getClockTime - tl <- liftIO getCurrentLocalTime - case runParser ledgerFile emptyCtx f s of - Right m -> liftM (journalFinalise tc tl f s) $ m `ap` return nulljournal - Left err -> throwError $ show err -- XXX raises an uncaught exception if we have a parsec user error, eg from many ? +parseJournal = parseJournalWith ledgerFile -- | Top-level journal parser. Returns a single composite, I/O performing, -- error-raising "JournalUpdate" which can be applied to an empty journal @@ -170,7 +162,7 @@ ledgerFile = do items <- many ledgerItem , ledgerTagDirective , ledgerEndTagDirective , emptyLine >> return (return id) - ] "ledger transaction, timelog entry, or directive" + ] "ledger transaction or directive" emptyLine :: GenParser Char st () emptyLine = do many spacenonewline diff --git a/hledger-lib/Hledger/Read/Timelog.hs b/hledger-lib/Hledger/Read/Timelog.hs index 8bb00d351..523735256 100644 --- a/hledger-lib/Hledger/Read/Timelog.hs +++ b/hledger-lib/Hledger/Read/Timelog.hs @@ -42,29 +42,23 @@ o 2007/03/10 17:26:02 -} -module Hledger.Read.Timelog {- ( +module Hledger.Read.Timelog ( + tests_Timelog, parseJournal, - parseJournalFile -) -} +) where -import Control.Monad.Error (ErrorT(..), MonadIO, liftIO, throwError) +import Control.Monad.Error (ErrorT(..)) import Text.ParserCombinators.Parsec -import System.Time (getClockTime) import Hledger.Data -import Hledger.Read.Common (LedgerFileCtx,JournalUpdate,emptyCtx,getParentAccount) -import Hledger.Read.Journal hiding (parseJournal, parseJournalFile) +import Hledger.Read.Common +import Hledger.Read.Journal hiding (parseJournal) -- | Parse and post-process a "Journal" from timeclock.el's timelog -- format, saving the provided file path and the current time, or give an -- error. parseJournal :: FilePath -> String -> ErrorT String IO Journal -parseJournal f s = do - tc <- liftIO getClockTime - tl <- liftIO getCurrentLocalTime - case runParser timelogFile emptyCtx f s of - Right m -> liftM (journalFinalise tc tl f s) $ m `ap` return nulljournal - Left err -> throwError $ show err -- XXX raises an uncaught exception if we have a parsec user error, eg from many ? +parseJournal = parseJournalWith timelogFile timelogFile :: GenParser Char LedgerFileCtx JournalUpdate timelogFile = do items <- many timelogItem