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

add support for megaparsec 6 (fixes #594)

Browse Source 
Older megaparsec is still supported.
Also cleans up our custom parser types,
and some text (un)packing is done in different places
(possible performance impact).
This commit is contained in:
Simon Michael 2017-07-27 04:59:55 -07:00
parent dccfa6a512
commit d7d5f8a064
23 changed files with 301 additions and 213 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
bin/hledger-check.hs
View File

@ -98,8 +98,7 @@ import qualified Hledger.Utils.Parse as H
import Options.Applicative import Options.Applicative
import System.Exit (exitFailure) import System.Exit (exitFailure)
import System.FilePath (FilePath) import System.FilePath (FilePath)
import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Compat as P
import qualified Text.Megaparsec.Text as P
main :: IO () main :: IO ()
main = do main = do
@ -391,7 +390,7 @@ args = info (helper <*> parser) $ mconcat
-- Turn a Parsec parser into a ReadM parser that also returns the -- Turn a Parsec parser into a ReadM parser that also returns the
-- input. -- input.
readParsec :: H.JournalStateParser ReadM a -> ReadM (String, a) readParsec :: H.JournalParser ReadM a -> ReadM (String, a)
readParsec p = do readParsec p = do
s <- str s <- str
parsed <- P.runParserT (runStateT p H.nulljournal) "" (pack s) parsed <- P.runParserT (runStateT p H.nulljournal) "" (pack s)
@ -418,7 +417,7 @@ data Predicate
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
-- | Parse a 'Predicate'. -- | Parse a 'Predicate'.
predicatep :: Monad m => H.JournalStateParser m Predicate predicatep :: Monad m => H.JournalParser m Predicate
predicatep = wrap predparensp <|> wrap predcomparep <|> wrap prednotp where predicatep = wrap predparensp <|> wrap predcomparep <|> wrap prednotp where
predparensp = P.char '(' *> spaces *> predicatep <* spaces <* P.char ')' predparensp = P.char '(' *> spaces *> predicatep <* spaces <* P.char ')'
predcomparep = Compare <$> valuep <*> (spaces *> lift comparep <* spaces) <*> valuep predcomparep = Compare <$> valuep <*> (spaces *> lift comparep <* spaces) <*> valuep
@ -434,7 +433,7 @@ data Value = Account H.AccountName | AccountNested H.AccountName | Amount H.Amou
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
-- | Parse a 'Value'. -- | Parse a 'Value'.
valuep :: Monad m => H.JournalStateParser m Value valuep :: Monad m => H.JournalParser m Value
-- Account name parser has to come last because they eat everything. -- Account name parser has to come last because they eat everything.
valuep = valueamountp <|> valueaccountnestedp <|> valueaccountp where valuep = valueamountp <|> valueaccountnestedp <|> valueaccountp where
valueamountp = Amount <$> H.amountp valueamountp = Amount <$> H.amountp

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

@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-| {-|
Date parsing and utilities for hledger. Date parsing and utilities for hledger.
@ -86,8 +87,7 @@ import Data.Time.Calendar.OrdinalDate
import Data.Time.Clock import Data.Time.Clock
import Data.Time.LocalTime import Data.Time.LocalTime
import Safe (headMay, lastMay, readMay) import Safe (headMay, lastMay, readMay)
import Text.Megaparsec import Text.Megaparsec.Compat
import Text.Megaparsec.Text
import Text.Printf import Text.Printf
import Hledger.Data.Types import Hledger.Data.Types
@ -256,7 +256,7 @@ earliest (Just d1) (Just d2) = Just $ min d1 d2
-- | Parse a period expression to an Interval and overall DateSpan using -- | Parse a period expression to an Interval and overall DateSpan using
-- the provided reference date, or return a parse error. -- the provided reference date, or return a parse error.
parsePeriodExpr :: Day -> Text -> Either (ParseError Char Dec) (Interval, DateSpan) parsePeriodExpr :: Day -> Text -> Either (ParseError Char MPErr) (Interval, DateSpan)
parsePeriodExpr refdate = parsewith (periodexpr refdate <* eof) parsePeriodExpr refdate = parsewith (periodexpr refdate <* eof)
maybePeriod :: Day -> Text -> Maybe (Interval,DateSpan) maybePeriod :: Day -> Text -> Maybe (Interval,DateSpan)
@ -316,13 +316,13 @@ fixSmartDateStr :: Day -> Text -> String
fixSmartDateStr d s = either fixSmartDateStr d s = either
(\e->error' $ printf "could not parse date %s %s" (show s) (show e)) (\e->error' $ printf "could not parse date %s %s" (show s) (show e))
id id
$ (fixSmartDateStrEither d s :: Either (ParseError Char Dec) String) $ (fixSmartDateStrEither d s :: Either (ParseError Char MPErr) String)
-- | A safe version of fixSmartDateStr. -- | A safe version of fixSmartDateStr.
fixSmartDateStrEither :: Day -> Text -> Either (ParseError Char Dec) String fixSmartDateStrEither :: Day -> Text -> Either (ParseError Char MPErr) String
fixSmartDateStrEither d = either Left (Right . showDate) . fixSmartDateStrEither' d fixSmartDateStrEither d = either Left (Right . showDate) . fixSmartDateStrEither' d
fixSmartDateStrEither' :: Day -> Text -> Either (ParseError Char Dec) Day fixSmartDateStrEither' :: Day -> Text -> Either (ParseError Char MPErr) Day
fixSmartDateStrEither' d s = case parsewith smartdateonly (T.toLower s) of fixSmartDateStrEither' d s = case parsewith smartdateonly (T.toLower s) of
Right sd -> Right $ fixSmartDate d sd Right sd -> Right $ fixSmartDate d sd
Left e -> Left e Left e -> Left e
@ -550,14 +550,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 :: Parser SmartDate smartdate :: SimpleTextParser 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 :: Parser SmartDate smartdateonly :: SimpleTextParser SmartDate
smartdateonly = do smartdateonly = do
d <- smartdate d <- smartdate
many spacenonewline many spacenonewline
@ -579,7 +579,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 :: Parser SmartDate yyyymmdd :: SimpleTextParser SmartDate
yyyymmdd = do yyyymmdd = do
y <- count 4 digitChar y <- count 4 digitChar
m <- count 2 digitChar m <- count 2 digitChar
@ -588,7 +588,7 @@ yyyymmdd = do
failIfInvalidDay d failIfInvalidDay d
return (y,m,d) return (y,m,d)
ymd :: Parser SmartDate ymd :: SimpleTextParser SmartDate
ymd = do ymd = do
y <- some digitChar y <- some digitChar
failIfInvalidYear y failIfInvalidYear y
@ -600,7 +600,7 @@ ymd = do
failIfInvalidDay d failIfInvalidDay d
return $ (y,m,d) return $ (y,m,d)
ym :: Parser SmartDate ym :: SimpleTextParser SmartDate
ym = do ym = do
y <- some digitChar y <- some digitChar
failIfInvalidYear y failIfInvalidYear y
@ -609,19 +609,19 @@ ym = do
failIfInvalidMonth m failIfInvalidMonth m
return (y,m,"") return (y,m,"")
y :: Parser SmartDate y :: SimpleTextParser SmartDate
y = do y = do
y <- some digitChar y <- some digitChar
failIfInvalidYear y failIfInvalidYear y
return (y,"","") return (y,"","")
d :: Parser SmartDate d :: SimpleTextParser SmartDate
d = do d = do
d <- some digitChar d <- some digitChar
failIfInvalidDay d failIfInvalidDay d
return ("","",d) return ("","",d)
md :: Parser SmartDate md :: SimpleTextParser SmartDate
md = do md = do
m <- some digitChar m <- some digitChar
failIfInvalidMonth m failIfInvalidMonth m
@ -636,48 +636,54 @@ monthabbrevs = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","n
-- weekdays = ["monday","tuesday","wednesday","thursday","friday","saturday","sunday"] -- weekdays = ["monday","tuesday","wednesday","thursday","friday","saturday","sunday"]
-- weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"] -- weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"]
monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months #if MIN_VERSION_megaparsec(6,0,0)
monIndex s = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs lc = T.toLower
#else
lc = lowercase
#endif
month :: Parser SmartDate monthIndex t = maybe 0 (+1) $ lc t `elemIndex` months
monIndex t = maybe 0 (+1) $ lc t `elemIndex` monthabbrevs
month :: SimpleTextParser 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 :: Parser SmartDate mon :: SimpleTextParser 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 :: Parser SmartDate today,yesterday,tomorrow :: SimpleTextParser 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 :: Parser SmartDate lastthisnextthing :: SimpleTextParser SmartDate
lastthisnextthing = do lastthisnextthing = do
r <- choice [ r <- choice $ map mptext [
string "last" "last"
,string "this" ,"this"
,string "next" ,"next"
] ]
many spacenonewline -- make the space optional for easier scripting many spacenonewline -- make the space optional for easier scripting
p <- choice [ p <- choice $ map mptext [
string "day" "day"
,string "week" ,"week"
,string "month" ,"month"
,string "quarter" ,"quarter"
,string "year" ,"year"
] ]
-- XXX support these in fixSmartDate -- XXX support these in fixSmartDate
-- ++ (map string $ months ++ monthabbrevs ++ weekdays ++ weekdayabbrevs) -- ++ (map string $ months ++ monthabbrevs ++ weekdays ++ weekdayabbrevs)
return ("",r,p) return ("", T.unpack r, T.unpack p)
-- | -- |
-- >>> let p = parsewith (periodexpr (parsedate "2008/11/26")) :: T.Text -> Either (ParseError Char Dec) (Interval, DateSpan) -- >>> let p = parsewith (periodexpr (parsedate "2008/11/26")) :: T.Text -> Either (ParseError Char MPErr) (Interval, DateSpan)
-- >>> p "from aug to oct" -- >>> p "from aug to oct"
-- Right (NoInterval,DateSpan 2008/08/01-2008/09/30) -- Right (NoInterval,DateSpan 2008/08/01-2008/09/30)
-- >>> p "aug to oct" -- >>> p "aug to oct"
@ -688,7 +694,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 :: Day -> Parser (Interval, DateSpan) periodexpr :: Day -> SimpleTextParser (Interval, DateSpan)
periodexpr rdate = choice $ map try [ periodexpr rdate = choice $ map try [
intervalanddateperiodexpr rdate, intervalanddateperiodexpr rdate,
intervalperiodexpr, intervalperiodexpr,
@ -696,7 +702,7 @@ periodexpr rdate = choice $ map try [
(return (NoInterval,DateSpan Nothing Nothing)) (return (NoInterval,DateSpan Nothing Nothing))
] ]
intervalanddateperiodexpr :: Day -> Parser (Interval, DateSpan) intervalanddateperiodexpr :: Day -> SimpleTextParser (Interval, DateSpan)
intervalanddateperiodexpr rdate = do intervalanddateperiodexpr rdate = do
many spacenonewline many spacenonewline
i <- reportinginterval i <- reportinginterval
@ -704,20 +710,20 @@ intervalanddateperiodexpr rdate = do
s <- periodexprdatespan rdate s <- periodexprdatespan rdate
return (i,s) return (i,s)
intervalperiodexpr :: Parser (Interval, DateSpan) intervalperiodexpr :: SimpleTextParser (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 :: Day -> Parser (Interval, DateSpan) dateperiodexpr :: Day -> SimpleTextParser (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 :: Parser Interval reportinginterval :: SimpleTextParser Interval
reportinginterval = choice' [ reportinginterval = choice' [
tryinterval "day" "daily" Days, tryinterval "day" "daily" Days,
tryinterval "week" "weekly" Weeks, tryinterval "week" "weekly" Weeks,
@ -757,25 +763,28 @@ 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 :: String -> String -> (Int -> Interval) -> Parser Interval tryinterval :: String -> String -> (Int -> Interval) -> SimpleTextParser Interval
tryinterval singular compact intcons = tryinterval singular compact intcons =
choice' [ choice' [
do string compact do mptext compact'
return $ intcons 1, return $ intcons 1,
do string "every" do mptext "every"
many spacenonewline many spacenonewline
string singular mptext singular'
return $ intcons 1, return $ intcons 1,
do string "every" do mptext "every"
many spacenonewline many spacenonewline
n <- fmap read $ some digitChar n <- fmap read $ some digitChar
many spacenonewline many spacenonewline
string plural mptext plural'
return $ intcons n return $ intcons n
] ]
where plural = singular ++ "s" where
compact' = T.pack compact
singular' = T.pack singular
plural' = T.pack $ singular ++ "s"
periodexprdatespan :: Day -> Parser DateSpan periodexprdatespan :: Day -> SimpleTextParser DateSpan
periodexprdatespan rdate = choice $ map try [ periodexprdatespan rdate = choice $ map try [
doubledatespan rdate, doubledatespan rdate,
fromdatespan rdate, fromdatespan rdate,
@ -783,7 +792,7 @@ periodexprdatespan rdate = choice $ map try [
justdatespan rdate justdatespan rdate
] ]
doubledatespan :: Day -> Parser DateSpan doubledatespan :: Day -> SimpleTextParser DateSpan
doubledatespan rdate = do doubledatespan rdate = do
optional (string "from" >> many spacenonewline) optional (string "from" >> many spacenonewline)
b <- smartdate b <- smartdate
@ -792,7 +801,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 :: Day -> Parser DateSpan fromdatespan :: Day -> SimpleTextParser DateSpan
fromdatespan rdate = do fromdatespan rdate = do
b <- choice [ b <- choice [
do do
@ -806,13 +815,13 @@ fromdatespan rdate = do
] ]
return $ DateSpan (Just $ fixSmartDate rdate b) Nothing return $ DateSpan (Just $ fixSmartDate rdate b) Nothing
todatespan :: Day -> Parser DateSpan todatespan :: Day -> SimpleTextParser 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 :: Day -> Parser DateSpan justdatespan :: Day -> SimpleTextParser DateSpan
justdatespan rdate = do justdatespan rdate = do
optional (string "in" >> many spacenonewline) optional (string "in" >> many spacenonewline)
d <- smartdate d <- smartdate

14
hledger-lib/Hledger/Data/StringFormat.hs
View File

@ -19,9 +19,9 @@ import Numeric
import Data.Char (isPrint) import Data.Char (isPrint)
import Data.Maybe import Data.Maybe
import Test.HUnit import Test.HUnit
import Text.Megaparsec import Text.Megaparsec.Compat
import Text.Megaparsec.String
import Hledger.Utils.Parse
import Hledger.Utils.String (formatString) import Hledger.Utils.String (formatString)
-- | A format specification/template to use when rendering a report line item as text. -- | A format specification/template to use when rendering a report line item as text.
@ -86,7 +86,7 @@ parseStringFormat input = case (runParser (stringformatp <* eof) "(unknown)") in
defaultStringFormatStyle = BottomAligned defaultStringFormatStyle = BottomAligned
stringformatp :: Parser StringFormat stringformatp :: SimpleStringParser StringFormat
stringformatp = do stringformatp = do
alignspec <- optional (try $ char '%' >> oneOf "^_,") alignspec <- optional (try $ char '%' >> oneOf "^_,")
let constructor = let constructor =
@ -97,10 +97,10 @@ stringformatp = do
_ -> defaultStringFormatStyle _ -> defaultStringFormatStyle
constructor <$> many componentp constructor <$> many componentp
componentp :: Parser StringFormatComponent componentp :: SimpleStringParser StringFormatComponent
componentp = formatliteralp <|> formatfieldp componentp = formatliteralp <|> formatfieldp
formatliteralp :: Parser StringFormatComponent formatliteralp :: SimpleStringParser StringFormatComponent
formatliteralp = do formatliteralp = do
s <- some c s <- some c
return $ FormatLiteral s return $ FormatLiteral s
@ -109,7 +109,7 @@ formatliteralp = do
c = (satisfy isPrintableButNotPercentage <?> "printable character") c = (satisfy isPrintableButNotPercentage <?> "printable character")
<|> try (string "%%" >> return '%') <|> try (string "%%" >> return '%')
formatfieldp :: Parser StringFormatComponent formatfieldp :: SimpleStringParser StringFormatComponent
formatfieldp = do formatfieldp = do
char '%' char '%'
leftJustified <- optional (char '-') leftJustified <- optional (char '-')
@ -124,7 +124,7 @@ formatfieldp = do
Just text -> Just m where ((m,_):_) = readDec text Just text -> Just m where ((m,_):_) = readDec text
_ -> Nothing _ -> Nothing
fieldp :: Parser ReportItemField fieldp :: SimpleStringParser ReportItemField
fieldp = do fieldp = do
try (string "account" >> return AccountField) try (string "account" >> return AccountField)
<|> try (string "depth_spacer" >> return DepthSpacerField) <|> try (string "depth_spacer" >> return DepthSpacerField)

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

@ -1,7 +1,7 @@
{-| {-|
A general query system for matching things (accounts, postings, A general query system for matching things (accounts, postings,
transactions..) by various criteria, and a parser for query expressions. transactions..) by various criteria, and a SimpleTextParser for query expressions.
-} -}
@ -55,8 +55,7 @@ import qualified Data.Text as T
import Data.Time.Calendar import Data.Time.Calendar
import Safe (readDef, headDef) import Safe (readDef, headDef)
import Test.HUnit import Test.HUnit
import Text.Megaparsec import Text.Megaparsec.Compat
import Text.Megaparsec.Text
import Hledger.Utils hiding (words') import Hledger.Utils hiding (words')
import Hledger.Data.Types import Hledger.Data.Types
@ -185,23 +184,23 @@ tests_parseQuery = [
words'' :: [T.Text] -> T.Text -> [T.Text] words'' :: [T.Text] -> T.Text -> [T.Text]
words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- XXX words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- XXX
where where
maybeprefixedquotedphrases :: Parser [T.Text] maybeprefixedquotedphrases :: SimpleTextParser [T.Text]
maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, singleQuotedPattern, doubleQuotedPattern, pattern] `sepBy` some spacenonewline maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, singleQuotedPattern, doubleQuotedPattern, pattern] `sepBy` some spacenonewline
prefixedQuotedPattern :: Parser T.Text prefixedQuotedPattern :: SimpleTextParser T.Text
prefixedQuotedPattern = do prefixedQuotedPattern = do
not' <- fromMaybe "" `fmap` (optional $ string "not:") not' <- fromMaybe "" `fmap` (optional $ mptext "not:")
let allowednexts | null not' = prefixes let allowednexts | T.null not' = prefixes
| otherwise = prefixes ++ [""] | otherwise = prefixes ++ [""]
next <- fmap T.pack $ choice' $ map (string . T.unpack) allowednexts next <- choice' $ map mptext allowednexts
let prefix :: T.Text let prefix :: T.Text
prefix = T.pack not' <> next prefix = not' <> next
p <- singleQuotedPattern <|> doubleQuotedPattern p <- singleQuotedPattern <|> doubleQuotedPattern
return $ prefix <> stripquotes p return $ prefix <> stripquotes p
singleQuotedPattern :: Parser T.Text singleQuotedPattern :: SimpleTextParser T.Text
singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf ("'" :: [Char])) >>= return . stripquotes . T.pack singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf ("'" :: [Char])) >>= return . stripquotes . T.pack
doubleQuotedPattern :: Parser T.Text doubleQuotedPattern :: SimpleTextParser T.Text
doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf ("\"" :: [Char])) >>= return . stripquotes . T.pack doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf ("\"" :: [Char])) >>= return . stripquotes . T.pack
pattern :: Parser T.Text pattern :: SimpleTextParser T.Text
pattern = fmap T.pack $ many (noneOf (" \n\r" :: [Char])) pattern = fmap T.pack $ many (noneOf (" \n\r" :: [Char]))
tests_words'' = [ tests_words'' = [

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

@ -36,8 +36,7 @@ import Data.Time.Calendar
import Data.Time.LocalTime import Data.Time.LocalTime
import Safe import Safe
import System.Time (getClockTime) import System.Time (getClockTime)
import Text.Megaparsec hiding (parse,State) import Text.Megaparsec.Compat
import Text.Megaparsec.Text
import Hledger.Data import Hledger.Data
import Hledger.Utils import Hledger.Utils
@ -47,12 +46,12 @@ import Hledger.Utils
--- * parsing utils --- * parsing utils
-- | Run a string parser with no state in the identity monad. -- | Run a string parser with no state in the identity monad.
runTextParser, rtp :: TextParser Identity a -> Text -> Either (ParseError Char Dec) a runTextParser, rtp :: TextParser Identity a -> Text -> Either (ParseError Char MPErr) a
runTextParser p t = runParser p "" t runTextParser p t = runParser p "" t
rtp = runTextParser 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 => TextParser m a -> Text -> m (Either (ParseError Char Dec) a) runJournalParser, rjp :: Monad m => TextParser m a -> Text -> m (Either (ParseError Char MPErr) a)
runJournalParser p t = runParserT p "" t runJournalParser p t = runParserT p "" t
rjp = runJournalParser rjp = runJournalParser
@ -89,7 +88,7 @@ parseAndFinaliseJournal parser assrt f txt = do
Left e -> throwError e Left e -> throwError e
Left e -> throwError $ parseErrorPretty e Left e -> throwError $ parseErrorPretty e
parseAndFinaliseJournal' :: JournalParser ParsedJournal -> Bool -> FilePath -> Text -> ExceptT String IO Journal parseAndFinaliseJournal' :: JournalParser Identity ParsedJournal -> Bool -> FilePath -> Text -> ExceptT String IO Journal
parseAndFinaliseJournal' parser assrt f txt = do parseAndFinaliseJournal' parser assrt f txt = do
t <- liftIO getClockTime t <- liftIO getClockTime
y <- liftIO getCurrentYear y <- liftIO getCurrentYear
@ -100,32 +99,32 @@ parseAndFinaliseJournal' parser assrt f txt = do
Left e -> throwError e Left e -> throwError e
Left e -> throwError $ parseErrorPretty e Left e -> throwError $ parseErrorPretty e
setYear :: Year -> JournalStateParser m () setYear :: Year -> JournalParser m ()
setYear y = modify' (\j -> j{jparsedefaultyear=Just y}) setYear y = modify' (\j -> j{jparsedefaultyear=Just y})
getYear :: JournalStateParser m (Maybe Year) getYear :: JournalParser m (Maybe Year)
getYear = fmap jparsedefaultyear get getYear = fmap jparsedefaultyear get
setDefaultCommodityAndStyle :: (CommoditySymbol,AmountStyle) -> JournalStateParser m () setDefaultCommodityAndStyle :: (CommoditySymbol,AmountStyle) -> JournalParser m ()
setDefaultCommodityAndStyle cs = modify' (\j -> j{jparsedefaultcommodity=Just cs}) setDefaultCommodityAndStyle cs = modify' (\j -> j{jparsedefaultcommodity=Just cs})
getDefaultCommodityAndStyle :: JournalStateParser m (Maybe (CommoditySymbol,AmountStyle)) getDefaultCommodityAndStyle :: JournalParser m (Maybe (CommoditySymbol,AmountStyle))
getDefaultCommodityAndStyle = jparsedefaultcommodity `fmap` get getDefaultCommodityAndStyle = jparsedefaultcommodity `fmap` get
pushAccount :: AccountName -> JournalStateParser m () pushAccount :: AccountName -> JournalParser m ()
pushAccount acct = modify' (\j -> j{jaccounts = acct : jaccounts j}) pushAccount acct = modify' (\j -> j{jaccounts = acct : jaccounts j})
pushParentAccount :: AccountName -> JournalStateParser m () pushParentAccount :: AccountName -> JournalParser m ()
pushParentAccount acct = modify' (\j -> j{jparseparentaccounts = acct : jparseparentaccounts j}) pushParentAccount acct = modify' (\j -> j{jparseparentaccounts = acct : jparseparentaccounts j})
popParentAccount :: JournalStateParser m () popParentAccount :: JournalParser m ()
popParentAccount = do popParentAccount = do
j <- get j <- get
case jparseparentaccounts j of case jparseparentaccounts j of
[] -> unexpected (Tokens ('E' :| "nd of apply account block with no beginning")) [] -> unexpected (Tokens ('E' :| "nd of apply account block with no beginning"))
(_:rest) -> put j{jparseparentaccounts=rest} (_:rest) -> put j{jparseparentaccounts=rest}
getParentAccount :: JournalStateParser m AccountName getParentAccount :: JournalParser m AccountName
getParentAccount = fmap (concatAccountNames . reverse . jparseparentaccounts) get getParentAccount = fmap (concatAccountNames . reverse . jparseparentaccounts) get
addAccountAlias :: MonadState Journal m => AccountAlias -> m () addAccountAlias :: MonadState Journal m => AccountAlias -> m ()
@ -181,7 +180,7 @@ statusp =
codep :: TextParser m String codep :: TextParser m String
codep = try (do { some spacenonewline; char '(' <?> "codep"; anyChar `manyTill` char ')' } ) <|> return "" codep = try (do { some spacenonewline; char '(' <?> "codep"; anyChar `manyTill` char ')' } ) <|> return ""
descriptionp :: JournalStateParser m String descriptionp :: JournalParser m String
descriptionp = many (noneOf (";\n" :: [Char])) descriptionp = many (noneOf (";\n" :: [Char]))
--- ** dates --- ** dates
@ -190,7 +189,7 @@ descriptionp = many (noneOf (";\n" :: [Char]))
-- Hyphen (-) and period (.) are also allowed as separators. -- Hyphen (-) and period (.) are also allowed as separators.
-- The year may be omitted if a default year has been set. -- The year may be omitted if a default year has been set.
-- Leading zeroes may be omitted. -- Leading zeroes may be omitted.
datep :: JournalStateParser m Day datep :: JournalParser m Day
datep = do datep = do
-- hacky: try to ensure precise errors for invalid dates -- hacky: try to ensure precise errors for invalid dates
-- XXX reported error position is not too good -- XXX reported error position is not too good
@ -220,7 +219,7 @@ datep = do
-- Seconds are optional. -- Seconds are optional.
-- The timezone is optional and ignored (the time is always interpreted as a local time). -- The timezone is optional and ignored (the time is always interpreted as a local time).
-- Leading zeroes may be omitted (except in a timezone). -- Leading zeroes may be omitted (except in a timezone).
datetimep :: JournalStateParser m LocalTime datetimep :: JournalParser m LocalTime
datetimep = do datetimep = do
day <- datep day <- datep
lift $ some spacenonewline lift $ some spacenonewline
@ -248,7 +247,7 @@ datetimep = do
-- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s') -- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s') return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
secondarydatep :: Day -> JournalStateParser m Day secondarydatep :: Day -> JournalParser m Day
secondarydatep primarydate = do secondarydatep primarydate = do
char '=' char '='
-- kludgy way to use primary date for default year -- kludgy way to use primary date for default year
@ -274,7 +273,7 @@ secondarydatep primarydate = do
--- ** account names --- ** account names
-- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect. -- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.
modifiedaccountnamep :: JournalStateParser m AccountName modifiedaccountnamep :: JournalParser m AccountName
modifiedaccountnamep = do modifiedaccountnamep = do
parent <- getParentAccount parent <- getParentAccount
aliases <- getAccountAliases aliases <- getAccountAliases
@ -313,7 +312,7 @@ accountnamep = do
-- | Parse whitespace then an amount, with an optional left or right -- | Parse whitespace then an amount, with an optional left or right
-- currency symbol and optional price, or return the special -- currency symbol and optional price, or return the special
-- "missing" marker amount. -- "missing" marker amount.
spaceandamountormissingp :: Monad m => JournalStateParser m MixedAmount spaceandamountormissingp :: Monad m => JournalParser m MixedAmount
spaceandamountormissingp = spaceandamountormissingp =
try (do try (do
lift $ some spacenonewline lift $ some spacenonewline
@ -337,7 +336,7 @@ test_spaceandamountormissingp = do
-- | Parse a single-commodity amount, with optional symbol on the left or -- | Parse a single-commodity amount, with optional symbol on the left or
-- right, optional unit or total price, and optional (ignored) -- right, optional unit or total price, and optional (ignored)
-- ledger-style balance assertion or fixed lot price declaration. -- ledger-style balance assertion or fixed lot price declaration.
amountp :: Monad m => JournalStateParser m Amount amountp :: Monad m => JournalParser m Amount
amountp = try leftsymbolamountp <|> try rightsymbolamountp <|> nosymbolamountp amountp = try leftsymbolamountp <|> try rightsymbolamountp <|> nosymbolamountp
#ifdef TESTS #ifdef TESTS
@ -377,7 +376,7 @@ multiplierp = do
return $ case multiplier of Just '*' -> True return $ case multiplier of Just '*' -> True
_ -> False _ -> False
leftsymbolamountp :: Monad m => JournalStateParser m Amount leftsymbolamountp :: Monad m => JournalParser m Amount
leftsymbolamountp = do leftsymbolamountp = do
sign <- lift signp sign <- lift signp
m <- lift multiplierp m <- lift multiplierp
@ -390,7 +389,7 @@ leftsymbolamountp = do
return $ applysign $ Amount c q p s m return $ applysign $ Amount c q p s m
<?> "left-symbol amount" <?> "left-symbol amount"
rightsymbolamountp :: Monad m => JournalStateParser m Amount rightsymbolamountp :: Monad m => JournalParser m Amount
rightsymbolamountp = do rightsymbolamountp = do
m <- lift multiplierp m <- lift multiplierp
(q,prec,mdec,mgrps) <- lift numberp (q,prec,mdec,mgrps) <- lift numberp
@ -401,7 +400,7 @@ rightsymbolamountp = do
return $ Amount c q p s m return $ Amount c q p s m
<?> "right-symbol amount" <?> "right-symbol amount"
nosymbolamountp :: Monad m => JournalStateParser m Amount nosymbolamountp :: Monad m => JournalParser m Amount
nosymbolamountp = do nosymbolamountp = do
m <- lift multiplierp m <- lift multiplierp
(q,prec,mdec,mgrps) <- lift numberp (q,prec,mdec,mgrps) <- lift numberp
@ -427,7 +426,7 @@ quotedcommoditysymbolp = do
simplecommoditysymbolp :: TextParser m CommoditySymbol simplecommoditysymbolp :: TextParser m CommoditySymbol
simplecommoditysymbolp = T.pack <$> some (noneOf nonsimplecommoditychars) simplecommoditysymbolp = T.pack <$> some (noneOf nonsimplecommoditychars)
priceamountp :: Monad m => JournalStateParser m Price priceamountp :: Monad m => JournalParser m Price
priceamountp = priceamountp =
try (do try (do
lift (many spacenonewline) lift (many spacenonewline)
@ -443,7 +442,7 @@ priceamountp =
return $ UnitPrice a)) return $ UnitPrice a))
<|> return NoPrice <|> return NoPrice
partialbalanceassertionp :: Monad m => JournalStateParser m (Maybe Amount) partialbalanceassertionp :: Monad m => JournalParser m (Maybe Amount)
partialbalanceassertionp = partialbalanceassertionp =
try (do try (do
lift (many spacenonewline) lift (many spacenonewline)
@ -464,7 +463,7 @@ partialbalanceassertionp =
-- <|> return Nothing -- <|> return Nothing
-- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices -- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices
fixedlotpricep :: Monad m => JournalStateParser m (Maybe Amount) fixedlotpricep :: Monad m => JournalParser m (Maybe Amount)
fixedlotpricep = fixedlotpricep =
try (do try (do
lift (many spacenonewline) lift (many spacenonewline)
@ -564,7 +563,7 @@ numberp = do
--- ** comments --- ** comments
multilinecommentp :: JournalStateParser m () multilinecommentp :: JournalParser m ()
multilinecommentp = do multilinecommentp = do
string "comment" >> lift (many spacenonewline) >> newline string "comment" >> lift (many spacenonewline) >> newline
go go
@ -573,13 +572,13 @@ multilinecommentp = do
<|> (anyLine >> go) <|> (anyLine >> go)
anyLine = anyChar `manyTill` newline anyLine = anyChar `manyTill` newline
emptyorcommentlinep :: JournalStateParser m () emptyorcommentlinep :: JournalParser m ()
emptyorcommentlinep = do emptyorcommentlinep = do
lift (many spacenonewline) >> (commentp <|> (lift (many spacenonewline) >> newline >> return "")) lift (many spacenonewline) >> (commentp <|> (lift (many spacenonewline) >> newline >> return ""))
return () return ()
-- | Parse a possibly multi-line comment following a semicolon. -- | Parse a possibly multi-line comment following a semicolon.
followingcommentp :: JournalStateParser m Text followingcommentp :: JournalParser m Text
followingcommentp = followingcommentp =
-- ptrace "followingcommentp" -- ptrace "followingcommentp"
do samelinecomment <- lift (many spacenonewline) >> (try semicoloncommentp <|> (newline >> return "")) do samelinecomment <- lift (many spacenonewline) >> (try semicoloncommentp <|> (newline >> return ""))
@ -641,16 +640,16 @@ followingcommentandtagsp mdefdate = do
return (comment, tags, mdate, mdate2) return (comment, tags, mdate, mdate2)
commentp :: JournalStateParser m Text commentp :: JournalParser m Text
commentp = commentStartingWithp commentchars commentp = commentStartingWithp commentchars
commentchars :: [Char] commentchars :: [Char]
commentchars = "#;*" commentchars = "#;*"
semicoloncommentp :: JournalStateParser m Text semicoloncommentp :: JournalParser m Text
semicoloncommentp = commentStartingWithp ";" semicoloncommentp = commentStartingWithp ";"
commentStartingWithp :: [Char] -> JournalStateParser m Text commentStartingWithp :: [Char] -> JournalParser m Text
commentStartingWithp cs = do commentStartingWithp cs = do
-- ptrace "commentStartingWith" -- ptrace "commentStartingWith"
oneOf cs oneOf cs
@ -681,7 +680,7 @@ commentTags s =
Left _ -> [] -- shouldn't happen Left _ -> [] -- shouldn't happen
-- | Parse all tags found in a string. -- | Parse all tags found in a string.
tagsp :: Parser [Tag] tagsp :: SimpleTextParser [Tag]
tagsp = -- do tagsp = -- do
-- pdbg 0 $ "tagsp" -- pdbg 0 $ "tagsp"
many (try (nontagp >> tagp)) many (try (nontagp >> tagp))
@ -690,7 +689,7 @@ tagsp = -- do
-- --
-- >>> rtp nontagp "\na b:, \nd:e, f" -- >>> rtp nontagp "\na b:, \nd:e, f"
-- Right "\na " -- Right "\na "
nontagp :: Parser String nontagp :: SimpleTextParser 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))
@ -704,7 +703,7 @@ nontagp = -- do
-- >>> rtp tagp "a:b b , c AuxDate: 4/2" -- >>> rtp tagp "a:b b , c AuxDate: 4/2"
-- Right ("a","b b") -- Right ("a","b b")
-- --
tagp :: Parser Tag tagp :: SimpleTextParser Tag
tagp = do tagp = do
-- pdbg 0 "tagp" -- pdbg 0 "tagp"
n <- tagnamep n <- tagnamep
@ -714,7 +713,7 @@ tagp = do
-- | -- |
-- >>> rtp tagnamep "a:" -- >>> rtp tagnamep "a:"
-- Right "a" -- Right "a"
tagnamep :: Parser Text tagnamep :: SimpleTextParser Text
tagnamep = -- do tagnamep = -- do
-- pdbg 0 "tagnamep" -- pdbg 0 "tagnamep"
T.pack <$> some (noneOf (": \t\n" :: [Char])) <* char ':' T.pack <$> some (noneOf (": \t\n" :: [Char])) <* char ':'
@ -761,13 +760,13 @@ datetagp :: Monad m => Maybe Day -> ErroringJournalParser m (TagName,Day)
datetagp mdefdate = do datetagp mdefdate = do
-- pdbg 0 "datetagp" -- pdbg 0 "datetagp"
string "date" string "date"
n <- T.pack . fromMaybe "" <$> optional (string "2") n <- fromMaybe "" <$> optional (mptext "2")
char ':' char ':'
startpos <- getPosition startpos <- getPosition
v <- lift tagvaluep v <- lift tagvaluep
-- re-parse value as a date. -- re-parse value as a date.
j <- get j <- get
let ep :: Either (ParseError Char Dec) Day let ep :: Either (ParseError Char MPErr) Day
ep = parseWithState' ep = parseWithState'
j{jparsedefaultyear=first3.toGregorian <$> mdefdate} j{jparsedefaultyear=first3.toGregorian <$> mdefdate}
-- The value extends to a comma, newline, or end of file. -- The value extends to a comma, newline, or end of file.
@ -827,7 +826,7 @@ bracketeddatetagsp mdefdate = do
-- looks sufficiently like a bracketed date, now we -- looks sufficiently like a bracketed date, now we
-- re-parse as dates and throw any errors -- re-parse as dates and throw any errors
j <- get j <- get
let ep :: Either (ParseError Char Dec) (Maybe Day, Maybe Day) let ep :: Either (ParseError Char MPErr) (Maybe Day, Maybe Day)
ep = parseWithState' ep = parseWithState'
j{jparsedefaultyear=first3.toGregorian <$> mdefdate} j{jparsedefaultyear=first3.toGregorian <$> mdefdate}
(do (do

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

@ -38,7 +38,6 @@ 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 qualified Data.Set as S
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
@ -54,8 +53,7 @@ import System.Directory (doesFileExist)
import System.FilePath import System.FilePath
import Test.HUnit hiding (State) import Test.HUnit hiding (State)
import Text.CSV (parseCSV, CSV) import Text.CSV (parseCSV, CSV)
import Text.Megaparsec hiding (parse, State) import Text.Megaparsec.Compat hiding (parse)
import Text.Megaparsec.Text
import qualified Text.Parsec as Parsec import qualified Text.Parsec as Parsec
import Text.Printf (printf) import Text.Printf (printf)
@ -133,12 +131,14 @@ readJournalFromCsv mrulesfile csvfile csvdata =
let let
-- convert CSV records to transactions -- convert CSV records to transactions
txns = snd $ mapAccumL txns = snd $ mapAccumL
(\pos r -> (pos, (\pos r ->
transactionFromCsvRecord let
(let SourcePos name line col = pos in SourcePos name line col = pos
SourcePos name (unsafePos $ unPos line + 1) col) line' = (mpMkPos . (+1) . mpUnPos) line
rules pos' = SourcePos name line' col
r)) in
(pos, transactionFromCsvRecord pos' rules r)
)
(initialPos parsecfilename) records (initialPos parsecfilename) records
-- Ensure transactions are ordered chronologically. -- Ensure transactions are ordered chronologically.
@ -312,7 +312,7 @@ data CsvRules = CsvRules {
rconditionalblocks :: [ConditionalBlock] rconditionalblocks :: [ConditionalBlock]
} deriving (Show, Eq) } deriving (Show, Eq)
type CsvRulesParser a = StateT CsvRules Parser a type CsvRulesParser a = StateT CsvRules SimpleTextParser a
type DirectiveName = String type DirectiveName = String
type CsvFieldName = String type CsvFieldName = String
@ -390,14 +390,11 @@ parseAndValidateCsvRules rulesfile s = do
Right r -> do Right r -> do
r_ <- liftIO $ runExceptT $ validateRules r r_ <- liftIO $ runExceptT $ validateRules r
ExceptT $ case r_ of ExceptT $ case r_ of
Left e -> return $ Left $ parseErrorPretty $ toParseError e Left s -> return $ Left $ parseErrorPretty $ mpMkParseError rulesfile s
Right r -> return $ Right r Right r -> return $ Right r
where
toParseError :: forall s. Ord s => s -> ParseError Char s
toParseError s = (mempty :: ParseError Char s) { errorCustom = S.singleton s}
-- | Parse this text as CSV conversion rules. The file path is for error messages. -- | Parse this text as CSV conversion rules. The file path is for error messages.
parseCsvRules :: FilePath -> T.Text -> Either (ParseError Char Dec) CsvRules parseCsvRules :: FilePath -> T.Text -> Either (ParseError Char MPErr) CsvRules
-- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s -- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s
parseCsvRules rulesfile s = parseCsvRules rulesfile s =
runParser (evalStateT rulesp rules) rulesfile s runParser (evalStateT rulesp rules) rulesfile s
@ -449,7 +446,7 @@ commentcharp = oneOf (";#*" :: [Char])
directivep :: CsvRulesParser (DirectiveName, String) directivep :: CsvRulesParser (DirectiveName, String)
directivep = (do directivep = (do
lift $ pdbg 3 "trying directive" lift $ pdbg 3 "trying directive"
d <- choiceInState $ map string directives d <- fmap T.unpack $ choiceInState $ map (lift . mptext . T.pack) directives
v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp) v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp)
<|> (optional (char ':') >> lift (many spacenonewline) >> lift eolof >> return "") <|> (optional (char ':') >> lift (many spacenonewline) >> lift eolof >> return "")
return (d, v) return (d, v)
@ -505,7 +502,9 @@ fieldassignmentp = do
<?> "field assignment" <?> "field assignment"
journalfieldnamep :: CsvRulesParser String journalfieldnamep :: CsvRulesParser String
journalfieldnamep = lift (pdbg 2 "trying journalfieldnamep") >> choiceInState (map string journalfieldnames) journalfieldnamep = do
lift (pdbg 2 "trying journalfieldnamep")
T.unpack <$> choiceInState (map (lift . mptext . T.pack) journalfieldnames)
-- Transaction fields and pseudo fields for CSV conversion. -- Transaction fields and pseudo fields for CSV conversion.
-- Names must precede any other name they contain, for the parser -- Names must precede any other name they contain, for the parser
@ -565,7 +564,7 @@ recordmatcherp = do
<?> "record matcher" <?> "record matcher"
matchoperatorp :: CsvRulesParser String matchoperatorp :: CsvRulesParser String
matchoperatorp = choiceInState $ map string matchoperatorp = fmap T.unpack $ choiceInState $ map mptext
["~" ["~"
-- ,"!~" -- ,"!~"
-- ,"=" -- ,"="

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

@ -90,7 +90,7 @@ import Test.HUnit
import Test.Framework import Test.Framework
import Text.Megaparsec.Error import Text.Megaparsec.Error
#endif #endif
import Text.Megaparsec hiding (parse) import Text.Megaparsec.Compat hiding (parse)
import Text.Printf import Text.Printf
import System.FilePath import System.FilePath
@ -187,7 +187,7 @@ includedirectivep = 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 <- readFileAnyLineEnding filepath `orRethrowIOError` (show parentpos ++ " reading " ++ filepath) txt <- readFileAnyLineEnding filepath `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)
(ej1::Either (ParseError Char Dec) ParsedJournal) <- (ej1::Either (ParseError Char MPErr) ParsedJournal) <-
runParserT runParserT
(evalStateT (evalStateT
(choiceInState (choiceInState
@ -227,7 +227,7 @@ orRethrowIOError io msg =
(Right <$> io) (Right <$> io)
`C.catch` \(e::C.IOException) -> return $ Left $ printf "%s:\n%s" msg (show e) `C.catch` \(e::C.IOException) -> return $ Left $ printf "%s:\n%s" msg (show e)
accountdirectivep :: JournalStateParser m () accountdirectivep :: JournalParser m ()
accountdirectivep = do accountdirectivep = do
string "account" string "account"
lift (some spacenonewline) lift (some spacenonewline)
@ -237,7 +237,7 @@ accountdirectivep = do
modify' (\j -> j{jaccounts = acct : jaccounts j}) modify' (\j -> j{jaccounts = acct : jaccounts j})
indentedlinep :: JournalStateParser m String indentedlinep :: JournalParser m String
indentedlinep = lift (some spacenonewline) >> (rstrip <$> lift restofline) indentedlinep = lift (some spacenonewline) >> (rstrip <$> lift restofline)
-- | Parse a one-line or multi-line commodity directive. -- | Parse a one-line or multi-line commodity directive.
@ -253,7 +253,7 @@ commoditydirectivep = try commoditydirectiveonelinep <|> commoditydirectivemulti
-- --
-- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00" -- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00"
-- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00 ; blah\n" -- >>> Right _ <- rejp commoditydirectiveonelinep "commodity $1.00 ; blah\n"
commoditydirectiveonelinep :: Monad m => JournalStateParser m () commoditydirectiveonelinep :: Monad m => JournalParser m ()
commoditydirectiveonelinep = do commoditydirectiveonelinep = do
string "commodity" string "commodity"
lift (some spacenonewline) lift (some spacenonewline)
@ -292,7 +292,7 @@ formatdirectivep expectedsym = do
else parserErrorAt pos $ else parserErrorAt pos $
printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity
applyaccountdirectivep :: JournalStateParser m () applyaccountdirectivep :: JournalParser m ()
applyaccountdirectivep = do applyaccountdirectivep = do
string "apply" >> lift (some spacenonewline) >> string "account" string "apply" >> lift (some spacenonewline) >> string "account"
lift (some spacenonewline) lift (some spacenonewline)
@ -300,12 +300,12 @@ applyaccountdirectivep = do
newline newline
pushParentAccount parent pushParentAccount parent
endapplyaccountdirectivep :: JournalStateParser m () endapplyaccountdirectivep :: JournalParser m ()
endapplyaccountdirectivep = do endapplyaccountdirectivep = do
string "end" >> lift (some spacenonewline) >> string "apply" >> lift (some spacenonewline) >> string "account" string "end" >> lift (some spacenonewline) >> string "apply" >> lift (some spacenonewline) >> string "account"
popParentAccount popParentAccount
aliasdirectivep :: JournalStateParser m () aliasdirectivep :: JournalParser m ()
aliasdirectivep = do aliasdirectivep = do
string "alias" string "alias"
lift (some spacenonewline) lift (some spacenonewline)
@ -336,12 +336,12 @@ regexaliasp = do
repl <- rstrip <$> anyChar `manyTill` eolof repl <- rstrip <$> anyChar `manyTill` eolof
return $ RegexAlias re repl return $ RegexAlias re repl
endaliasesdirectivep :: JournalStateParser m () endaliasesdirectivep :: JournalParser m ()
endaliasesdirectivep = do endaliasesdirectivep = do
string "end aliases" string "end aliases"
clearAccountAliases clearAccountAliases
tagdirectivep :: JournalStateParser m () tagdirectivep :: JournalParser m ()
tagdirectivep = do tagdirectivep = do
string "tag" <?> "tag directive" string "tag" <?> "tag directive"
lift (some spacenonewline) lift (some spacenonewline)
@ -349,13 +349,13 @@ tagdirectivep = do
lift restofline lift restofline
return () return ()
endtagdirectivep :: JournalStateParser m () endtagdirectivep :: JournalParser m ()
endtagdirectivep = do endtagdirectivep = do
(string "end tag" <|> string "pop") <?> "end tag or pop directive" (string "end tag" <|> string "pop") <?> "end tag or pop directive"
lift restofline lift restofline
return () return ()
defaultyeardirectivep :: JournalStateParser m () defaultyeardirectivep :: JournalParser m ()
defaultyeardirectivep = do defaultyeardirectivep = do
char 'Y' <?> "default year" char 'Y' <?> "default year"
lift (many spacenonewline) lift (many spacenonewline)
@ -364,7 +364,7 @@ defaultyeardirectivep = do
failIfInvalidYear y failIfInvalidYear y
setYear y' setYear y'
defaultcommoditydirectivep :: Monad m => JournalStateParser m () defaultcommoditydirectivep :: Monad m => JournalParser m ()
defaultcommoditydirectivep = do defaultcommoditydirectivep = do
char 'D' <?> "default commodity" char 'D' <?> "default commodity"
lift (some spacenonewline) lift (some spacenonewline)
@ -372,7 +372,7 @@ defaultcommoditydirectivep = do
lift restofline lift restofline
setDefaultCommodityAndStyle (acommodity, astyle) setDefaultCommodityAndStyle (acommodity, astyle)
marketpricedirectivep :: Monad m => JournalStateParser m MarketPrice marketpricedirectivep :: Monad m => JournalParser m MarketPrice
marketpricedirectivep = do marketpricedirectivep = do
char 'P' <?> "market price" char 'P' <?> "market price"
lift (many spacenonewline) lift (many spacenonewline)
@ -384,7 +384,7 @@ marketpricedirectivep = do
lift restofline lift restofline
return $ MarketPrice date symbol price return $ MarketPrice date symbol price
ignoredpricecommoditydirectivep :: JournalStateParser m () ignoredpricecommoditydirectivep :: JournalParser m ()
ignoredpricecommoditydirectivep = do ignoredpricecommoditydirectivep = do
char 'N' <?> "ignored-price commodity" char 'N' <?> "ignored-price commodity"
lift (some spacenonewline) lift (some spacenonewline)
@ -392,7 +392,7 @@ ignoredpricecommoditydirectivep = do
lift restofline lift restofline
return () return ()
commodityconversiondirectivep :: Monad m => JournalStateParser m () commodityconversiondirectivep :: Monad m => JournalParser m ()
commodityconversiondirectivep = do commodityconversiondirectivep = do
char 'C' <?> "commodity conversion" char 'C' <?> "commodity conversion"
lift (some spacenonewline) lift (some spacenonewline)

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

@ -60,7 +60,7 @@ 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.Megaparsec hiding (parse) import Text.Megaparsec.Compat hiding (parse)
import Hledger.Data import Hledger.Data
-- XXX too much reuse ? -- XXX too much reuse ?
@ -105,7 +105,7 @@ timeclockfilep = do many timeclockitemp
] <?> "timeclock entry, or default year or historical price directive" ] <?> "timeclock entry, or default year or historical price directive"
-- | Parse a timeclock entry. -- | Parse a timeclock entry.
timeclockentryp :: JournalStateParser m TimeclockEntry timeclockentryp :: JournalParser m TimeclockEntry
timeclockentryp = do timeclockentryp = do
sourcepos <- genericSourcePos <$> lift getPosition sourcepos <- genericSourcePos <$> lift getPosition
code <- oneOf ("bhioO" :: [Char]) code <- oneOf ("bhioO" :: [Char])

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

@ -42,7 +42,7 @@ import Data.List (foldl')
import Data.Maybe import Data.Maybe
import Data.Text (Text) import Data.Text (Text)
import Test.HUnit import Test.HUnit
import Text.Megaparsec hiding (parse) import Text.Megaparsec.Compat hiding (parse)
import Hledger.Data import Hledger.Data
import Hledger.Read.Common import Hledger.Read.Common
@ -66,12 +66,12 @@ reader = Reader
parse :: Maybe FilePath -> Bool -> FilePath -> Text -> ExceptT String IO Journal parse :: Maybe FilePath -> Bool -> FilePath -> Text -> ExceptT String IO Journal
parse _ = parseAndFinaliseJournal timedotfilep parse _ = parseAndFinaliseJournal timedotfilep
timedotfilep :: JournalStateParser m ParsedJournal timedotfilep :: JournalParser m ParsedJournal
timedotfilep = do many timedotfileitemp timedotfilep = do many timedotfileitemp
eof eof
get get
where where
timedotfileitemp :: JournalStateParser m () timedotfileitemp :: JournalParser m ()
timedotfileitemp = do timedotfileitemp = do
ptrace "timedotfileitemp" ptrace "timedotfileitemp"
choice [ choice [
@ -89,7 +89,7 @@ addTransactions ts j = foldl' (flip ($)) j (map addTransaction ts)
-- biz.research . -- biz.research .
-- inc.client1 .... .... .... .... .... .... -- inc.client1 .... .... .... .... .... ....
-- @ -- @
timedotdayp :: JournalStateParser m [Transaction] timedotdayp :: JournalParser m [Transaction]
timedotdayp = do timedotdayp = do
ptrace " timedotdayp" ptrace " timedotdayp"
d <- datep <* lift eolof d <- datep <* lift eolof
@ -101,7 +101,7 @@ timedotdayp = do
-- @ -- @
-- fos.haskell .... .. -- fos.haskell .... ..
-- @ -- @
timedotentryp :: JournalStateParser m Transaction timedotentryp :: JournalParser m Transaction
timedotentryp = do timedotentryp = do
ptrace " timedotentryp" ptrace " timedotentryp"
pos <- genericSourcePos <$> getPosition pos <- genericSourcePos <$> getPosition
@ -125,14 +125,14 @@ timedotentryp = do
} }
return t return t
timedotdurationp :: JournalStateParser m Quantity timedotdurationp :: JournalParser m Quantity
timedotdurationp = try timedotnumberp <|> timedotdotsp timedotdurationp = try timedotnumberp <|> timedotdotsp
-- | Parse a duration written as a decimal number of hours (optionally followed by the letter h). -- | Parse a duration written as a decimal number of hours (optionally followed by the letter h).
-- @ -- @
-- 1.5h -- 1.5h
-- @ -- @
timedotnumberp :: JournalStateParser m Quantity timedotnumberp :: JournalParser m Quantity
timedotnumberp = do timedotnumberp = do
(q, _, _, _) <- lift numberp (q, _, _, _) <- lift numberp
lift (many spacenonewline) lift (many spacenonewline)
@ -144,7 +144,7 @@ timedotnumberp = do
-- @ -- @
-- .... .. -- .... ..
-- @ -- @
timedotdotsp :: JournalStateParser m Quantity timedotdotsp :: JournalParser m Quantity
timedotdotsp = do timedotdotsp = do
dots <- filter (not.isSpace) <$> many (oneOf (". " :: [Char])) dots <- filter (not.isSpace) <$> many (oneOf (". " :: [Char]))
return $ (/4) $ fromIntegral $ length dots return $ (/4) $ fromIntegral $ length dots

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

@ -1,38 +1,42 @@
{-# LANGUAGE FlexibleContexts, TypeFamilies #-} {-# LANGUAGE CPP, TypeFamilies #-}
module Hledger.Utils.Parse where module Hledger.Utils.Parse where
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.State.Strict (StateT, evalStateT)
import Data.Char import Data.Char
import Data.Functor.Identity (Identity(..))
import Data.List import Data.List
import Data.Text (Text) import Data.Text (Text)
import Text.Megaparsec hiding (State) import Text.Megaparsec.Compat
import Data.Functor.Identity (Identity(..))
import Text.Printf import Text.Printf
import Control.Monad.State.Strict (StateT, evalStateT)
import Hledger.Data.Types import Hledger.Data.Types
import Hledger.Utils.UTF8IOCompat (error') import Hledger.Utils.UTF8IOCompat (error')
-- | A parser of strict text with generic user state, monad and return type. -- | A parser of string to some type.
type TextParser m a = ParsecT Dec Text m a type SimpleStringParser a = Parsec MPErr String a
type JournalStateParser m a = StateT Journal (ParsecT Dec Text m) a -- | A parser of strict text to some type.
type SimpleTextParser = Parsec MPErr Text -- XXX an "a" argument breaks the CsvRulesParser declaration somehow
type JournalParser a = StateT Journal (ParsecT Dec Text Identity) a -- | A parser of text in some monad.
type TextParser m a = ParsecT MPErr Text m a
-- | A journal parser that runs in IO and can throw an error mid-parse. -- | A parser of text in some monad, with a journal as state.
type ErroringJournalParser m a = StateT Journal (ParsecT Dec Text (ExceptT String m)) a type JournalParser m a = StateT Journal (ParsecT MPErr Text m) a
-- | A parser of text in some monad, with a journal as state, that can throw an error string mid-parse.
type ErroringJournalParser m a = StateT Journal (ParsecT MPErr Text (ExceptT String m)) a
-- | Backtracking choice, use this when alternatives share a prefix. -- | Backtracking choice, use this when alternatives share a prefix.
-- Consumes no input if all choices fail. -- Consumes no input if all choices fail.
choice' :: [TextParser m a] -> TextParser m a choice' :: [TextParser m a] -> TextParser m a
choice' = choice . map Text.Megaparsec.try choice' = choice . map try
-- | Backtracking choice, use this when alternatives share a prefix. -- | Backtracking choice, use this when alternatives share a prefix.
-- Consumes no input if all choices fail. -- Consumes no input if all choices fail.
choiceInState :: [StateT s (ParsecT Dec Text m) a] -> StateT s (ParsecT Dec Text m) a choiceInState :: [StateT s (ParsecT MPErr Text m) a] -> StateT s (ParsecT MPErr Text m) a
choiceInState = choice . map Text.Megaparsec.try choiceInState = choice . map try
parsewith :: Parsec e Text a -> Text -> Either (ParseError Char e) a parsewith :: Parsec e Text a -> Text -> Either (ParseError Char e) a
parsewith p = runParser p "" parsewith p = runParser p ""
@ -40,10 +44,15 @@ parsewith p = runParser p ""
parsewithString :: Parsec e String a -> String -> Either (ParseError Char e) a parsewithString :: Parsec e String a -> String -> Either (ParseError Char e) a
parsewithString p = runParser p "" parsewithString p = runParser p ""
parseWithState :: Monad m => st -> StateT st (ParsecT Dec Text m) a -> Text -> m (Either (ParseError Char Dec) a) parseWithState :: Monad m => st -> StateT st (ParsecT MPErr Text m) a -> Text -> m (Either (ParseError Char MPErr) a)
parseWithState ctx p s = runParserT (evalStateT p ctx) "" s parseWithState ctx p s = runParserT (evalStateT p ctx) "" s
parseWithState' :: (Stream s, ErrorComponent e) => st -> StateT st (ParsecT e s Identity) a -> s -> (Either (ParseError (Token s) e) a) parseWithState' :: (
Stream s
#if !MIN_VERSION_megaparsec(6,0,0)
,ErrorComponent e
#endif
) => st -> StateT st (ParsecT e s Identity) a -> s -> (Either (ParseError (Token s) e) a)
parseWithState' ctx p s = runParser (evalStateT p ctx) "" s parseWithState' ctx p s = runParser (evalStateT p ctx) "" s
fromparse :: (Show t, Show e) => Either (ParseError t e) a -> a fromparse :: (Show t, Show e) => Either (ParseError t e) a -> a
@ -61,7 +70,7 @@ showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $
nonspace :: TextParser m Char nonspace :: TextParser m Char
nonspace = satisfy (not . isSpace) nonspace = satisfy (not . isSpace)
spacenonewline :: (Stream s, Char ~ Token s) => ParsecT Dec s m Char spacenonewline :: (Stream s, Char ~ Token s) => ParsecT MPErr s m Char
spacenonewline = satisfy (`elem` " \v\f\t") spacenonewline = satisfy (`elem` " \v\f\t")
restofline :: TextParser m String restofline :: TextParser m String

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

@ -49,7 +49,7 @@ module Hledger.Utils.String (
import Data.Char import Data.Char
import Data.List import Data.List
import Text.Megaparsec import Text.Megaparsec.Compat
import Text.Printf (printf) import Text.Printf (printf)
import Hledger.Utils.Parse import Hledger.Utils.Parse

66
hledger-lib/Text/Megaparsec/Compat.hs Normal file
View File

@ -0,0 +1,66 @@
{-# LANGUAGE CPP, FlexibleContexts #-}
module Text.Megaparsec.Compat
(module Text.Megaparsec
#if MIN_VERSION_megaparsec(6,0,0)
,module Text.Megaparsec.Char
#endif
,MPErr
,mptext
,mpMkPos
,mpUnPos
,mpMkParseError
)
where
import qualified Data.Set as S
import Data.Text
import Text.Megaparsec
#if MIN_VERSION_megaparsec(6,0,0)
import Text.Megaparsec.Char
import Data.List.NonEmpty (fromList)
import Data.Void (Void)
-- | A basic parse error type.
type MPErr = ErrorFancy Void
-- | Parse and return some Text.
mptext :: MonadParsec e Text m => Tokens Text -> m (Tokens Text)
mptext = string
#else
import Text.Megaparsec.Prim (MonadParsec)
type MPErr = Dec
mptext :: MonadParsec e Text m => Text -> m Text
mptext = fmap pack . string . unpack
#endif
mpMkPos :: Int -> Pos
mpMkPos =
#if MIN_VERSION_megaparsec(6,0,0)
mkPos
#else
unsafePos . fromIntegral
#endif
mpUnPos :: Pos -> Int
mpUnPos =
#if MIN_VERSION_megaparsec(6,0,0)
unPos
#else
fromIntegral . unPos
#endif
mpMkParseError :: FilePath -> String -> ParseError Char String
mpMkParseError f s =
#if MIN_VERSION_megaparsec(6,0,0)
FancyError (fromList [initialPos f]) (S.singleton $ ErrorFail s)
#else
(mempty :: ParseError Char String){errorCustom = S.singleton $ f ++ ": " ++ s}
#endif

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

@ -1,4 +1,4 @@
-- This file has been generated from package.yaml by hpack version 0.17.0. -- This file has been generated from package.yaml by hpack version 0.17.1.
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
@ -72,7 +72,7 @@ library
, directory , directory
, filepath , filepath
, hashtables >= 1.2 , hashtables >= 1.2
, megaparsec >=5.0 && < 5.4 , megaparsec >=5.0 && < 6.1
, mtl , mtl
, mtl-compat , mtl-compat
, old-time , old-time
@ -141,6 +141,7 @@ library
Hledger.Utils.Text Hledger.Utils.Text
Hledger.Utils.Tree Hledger.Utils.Tree
Hledger.Utils.UTF8IOCompat Hledger.Utils.UTF8IOCompat
Text.Megaparsec.Compat
other-modules: other-modules:
Paths_hledger_lib Paths_hledger_lib
default-language: Haskell2010 default-language: Haskell2010
@ -168,7 +169,7 @@ test-suite doctests
, directory , directory
, filepath , filepath
, hashtables >= 1.2 , hashtables >= 1.2
, megaparsec >=5.0 && < 5.4 , megaparsec >=5.0 && < 6.1
, mtl , mtl
, mtl-compat , mtl-compat
, old-time , old-time
@ -230,6 +231,7 @@ test-suite doctests
Hledger.Utils.Text Hledger.Utils.Text
Hledger.Utils.Tree Hledger.Utils.Tree
Hledger.Utils.UTF8IOCompat Hledger.Utils.UTF8IOCompat
Text.Megaparsec.Compat
default-language: Haskell2010 default-language: Haskell2010
test-suite hunittests test-suite hunittests
@ -255,7 +257,7 @@ test-suite hunittests
, directory , directory
, filepath , filepath
, hashtables >= 1.2 , hashtables >= 1.2
, megaparsec >=5.0 && < 5.4 , megaparsec >=5.0 && < 6.1
, mtl , mtl
, mtl-compat , mtl-compat
, old-time , old-time
@ -326,4 +328,5 @@ test-suite hunittests
Hledger.Utils.Text Hledger.Utils.Text
Hledger.Utils.Tree Hledger.Utils.Tree
Hledger.Utils.UTF8IOCompat Hledger.Utils.UTF8IOCompat
Text.Megaparsec.Compat
default-language: Haskell2010 default-language: Haskell2010

3
hledger-lib/package.yaml
View File

@ -54,7 +54,7 @@ dependencies:
- directory - directory
- filepath - filepath
- hashtables >= 1.2 - hashtables >= 1.2
- megaparsec >=5.0 && < 5.4 - megaparsec >=5.0 && < 6.1
- mtl - mtl
- mtl-compat - mtl-compat
- old-time - old-time
@ -127,6 +127,7 @@ library:
- Hledger.Utils.Text - Hledger.Utils.Text
- Hledger.Utils.Tree - Hledger.Utils.Tree
- Hledger.Utils.UTF8IOCompat - Hledger.Utils.UTF8IOCompat
- Text.Megaparsec.Compat
# other-modules: # other-modules:
# - Ledger.Parser.Text # - Ledger.Parser.Text
dependencies: dependencies:

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

@ -1,4 +1,4 @@
-- This file has been generated from package.yaml by hpack version 0.17.0. -- This file has been generated from package.yaml by hpack version 0.17.1.
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
@ -72,7 +72,7 @@ executable hledger-ui
, HUnit , HUnit
, microlens >= 0.4 && < 0.5 , microlens >= 0.4 && < 0.5
, microlens-platform >= 0.2.3.1 && < 0.4 , microlens-platform >= 0.2.3.1 && < 0.4
, megaparsec >=5.0 && < 5.4 , megaparsec >=5.0 && < 6.1
, pretty-show >=1.6.4 , pretty-show >=1.6.4
, process >= 1.2 , process >= 1.2
, safe >= 0.2 , safe >= 0.2

2
hledger-ui/package.yaml
View File

@ -63,7 +63,7 @@ executables:
- HUnit - HUnit
- microlens >= 0.4 && < 0.5 - microlens >= 0.4 && < 0.5
- microlens-platform >= 0.2.3.1 && < 0.4 - microlens-platform >= 0.2.3.1 && < 0.4
- megaparsec >=5.0 && < 5.4 - megaparsec >=5.0 && < 6.1
- pretty-show >=1.6.4 - pretty-show >=1.6.4
- process >= 1.2 - process >= 1.2
- safe >= 0.2 - safe >= 0.2

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

@ -1,4 +1,4 @@
-- This file has been generated from package.yaml by hpack version 0.17.0. -- This file has been generated from package.yaml by hpack version 0.17.1.
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
@ -159,7 +159,7 @@ library
, yesod-form , yesod-form
, yesod-static , yesod-static
, json , json
, megaparsec >=5.0 && < 5.4 , megaparsec >=5.0 && < 6.1
, mtl , mtl
if (flag(dev)) || (flag(library-only)) if (flag(dev)) || (flag(library-only))
cpp-options: -DDEVELOPMENT cpp-options: -DDEVELOPMENT

2
hledger-web/package.yaml
View File

@ -119,7 +119,7 @@ library:
- Settings.Development - Settings.Development
- Settings.StaticFiles - Settings.StaticFiles
dependencies: dependencies:
- megaparsec >=5.0 && < 5.4 - megaparsec >=5.0 && < 6.1
- mtl - mtl
when: when:
- condition: (flag(dev)) || (flag(library-only)) - condition: (flag(dev)) || (flag(library-only))

10
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 #-} {-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind #-}
{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, RecordWildCards, TypeOperators, FlexibleContexts, OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, RecordWildCards, TypeOperators, FlexibleContexts, OverloadedStrings #-}
module Hledger.Cli.Add module Hledger.Cli.Add
where where
@ -16,6 +16,7 @@ import Control.Monad.Trans.Class
import Control.Monad.State.Strict (evalState, evalStateT) import Control.Monad.State.Strict (evalState, evalStateT)
import Control.Monad.Trans (liftIO) import Control.Monad.Trans (liftIO)
import Data.Char (toUpper, toLower) import Data.Char (toUpper, toLower)
import Data.Functor.Identity (Identity(..))
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
@ -30,8 +31,7 @@ import System.Console.Haskeline.Completion
import System.Console.Wizard import System.Console.Wizard
import System.Console.Wizard.Haskeline import System.Console.Wizard.Haskeline
import System.IO ( stderr, hPutStr, hPutStrLn ) import System.IO ( stderr, hPutStr, hPutStrLn )
import Text.Megaparsec import Text.Megaparsec.Compat
import Text.Megaparsec.Text
import Text.Printf import Text.Printf
import Hledger import Hledger
@ -187,7 +187,7 @@ dateAndCodeWizard EntryState{..} = do
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) "" $ T.pack $ lowercase s edc = runParser (dateandcodep <* eof) "" $ T.pack $ lowercase s
dateandcodep :: Parser (SmartDate, Text) dateandcodep :: SimpleTextParser (SmartDate, Text)
dateandcodep = do dateandcodep = do
d <- smartdate d <- smartdate
c <- optional codep c <- optional codep
@ -285,7 +285,7 @@ amountAndCommentWizard EntryState{..} = do
"" ""
(T.pack s) (T.pack s)
nodefcommodityj = esJournal{jparsedefaultcommodity=Nothing} nodefcommodityj = esJournal{jparsedefaultcommodity=Nothing}
amountandcommentp :: JournalParser (Amount, Text) amountandcommentp :: JournalParser Identity (Amount, Text)
amountandcommentp = do amountandcommentp = do
a <- amountp a <- amountp
lift (many spacenonewline) lift (many spacenonewline)

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

@ -5,7 +5,7 @@ related utilities used by hledger commands.
-} -}
{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, FlexibleContexts, TypeFamilies #-} {-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, FlexibleContexts, TypeFamilies, OverloadedStrings #-}
module Hledger.Cli.CliOptions ( module Hledger.Cli.CliOptions (
@ -94,7 +94,7 @@ import System.Environment
import System.Exit (exitSuccess) import System.Exit (exitSuccess)
import System.FilePath import System.FilePath
import Test.HUnit import Test.HUnit
import Text.Megaparsec import Text.Megaparsec.Compat
import Hledger import Hledger
import Hledger.Cli.DocFiles import Hledger.Cli.DocFiles
@ -549,7 +549,7 @@ rulesFilePathFromOpts opts = do
widthFromOpts :: CliOpts -> Int widthFromOpts :: CliOpts -> Int
widthFromOpts CliOpts{width_=Nothing, available_width_=w} = w widthFromOpts CliOpts{width_=Nothing, available_width_=w} = w
widthFromOpts CliOpts{width_=Just s} = widthFromOpts CliOpts{width_=Just s} =
case runParser (read `fmap` some digitChar <* eof :: ParsecT Dec String Identity Int) "(unknown)" s of case runParser (read `fmap` some digitChar <* eof :: ParsecT MPErr String Identity Int) "(unknown)" s of
Left e -> usageError $ "could not parse width option: "++show e Left e -> usageError $ "could not parse width option: "++show e
Right w -> w Right w -> w
@ -571,7 +571,7 @@ registerWidthsFromOpts CliOpts{width_=Just s} =
Left e -> usageError $ "could not parse width option: "++show e Left e -> usageError $ "could not parse width option: "++show e
Right ws -> ws Right ws -> ws
where where
registerwidthp :: (Stream s, Char ~ Token s) => ParsecT Dec s m (Int, Maybe Int) registerwidthp :: (Stream s, Char ~ Token s) => ParsecT MPErr s m (Int, Maybe Int)
registerwidthp = do registerwidthp = do
totalwidth <- read `fmap` some digitChar totalwidth <- read `fmap` some digitChar
descwidth <- optional (char ',' >> read `fmap` some digitChar) descwidth <- optional (char ',' >> read `fmap` some digitChar)
@ -665,10 +665,10 @@ isHledgerExeName :: String -> Bool
isHledgerExeName = isRight . parsewith hledgerexenamep . T.pack isHledgerExeName = isRight . parsewith hledgerexenamep . T.pack
where where
hledgerexenamep = do hledgerexenamep = do
_ <- string progname _ <- mptext $ T.pack progname
_ <- char '-' _ <- char '-'
_ <- some (noneOf ".") _ <- some $ noneOf ['.']
optional (string "." >> choice' (map string addonExtensions)) optional (string "." >> choice' (map (mptext . T.pack) addonExtensions))
eof eof
stripAddonExtension :: String -> String stripAddonExtension :: String -> String

4
hledger/hledger.cabal
View File

@ -1,4 +1,4 @@
-- This file has been generated from package.yaml by hpack version 0.17.0. -- This file has been generated from package.yaml by hpack version 0.17.1.
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
@ -106,7 +106,7 @@ library
, mtl , mtl
, mtl-compat , mtl-compat
, old-time , old-time
, megaparsec >=5.0 && < 5.4 , megaparsec >=5.0 && < 6.1
, regex-tdfa , regex-tdfa
, safe >=0.2 , safe >=0.2
, split >=0.1 && <0.3 , split >=0.1 && <0.3

2
hledger/package.yaml
View File

@ -120,7 +120,7 @@ library:
- mtl - mtl
- mtl-compat - mtl-compat
- old-time - old-time
- megaparsec >=5.0 && < 5.4 - megaparsec >=5.0 && < 6.1
- regex-tdfa - regex-tdfa
- safe >=0.2 - safe >=0.2
- split >=0.1 && <0.3 - split >=0.1 && <0.3

6
stack.yaml
View File

@ -3,7 +3,11 @@
resolver: lts-8.23 resolver: lts-8.23
extra-deps: [] extra-deps:
[]
#megaparsec >=6:
#- megaparsec-6.0.0
#- parser-combinators-0.1.0
packages: packages:
- hledger-lib - hledger-lib