diff --git a/bin/hledger-check.hs b/bin/hledger-check.hs index ec1045213..0fdd9ad9c 100755 --- a/bin/hledger-check.hs +++ b/bin/hledger-check.hs @@ -98,8 +98,7 @@ import qualified Hledger.Utils.Parse as H import Options.Applicative import System.Exit (exitFailure) import System.FilePath (FilePath) -import qualified Text.Megaparsec as P -import qualified Text.Megaparsec.Text as P +import qualified Text.Megaparsec.Compat as P main :: IO () main = do @@ -391,7 +390,7 @@ args = info (helper <*> parser) $ mconcat -- Turn a Parsec parser into a ReadM parser that also returns the -- input. - readParsec :: H.JournalStateParser ReadM a -> ReadM (String, a) + readParsec :: H.JournalParser ReadM a -> ReadM (String, a) readParsec p = do s <- str parsed <- P.runParserT (runStateT p H.nulljournal) "" (pack s) @@ -418,7 +417,7 @@ data Predicate deriving (Eq, Ord, Show) -- | 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 predparensp = P.char '(' *> spaces *> predicatep <* spaces <* P.char ')' 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) -- | 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. valuep = valueamountp <|> valueaccountnestedp <|> valueaccountp where valueamountp = Amount <$> H.amountp diff --git a/hledger-lib/Hledger/Data/Dates.hs b/hledger-lib/Hledger/Data/Dates.hs index 04500d3d9..6ce584654 100644 --- a/hledger-lib/Hledger/Data/Dates.hs +++ b/hledger-lib/Hledger/Data/Dates.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-| Date parsing and utilities for hledger. @@ -86,8 +87,7 @@ import Data.Time.Calendar.OrdinalDate import Data.Time.Clock import Data.Time.LocalTime import Safe (headMay, lastMay, readMay) -import Text.Megaparsec -import Text.Megaparsec.Text +import Text.Megaparsec.Compat import Text.Printf 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 -- 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) maybePeriod :: Day -> Text -> Maybe (Interval,DateSpan) @@ -316,13 +316,13 @@ fixSmartDateStr :: Day -> Text -> String fixSmartDateStr d s = either (\e->error' $ printf "could not parse date %s %s" (show s) (show e)) id - $ (fixSmartDateStrEither d s :: Either (ParseError Char Dec) String) + $ (fixSmartDateStrEither d s :: Either (ParseError Char MPErr) String) -- | 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' :: 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 Right sd -> Right $ fixSmartDate d sd 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). Assumes any text in the parse stream has been lowercased. -} -smartdate :: Parser SmartDate +smartdate :: SimpleTextParser SmartDate smartdate = do -- XXX maybe obscures date errors ? see ledgerdate (y,m,d) <- choice' [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing] return (y,m,d) -- | Like smartdate, but there must be nothing other than whitespace after the date. -smartdateonly :: Parser SmartDate +smartdateonly :: SimpleTextParser SmartDate smartdateonly = do d <- smartdate 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 failIfInvalidDay s = unless (validDay s) $ fail $ "bad day number: " ++ s -yyyymmdd :: Parser SmartDate +yyyymmdd :: SimpleTextParser SmartDate yyyymmdd = do y <- count 4 digitChar m <- count 2 digitChar @@ -588,7 +588,7 @@ yyyymmdd = do failIfInvalidDay d return (y,m,d) -ymd :: Parser SmartDate +ymd :: SimpleTextParser SmartDate ymd = do y <- some digitChar failIfInvalidYear y @@ -600,7 +600,7 @@ ymd = do failIfInvalidDay d return $ (y,m,d) -ym :: Parser SmartDate +ym :: SimpleTextParser SmartDate ym = do y <- some digitChar failIfInvalidYear y @@ -609,19 +609,19 @@ ym = do failIfInvalidMonth m return (y,m,"") -y :: Parser SmartDate +y :: SimpleTextParser SmartDate y = do y <- some digitChar failIfInvalidYear y return (y,"","") -d :: Parser SmartDate +d :: SimpleTextParser SmartDate d = do d <- some digitChar failIfInvalidDay d return ("","",d) -md :: Parser SmartDate +md :: SimpleTextParser SmartDate md = do m <- some digitChar 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"] -- weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"] -monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months -monIndex s = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs +#if MIN_VERSION_megaparsec(6,0,0) +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 m <- choice $ map (try . string) months let i = monthIndex m return ("",show i,"") -mon :: Parser SmartDate +mon :: SimpleTextParser SmartDate mon = do m <- choice $ map (try . string) monthabbrevs let i = monIndex m return ("",show i,"") -today,yesterday,tomorrow :: Parser SmartDate +today,yesterday,tomorrow :: SimpleTextParser SmartDate today = string "today" >> return ("","","today") yesterday = string "yesterday" >> return ("","","yesterday") tomorrow = string "tomorrow" >> return ("","","tomorrow") -lastthisnextthing :: Parser SmartDate +lastthisnextthing :: SimpleTextParser SmartDate lastthisnextthing = do - r <- choice [ - string "last" - ,string "this" - ,string "next" + r <- choice $ map mptext [ + "last" + ,"this" + ,"next" ] many spacenonewline -- make the space optional for easier scripting - p <- choice [ - string "day" - ,string "week" - ,string "month" - ,string "quarter" - ,string "year" + p <- choice $ map mptext [ + "day" + ,"week" + ,"month" + ,"quarter" + ,"year" ] -- XXX support these in fixSmartDate -- ++ (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" -- Right (NoInterval,DateSpan 2008/08/01-2008/09/30) -- >>> p "aug to oct" @@ -688,7 +694,7 @@ lastthisnextthing = do -- Right (Days 1,DateSpan 2008/08/01-) -- >>> p "every week to 2009" -- Right (Weeks 1,DateSpan -2008/12/31) -periodexpr :: Day -> Parser (Interval, DateSpan) +periodexpr :: Day -> SimpleTextParser (Interval, DateSpan) periodexpr rdate = choice $ map try [ intervalanddateperiodexpr rdate, intervalperiodexpr, @@ -696,7 +702,7 @@ periodexpr rdate = choice $ map try [ (return (NoInterval,DateSpan Nothing Nothing)) ] -intervalanddateperiodexpr :: Day -> Parser (Interval, DateSpan) +intervalanddateperiodexpr :: Day -> SimpleTextParser (Interval, DateSpan) intervalanddateperiodexpr rdate = do many spacenonewline i <- reportinginterval @@ -704,20 +710,20 @@ intervalanddateperiodexpr rdate = do s <- periodexprdatespan rdate return (i,s) -intervalperiodexpr :: Parser (Interval, DateSpan) +intervalperiodexpr :: SimpleTextParser (Interval, DateSpan) intervalperiodexpr = do many spacenonewline i <- reportinginterval return (i, DateSpan Nothing Nothing) -dateperiodexpr :: Day -> Parser (Interval, DateSpan) +dateperiodexpr :: Day -> SimpleTextParser (Interval, DateSpan) dateperiodexpr rdate = do many spacenonewline s <- periodexprdatespan rdate return (NoInterval, s) -- Parse a reporting interval. -reportinginterval :: Parser Interval +reportinginterval :: SimpleTextParser Interval reportinginterval = choice' [ tryinterval "day" "daily" Days, tryinterval "week" "weekly" Weeks, @@ -757,25 +763,28 @@ reportinginterval = choice' [ thsuffix = choice' $ map string ["st","nd","rd","th"] -- 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 = - choice' [ - do string compact - return $ intcons 1, - do string "every" - many spacenonewline - string singular - return $ intcons 1, - do string "every" - many spacenonewline - n <- fmap read $ some digitChar - many spacenonewline - string plural - return $ intcons n - ] - where plural = singular ++ "s" + choice' [ + do mptext compact' + return $ intcons 1, + do mptext "every" + many spacenonewline + mptext singular' + return $ intcons 1, + do mptext "every" + many spacenonewline + n <- fmap read $ some digitChar + many spacenonewline + mptext plural' + return $ intcons n + ] + 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 [ doubledatespan rdate, fromdatespan rdate, @@ -783,7 +792,7 @@ periodexprdatespan rdate = choice $ map try [ justdatespan rdate ] -doubledatespan :: Day -> Parser DateSpan +doubledatespan :: Day -> SimpleTextParser DateSpan doubledatespan rdate = do optional (string "from" >> many spacenonewline) b <- smartdate @@ -792,7 +801,7 @@ doubledatespan rdate = do e <- smartdate return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e) -fromdatespan :: Day -> Parser DateSpan +fromdatespan :: Day -> SimpleTextParser DateSpan fromdatespan rdate = do b <- choice [ do @@ -806,13 +815,13 @@ fromdatespan rdate = do ] return $ DateSpan (Just $ fixSmartDate rdate b) Nothing -todatespan :: Day -> Parser DateSpan +todatespan :: Day -> SimpleTextParser DateSpan todatespan rdate = do choice [string "to", string "-"] >> many spacenonewline e <- smartdate return $ DateSpan Nothing (Just $ fixSmartDate rdate e) -justdatespan :: Day -> Parser DateSpan +justdatespan :: Day -> SimpleTextParser DateSpan justdatespan rdate = do optional (string "in" >> many spacenonewline) d <- smartdate diff --git a/hledger-lib/Hledger/Data/StringFormat.hs b/hledger-lib/Hledger/Data/StringFormat.hs index 7d63cb045..556dc6505 100644 --- a/hledger-lib/Hledger/Data/StringFormat.hs +++ b/hledger-lib/Hledger/Data/StringFormat.hs @@ -19,9 +19,9 @@ import Numeric import Data.Char (isPrint) import Data.Maybe import Test.HUnit -import Text.Megaparsec -import Text.Megaparsec.String +import Text.Megaparsec.Compat +import Hledger.Utils.Parse import Hledger.Utils.String (formatString) -- | 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 -stringformatp :: Parser StringFormat +stringformatp :: SimpleStringParser StringFormat stringformatp = do alignspec <- optional (try $ char '%' >> oneOf "^_,") let constructor = @@ -97,10 +97,10 @@ stringformatp = do _ -> defaultStringFormatStyle constructor <$> many componentp -componentp :: Parser StringFormatComponent +componentp :: SimpleStringParser StringFormatComponent componentp = formatliteralp <|> formatfieldp -formatliteralp :: Parser StringFormatComponent +formatliteralp :: SimpleStringParser StringFormatComponent formatliteralp = do s <- some c return $ FormatLiteral s @@ -109,7 +109,7 @@ formatliteralp = do c = (satisfy isPrintableButNotPercentage "printable character") <|> try (string "%%" >> return '%') -formatfieldp :: Parser StringFormatComponent +formatfieldp :: SimpleStringParser StringFormatComponent formatfieldp = do char '%' leftJustified <- optional (char '-') @@ -124,7 +124,7 @@ formatfieldp = do Just text -> Just m where ((m,_):_) = readDec text _ -> Nothing -fieldp :: Parser ReportItemField +fieldp :: SimpleStringParser ReportItemField fieldp = do try (string "account" >> return AccountField) <|> try (string "depth_spacer" >> return DepthSpacerField) diff --git a/hledger-lib/Hledger/Query.hs b/hledger-lib/Hledger/Query.hs index 9c3bb9e2b..2f032cf26 100644 --- a/hledger-lib/Hledger/Query.hs +++ b/hledger-lib/Hledger/Query.hs @@ -1,7 +1,7 @@ {-| 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 Safe (readDef, headDef) import Test.HUnit -import Text.Megaparsec -import Text.Megaparsec.Text +import Text.Megaparsec.Compat import Hledger.Utils hiding (words') import Hledger.Data.Types @@ -185,23 +184,23 @@ tests_parseQuery = [ words'' :: [T.Text] -> T.Text -> [T.Text] words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- XXX where - maybeprefixedquotedphrases :: Parser [T.Text] + maybeprefixedquotedphrases :: SimpleTextParser [T.Text] maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, singleQuotedPattern, doubleQuotedPattern, pattern] `sepBy` some spacenonewline - prefixedQuotedPattern :: Parser T.Text + prefixedQuotedPattern :: SimpleTextParser T.Text prefixedQuotedPattern = do - not' <- fromMaybe "" `fmap` (optional $ string "not:") - let allowednexts | null not' = prefixes - | otherwise = prefixes ++ [""] - next <- fmap T.pack $ choice' $ map (string . T.unpack) allowednexts + not' <- fromMaybe "" `fmap` (optional $ mptext "not:") + let allowednexts | T.null not' = prefixes + | otherwise = prefixes ++ [""] + next <- choice' $ map mptext allowednexts let prefix :: T.Text - prefix = T.pack not' <> next + prefix = not' <> next p <- singleQuotedPattern <|> doubleQuotedPattern return $ prefix <> stripquotes p - singleQuotedPattern :: Parser T.Text + singleQuotedPattern :: SimpleTextParser T.Text 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 - pattern :: Parser T.Text + pattern :: SimpleTextParser T.Text pattern = fmap T.pack $ many (noneOf (" \n\r" :: [Char])) tests_words'' = [ diff --git a/hledger-lib/Hledger/Read/Common.hs b/hledger-lib/Hledger/Read/Common.hs index 86312346b..d099a3971 100644 --- a/hledger-lib/Hledger/Read/Common.hs +++ b/hledger-lib/Hledger/Read/Common.hs @@ -36,8 +36,7 @@ import Data.Time.Calendar import Data.Time.LocalTime import Safe import System.Time (getClockTime) -import Text.Megaparsec hiding (parse,State) -import Text.Megaparsec.Text +import Text.Megaparsec.Compat import Hledger.Data import Hledger.Utils @@ -47,12 +46,12 @@ import Hledger.Utils --- * parsing utils -- | 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 rtp = runTextParser -- | 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 rjp = runJournalParser @@ -89,7 +88,7 @@ parseAndFinaliseJournal parser assrt f txt = do Left e -> throwError 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 t <- liftIO getClockTime y <- liftIO getCurrentYear @@ -100,32 +99,32 @@ parseAndFinaliseJournal' parser assrt f txt = do Left e -> throwError e Left e -> throwError $ parseErrorPretty e -setYear :: Year -> JournalStateParser m () +setYear :: Year -> JournalParser m () setYear y = modify' (\j -> j{jparsedefaultyear=Just y}) -getYear :: JournalStateParser m (Maybe Year) +getYear :: JournalParser m (Maybe Year) getYear = fmap jparsedefaultyear get -setDefaultCommodityAndStyle :: (CommoditySymbol,AmountStyle) -> JournalStateParser m () +setDefaultCommodityAndStyle :: (CommoditySymbol,AmountStyle) -> JournalParser m () setDefaultCommodityAndStyle cs = modify' (\j -> j{jparsedefaultcommodity=Just cs}) -getDefaultCommodityAndStyle :: JournalStateParser m (Maybe (CommoditySymbol,AmountStyle)) +getDefaultCommodityAndStyle :: JournalParser m (Maybe (CommoditySymbol,AmountStyle)) getDefaultCommodityAndStyle = jparsedefaultcommodity `fmap` get -pushAccount :: AccountName -> JournalStateParser m () +pushAccount :: AccountName -> JournalParser m () 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}) -popParentAccount :: JournalStateParser m () +popParentAccount :: JournalParser m () popParentAccount = do j <- get case jparseparentaccounts j of [] -> unexpected (Tokens ('E' :| "nd of apply account block with no beginning")) (_:rest) -> put j{jparseparentaccounts=rest} -getParentAccount :: JournalStateParser m AccountName +getParentAccount :: JournalParser m AccountName getParentAccount = fmap (concatAccountNames . reverse . jparseparentaccounts) get addAccountAlias :: MonadState Journal m => AccountAlias -> m () @@ -181,7 +180,7 @@ statusp = codep :: TextParser m String codep = try (do { some spacenonewline; char '(' "codep"; anyChar `manyTill` char ')' } ) <|> return "" -descriptionp :: JournalStateParser m String +descriptionp :: JournalParser m String descriptionp = many (noneOf (";\n" :: [Char])) --- ** dates @@ -190,7 +189,7 @@ descriptionp = many (noneOf (";\n" :: [Char])) -- Hyphen (-) and period (.) are also allowed as separators. -- The year may be omitted if a default year has been set. -- Leading zeroes may be omitted. -datep :: JournalStateParser m Day +datep :: JournalParser m Day datep = do -- hacky: try to ensure precise errors for invalid dates -- XXX reported error position is not too good @@ -220,7 +219,7 @@ datep = do -- Seconds are optional. -- The timezone is optional and ignored (the time is always interpreted as a local time). -- Leading zeroes may be omitted (except in a timezone). -datetimep :: JournalStateParser m LocalTime +datetimep :: JournalParser m LocalTime datetimep = do day <- datep lift $ some spacenonewline @@ -248,7 +247,7 @@ datetimep = do -- return $ localTimeToUTC tz' $ 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 char '=' -- kludgy way to use primary date for default year @@ -274,7 +273,7 @@ secondarydatep primarydate = do --- ** account names -- | 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 parent <- getParentAccount aliases <- getAccountAliases @@ -313,7 +312,7 @@ accountnamep = do -- | Parse whitespace then an amount, with an optional left or right -- currency symbol and optional price, or return the special -- "missing" marker amount. -spaceandamountormissingp :: Monad m => JournalStateParser m MixedAmount +spaceandamountormissingp :: Monad m => JournalParser m MixedAmount spaceandamountormissingp = try (do lift $ some spacenonewline @@ -337,7 +336,7 @@ test_spaceandamountormissingp = do -- | Parse a single-commodity amount, with optional symbol on the left or -- right, optional unit or total price, and optional (ignored) -- 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 #ifdef TESTS @@ -377,7 +376,7 @@ multiplierp = do return $ case multiplier of Just '*' -> True _ -> False -leftsymbolamountp :: Monad m => JournalStateParser m Amount +leftsymbolamountp :: Monad m => JournalParser m Amount leftsymbolamountp = do sign <- lift signp m <- lift multiplierp @@ -390,7 +389,7 @@ leftsymbolamountp = do return $ applysign $ Amount c q p s m "left-symbol amount" -rightsymbolamountp :: Monad m => JournalStateParser m Amount +rightsymbolamountp :: Monad m => JournalParser m Amount rightsymbolamountp = do m <- lift multiplierp (q,prec,mdec,mgrps) <- lift numberp @@ -401,7 +400,7 @@ rightsymbolamountp = do return $ Amount c q p s m "right-symbol amount" -nosymbolamountp :: Monad m => JournalStateParser m Amount +nosymbolamountp :: Monad m => JournalParser m Amount nosymbolamountp = do m <- lift multiplierp (q,prec,mdec,mgrps) <- lift numberp @@ -427,7 +426,7 @@ quotedcommoditysymbolp = do simplecommoditysymbolp :: TextParser m CommoditySymbol simplecommoditysymbolp = T.pack <$> some (noneOf nonsimplecommoditychars) -priceamountp :: Monad m => JournalStateParser m Price +priceamountp :: Monad m => JournalParser m Price priceamountp = try (do lift (many spacenonewline) @@ -443,7 +442,7 @@ priceamountp = return $ UnitPrice a)) <|> return NoPrice -partialbalanceassertionp :: Monad m => JournalStateParser m (Maybe Amount) +partialbalanceassertionp :: Monad m => JournalParser m (Maybe Amount) partialbalanceassertionp = try (do lift (many spacenonewline) @@ -464,7 +463,7 @@ partialbalanceassertionp = -- <|> return Nothing -- 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 = try (do lift (many spacenonewline) @@ -564,7 +563,7 @@ numberp = do --- ** comments -multilinecommentp :: JournalStateParser m () +multilinecommentp :: JournalParser m () multilinecommentp = do string "comment" >> lift (many spacenonewline) >> newline go @@ -573,13 +572,13 @@ multilinecommentp = do <|> (anyLine >> go) anyLine = anyChar `manyTill` newline -emptyorcommentlinep :: JournalStateParser m () +emptyorcommentlinep :: JournalParser m () emptyorcommentlinep = do lift (many spacenonewline) >> (commentp <|> (lift (many spacenonewline) >> newline >> return "")) return () -- | Parse a possibly multi-line comment following a semicolon. -followingcommentp :: JournalStateParser m Text +followingcommentp :: JournalParser m Text followingcommentp = -- ptrace "followingcommentp" do samelinecomment <- lift (many spacenonewline) >> (try semicoloncommentp <|> (newline >> return "")) @@ -641,16 +640,16 @@ followingcommentandtagsp mdefdate = do return (comment, tags, mdate, mdate2) -commentp :: JournalStateParser m Text +commentp :: JournalParser m Text commentp = commentStartingWithp commentchars commentchars :: [Char] commentchars = "#;*" -semicoloncommentp :: JournalStateParser m Text +semicoloncommentp :: JournalParser m Text semicoloncommentp = commentStartingWithp ";" -commentStartingWithp :: [Char] -> JournalStateParser m Text +commentStartingWithp :: [Char] -> JournalParser m Text commentStartingWithp cs = do -- ptrace "commentStartingWith" oneOf cs @@ -681,7 +680,7 @@ commentTags s = Left _ -> [] -- shouldn't happen -- | Parse all tags found in a string. -tagsp :: Parser [Tag] +tagsp :: SimpleTextParser [Tag] tagsp = -- do -- pdbg 0 $ "tagsp" many (try (nontagp >> tagp)) @@ -690,7 +689,7 @@ tagsp = -- do -- -- >>> rtp nontagp "\na b:, \nd:e, f" -- Right "\na " -nontagp :: Parser String +nontagp :: SimpleTextParser String nontagp = -- do -- pdbg 0 "nontagp" -- anyChar `manyTill` (lookAhead (try (tagorbracketeddatetagsp Nothing >> return ()) <|> eof)) @@ -704,7 +703,7 @@ nontagp = -- do -- >>> rtp tagp "a:b b , c AuxDate: 4/2" -- Right ("a","b b") -- -tagp :: Parser Tag +tagp :: SimpleTextParser Tag tagp = do -- pdbg 0 "tagp" n <- tagnamep @@ -714,7 +713,7 @@ tagp = do -- | -- >>> rtp tagnamep "a:" -- Right "a" -tagnamep :: Parser Text +tagnamep :: SimpleTextParser Text tagnamep = -- do -- pdbg 0 "tagnamep" T.pack <$> some (noneOf (": \t\n" :: [Char])) <* char ':' @@ -761,13 +760,13 @@ datetagp :: Monad m => Maybe Day -> ErroringJournalParser m (TagName,Day) datetagp mdefdate = do -- pdbg 0 "datetagp" string "date" - n <- T.pack . fromMaybe "" <$> optional (string "2") + n <- fromMaybe "" <$> optional (mptext "2") char ':' startpos <- getPosition v <- lift tagvaluep -- re-parse value as a date. j <- get - let ep :: Either (ParseError Char Dec) Day + let ep :: Either (ParseError Char MPErr) Day ep = parseWithState' j{jparsedefaultyear=first3.toGregorian <$> mdefdate} -- 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 -- re-parse as dates and throw any errors j <- get - let ep :: Either (ParseError Char Dec) (Maybe Day, Maybe Day) + let ep :: Either (ParseError Char MPErr) (Maybe Day, Maybe Day) ep = parseWithState' j{jparsedefaultyear=first3.toGregorian <$> mdefdate} (do diff --git a/hledger-lib/Hledger/Read/CsvReader.hs b/hledger-lib/Hledger/Read/CsvReader.hs index 3ec9c7a4b..b72dc5d3a 100644 --- a/hledger-lib/Hledger/Read/CsvReader.hs +++ b/hledger-lib/Hledger/Read/CsvReader.hs @@ -38,7 +38,6 @@ import Data.Char (toLower, isDigit, isSpace) import Data.List.Compat import Data.Maybe import Data.Ord -import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T @@ -54,8 +53,7 @@ import System.Directory (doesFileExist) import System.FilePath import Test.HUnit hiding (State) import Text.CSV (parseCSV, CSV) -import Text.Megaparsec hiding (parse, State) -import Text.Megaparsec.Text +import Text.Megaparsec.Compat hiding (parse) import qualified Text.Parsec as Parsec import Text.Printf (printf) @@ -133,13 +131,15 @@ readJournalFromCsv mrulesfile csvfile csvdata = let -- convert CSV records to transactions txns = snd $ mapAccumL - (\pos r -> (pos, - transactionFromCsvRecord - (let SourcePos name line col = pos in - SourcePos name (unsafePos $ unPos line + 1) col) - rules - r)) - (initialPos parsecfilename) records + (\pos r -> + let + SourcePos name line col = pos + line' = (mpMkPos . (+1) . mpUnPos) line + pos' = SourcePos name line' col + in + (pos, transactionFromCsvRecord pos' rules r) + ) + (initialPos parsecfilename) records -- Ensure transactions are ordered chronologically. -- First, reverse them to get same-date transactions ordered chronologically, @@ -312,7 +312,7 @@ data CsvRules = CsvRules { rconditionalblocks :: [ConditionalBlock] } deriving (Show, Eq) -type CsvRulesParser a = StateT CsvRules Parser a +type CsvRulesParser a = StateT CsvRules SimpleTextParser a type DirectiveName = String type CsvFieldName = String @@ -390,14 +390,11 @@ parseAndValidateCsvRules rulesfile s = do Right r -> do r_ <- liftIO $ runExceptT $ validateRules r ExceptT $ case r_ of - Left e -> return $ Left $ parseErrorPretty $ toParseError e + Left s -> return $ Left $ parseErrorPretty $ mpMkParseError rulesfile s 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. -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 (evalStateT rulesp rules) rulesfile s @@ -449,10 +446,10 @@ commentcharp = oneOf (";#*" :: [Char]) directivep :: CsvRulesParser (DirectiveName, String) directivep = (do 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) <|> (optional (char ':') >> lift (many spacenonewline) >> lift eolof >> return "") - return (d,v) + return (d, v) ) "directive" directives = @@ -505,7 +502,9 @@ fieldassignmentp = do "field assignment" 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. -- Names must precede any other name they contain, for the parser @@ -565,7 +564,7 @@ recordmatcherp = do "record matcher" matchoperatorp :: CsvRulesParser String -matchoperatorp = choiceInState $ map string +matchoperatorp = fmap T.unpack $ choiceInState $ map mptext ["~" -- ,"!~" -- ,"=" diff --git a/hledger-lib/Hledger/Read/JournalReader.hs b/hledger-lib/Hledger/Read/JournalReader.hs index f20b2d3ad..e8a2f6c8e 100644 --- a/hledger-lib/Hledger/Read/JournalReader.hs +++ b/hledger-lib/Hledger/Read/JournalReader.hs @@ -90,7 +90,7 @@ import Test.HUnit import Test.Framework import Text.Megaparsec.Error #endif -import Text.Megaparsec hiding (parse) +import Text.Megaparsec.Compat hiding (parse) import Text.Printf import System.FilePath @@ -187,7 +187,7 @@ includedirectivep = do let curdir = takeDirectory (sourceName parentpos) filepath <- expandPath curdir filename `orRethrowIOError` (show parentpos ++ " locating " ++ filename) txt <- readFileAnyLineEnding filepath `orRethrowIOError` (show parentpos ++ " reading " ++ filepath) - (ej1::Either (ParseError Char Dec) ParsedJournal) <- + (ej1::Either (ParseError Char MPErr) ParsedJournal) <- runParserT (evalStateT (choiceInState @@ -227,7 +227,7 @@ orRethrowIOError io msg = (Right <$> io) `C.catch` \(e::C.IOException) -> return $ Left $ printf "%s:\n%s" msg (show e) -accountdirectivep :: JournalStateParser m () +accountdirectivep :: JournalParser m () accountdirectivep = do string "account" lift (some spacenonewline) @@ -237,7 +237,7 @@ accountdirectivep = do modify' (\j -> j{jaccounts = acct : jaccounts j}) -indentedlinep :: JournalStateParser m String +indentedlinep :: JournalParser m String indentedlinep = lift (some spacenonewline) >> (rstrip <$> lift restofline) -- | 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 ; blah\n" -commoditydirectiveonelinep :: Monad m => JournalStateParser m () +commoditydirectiveonelinep :: Monad m => JournalParser m () commoditydirectiveonelinep = do string "commodity" lift (some spacenonewline) @@ -292,7 +292,7 @@ formatdirectivep expectedsym = do else parserErrorAt pos $ printf "commodity directive symbol \"%s\" and format directive symbol \"%s\" should be the same" expectedsym acommodity -applyaccountdirectivep :: JournalStateParser m () +applyaccountdirectivep :: JournalParser m () applyaccountdirectivep = do string "apply" >> lift (some spacenonewline) >> string "account" lift (some spacenonewline) @@ -300,12 +300,12 @@ applyaccountdirectivep = do newline pushParentAccount parent -endapplyaccountdirectivep :: JournalStateParser m () +endapplyaccountdirectivep :: JournalParser m () endapplyaccountdirectivep = do string "end" >> lift (some spacenonewline) >> string "apply" >> lift (some spacenonewline) >> string "account" popParentAccount -aliasdirectivep :: JournalStateParser m () +aliasdirectivep :: JournalParser m () aliasdirectivep = do string "alias" lift (some spacenonewline) @@ -336,12 +336,12 @@ regexaliasp = do repl <- rstrip <$> anyChar `manyTill` eolof return $ RegexAlias re repl -endaliasesdirectivep :: JournalStateParser m () +endaliasesdirectivep :: JournalParser m () endaliasesdirectivep = do string "end aliases" clearAccountAliases -tagdirectivep :: JournalStateParser m () +tagdirectivep :: JournalParser m () tagdirectivep = do string "tag" "tag directive" lift (some spacenonewline) @@ -349,13 +349,13 @@ tagdirectivep = do lift restofline return () -endtagdirectivep :: JournalStateParser m () +endtagdirectivep :: JournalParser m () endtagdirectivep = do (string "end tag" <|> string "pop") "end tag or pop directive" lift restofline return () -defaultyeardirectivep :: JournalStateParser m () +defaultyeardirectivep :: JournalParser m () defaultyeardirectivep = do char 'Y' "default year" lift (many spacenonewline) @@ -364,7 +364,7 @@ defaultyeardirectivep = do failIfInvalidYear y setYear y' -defaultcommoditydirectivep :: Monad m => JournalStateParser m () +defaultcommoditydirectivep :: Monad m => JournalParser m () defaultcommoditydirectivep = do char 'D' "default commodity" lift (some spacenonewline) @@ -372,7 +372,7 @@ defaultcommoditydirectivep = do lift restofline setDefaultCommodityAndStyle (acommodity, astyle) -marketpricedirectivep :: Monad m => JournalStateParser m MarketPrice +marketpricedirectivep :: Monad m => JournalParser m MarketPrice marketpricedirectivep = do char 'P' "market price" lift (many spacenonewline) @@ -384,7 +384,7 @@ marketpricedirectivep = do lift restofline return $ MarketPrice date symbol price -ignoredpricecommoditydirectivep :: JournalStateParser m () +ignoredpricecommoditydirectivep :: JournalParser m () ignoredpricecommoditydirectivep = do char 'N' "ignored-price commodity" lift (some spacenonewline) @@ -392,7 +392,7 @@ ignoredpricecommoditydirectivep = do lift restofline return () -commodityconversiondirectivep :: Monad m => JournalStateParser m () +commodityconversiondirectivep :: Monad m => JournalParser m () commodityconversiondirectivep = do char 'C' "commodity conversion" lift (some spacenonewline) diff --git a/hledger-lib/Hledger/Read/TimeclockReader.hs b/hledger-lib/Hledger/Read/TimeclockReader.hs index 412b71735..3766b0982 100644 --- a/hledger-lib/Hledger/Read/TimeclockReader.hs +++ b/hledger-lib/Hledger/Read/TimeclockReader.hs @@ -60,7 +60,7 @@ import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import Test.HUnit -import Text.Megaparsec hiding (parse) +import Text.Megaparsec.Compat hiding (parse) import Hledger.Data -- XXX too much reuse ? @@ -105,7 +105,7 @@ timeclockfilep = do many timeclockitemp ] "timeclock entry, or default year or historical price directive" -- | Parse a timeclock entry. -timeclockentryp :: JournalStateParser m TimeclockEntry +timeclockentryp :: JournalParser m TimeclockEntry timeclockentryp = do sourcepos <- genericSourcePos <$> lift getPosition code <- oneOf ("bhioO" :: [Char]) diff --git a/hledger-lib/Hledger/Read/TimedotReader.hs b/hledger-lib/Hledger/Read/TimedotReader.hs index cc661ebf5..756e97d1d 100644 --- a/hledger-lib/Hledger/Read/TimedotReader.hs +++ b/hledger-lib/Hledger/Read/TimedotReader.hs @@ -42,7 +42,7 @@ import Data.List (foldl') import Data.Maybe import Data.Text (Text) import Test.HUnit -import Text.Megaparsec hiding (parse) +import Text.Megaparsec.Compat hiding (parse) import Hledger.Data import Hledger.Read.Common @@ -66,12 +66,12 @@ reader = Reader parse :: Maybe FilePath -> Bool -> FilePath -> Text -> ExceptT String IO Journal parse _ = parseAndFinaliseJournal timedotfilep -timedotfilep :: JournalStateParser m ParsedJournal +timedotfilep :: JournalParser m ParsedJournal timedotfilep = do many timedotfileitemp eof get where - timedotfileitemp :: JournalStateParser m () + timedotfileitemp :: JournalParser m () timedotfileitemp = do ptrace "timedotfileitemp" choice [ @@ -89,7 +89,7 @@ addTransactions ts j = foldl' (flip ($)) j (map addTransaction ts) -- biz.research . -- inc.client1 .... .... .... .... .... .... -- @ -timedotdayp :: JournalStateParser m [Transaction] +timedotdayp :: JournalParser m [Transaction] timedotdayp = do ptrace " timedotdayp" d <- datep <* lift eolof @@ -101,7 +101,7 @@ timedotdayp = do -- @ -- fos.haskell .... .. -- @ -timedotentryp :: JournalStateParser m Transaction +timedotentryp :: JournalParser m Transaction timedotentryp = do ptrace " timedotentryp" pos <- genericSourcePos <$> getPosition @@ -125,14 +125,14 @@ timedotentryp = do } return t -timedotdurationp :: JournalStateParser m Quantity +timedotdurationp :: JournalParser m Quantity timedotdurationp = try timedotnumberp <|> timedotdotsp -- | Parse a duration written as a decimal number of hours (optionally followed by the letter h). -- @ -- 1.5h -- @ -timedotnumberp :: JournalStateParser m Quantity +timedotnumberp :: JournalParser m Quantity timedotnumberp = do (q, _, _, _) <- lift numberp lift (many spacenonewline) @@ -144,7 +144,7 @@ timedotnumberp = do -- @ -- .... .. -- @ -timedotdotsp :: JournalStateParser m Quantity +timedotdotsp :: JournalParser m Quantity timedotdotsp = do dots <- filter (not.isSpace) <$> many (oneOf (". " :: [Char])) return $ (/4) $ fromIntegral $ length dots diff --git a/hledger-lib/Hledger/Utils/Parse.hs b/hledger-lib/Hledger/Utils/Parse.hs index 75fa0fc82..f5041bab6 100644 --- a/hledger-lib/Hledger/Utils/Parse.hs +++ b/hledger-lib/Hledger/Utils/Parse.hs @@ -1,38 +1,42 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} +{-# LANGUAGE CPP, TypeFamilies #-} module Hledger.Utils.Parse where import Control.Monad.Except +import Control.Monad.State.Strict (StateT, evalStateT) import Data.Char +import Data.Functor.Identity (Identity(..)) import Data.List import Data.Text (Text) -import Text.Megaparsec hiding (State) -import Data.Functor.Identity (Identity(..)) +import Text.Megaparsec.Compat import Text.Printf -import Control.Monad.State.Strict (StateT, evalStateT) - import Hledger.Data.Types import Hledger.Utils.UTF8IOCompat (error') --- | A parser of strict text with generic user state, monad and return type. -type TextParser m a = ParsecT Dec Text m a +-- | A parser of string to some type. +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. -type ErroringJournalParser m a = StateT Journal (ParsecT Dec Text (ExceptT String m)) a +-- | A parser of text in some monad, with a journal as state. +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. -- Consumes no input if all choices fail. 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. -- Consumes no input if all choices fail. -choiceInState :: [StateT s (ParsecT Dec Text m) a] -> StateT s (ParsecT Dec Text m) a -choiceInState = choice . map Text.Megaparsec.try +choiceInState :: [StateT s (ParsecT MPErr Text m) a] -> StateT s (ParsecT MPErr Text m) a +choiceInState = choice . map try parsewith :: Parsec e Text a -> Text -> Either (ParseError Char e) a parsewith p = runParser p "" @@ -40,10 +44,15 @@ parsewith p = runParser p "" parsewithString :: Parsec e String a -> String -> Either (ParseError Char e) a 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' :: (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 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 = 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") restofline :: TextParser m String diff --git a/hledger-lib/Hledger/Utils/String.hs b/hledger-lib/Hledger/Utils/String.hs index f86e31379..2265e7be2 100644 --- a/hledger-lib/Hledger/Utils/String.hs +++ b/hledger-lib/Hledger/Utils/String.hs @@ -49,7 +49,7 @@ module Hledger.Utils.String ( import Data.Char import Data.List -import Text.Megaparsec +import Text.Megaparsec.Compat import Text.Printf (printf) import Hledger.Utils.Parse diff --git a/hledger-lib/Text/Megaparsec/Compat.hs b/hledger-lib/Text/Megaparsec/Compat.hs new file mode 100644 index 000000000..53261c97e --- /dev/null +++ b/hledger-lib/Text/Megaparsec/Compat.hs @@ -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 diff --git a/hledger-lib/hledger-lib.cabal b/hledger-lib/hledger-lib.cabal index 0c8c5a5b0..f96bc0442 100644 --- a/hledger-lib/hledger-lib.cabal +++ b/hledger-lib/hledger-lib.cabal @@ -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 @@ -72,7 +72,7 @@ library , directory , filepath , hashtables >= 1.2 - , megaparsec >=5.0 && < 5.4 + , megaparsec >=5.0 && < 6.1 , mtl , mtl-compat , old-time @@ -141,6 +141,7 @@ library Hledger.Utils.Text Hledger.Utils.Tree Hledger.Utils.UTF8IOCompat + Text.Megaparsec.Compat other-modules: Paths_hledger_lib default-language: Haskell2010 @@ -168,7 +169,7 @@ test-suite doctests , directory , filepath , hashtables >= 1.2 - , megaparsec >=5.0 && < 5.4 + , megaparsec >=5.0 && < 6.1 , mtl , mtl-compat , old-time @@ -230,6 +231,7 @@ test-suite doctests Hledger.Utils.Text Hledger.Utils.Tree Hledger.Utils.UTF8IOCompat + Text.Megaparsec.Compat default-language: Haskell2010 test-suite hunittests @@ -255,7 +257,7 @@ test-suite hunittests , directory , filepath , hashtables >= 1.2 - , megaparsec >=5.0 && < 5.4 + , megaparsec >=5.0 && < 6.1 , mtl , mtl-compat , old-time @@ -326,4 +328,5 @@ test-suite hunittests Hledger.Utils.Text Hledger.Utils.Tree Hledger.Utils.UTF8IOCompat + Text.Megaparsec.Compat default-language: Haskell2010 diff --git a/hledger-lib/package.yaml b/hledger-lib/package.yaml index 78903e5fd..dbf5d9f3a 100644 --- a/hledger-lib/package.yaml +++ b/hledger-lib/package.yaml @@ -54,7 +54,7 @@ dependencies: - directory - filepath - hashtables >= 1.2 -- megaparsec >=5.0 && < 5.4 +- megaparsec >=5.0 && < 6.1 - mtl - mtl-compat - old-time @@ -127,6 +127,7 @@ library: - Hledger.Utils.Text - Hledger.Utils.Tree - Hledger.Utils.UTF8IOCompat + - Text.Megaparsec.Compat # other-modules: # - Ledger.Parser.Text dependencies: diff --git a/hledger-ui/hledger-ui.cabal b/hledger-ui/hledger-ui.cabal index 6f97f74ea..449246303 100644 --- a/hledger-ui/hledger-ui.cabal +++ b/hledger-ui/hledger-ui.cabal @@ -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 @@ -72,7 +72,7 @@ executable hledger-ui , HUnit , microlens >= 0.4 && < 0.5 , microlens-platform >= 0.2.3.1 && < 0.4 - , megaparsec >=5.0 && < 5.4 + , megaparsec >=5.0 && < 6.1 , pretty-show >=1.6.4 , process >= 1.2 , safe >= 0.2 diff --git a/hledger-ui/package.yaml b/hledger-ui/package.yaml index 34a3f1c34..cf4bf969c 100644 --- a/hledger-ui/package.yaml +++ b/hledger-ui/package.yaml @@ -63,7 +63,7 @@ executables: - HUnit - microlens >= 0.4 && < 0.5 - microlens-platform >= 0.2.3.1 && < 0.4 - - megaparsec >=5.0 && < 5.4 + - megaparsec >=5.0 && < 6.1 - pretty-show >=1.6.4 - process >= 1.2 - safe >= 0.2 diff --git a/hledger-web/hledger-web.cabal b/hledger-web/hledger-web.cabal index 59323d490..f8482e5b4 100644 --- a/hledger-web/hledger-web.cabal +++ b/hledger-web/hledger-web.cabal @@ -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 @@ -159,7 +159,7 @@ library , yesod-form , yesod-static , json - , megaparsec >=5.0 && < 5.4 + , megaparsec >=5.0 && < 6.1 , mtl if (flag(dev)) || (flag(library-only)) cpp-options: -DDEVELOPMENT diff --git a/hledger-web/package.yaml b/hledger-web/package.yaml index 90b9ddb7a..9e025cb6c 100644 --- a/hledger-web/package.yaml +++ b/hledger-web/package.yaml @@ -119,7 +119,7 @@ library: - Settings.Development - Settings.StaticFiles dependencies: - - megaparsec >=5.0 && < 5.4 + - megaparsec >=5.0 && < 6.1 - mtl when: - condition: (flag(dev)) || (flag(library-only)) diff --git a/hledger/Hledger/Cli/Add.hs b/hledger/Hledger/Cli/Add.hs index 01317d5c3..999b20e28 100644 --- a/hledger/Hledger/Cli/Add.hs +++ b/hledger/Hledger/Cli/Add.hs @@ -3,7 +3,7 @@ A history-aware add command to help with data entry. |-} {-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind #-} -{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, RecordWildCards, TypeOperators, FlexibleContexts, OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, RecordWildCards, TypeOperators, FlexibleContexts, OverloadedStrings #-} module Hledger.Cli.Add where @@ -16,6 +16,7 @@ import Control.Monad.Trans.Class import Control.Monad.State.Strict (evalState, evalStateT) import Control.Monad.Trans (liftIO) import Data.Char (toUpper, toLower) +import Data.Functor.Identity (Identity(..)) import Data.List.Compat import qualified Data.Set as S import Data.Maybe @@ -30,8 +31,7 @@ import System.Console.Haskeline.Completion import System.Console.Wizard import System.Console.Wizard.Haskeline import System.IO ( stderr, hPutStr, hPutStrLn ) -import Text.Megaparsec -import Text.Megaparsec.Text +import Text.Megaparsec.Compat import Text.Printf import Hledger @@ -187,7 +187,7 @@ dateAndCodeWizard EntryState{..} = do parseSmartDateAndCode refdate s = either (const Nothing) (\(d,c) -> return (fixSmartDate refdate d, c)) edc where edc = runParser (dateandcodep <* eof) "" $ T.pack $ lowercase s - dateandcodep :: Parser (SmartDate, Text) + dateandcodep :: SimpleTextParser (SmartDate, Text) dateandcodep = do d <- smartdate c <- optional codep @@ -285,7 +285,7 @@ amountAndCommentWizard EntryState{..} = do "" (T.pack s) nodefcommodityj = esJournal{jparsedefaultcommodity=Nothing} - amountandcommentp :: JournalParser (Amount, Text) + amountandcommentp :: JournalParser Identity (Amount, Text) amountandcommentp = do a <- amountp lift (many spacenonewline) diff --git a/hledger/Hledger/Cli/CliOptions.hs b/hledger/Hledger/Cli/CliOptions.hs index 62170e984..ae106db66 100644 --- a/hledger/Hledger/Cli/CliOptions.hs +++ b/hledger/Hledger/Cli/CliOptions.hs @@ -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 ( @@ -94,7 +94,7 @@ import System.Environment import System.Exit (exitSuccess) import System.FilePath import Test.HUnit -import Text.Megaparsec +import Text.Megaparsec.Compat import Hledger import Hledger.Cli.DocFiles @@ -549,7 +549,7 @@ rulesFilePathFromOpts opts = do widthFromOpts :: CliOpts -> Int widthFromOpts CliOpts{width_=Nothing, available_width_=w} = w 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 Right w -> w @@ -571,7 +571,7 @@ registerWidthsFromOpts CliOpts{width_=Just s} = Left e -> usageError $ "could not parse width option: "++show e Right ws -> ws 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 totalwidth <- read `fmap` some digitChar descwidth <- optional (char ',' >> read `fmap` some digitChar) @@ -665,10 +665,10 @@ isHledgerExeName :: String -> Bool isHledgerExeName = isRight . parsewith hledgerexenamep . T.pack where hledgerexenamep = do - _ <- string progname + _ <- mptext $ T.pack progname _ <- char '-' - _ <- some (noneOf ".") - optional (string "." >> choice' (map string addonExtensions)) + _ <- some $ noneOf ['.'] + optional (string "." >> choice' (map (mptext . T.pack) addonExtensions)) eof stripAddonExtension :: String -> String diff --git a/hledger/hledger.cabal b/hledger/hledger.cabal index 5b2f2f63d..e308e98a5 100644 --- a/hledger/hledger.cabal +++ b/hledger/hledger.cabal @@ -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 @@ -106,7 +106,7 @@ library , mtl , mtl-compat , old-time - , megaparsec >=5.0 && < 5.4 + , megaparsec >=5.0 && < 6.1 , regex-tdfa , safe >=0.2 , split >=0.1 && <0.3 diff --git a/hledger/package.yaml b/hledger/package.yaml index 9fe188aad..6fe1b26a0 100644 --- a/hledger/package.yaml +++ b/hledger/package.yaml @@ -120,7 +120,7 @@ library: - mtl - mtl-compat - old-time - - megaparsec >=5.0 && < 5.4 + - megaparsec >=5.0 && < 6.1 - regex-tdfa - safe >=0.2 - split >=0.1 && <0.3 diff --git a/stack.yaml b/stack.yaml index 7a3bc45ba..66f2c82eb 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,7 +3,11 @@ resolver: lts-8.23 -extra-deps: [] +extra-deps: + [] +#megaparsec >=6: +#- megaparsec-6.0.0 +#- parser-combinators-0.1.0 packages: - hledger-lib