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

ErrorT -> ExceptT, handle mtl <2.2.1 && >=2.2.1 (#239)

Browse Source
This commit is contained in:
Simon Michael 2015-03-29 07:53:23 -07:00
parent aa47a7dc12
commit 8e50395b7c
7 changed files with 56 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -19,7 +19,7 @@ For more detailed documentation on each type, see the corresponding modules.
module Hledger.Data.Types
where
import Control.Monad.Error (ErrorT)
import Control.Monad.Except (ExceptT)
import Data.Data
#ifndef DOUBLE
import Data.Decimal
@ -200,7 +200,7 @@ data Journal = Journal {
-- | A JournalUpdate is some transformation of a Journal. It can do I/O or
-- raise an error.
type JournalUpdate = ErrorT String IO (Journal -> Journal)
type JournalUpdate = ExceptT String IO (Journal -> Journal)
-- | The id of a data format understood by hledger, eg @journal@ or @csv@.
type StorageFormat = String
@ -213,7 +213,7 @@ data Reader = Reader {
-- quickly check if this reader can probably handle the given file path and file content
,rDetector :: FilePath -> String -> Bool
-- 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 -> ErrorT String IO Journal
,rParser :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal
}
instance Show Reader where show r = rFormat r ++ " reader"

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

@ -31,7 +31,7 @@ module Hledger.Read (
)
where
import qualified Control.Exception as C
import Control.Monad.Error
import Control.Monad.Except
import Data.List
import Data.Maybe
import System.Directory (doesFileExist, getHomeDirectory)
@ -127,7 +127,7 @@ readJournal format rulesfile assrt path s =
firstSuccessOrBestError [] [] = return $ Left "no readers found"
firstSuccessOrBestError errs (r:rs) = do
dbgAtM 1 "trying reader" (rFormat r)
result <- (runErrorT . (rParser r) rulesfile assrt path') s
result <- (runExceptT . (rParser r) rulesfile assrt path') s
dbgAtM 1 "reader result" $ either id show result
case result of Right j -> return $ Right j -- success!
Left e -> firstSuccessOrBestError (errs++[e]) rs -- keep trying
@ -235,7 +235,7 @@ tests_Hledger_Read = TestList $
tests_Hledger_Read_CsvReader,
"journal" ~: do
r <- runErrorT $ parseWithCtx nullctx JournalReader.journal ""
r <- runExceptT $ parseWithCtx nullctx JournalReader.journal ""
assertBool "journal should parse an empty file" (isRight $ r)
jE <- readJournal Nothing Nothing True Nothing "" -- don't know how to get it from journal
either error' (assertBool "journal parsing an empty file should give an empty journal" . null . jtxns) jE

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

@ -23,7 +23,7 @@ where
import Control.Applicative ((<$>), (<*))
import Control.Exception hiding (try)
import Control.Monad
import Control.Monad.Error
import Control.Monad.Except
-- import Test.HUnit
import Data.Char (toLower, isDigit, isSpace)
import Data.List
@ -68,7 +68,7 @@ detect f s
-- | Parse and post-process a "Journal" from CSV data, or give an error.
-- XXX currently ignores the string and reads from the file path
parse :: Maybe FilePath -> Bool -> FilePath -> String -> ErrorT String IO Journal
parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal
parse rulesfile _ f s = do
r <- liftIO $ readJournalFromCsv rulesfile f s
case r of Left e -> throwError e
@ -97,7 +97,7 @@ readJournalFromCsv mrulesfile csvfile csvdata =
if created
then hPrintf stderr "creating default conversion rules file %s, edit this file for better results\n" rulesfile
else hPrintf stderr "using conversion rules file %s\n" rulesfile
rules_ <- liftIO $ runErrorT $ parseRulesFile rulesfile
rules_ <- liftIO $ runExceptT $ parseRulesFile rulesfile
let rules = case rules_ of
Right (t::CsvRules) -> t
Left err -> throwerr $ show err
@ -340,15 +340,15 @@ getDirective :: DirectiveName -> CsvRules -> Maybe FieldTemplate
getDirective directivename = lookup directivename . rdirectives
parseRulesFile :: FilePath -> ErrorT String IO CsvRules
parseRulesFile :: FilePath -> ExceptT String IO CsvRules
parseRulesFile f = do
s <- liftIO $ (readFile' f >>= expandIncludes (takeDirectory f))
let rules = parseCsvRules f s
case rules of
Left e -> ErrorT $ return $ Left $ show e
Left e -> ExceptT $ return $ Left $ show e
Right r -> do
r_ <- liftIO $ runErrorT $ validateRules r
ErrorT $ case r_ of
r_ <- liftIO $ runExceptT $ validateRules r
ExceptT $ case r_ of
Left e -> return $ Left $ show $ toParseError e
Right r -> return $ Right r
where
@ -374,13 +374,13 @@ parseCsvRules rulesfile s =
runParser rulesp rules rulesfile s
-- | Return the validated rules, or an error.
validateRules :: CsvRules -> ErrorT String IO CsvRules
validateRules :: CsvRules -> ExceptT String IO CsvRules
validateRules rules = do
unless (isAssigned "date") $ ErrorT $ return $ Left "Please specify (at top level) the date field. Eg: date %1\n"
unless (isAssigned "date") $ ExceptT $ return $ Left "Please specify (at top level) the date field. Eg: date %1\n"
unless ((amount && not (amountin || amountout)) ||
(not amount && (amountin && amountout)))
$ ErrorT $ return $ Left "Please specify (at top level) either the amount field, or both the amount-in and amount-out fields. Eg: amount %2\n"
ErrorT $ return $ Right rules
$ ExceptT $ return $ Left "Please specify (at top level) either the amount field, or both the amount-in and amount-out fields. Eg: amount %2\n"
ExceptT $ return $ Right rules
where
amount = isAssigned "amount"
amountin = isAssigned "amount-in"

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

@ -48,7 +48,7 @@ where
import Control.Applicative ((<*))
import qualified Control.Exception as C
import Control.Monad
import Control.Monad.Error
import Control.Monad.Except
import Data.Char (isNumber)
import Data.List
import Data.List.Split (wordsBy)
@ -87,7 +87,7 @@ detect f s
-- | Parse and post-process a "Journal" from hledger's journal file
-- format, or give an error.
parse :: Maybe FilePath -> Bool -> FilePath -> String -> ErrorT String IO Journal
parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal
parse _ = parseJournalWith journal
-- parsing utils
@ -98,7 +98,7 @@ combineJournalUpdates us = liftM (foldl' (\acc new x -> new (acc x)) id) $ seque
-- | 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 :: (ParsecT [Char] JournalContext (ErrorT String IO) (JournalUpdate,JournalContext)) -> Bool -> FilePath -> String -> ErrorT String IO Journal
parseJournalWith :: (ParsecT [Char] JournalContext (ExceptT String IO) (JournalUpdate,JournalContext)) -> Bool -> FilePath -> String -> ExceptT String IO Journal
parseJournalWith p assrt f s = do
tc <- liftIO getClockTime
tl <- liftIO getCurrentLocalTime
@ -151,7 +151,7 @@ clearAccountAliases = modifyState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]})
-- | Top-level journal parser. Returns a single composite, I/O performing,
-- error-raising "JournalUpdate" (and final "JournalContext") which can be
-- applied to an empty journal to get the final result.
journal :: ParsecT [Char] JournalContext (ErrorT String IO) (JournalUpdate,JournalContext)
journal :: ParsecT [Char] JournalContext (ExceptT String IO) (JournalUpdate,JournalContext)
journal = do
journalupdates <- many journalItem
eof
@ -171,7 +171,7 @@ journal = do
] <?> "journal transaction or directive"
-- cf http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives
directive :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
directive :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
directive = do
optional $ char '!'
choice' [
@ -189,7 +189,7 @@ directive = do
]
<?> "directive"
includedirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
includedirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
includedirective = do
string "include"
many1 spacenonewline
@ -197,7 +197,7 @@ includedirective = do
outerState <- getState
outerPos <- getPosition
let curdir = takeDirectory (sourceName outerPos)
let (u::ErrorT String IO (Journal -> Journal, JournalContext)) = do
let (u::ExceptT String IO (Journal -> Journal, JournalContext)) = do
filepath <- expandPath curdir filename
txt <- readFileOrError outerPos filepath
let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"
@ -210,18 +210,18 @@ includedirective = do
return (u, ctx)
Left err -> throwError $ inIncluded ++ show err
where readFileOrError pos fp =
ErrorT $ liftM Right (readFile' fp) `C.catch`
ExceptT $ liftM Right (readFile' fp) `C.catch`
\e -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show (e::C.IOException))
r <- liftIO $ runErrorT u
r <- liftIO $ runExceptT u
case r of
Left err -> return $ throwError err
Right (ju, _finalparsectx) -> return $ ErrorT $ return $ Right ju
Right (ju, _finalparsectx) -> return $ ExceptT $ return $ Right ju
journalAddFile :: (FilePath,String) -> Journal -> Journal
journalAddFile f j@Journal{files=fs} = j{files=fs++[f]}
-- NOTE: first encountered file to left, to avoid a reverse
accountdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
accountdirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
accountdirective = do
string "account"
many1 spacenonewline
@ -229,16 +229,16 @@ accountdirective = do
newline
pushParentAccount parent
-- return $ return id
return $ ErrorT $ return $ Right id
return $ ExceptT $ return $ Right id
enddirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
enddirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
enddirective = do
string "end"
popParentAccount
-- return (return id)
return $ ErrorT $ return $ Right id
return $ ExceptT $ return $ Right id
aliasdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
aliasdirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
aliasdirective = do
string "alias"
many1 spacenonewline
@ -249,13 +249,13 @@ aliasdirective = do
,accountNameWithoutPostingType $ strip alias)
return $ return id
endaliasesdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
endaliasesdirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
endaliasesdirective = do
string "end aliases"
clearAccountAliases
return (return id)
tagdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
tagdirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
tagdirective = do
string "tag" <?> "tag directive"
many1 spacenonewline
@ -263,13 +263,13 @@ tagdirective = do
restofline
return $ return id
endtagdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
endtagdirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
endtagdirective = do
(string "end tag" <|> string "pop") <?> "end tag or pop directive"
restofline
return $ return id
defaultyeardirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
defaultyeardirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
defaultyeardirective = do
char 'Y' <?> "default year"
many spacenonewline
@ -279,7 +279,7 @@ defaultyeardirective = do
setYear y'
return $ return id
defaultcommoditydirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
defaultcommoditydirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
defaultcommoditydirective = do
char 'D' <?> "default commodity"
many1 spacenonewline
@ -288,7 +288,7 @@ defaultcommoditydirective = do
restofline
return $ return id
historicalpricedirective :: ParsecT [Char] JournalContext (ErrorT String IO) HistoricalPrice
historicalpricedirective :: ParsecT [Char] JournalContext (ExceptT String IO) HistoricalPrice
historicalpricedirective = do
char 'P' <?> "historical price"
many spacenonewline
@ -300,7 +300,7 @@ historicalpricedirective = do
restofline
return $ HistoricalPrice date symbol price
ignoredpricecommoditydirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
ignoredpricecommoditydirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
ignoredpricecommoditydirective = do
char 'N' <?> "ignored-price commodity"
many1 spacenonewline
@ -308,7 +308,7 @@ ignoredpricecommoditydirective = do
restofline
return $ return id
commodityconversiondirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
commodityconversiondirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate
commodityconversiondirective = do
char 'C' <?> "commodity conversion"
many1 spacenonewline
@ -320,7 +320,7 @@ commodityconversiondirective = do
restofline
return $ return id
modifiertransaction :: ParsecT [Char] JournalContext (ErrorT String IO) ModifierTransaction
modifiertransaction :: ParsecT [Char] JournalContext (ExceptT String IO) ModifierTransaction
modifiertransaction = do
char '=' <?> "modifier transaction"
many spacenonewline
@ -328,7 +328,7 @@ modifiertransaction = do
postings <- postings
return $ ModifierTransaction valueexpr postings
periodictransaction :: ParsecT [Char] JournalContext (ErrorT String IO) PeriodicTransaction
periodictransaction :: ParsecT [Char] JournalContext (ExceptT String IO) PeriodicTransaction
periodictransaction = do
char '~' <?> "periodic transaction"
many spacenonewline
@ -337,7 +337,7 @@ periodictransaction = do
return $ PeriodicTransaction periodexpr postings
-- | Parse a (possibly unbalanced) transaction.
transaction :: ParsecT [Char] JournalContext (ErrorT String IO) Transaction
transaction :: ParsecT [Char] JournalContext (ExceptT String IO) Transaction
transaction = do
-- ptrace "transaction"
sourcepos <- getPosition

8
hledger-lib/Hledger/Read/TimelogReader.hs
View File

@ -48,7 +48,7 @@ module Hledger.Read.TimelogReader (
)
where
import Control.Monad
import Control.Monad.Error
import Control.Monad.Except
import Data.List (isPrefixOf, foldl')
import Test.HUnit
import Text.Parsec hiding (parse)
@ -78,10 +78,10 @@ detect f s
-- | 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.
parse :: Maybe FilePath -> Bool -> FilePath -> String -> ErrorT String IO Journal
parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal
parse _ = parseJournalWith timelogFile
timelogFile :: ParsecT [Char] JournalContext (ErrorT String IO) (JournalUpdate, JournalContext)
timelogFile :: ParsecT [Char] JournalContext (ExceptT String IO) (JournalUpdate, JournalContext)
timelogFile = do items <- many timelogItem
eof
ctx <- getState
@ -98,7 +98,7 @@ timelogFile = do items <- many timelogItem
] <?> "timelog entry, or default year or historical price directive"
-- | Parse a timelog entry.
timelogentry :: ParsecT [Char] JournalContext (ErrorT String IO) TimeLogEntry
timelogentry :: ParsecT [Char] JournalContext (ExceptT String IO) TimeLogEntry
timelogentry = do
sourcepos <- getPosition
code <- oneOf "bhioO"

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

@ -45,6 +45,7 @@ flag old-locale
if true then depend on time < 1.5 together with old-locale.
default: False
library
-- should set patchlevel here as in Makefile
cpp-options: -DPATCHLEVEL=0
@ -99,6 +100,7 @@ library
,directory
,filepath
,mtl
,mtl-compat
,old-time
,parsec >= 3
,regex-tdfa
@ -115,6 +117,7 @@ library
else
build-depends: time >= 1.5
test-suite tests
type: exitcode-stdio-1.0
main-is: suite.hs
@ -135,6 +138,7 @@ test-suite tests
, filepath
, HUnit
, mtl
, mtl-compat
, old-time
, parsec >= 3
, regex-tdfa

7
hledger/hledger.cabal
View File

@ -87,6 +87,7 @@ library
,haskeline >= 0.6 && <= 0.8
,HUnit
,mtl
,mtl-compat
,old-time
,parsec >= 3
,process
@ -140,6 +141,7 @@ executable hledger
,haskeline >= 0.6 && <= 0.8
,HUnit
,mtl
,mtl-compat
,old-time
,parsec >= 3
,process
@ -181,6 +183,7 @@ test-suite tests
, haskeline
, HUnit
, mtl
, mtl-compat
, old-time
, parsec >= 3
, process
@ -196,12 +199,12 @@ test-suite tests
, text
, transformers
, wizards == 1.0.*
if impl(ghc >= 7.4)
build-depends: pretty-show >= 1.6.4
if flag(old-locale)
build-depends: time < 1.5, old-locale
else
build-depends: time >= 1.5
if impl(ghc >= 7.4)
build-depends: pretty-show >= 1.6.4
-- not a standard cabal bench test, I think