lib: switch parsers to the custom error type

Also add an explicit export list to `hledger-lib/Hledger/Utils/Parse.hs`
in order to re-export the custom error type (for convenience).
This commit is contained in:
Alex Chen 2018-06-05 14:23:47 -06:00
parent ca201e4618
commit c5561f25f1
5 changed files with 45 additions and 23 deletions

View File

@ -91,7 +91,6 @@ import Data.Time.Calendar
import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.OrdinalDate
import Data.Time.Clock import Data.Time.Clock
import Data.Time.LocalTime import Data.Time.LocalTime
import Data.Void (Void)
import Safe (headMay, lastMay, readMay) import Safe (headMay, lastMay, readMay)
import Text.Megaparsec import Text.Megaparsec
import Text.Megaparsec.Char import Text.Megaparsec.Char
@ -313,7 +312,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 Void) (Interval, DateSpan) parsePeriodExpr :: Day -> Text -> Either (ParseError Char CustomErr) (Interval, DateSpan)
parsePeriodExpr refdate s = parsewith (periodexpr refdate <* eof) (T.toLower s) parsePeriodExpr refdate s = parsewith (periodexpr refdate <* eof) (T.toLower s)
maybePeriod :: Day -> Text -> Maybe (Interval,DateSpan) maybePeriod :: Day -> Text -> Maybe (Interval,DateSpan)
@ -373,13 +372,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 Void) String) $ (fixSmartDateStrEither d s :: Either (ParseError Char CustomErr) String)
-- | A safe version of fixSmartDateStr. -- | A safe version of fixSmartDateStr.
fixSmartDateStrEither :: Day -> Text -> Either (ParseError Char Void) String fixSmartDateStrEither :: Day -> Text -> Either (ParseError Char CustomErr) String
fixSmartDateStrEither d = either Left (Right . showDate) . fixSmartDateStrEither' d fixSmartDateStrEither d = either Left (Right . showDate) . fixSmartDateStrEither' d
fixSmartDateStrEither' :: Day -> Text -> Either (ParseError Char Void) Day fixSmartDateStrEither' :: Day -> Text -> Either (ParseError Char CustomErr) 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

View File

@ -113,7 +113,6 @@ import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Calendar import Data.Time.Calendar
import Data.Time.LocalTime import Data.Time.LocalTime
import Data.Void (Void)
import System.Time (getClockTime) import System.Time (getClockTime)
import Text.Megaparsec import Text.Megaparsec
import Text.Megaparsec.Char import Text.Megaparsec.Char
@ -184,12 +183,12 @@ rawOptsToInputOpts rawopts = InputOpts{
--- * parsing utilities --- * parsing utilities
-- | 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 Void) a runTextParser, rtp :: TextParser Identity a -> Text -> Either (ParseError Char CustomErr) 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 => JournalParser m a -> Text -> m (Either (ParseError Char Void) a) runJournalParser, rjp :: Monad m => JournalParser m a -> Text -> m (Either (ParseError Char CustomErr) a)
runJournalParser p t = runParserT (evalStateT p mempty) "" t runJournalParser p t = runParserT (evalStateT p mempty) "" t
rjp = runJournalParser rjp = runJournalParser
@ -981,7 +980,7 @@ followingcommentandtagsp mdefdate = do
runTextParser (setPosition pos *> parser) txt runTextParser (setPosition pos *> parser) txt
tagDate :: (SourcePos, Tag) tagDate :: (SourcePos, Tag)
-> Either (ParseError Char Void) (TagName, Day) -> Either (ParseError Char CustomErr) (TagName, Day)
tagDate (pos, (name, value)) = tagDate (pos, (name, value)) =
fmap (name,) $ runTextParserAt (datep' myear) (pos, value) fmap (name,) $ runTextParserAt (datep' myear) (pos, value)
where myear = fmap (first3 . toGregorian) mdefdate where myear = fmap (first3 . toGregorian) mdefdate

View File

@ -45,7 +45,6 @@ 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
import Data.Time.Calendar (Day) import Data.Time.Calendar (Day)
import Data.Void (Void)
#if MIN_VERSION_time(1,5,0) #if MIN_VERSION_time(1,5,0)
import Data.Time.Format (parseTimeM, defaultTimeLocale) import Data.Time.Format (parseTimeM, defaultTimeLocale)
#else #else
@ -404,7 +403,7 @@ parseAndValidateCsvRules rulesfile s = do
makeParseError f s = FancyError (fromList [initialPos f]) (S.singleton $ ErrorFail s) 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. -- | Parse this text as CSV conversion rules. The file path is for error messages.
parseCsvRules :: FilePath -> T.Text -> Either (ParseError Char Void) CsvRules parseCsvRules :: FilePath -> T.Text -> Either (ParseError Char CustomErr) 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

View File

@ -84,7 +84,6 @@ import Data.List
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Calendar import Data.Time.Calendar
import Data.Time.LocalTime import Data.Time.LocalTime
import Data.Void (Void)
import Safe import Safe
import Test.HUnit import Test.HUnit
#ifdef TESTS #ifdef TESTS
@ -199,7 +198,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 <- readFilePortably filepath `orRethrowIOError` (show parentpos ++ " reading " ++ filepath) txt <- readFilePortably filepath `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)
(ej1::Either (ParseError Char Void) ParsedJournal) <- (ej1::Either (ParseError Char CustomErr) ParsedJournal) <-
runParserT runParserT
(evalStateT (evalStateT
(choiceInState (choiceInState

View File

@ -1,5 +1,32 @@
{-# LANGUAGE CPP, TypeFamilies #-} {-# LANGUAGE CPP, TypeFamilies #-}
module Hledger.Utils.Parse where
module Hledger.Utils.Parse (
SimpleStringParser,
SimpleTextParser,
TextParser,
JournalParser,
ErroringJournalParser,
choice',
choiceInState,
surroundedBy,
parsewith,
parsewithString,
parseWithState,
parseWithState',
fromparse,
parseerror,
showDateParseError,
nonspace,
isNonNewlineSpace,
spacenonewline,
restofline,
eolof,
-- * re-exports
CustomErr
)
where
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.State.Strict (StateT, evalStateT) import Control.Monad.State.Strict (StateT, evalStateT)
@ -7,7 +34,6 @@ import Data.Char
import Data.Functor.Identity (Identity(..)) import Data.Functor.Identity (Identity(..))
import Data.List import Data.List
import Data.Text (Text) import Data.Text (Text)
import Data.Void (Void)
import Text.Megaparsec import Text.Megaparsec
import Text.Megaparsec.Char import Text.Megaparsec.Char
import Text.Printf import Text.Printf
@ -17,19 +43,19 @@ import Hledger.Utils.ParseErrors
import Hledger.Utils.UTF8IOCompat (error') import Hledger.Utils.UTF8IOCompat (error')
-- | A parser of string to some type. -- | A parser of string to some type.
type SimpleStringParser a = Parsec Void String a type SimpleStringParser a = Parsec CustomErr String a
-- | A parser of strict text to some type. -- | A parser of strict text to some type.
type SimpleTextParser = Parsec Void Text -- XXX an "a" argument breaks the CsvRulesParser declaration somehow type SimpleTextParser = Parsec CustomErr Text -- XXX an "a" argument breaks the CsvRulesParser declaration somehow
-- | A parser of text in some monad. -- | A parser of text in some monad.
type TextParser m a = ParsecT Void Text m a type TextParser m a = ParsecT CustomErr Text m a
-- | A parser of text in some monad, with a journal as state. -- | A parser of text in some monad, with a journal as state.
type JournalParser m a = StateT Journal (ParsecT Void Text m) a type JournalParser m a = StateT Journal (ParsecT CustomErr Text m) a
-- | A parser of text in some monad, with a journal as state, that can throw an error string mid-parse. -- | 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 Void Text (ExceptT String m)) a type ErroringJournalParser m a = StateT Journal (ParsecT CustomErr 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.
@ -38,7 +64,7 @@ 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 Void Text m) a] -> StateT s (ParsecT Void Text m) a choiceInState :: [StateT s (ParsecT CustomErr Text m) a] -> StateT s (ParsecT CustomErr Text m) a
choiceInState = choice . map try choiceInState = choice . map try
surroundedBy :: Applicative m => m openclose -> m a -> m a surroundedBy :: Applicative m => m openclose -> m a -> m a
@ -50,7 +76,7 @@ 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 Void Text m) a -> Text -> m (Either (ParseError Char Void) a) parseWithState :: Monad m => st -> StateT st (ParsecT CustomErr Text m) a -> Text -> m (Either (ParseError Char CustomErr) a)
parseWithState ctx p s = runParserT (evalStateT p ctx) "" s parseWithState ctx p s = runParserT (evalStateT p ctx) "" s
parseWithState' parseWithState'
@ -79,7 +105,7 @@ nonspace = satisfy (not . isSpace)
isNonNewlineSpace :: Char -> Bool isNonNewlineSpace :: Char -> Bool
isNonNewlineSpace c = c /= '\n' && isSpace c isNonNewlineSpace c = c /= '\n' && isSpace c
spacenonewline :: (Stream s, Char ~ Token s) => ParsecT Void s m Char spacenonewline :: (Stream s, Char ~ Token s) => ParsecT CustomErr s m Char
spacenonewline = satisfy isNonNewlineSpace spacenonewline = satisfy isNonNewlineSpace
restofline :: TextParser m String restofline :: TextParser m String