lib: remove the megaparsec compatability module

This commit is contained in:
Alex Chen 2018-05-21 16:47:56 -06:00 committed by Simon Michael
parent c4ba7542d7
commit b245ec7b3d
18 changed files with 82 additions and 133 deletions

View File

@ -103,7 +103,8 @@ import qualified Hledger.Utils.Parse as H
import Options.Applicative
import System.Exit (exitFailure)
import System.FilePath (FilePath)
import qualified Text.Megaparsec.Compat as P
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P
main :: IO ()
main = do

View File

@ -89,8 +89,10 @@ import Data.Time.Calendar
import Data.Time.Calendar.OrdinalDate
import Data.Time.Clock
import Data.Time.LocalTime
import Data.Void (Void)
import Safe (headMay, lastMay, readMay)
import Text.Megaparsec.Compat
import Text.Megaparsec
import Text.Megaparsec.Char
import Text.Megaparsec.Perm
import Text.Printf
@ -309,7 +311,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 MPErr) (Interval, DateSpan)
parsePeriodExpr :: Day -> Text -> Either (ParseError Char Void) (Interval, DateSpan)
parsePeriodExpr refdate s = parsewith (periodexpr refdate <* eof) (T.toLower s)
maybePeriod :: Day -> Text -> Maybe (Interval,DateSpan)
@ -369,13 +371,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 MPErr) String)
$ (fixSmartDateStrEither d s :: Either (ParseError Char Void) String)
-- | A safe version of fixSmartDateStr.
fixSmartDateStrEither :: Day -> Text -> Either (ParseError Char MPErr) String
fixSmartDateStrEither :: Day -> Text -> Either (ParseError Char Void) String
fixSmartDateStrEither d = either Left (Right . showDate) . fixSmartDateStrEither' d
fixSmartDateStrEither' :: Day -> Text -> Either (ParseError Char MPErr) Day
fixSmartDateStrEither' :: Day -> Text -> Either (ParseError Char Void) Day
fixSmartDateStrEither' d s = case parsewith smartdateonly (T.toLower s) of
Right sd -> Right $ fixSmartDate d sd
Left e -> Left e
@ -841,13 +843,13 @@ tomorrow = string "tomorrow" >> return ("","","tomorrow")
lastthisnextthing :: SimpleTextParser SmartDate
lastthisnextthing = do
r <- choice $ map mptext [
r <- choice $ map string [
"last"
,"this"
,"next"
]
skipMany spacenonewline -- make the space optional for easier scripting
p <- choice $ map mptext [
p <- choice $ map string [
"day"
,"week"
,"month"
@ -982,17 +984,17 @@ reportinginterval = choice' [
tryinterval :: String -> String -> (Int -> Interval) -> SimpleTextParser Interval
tryinterval singular compact intcons =
choice' [
do mptext compact'
do string compact'
return $ intcons 1,
do mptext "every"
do string "every"
skipMany spacenonewline
mptext singular'
string singular'
return $ intcons 1,
do mptext "every"
do string "every"
skipMany spacenonewline
n <- fmap read $ some digitChar
skipMany spacenonewline
mptext plural'
string plural'
return $ intcons n
]
where

View File

@ -19,7 +19,8 @@ import Numeric
import Data.Char (isPrint)
import Data.Maybe
import Test.HUnit
import Text.Megaparsec.Compat
import Text.Megaparsec
import Text.Megaparsec.Char
import Hledger.Utils.Parse
import Hledger.Utils.String (formatString)

View File

@ -58,7 +58,8 @@ import qualified Data.Text as T
import Data.Time.Calendar
import Safe (readDef, headDef)
import Test.HUnit
import Text.Megaparsec.Compat
import Text.Megaparsec
import Text.Megaparsec.Char
import Hledger.Utils hiding (words')
import Hledger.Data.Types
@ -191,10 +192,10 @@ words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- XXX
maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, singleQuotedPattern, doubleQuotedPattern, pattern] `sepBy` skipSome spacenonewline
prefixedQuotedPattern :: SimpleTextParser T.Text
prefixedQuotedPattern = do
not' <- fromMaybe "" `fmap` (optional $ mptext "not:")
not' <- fromMaybe "" `fmap` (optional $ string "not:")
let allowednexts | T.null not' = prefixes
| otherwise = prefixes ++ [""]
next <- choice' $ map mptext allowednexts
next <- choice' $ map string allowednexts
let prefix :: T.Text
prefix = not' <> next
p <- singleQuotedPattern <|> doubleQuotedPattern

View File

@ -112,9 +112,10 @@ import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar
import Data.Time.LocalTime
import Data.Void (Void)
import System.Time (getClockTime)
import Text.Megaparsec.Compat
import Control.Applicative.Combinators (skipManyTill)
import Text.Megaparsec
import Text.Megaparsec.Char
import Hledger.Data
import Hledger.Utils
@ -181,13 +182,13 @@ rawOptsToInputOpts rawopts = InputOpts{
--- * parsing utilities
-- | Run a string parser with no state in the identity monad.
runTextParser, rtp :: TextParser Identity a -> Text -> Either (ParseError Char MPErr) a
runTextParser, rtp :: TextParser Identity a -> Text -> Either (ParseError Char Void) a
runTextParser p t = runParser p "" t
rtp = runTextParser
-- XXX odd, why doesn't this take a JournalParser ?
-- | Run a journal parser with a null journal-parsing state.
runJournalParser, rjp :: Monad m => TextParser m a -> Text -> m (Either (ParseError Char MPErr) a)
runJournalParser, rjp :: Monad m => TextParser m a -> Text -> m (Either (ParseError Char Void) a)
runJournalParser p t = runParserT p "" t
rjp = runJournalParser
@ -913,7 +914,7 @@ followingcommentandtagsp mdefdate = do
runTextParser (setPosition pos *> parser) txt
tagDate :: (SourcePos, Tag)
-> Either (ParseError Char MPErr) (TagName, Day)
-> Either (ParseError Char Void) (TagName, Day)
tagDate (pos, (name, value)) =
fmap (name,) $ runTextParserAt (datep' myear) (pos, value)
where myear = fmap (first3 . toGregorian) mdefdate

View File

@ -36,12 +36,15 @@ import Control.Monad.State.Strict (StateT, get, modify', evalStateT)
-- import Test.HUnit
import Data.Char (toLower, isDigit, isSpace)
import Data.List.Compat
import Data.List.NonEmpty (fromList)
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
import Data.Time.Calendar (Day)
import Data.Void (Void)
#if MIN_VERSION_time(1,5,0)
import Data.Time.Format (parseTimeM, defaultTimeLocale)
#else
@ -53,7 +56,8 @@ import System.Directory (doesFileExist)
import System.FilePath
import Test.HUnit hiding (State)
import Text.CSV (parseCSV, CSV)
import Text.Megaparsec.Compat hiding (parse)
import Text.Megaparsec hiding (parse)
import Text.Megaparsec.Char
import qualified Text.Parsec as Parsec
import Text.Printf (printf)
@ -135,7 +139,7 @@ readJournalFromCsv mrulesfile csvfile csvdata =
(\pos r ->
let
SourcePos name line col = pos
line' = (mpMkPos . (+1) . mpUnPos) line
line' = (mkPos . (+1) . unPos) line
pos' = SourcePos name line' col
in
(pos, transactionFromCsvRecord pos' rules r)
@ -391,11 +395,15 @@ parseAndValidateCsvRules rulesfile s = do
Right r -> do
r_ <- liftIO $ runExceptT $ validateRules r
ExceptT $ case r_ of
Left s -> return $ Left $ parseErrorPretty $ mpMkParseError rulesfile s
Left s -> return $ Left $ parseErrorPretty $ makeParseError rulesfile s
Right r -> return $ Right r
where
makeParseError :: FilePath -> String -> ParseError Char String
makeParseError f s = FancyError (fromList [initialPos f]) (S.singleton $ ErrorFail s)
-- | Parse this text as CSV conversion rules. The file path is for error messages.
parseCsvRules :: FilePath -> T.Text -> Either (ParseError Char MPErr) CsvRules
parseCsvRules :: FilePath -> T.Text -> Either (ParseError Char Void) CsvRules
-- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s
parseCsvRules rulesfile s =
runParser (evalStateT rulesp rules) rulesfile s
@ -447,7 +455,7 @@ commentcharp = oneOf (";#*" :: [Char])
directivep :: CsvRulesParser (DirectiveName, String)
directivep = (do
lift $ pdbg 3 "trying directive"
d <- fmap T.unpack $ choiceInState $ map (lift . mptext . T.pack) directives
d <- fmap T.unpack $ choiceInState $ map (lift . string . T.pack) directives
v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp)
<|> (optional (char ':') >> lift (skipMany spacenonewline) >> lift eolof >> return "")
return (d, v)
@ -505,7 +513,7 @@ fieldassignmentp = do
journalfieldnamep :: CsvRulesParser String
journalfieldnamep = do
lift (pdbg 2 "trying journalfieldnamep")
T.unpack <$> choiceInState (map (lift . mptext . T.pack) journalfieldnames)
T.unpack <$> choiceInState (map (lift . string . T.pack) journalfieldnames)
-- Transaction fields and pseudo fields for CSV conversion.
-- Names must precede any other name they contain, for the parser
@ -565,7 +573,7 @@ recordmatcherp = do
<?> "record matcher"
matchoperatorp :: CsvRulesParser String
matchoperatorp = fmap T.unpack $ choiceInState $ map mptext
matchoperatorp = fmap T.unpack $ choiceInState $ map string
["~"
-- ,"!~"
-- ,"="

View File

@ -87,13 +87,15 @@ import Data.List
import qualified Data.Text as T
import Data.Time.Calendar
import Data.Time.LocalTime
import Data.Void (Void)
import Safe
import Test.HUnit
#ifdef TESTS
import Test.Framework
import Text.Megaparsec.Error
#endif
import Text.Megaparsec.Compat hiding (parse)
import Text.Megaparsec hiding (parse)
import Text.Megaparsec.Char
import Text.Printf
import System.FilePath
@ -200,7 +202,7 @@ includedirectivep = do
let curdir = takeDirectory (sourceName parentpos)
filepath <- expandPath curdir filename `orRethrowIOError` (show parentpos ++ " locating " ++ filename)
txt <- readFilePortably filepath `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)
(ej1::Either (ParseError Char MPErr) ParsedJournal) <-
(ej1::Either (ParseError Char Void) ParsedJournal) <-
runParserT
(evalStateT
(choiceInState

View File

@ -60,7 +60,8 @@ import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Test.HUnit
import Text.Megaparsec.Compat hiding (parse)
import Text.Megaparsec hiding (parse)
import Text.Megaparsec.Char
import Hledger.Data
-- XXX too much reuse ?

View File

@ -44,7 +44,8 @@ import Data.List (foldl')
import Data.Maybe
import Data.Text (Text)
import Test.HUnit
import Text.Megaparsec.Compat hiding (parse)
import Text.Megaparsec hiding (parse)
import Text.Megaparsec.Char
import Hledger.Data
import Hledger.Read.Common

View File

@ -7,26 +7,28 @@ import Data.Char
import Data.Functor.Identity (Identity(..))
import Data.List
import Data.Text (Text)
import Text.Megaparsec.Compat
import Data.Void (Void)
import Text.Megaparsec
import Text.Megaparsec.Char
import Text.Printf
import Hledger.Data.Types
import Hledger.Utils.UTF8IOCompat (error')
-- | A parser of string to some type.
type SimpleStringParser a = Parsec MPErr String a
type SimpleStringParser a = Parsec Void String a
-- | A parser of strict text to some type.
type SimpleTextParser = Parsec MPErr Text -- XXX an "a" argument breaks the CsvRulesParser declaration somehow
type SimpleTextParser = Parsec Void Text -- XXX an "a" argument breaks the CsvRulesParser declaration somehow
-- | A parser of text in some monad.
type TextParser m a = ParsecT MPErr Text m a
type TextParser m a = ParsecT Void Text 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
type JournalParser m a = StateT Journal (ParsecT Void 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
type ErroringJournalParser m a = StateT Journal (ParsecT Void Text (ExceptT String m)) a
-- | Backtracking choice, use this when alternatives share a prefix.
-- Consumes no input if all choices fail.
@ -35,7 +37,7 @@ choice' = choice . map try
-- | Backtracking choice, use this when alternatives share a prefix.
-- Consumes no input if all choices fail.
choiceInState :: [StateT s (ParsecT MPErr Text m) a] -> StateT s (ParsecT MPErr Text m) a
choiceInState :: [StateT s (ParsecT Void Text m) a] -> StateT s (ParsecT Void Text m) a
choiceInState = choice . map try
surroundedBy :: Applicative m => m openclose -> m a -> m a
@ -47,7 +49,7 @@ 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 MPErr Text m) a -> Text -> m (Either (ParseError Char MPErr) a)
parseWithState :: Monad m => st -> StateT st (ParsecT Void Text m) a -> Text -> m (Either (ParseError Char Void) a)
parseWithState ctx p s = runParserT (evalStateT p ctx) "" s
parseWithState' :: (
@ -73,7 +75,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 MPErr s m Char
spacenonewline :: (Stream s, Char ~ Token s) => ParsecT Void s m Char
spacenonewline = satisfy (`elem` " \v\f\t")
restofline :: TextParser m String

View File

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

View File

@ -1,74 +0,0 @@
-- | Paper over some differences between megaparsec 5 and 6,
-- making it possible to write code that supports both.
{-# 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
#if MIN_VERSION_megaparsec(6,0,0)
import Text.Megaparsec hiding (skipManyTill)
import Text.Megaparsec.Char
import Data.List.NonEmpty (fromList)
import Data.Void (Void)
-- | A basic parse error type.
type MPErr = Void
-- | Make a simple parse error.
mpMkParseError :: FilePath -> String -> ParseError Char String
mpMkParseError f s = FancyError (fromList [initialPos f]) (S.singleton $ ErrorFail s)
-- | Make a Pos. With a negative argument, throws InvalidPosException (megaparsec >= 6)
-- or calls error (megaparsec < 6).
mpMkPos :: Int -> Pos
mpMkPos = mkPos
-- | Unmake a Pos.
mpUnPos :: Pos -> Int
mpUnPos = unPos
-- | Parse and return some Text.
mptext :: MonadParsec e Text m => Tokens Text -> m (Tokens Text)
mptext = string
#else
import Text.Megaparsec
import Text.Megaparsec.Prim (MonadParsec)
-- | A basic parse error type.
type MPErr = Dec
-- | Make a simple parse error.
mpMkParseError :: FilePath -> String -> ParseError Char String
mpMkParseError f s = (mempty :: ParseError Char String){errorCustom = S.singleton $ f ++ ": " ++ s}
-- | Make a Pos. With a negative argument, throws InvalidPosException (megaparsec >= 6)
-- or calls error (megaparsec < 6).
mpMkPos :: Int -> Pos
mpMkPos = unsafePos . fromIntegral
-- | Unmake a Pos.
mpUnPos :: Pos -> Int
mpUnPos = fromIntegral . unPos
-- | Parse and return some Text.
mptext :: MonadParsec e Text m => Text -> m Text
mptext = fmap pack . string . unpack
#endif

View File

@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: 5fde68eeaac8c1e790c207a8db26776e8659d7058fb3215c3c9678641d406a97
-- hash: 22b7806755a6e3d8afa63a7e941273b64188b90a6695b78fa7f59dcb150e19f7
name: hledger-lib
version: 1.9.99
@ -93,7 +93,6 @@ library
Hledger.Utils.Text
Hledger.Utils.Tree
Hledger.Utils.UTF8IOCompat
Text.Megaparsec.Compat
Text.Tabular.AsciiWide
other-modules:
Paths_hledger_lib
@ -188,7 +187,6 @@ test-suite doctests
Hledger.Utils.Text
Hledger.Utils.Tree
Hledger.Utils.UTF8IOCompat
Text.Megaparsec.Compat
Text.Tabular.AsciiWide
Paths_hledger_lib
hs-source-dirs:
@ -287,7 +285,6 @@ test-suite easytests
Hledger.Utils.Text
Hledger.Utils.Tree
Hledger.Utils.UTF8IOCompat
Text.Megaparsec.Compat
Text.Tabular.AsciiWide
Paths_hledger_lib
hs-source-dirs:
@ -384,7 +381,6 @@ test-suite hunittests
Hledger.Utils.Text
Hledger.Utils.Tree
Hledger.Utils.UTF8IOCompat
Text.Megaparsec.Compat
Text.Tabular.AsciiWide
Paths_hledger_lib
hs-source-dirs:

View File

@ -142,7 +142,6 @@ library:
- Hledger.Utils.Text
- Hledger.Utils.Tree
- Hledger.Utils.UTF8IOCompat
- Text.Megaparsec.Compat
- Text.Tabular.AsciiWide
# other-modules:
# - Ledger.Parser.Text

View File

@ -19,8 +19,10 @@ import Control.Monad.IO.Class (liftIO)
import Data.Monoid
#endif
import Data.Time.Calendar (Day)
import Data.Void (Void)
import Graphics.Vty (Event(..),Key(..))
import Text.Megaparsec.Compat
import Text.Megaparsec
import Text.Megaparsec.Char
import Hledger.Cli hiding (progname,prognameandversion)
import Hledger.UI.UIOptions
@ -108,7 +110,7 @@ esHandle _ _ = error "event handler called with wrong screen type, should not ha
-- | Parse the file name, line and column number from a hledger parse error message, if possible.
-- Temporary, we should keep the original parse error location. XXX
hledgerparseerrorpositionp :: ParsecT MPErr String t (String, Int, Int)
hledgerparseerrorpositionp :: ParsecT Void String t (String, Int, Int)
hledgerparseerrorpositionp = do
anyChar `manyTill` char '"'
f <- anyChar `manyTill` (oneOf ['"','\n'])

View File

@ -17,7 +17,9 @@ import qualified Data.List as L (head) -- qualified keeps dev & prod builds warn
import Data.Text (append, pack, unpack)
import qualified Data.Text as T
import Data.Time.Calendar
import Text.Megaparsec.Compat (digitChar, eof, some, string, runParser, ParseError, MPErr)
import Data.Void (Void)
import Text.Megaparsec
import Text.Megaparsec.Char
import Hledger.Utils
import Hledger.Data
@ -83,7 +85,7 @@ postAddForm = do
let numberedParams s =
reverse $ dropWhile (T.null . snd) $ reverse $ sort
[ (n,v) | (k,v) <- params
, let en = parsewith (paramnamep s) k :: Either (ParseError Char MPErr) Int
, let en = parsewith (paramnamep s) k :: Either (ParseError Char Void) Int
, isRight en
, let Right n = en
]

View File

@ -87,6 +87,7 @@ import Data.Maybe
--import Data.String.Here
-- import Data.Text (Text)
import qualified Data.Text as T
import Data.Void (Void)
import Safe
import System.Console.CmdArgs hiding (Default,def)
import System.Console.CmdArgs.Explicit
@ -99,7 +100,8 @@ import System.Environment
import System.Exit (exitSuccess)
import System.FilePath
import Test.HUnit
import Text.Megaparsec.Compat
import Text.Megaparsec
import Text.Megaparsec.Char
import Hledger
import Hledger.Cli.DocFiles
@ -554,7 +556,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 MPErr String Identity Int) "(unknown)" s of
case runParser (read `fmap` some digitChar <* eof :: ParsecT Void String Identity Int) "(unknown)" s of
Left e -> usageError $ "could not parse width option: "++show e
Right w -> w
@ -576,7 +578,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 MPErr s m (Int, Maybe Int)
registerwidthp :: (Stream s, Char ~ Token s) => ParsecT Void s m (Int, Maybe Int)
registerwidthp = do
totalwidth <- read `fmap` some digitChar
descwidth <- optional (char ',' >> read `fmap` some digitChar)
@ -665,10 +667,10 @@ isHledgerExeName :: String -> Bool
isHledgerExeName = isRight . parsewith hledgerexenamep . T.pack
where
hledgerexenamep = do
_ <- mptext $ T.pack progname
_ <- string $ T.pack progname
_ <- char '-'
_ <- some $ noneOf ['.']
optional (string "." >> choice' (map (mptext . T.pack) addonExtensions))
optional (string "." >> choice' (map (string . T.pack) addonExtensions))
eof
stripAddonExtension :: String -> String

View File

@ -37,7 +37,8 @@ import System.Console.Haskeline.Completion
import System.Console.Wizard
import System.Console.Wizard.Haskeline
import System.IO ( stderr, hPutStr, hPutStrLn )
import Text.Megaparsec.Compat
import Text.Megaparsec
import Text.Megaparsec.Char
import Text.Printf
import Hledger