hledger-iadd 1.2.3 → 1.2.4
raw patch · 7 files changed
+192/−61 lines, 7 filesdep +semigroupsdep ~megaparsec
Dependencies added: semigroups
Dependency ranges changed: megaparsec
Files
- ChangeLog.md +4/−0
- hledger-iadd.cabal +6/−4
- src/AmountParser.hs +2/−2
- src/ConfigParser.hs +41/−48
- src/DateParser.hs +2/−3
- src/Text/Megaparsec/Compat.hs +132/−0
- src/main/Main.hs +5/−4
ChangeLog.md view
@@ -1,3 +1,7 @@+# 1.2.4++ - Support for megaparsec-6.0+ # 1.2.3 - Support for brick-0.20
hledger-iadd.cabal view
@@ -1,5 +1,5 @@ name: hledger-iadd-version: 1.2.3+version: 1.2.4 synopsis: A terminal UI as drop-in replacement for hledger add description: This is a terminal UI as drop-in replacement for hledger add. .@@ -54,6 +54,7 @@ , Brick.Widgets.BetterDialog , Brick.Widgets.WrappedText , Brick.Widgets.Edit.EmacsBindings+ , Text.Megaparsec.Compat default-language: Haskell2010 build-depends: base >= 4.8 && < 5 , hledger-lib >= 1.0 && < 1.4@@ -66,7 +67,7 @@ , transformers >= 0.3 , time >= 1.5 , vector- , megaparsec >= 5.0 && <5.4+ , megaparsec >= 5.0 && <6.1 , containers , optparse-applicative , directory@@ -74,6 +75,7 @@ , xdg-basedir , unordered-containers , free >= 4.12.4+ , semigroups >= 0.5.0 ghc-options: -Wall -fdefer-typed-holes -fno-warn-name-shadowing executable hledger-iadd@@ -97,7 +99,7 @@ , xdg-basedir , unordered-containers , free >= 4.12.4- , megaparsec >= 5.0 && <5.4+ , megaparsec >= 5.0 && <6.1 ghc-options: -threaded -Wall -fdefer-typed-holes -fno-warn-name-shadowing test-suite spec@@ -120,6 +122,6 @@ , QuickCheck , text-format , free >= 4.12.4- , megaparsec >= 5.0 && <5.4+ , megaparsec >= 5.0 && <6.1 , text-zipper >= 0.10 ghc-options: -threaded -Wall -fdefer-typed-holes -fno-warn-name-shadowing
src/AmountParser.hs view
@@ -4,9 +4,9 @@ import qualified Hledger as HL import Data.Functor.Identity import Control.Monad.Trans.State.Strict-import Text.Megaparsec+import Text.Megaparsec.Compat hiding (Parser) -type Parser a = HL.JournalStateParser Identity a+type Parser a = HL.JournalParser Identity a parseAmount :: HL.Journal -> Text -> Either String HL.MixedAmount parseAmount journal t = case runIdentity $ runParserT (evalStateT (mixed <* optional space <* eof) journal) "" t of
src/ConfigParser.hs view
@@ -39,6 +39,7 @@ , parserDefault , parserExample , ConfParseError+ , OParser , Option , OptionArgument() ) where@@ -51,31 +52,45 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T-import qualified Data.Set as S import qualified Text.Megaparsec as P-import Text.Megaparsec hiding ((<|>), many, option, optional)-import Text.Megaparsec.Text+import Text.Megaparsec.Compat hiding (option)+import Data.Maybe+-- import Text.Megaparsec.Text +-- | Errors that can occur during parsing. Use the 'Show' instance for printing.+data ConfParseError = UnknownOption Text+ | TypeError Text Text -- Type and Option name+ deriving (Eq, Ord, Show)++instance ShowErrorComponent ConfParseError where+ showErrorComponent (UnknownOption name) = "Unknown option " ++ T.unpack name+ showErrorComponent (TypeError typ name) =+ "in " ++ T.unpack typ ++ " argument for option " ++ T.unpack name++type OParser = Parsec (CustomError ConfParseError) Text++type CustomParseError = ParseError Char (CustomError ConfParseError)+ -- | Parse a config file from a 'Text'. parseConfig :: FilePath -- ^ File path to use in error messages -> Text -- ^ The input test -> OptParser a -- ^ The parser to use- -> Either ConfParseError a+ -> Either CustomParseError a parseConfig path input parser = case parse (assignmentList <* eof) path input of- Left err -> Left $ SyntaxError err+ Left err -> Left err Right res -> runOptionParser res parser -- | Parse a config file from an actual file in the filesystem. parseConfigFile :: FilePath -- ^ Path to the file -> OptParser a -- ^ The parser to use- -> IO (Either ConfParseError a)+ -> IO (Either CustomParseError a) parseConfigFile path parser = do input <- T.readFile path return $ parseConfig path input parser -- | An option in the config file. Use 'option' as a smart constructor. data Option a = Option- { optParser :: Parser a+ { optParser :: OParser a , optType :: Text -- Something like "string" or "integer" , optName :: Text , optHelp :: Text@@ -86,23 +101,11 @@ -- | The main parser type. Use 'option' and the 'Applicative' instance to create those. type OptParser a = Ap Option a --- | Errors that can occur during parsing. Use the 'Show' instance for printing.-data ConfParseError = SyntaxError (ParseError Char Dec)- | UnknownOption SourcePos Text- | TypeError (ParseError Char Dec)- deriving (Eq)--instance Show ConfParseError where- show (SyntaxError e) = parseErrorPretty e- show (UnknownOption pos key) =- sourcePosPretty pos ++ ": Unknown option " ++ T.unpack key ++ "\n"- show (TypeError e) = parseErrorPretty e- -- | Class for supported option types. -- -- At the moment, orphan instances are not supported class OptionArgument a where- mkParser :: (Text, Parser a)+ mkParser :: (Text, OParser a) printArgument :: a -> Text -- | 'OptParser' that parses one option.@@ -124,7 +127,7 @@ -> Text -- ^ A textual representation of the default value -> Text -- ^ A help string for the option -> Text -- ^ A description of the expected type such sas "string" or "integer"- -> Parser a -- ^ Parser for the option+ -> OParser a -- ^ Parser for the option -> OptParser a customOption optName optDefault optDefaultTxt optHelp optType optParser = liftAp $ Option {..} @@ -149,7 +152,7 @@ where escape = T.replace "\"" "\\\"" . T.replace "\\" "\\\\" -runOptionParser :: [Assignment] -> OptParser a -> Either ConfParseError a+runOptionParser :: [Assignment] -> OptParser a -> Either CustomParseError a runOptionParser (a:as) parser = parseOption parser a >>= runOptionParser as runOptionParser [] parser = Right $ parserDefault parser @@ -174,16 +177,15 @@ where example1 a = commentify (optHelp a) <> optName a <> " = " <> optDefaultTxt a <> "\n\n" commentify = T.unlines . map ("# " <>) . T.lines -parseOption :: OptParser a -> Assignment -> Either ConfParseError (OptParser a)+parseOption :: OptParser a -> Assignment -> Either CustomParseError (OptParser a) parseOption (Pure _) ass =- Left $ UnknownOption (assignmentPosition ass) (assignmentKey ass)+ Left $ mkCustomError (assignmentPosition ass) (UnknownOption (assignmentKey ass)) parseOption (Ap opt rest) ass | optName opt == assignmentKey ass = let content = (valueContent $ assignmentValue ass) pos = (valuePosition $ assignmentValue ass) in case parseWithStart (optParser opt <* eof) pos content of- Left e -> Left $ TypeError $ addErrorMessage e $- "in " ++ T.unpack (optType opt) ++ " argument for option " ++ T.unpack (assignmentKey ass)+ Left e -> Left $ addCustomError e $ TypeError (optType opt) (assignmentKey ass) Right res -> Right $ fmap ($ res) rest | otherwise = fmap (Ap opt) $ parseOption rest ass @@ -200,56 +202,47 @@ , valueContent :: Text } deriving (Show) -assignmentList :: Parser [Assignment]+assignmentList :: OParser [Assignment] assignmentList = whitespace *> many (assignment <* whitespace) -assignment :: Parser Assignment+assignment :: OParser Assignment assignment = do Assignment <$> getPosition <*> key <* whitespaceNoComment <* char '=' <* whitespaceNoComment <*> value -key :: Parser Text+key :: OParser Text key = T.pack <$> some (alphaNumChar <|> char '_' <|> char '-') -value :: Parser AssignmentValue+value :: OParser AssignmentValue value = AssignmentValue <$> getPosition <*> content <* whitespaceNoEOL <* (void eol <|> eof) -content :: Parser Text+content :: OParser Text content = escapedString <|> bareString -bareString :: Parser Text+bareString :: OParser Text bareString = (T.strip . T.pack <$> some (noneOf ("#\n" :: String))) <?> "bare string" -escapedString :: Parser Text+escapedString :: OParser Text escapedString = (T.pack <$> (char '"' *> many escapedChar <* char '"')) <?> "quoted string" where escapedChar = char '\\' *> anyChar <|> noneOf ("\"" :: String) -whitespace :: Parser ()+whitespace :: OParser () whitespace = skipMany $ (void $ oneOf (" \t\n" :: String)) <|> comment -whitespaceNoEOL :: Parser ()+whitespaceNoEOL :: OParser () whitespaceNoEOL = skipMany $ (void $ oneOf (" \t" :: String)) <|> comment -whitespaceNoComment :: Parser ()+whitespaceNoComment :: OParser () whitespaceNoComment = skipMany $ oneOf (" \t" :: String) -comment :: Parser ()+comment :: OParser () comment = char '#' >> skipMany (noneOf ("\n" :: String)) -parseWithStart :: (Stream s, ErrorComponent e)- => Parsec e s a -> SourcePos -> s -> Either (ParseError (Token s) e) a-parseWithStart p pos = parse p' (sourceName pos)- where p' = do setPosition pos; p--parseNumber :: Read a => Parser a-parseNumber = read <$> ((<>) <$> (P.option "" $ string "-") <*> some digitChar)---- | Helper function brought over from parsec-addErrorMessage :: ParseError t Dec -> String -> ParseError t Dec-addErrorMessage e errorMsg = e { errorCustom = S.insert (DecFail errorMsg) (errorCustom e) }+parseNumber :: Read a => OParser a+parseNumber = read <$> ((<>) <$> (maybeToList <$> optional (char '-')) <*> some digitChar)
src/DateParser.hs view
@@ -30,8 +30,7 @@ import Data.Time hiding (parseTime) import Data.Time.Calendar.WeekDate import qualified Hledger.Data.Dates as HL-import Text.Megaparsec hiding ((<|>), many)-import Text.Megaparsec.Text+import Text.Megaparsec.Compat newtype DateFormat = DateFormat [DateSpec] deriving (Eq, Show)@@ -158,7 +157,7 @@ DateYearShort -> part $ (,mempty,mempty) . fmap completeYear DateMonth -> part (mempty,,mempty) DateDay -> part (mempty,mempty,)- DateString s -> string (T.unpack s) >> pure mempty+ DateString s -> string s >> pure mempty DateOptional ds' -> option mempty (try $ parseDate' ds') where digits = some digitChar
+ src/Text/Megaparsec/Compat.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE CPP, GADTs #-}++-- | Compatibility module to bridge the gap between megaparsec-5 and megaparsec-6+--+-- Import this instead of Text.Megaparsec, Text.Megaparsec.Char and+-- Text.Megaparsec.Text+module Text.Megaparsec.Compat+ (+ -- * Re-exports+ module Text.Megaparsec.Char+ , module Text.Megaparsec+ -- * Compatibility reimplementations+ , Parser+#if MIN_VERSION_megaparsec(6,0,0)+ , Dec+#endif+ , string+ -- * Custom error handling+ , CustomError+ , mkCustomError+ , addCustomError+ -- * Additional helpers+ , parseWithStart+ ) where++import qualified Data.Set as S+import Data.Set (Set)+import Data.Text (Text)+import Text.Megaparsec.Char hiding (string)+import qualified Text.Megaparsec.Char as P+import qualified Data.List.NonEmpty as NE++#if MIN_VERSION_megaparsec(6,0,0)+import Data.Void+import Text.Megaparsec+#else+import Text.Megaparsec.Prim+import Text.Megaparsec hiding (string)+import qualified Data.Text as T+#endif++#if MIN_VERSION_megaparsec(6,0,0)+-- | Custom error type for when no custom errors are needed+type Dec = Void+#endif++-- | Same as the type in Text.Megaparsec.Text from megaparsec-5+type Parser = Parsec Dec Text++-- | Custom error type that mimics FancyError of megaparsec-6 but retains+-- information about unexpected and expected tokens.+#if MIN_VERSION_megaparsec(6,0,0)+data CustomError e = CustomError+ (Maybe (ErrorItem Char)) -- unexpected+ (Set (ErrorItem Char)) -- expected+ e -- custom error data+ deriving (Eq, Show, Ord)++instance ShowErrorComponent e => ShowErrorComponent (CustomError e) where+ showErrorComponent (CustomError us es e) =+ parseErrorTextPretty (TrivialError undefined us es :: ParseError Char Void)+ ++ showErrorComponent e+#else+data CustomError e = CustomError e+ | CustomFail String+ | CustomIndentation Ordering Pos Pos+ deriving (Eq, Ord, Show)++instance Ord e => ErrorComponent (CustomError e) where+ representFail = CustomFail+ representIndentation = CustomIndentation++instance ShowErrorComponent e => ShowErrorComponent (CustomError e) where+ showErrorComponent (CustomError e) = showErrorComponent e+ showErrorComponent (CustomFail msg) = msg+ showErrorComponent (CustomIndentation ord ref actual) =+ "incorrect indentation (got " ++ show (unPos actual) +++ ", should be " ++ p ++ show (unPos ref) ++ ")"+ where p = case ord of+ LT -> "less than "+ EQ -> "equal to "+ GT -> "greater than "+#endif++-- | Wrap a custom error type into a 'ParseError'.+mkCustomError :: SourcePos -> e -> ParseError t (CustomError e)+#if MIN_VERSION_megaparsec(6,0,0)+mkCustomError pos custom = FancyError (neSingleton pos)+ (S.singleton (ErrorCustom (CustomError Nothing S.empty custom)))+#else+mkCustomError pos custom = ParseError (neSingleton pos) S.empty S.empty+ (S.singleton (CustomError custom))+#endif++-- | Add a custom error to an already existing error.+--+-- This retains the original information such as expected and unexpected tokens+-- as well as the source position.+addCustomError :: Ord e => ParseError Char (CustomError e) -> e -> ParseError Char (CustomError e)+#if MIN_VERSION_megaparsec(6,0,0)+addCustomError e custom = case e of+ TrivialError source us es ->+ FancyError source (S.singleton (ErrorCustom (CustomError us es custom)))+ FancyError source es ->+ FancyError source (S.insert (ErrorCustom (CustomError Nothing S.empty custom)) es)+#else+addCustomError e custom = e { errorCustom = S.insert (CustomError custom) (errorCustom e) }+#endif+++-- | Like 'parse', but start at a specific source position instead of 0.+#if MIN_VERSION_megaparsec(6,0,0)+parseWithStart :: (Stream s, Ord e)+#else+parseWithStart :: (Stream s, ErrorComponent e)+#endif+ => Parsec e s a -> SourcePos -> s -> Either (ParseError (Token s) e) a+parseWithStart p pos = parse p' (sourceName pos)+ where p' = do setPosition pos; p+++-- | Reimplementation of 'Text.Megaparsec.Char.string', but specialized to 'Text'.+#if MIN_VERSION_megaparsec(6,0,0)+string :: MonadParsec e s m => Tokens s -> m (Tokens s)+string = P.string+#else+string :: (MonadParsec e s m, Token s ~ Char) => Text -> m Text+string x = T.pack <$> P.string (T.unpack x)+#endif++neSingleton :: a -> NE.NonEmpty a+neSingleton x = x NE.:| []
src/main/Main.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings, LambdaCase #-}+{-# LANGUAGE PackageImports #-} module Main where @@ -35,8 +36,8 @@ import System.Environment.XDG.BaseDir import System.Exit import System.IO-import qualified Text.Megaparsec as P-import qualified Text.Megaparsec.Text as P+-- explicit package import since hledger-lib defines the same module+import qualified "hledger-iadd" Text.Megaparsec.Compat as P import Brick.Widgets.HelpMessage import Brick.Widgets.CommentDialog@@ -379,7 +380,7 @@ configPath = getUserConfigFile "hledger-iadd" "config.conf" -- | Megaparsec parser for MatchAlgo, used for config file parsing-parseMatchAlgo :: P.Parser MatchAlgo+parseMatchAlgo :: OParser MatchAlgo parseMatchAlgo = (P.string "fuzzy" *> pure Fuzzy) <|> (P.string "substrings" *> pure Substrings) @@ -420,7 +421,7 @@ Left (_ :: SomeException) -> return (parserDefault $ confParser def) Right res -> case parseConfig path res (confParser def) of Left err -> do- putStr (show err)+ putStr (P.parseErrorPretty err) exitFailure Right res' -> return res'