diff --git a/hledger-lib/Hledger/Data/Journal.hs b/hledger-lib/Hledger/Data/Journal.hs index 377baeb16..ce5565bc8 100644 --- a/hledger-lib/Hledger/Data/Journal.hs +++ b/hledger-lib/Hledger/Data/Journal.hs @@ -90,6 +90,7 @@ import Control.Monad.Extra import Control.Monad.Reader as R import Control.Monad.ST import Data.Array.ST +import Data.Default (Default(..)) import Data.Function ((&)) import qualified Data.HashTable.ST.Cuckoo as H import Data.List @@ -97,9 +98,8 @@ import Data.List.Extra (groupSort, nubSort) import qualified Data.Map as M import Data.Maybe #if !(MIN_VERSION_base(4,11,0)) -import Data.Monoid +import Data.Semigroup (Semigroup(..)) #endif -import qualified Data.Semigroup as Sem import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T @@ -157,7 +157,7 @@ instance Show Journal where -- ,show $ map fst $ jfiles j -- ] --- The monoid instance for Journal is useful for two situations. +-- The semigroup instance for Journal is useful for two situations. -- -- 1. concatenating finalised journals, eg with multiple -f options: -- FIRST <> SECOND. The second's list fields are appended to the @@ -168,7 +168,9 @@ instance Show Journal where -- CHILD <> PARENT. A parsed journal's data is in reverse order, so -- this gives what we want. -- -instance Sem.Semigroup Journal where +-- Note that (<>) is right-biased, so nulljournal is only a left identity. +-- In particular, this prevents Journal from being a monoid. +instance Semigroup Journal where j1 <> j2 = Journal { jparsedefaultyear = jparsedefaultyear j2 ,jparsedefaultcommodity = jparsedefaultcommodity j2 @@ -190,12 +192,8 @@ instance Sem.Semigroup Journal where ,jlastreadtime = max (jlastreadtime j1) (jlastreadtime j2) } -instance Monoid Journal where - mempty = nulljournal -#if !(MIN_VERSION_base(4,11,0)) - -- This is redundant starting with base-4.11 / GHC 8.4. - mappend = (Sem.<>) -#endif +instance Default Journal where + def = nulljournal nulljournal :: Journal nulljournal = Journal { diff --git a/hledger-lib/Hledger/Read.hs b/hledger-lib/Hledger/Read.hs index f6bf68ae9..0fe07f00d 100644 --- a/hledger-lib/Hledger/Read.hs +++ b/hledger-lib/Hledger/Read.hs @@ -48,22 +48,24 @@ import Control.Arrow (right) import qualified Control.Exception as C import Control.Monad (when) import "mtl" Control.Monad.Except (runExceptT) -import Data.Default +import Data.Default (def) import Data.Foldable (asum) -import Data.List -import Data.Maybe -import Data.Ord +import Data.List (group, sort, sortBy) +import Data.List.NonEmpty (nonEmpty) +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) +import Data.Semigroup (sconcat) import Data.Text (Text) import qualified Data.Text as T import Data.Time (Day) -import Safe +import Safe (headDef) import System.Directory (doesFileExist, getHomeDirectory) import System.Environment (getEnv) import System.Exit (exitFailure) -import System.FilePath +import System.FilePath ((<.>), (), splitDirectories, splitFileName) import System.Info (os) -import System.IO -import Text.Printf +import System.IO (stderr, writeFile) +import Text.Printf (hPrintf, printf) import Hledger.Data.Dates (getCurrentDay, parsedate, showDate) import Hledger.Data.Types @@ -150,11 +152,7 @@ type PrefixedFilePath = FilePath -- Also the final parse state saved in the Journal does span all files. readJournalFiles :: InputOpts -> [PrefixedFilePath] -> IO (Either String Journal) readJournalFiles iopts = - (right mconcat1 . sequence <$>) . mapM (readJournalFile iopts) - where - mconcat1 :: Monoid t => [t] -> t - mconcat1 [] = mempty - mconcat1 x = foldr1 mappend x + fmap (right (maybe def sconcat . nonEmpty) . sequence) . mapM (readJournalFile iopts) -- | Read a Journal from this file, or from stdin if the file path is -, -- or return an error message. The file path can have a READER: prefix. diff --git a/hledger-lib/Hledger/Read/Common.hs b/hledger-lib/Hledger/Read/Common.hs index ca27d8837..aadb47626 100644 --- a/hledger-lib/Hledger/Read/Common.hs +++ b/hledger-lib/Hledger/Read/Common.hs @@ -222,7 +222,7 @@ rtp = runTextParser runJournalParser, rjp :: Monad m => JournalParser m a -> Text -> m (Either (ParseErrorBundle Text CustomErr) a) -runJournalParser p t = runParserT (evalStateT p mempty) "" t +runJournalParser p t = runParserT (evalStateT p nulljournal) "" t rjp = runJournalParser -- | Run an erroring journal parser in some monad. See also: parseWithState. @@ -232,7 +232,7 @@ runErroringJournalParser, rejp -> Text -> m (Either FinalParseError (Either (ParseErrorBundle Text CustomErr) a)) runErroringJournalParser p t = - runExceptT $ runParserT (evalStateT p mempty) "" t + runExceptT $ runParserT (evalStateT p nulljournal) "" t rejp = runErroringJournalParser genericSourcePos :: SourcePos -> GenericSourcePos @@ -680,7 +680,7 @@ amountwithoutpricep = do -- | Parse an amount from a string, or get an error. amountp' :: String -> Amount amountp' s = - case runParser (evalStateT (amountp <* eof) mempty) "" (T.pack s) of + case runParser (evalStateT (amountp <* eof) nulljournal) "" (T.pack s) of Right amt -> amt Left err -> error' $ show err -- XXX should throwError diff --git a/hledger-lib/Hledger/Read/CsvReader.hs b/hledger-lib/Hledger/Read/CsvReader.hs index 04bde3e1e..6102a456e 100644 --- a/hledger-lib/Hledger/Read/CsvReader.hs +++ b/hledger-lib/Hledger/Read/CsvReader.hs @@ -963,7 +963,7 @@ mkPosting rules record number accountFld amountFld amountInFld amountOutFld bala | all isSpace str = Nothing | otherwise = Just (either (balanceerror n str) id $ - runParser (evalStateT (amountp <* eof) mempty) "" $ + runParser (evalStateT (amountp <* eof) nulljournal) "" $ T.pack $ (currency++) $ simplifySign str ,nullsourcepos) -- XXX parse position to show when assertion fails, -- the csv record's line number would be good @@ -1039,7 +1039,7 @@ chooseAmount rules record currency amountFld amountInFld amountOutFld = parseAmount currency amountstr = either (amounterror amountstr) (Mixed . (:[])) - <$> runParser (evalStateT (amountp <* eof) mempty) "" + <$> runParser (evalStateT (amountp <* eof) nulljournal) "" <$> T.pack <$> (currency++) <$> simplifySign diff --git a/hledger-lib/Hledger/Read/JournalReader.hs b/hledger-lib/Hledger/Read/JournalReader.hs index e20380cd2..836da45f7 100644 --- a/hledger-lib/Hledger/Read/JournalReader.hs +++ b/hledger-lib/Hledger/Read/JournalReader.hs @@ -85,7 +85,7 @@ import Control.Monad.Trans.Class (lift) import Data.Either (isRight) import qualified Data.Map.Strict as M #if !(MIN_VERSION_base(4,11,0)) -import Data.Monoid ((<>)) +import Data.Semigroup ((<>)) #endif import Data.Text (Text) import Data.String @@ -298,7 +298,7 @@ includedirectivep = do put $ updatedChildj <> parentj newJournalWithParseStateFrom :: FilePath -> Journal -> Journal - newJournalWithParseStateFrom filepath j = mempty{ + newJournalWithParseStateFrom filepath j = nulljournal{ jparsedefaultyear = jparsedefaultyear j ,jparsedefaultcommodity = jparsedefaultcommodity j ,jparseparentaccounts = jparseparentaccounts j @@ -747,7 +747,7 @@ tests_JournalReader = tests "JournalReader" [ ,test "yearless date with no default year" $ assertParseError datep "1/1" "current year is unknown" ,test "yearless date with default year" $ do let s = "1/1" - ep <- parseWithState mempty{jparsedefaultyear=Just 2018} datep s + ep <- parseWithState nulljournal{jparsedefaultyear=Just 2018} datep s either (assertFailure . ("parse error at "++) . customErrorBundlePretty) (const $ return ()) ep ,test "no leading zero" $ assertParse datep "2018/1/1" ] diff --git a/hledger-lib/Hledger/Utils/Test.hs b/hledger-lib/Hledger/Utils/Test.hs index b1de72bfe..6460092bf 100644 --- a/hledger-lib/Hledger/Utils/Test.hs +++ b/hledger-lib/Hledger/Utils/Test.hs @@ -25,8 +25,9 @@ where import Control.Monad.Except (ExceptT, runExceptT) import Control.Monad.State.Strict (StateT, evalStateT, execStateT) +import Data.Default (Default(..)) #if !(MIN_VERSION_base(4,11,0)) -import Data.Monoid ((<>)) +import Data.Semigroup ((<>)) #endif -- import Data.CallStack import Data.List (isInfixOf) @@ -73,35 +74,35 @@ assertRight (Left a) = assertFailure $ "expected Right, got (Left " ++ show a + -- | Assert that this stateful parser runnable in IO successfully parses -- all of the given input text, showing the parse error if it fails. -- Suitable for hledger's JournalParser parsers. -assertParse :: (HasCallStack, Eq a, Show a, Monoid st) => +assertParse :: (HasCallStack, Eq a, Show a, Default st) => StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> Assertion assertParse parser input = do - ep <- runParserT (evalStateT (parser <* eof) mempty) "" input + ep <- runParserT (evalStateT (parser <* eof) def) "" input either (assertFailure.(++"\n").("\nparse error at "++).customErrorBundlePretty) (const $ return ()) ep -- | Assert a parser produces an expected value. -assertParseEq :: (HasCallStack, Eq a, Show a, Monoid st) => +assertParseEq :: (HasCallStack, Eq a, Show a, Default st) => StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> a -> Assertion assertParseEq parser input expected = assertParseEqOn parser input id expected -- | Like assertParseEq, but transform the parse result with the given function -- before comparing it. -assertParseEqOn :: (HasCallStack, Eq b, Show b, Monoid st) => +assertParseEqOn :: (HasCallStack, Eq b, Show b, Default st) => StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> (a -> b) -> b -> Assertion assertParseEqOn parser input f expected = do - ep <- runParserT (evalStateT (parser <* eof) mempty) "" input + ep <- runParserT (evalStateT (parser <* eof) def) "" input either (assertFailure . (++"\n") . ("\nparse error at "++) . customErrorBundlePretty) (assertEqual "" expected . f) ep -- | Assert that this stateful parser runnable in IO fails to parse -- the given input text, with a parse error containing the given string. -assertParseError :: (HasCallStack, Eq a, Show a, Monoid st) => +assertParseError :: (HasCallStack, Eq a, Show a, Default st) => StateT st (ParsecT CustomErr T.Text IO) a -> String -> String -> Assertion assertParseError parser input errstr = do - ep <- runParserT (evalStateT parser mempty) "" (T.pack input) + ep <- runParserT (evalStateT parser def) "" (T.pack input) case ep of Right v -> assertFailure $ "\nparse succeeded unexpectedly, producing:\n" ++ pshow v ++ "\n" Left e -> do @@ -113,28 +114,28 @@ assertParseError parser input errstr = do -- | Run a stateful parser in IO like assertParse, then assert that the -- final state (the wrapped state, not megaparsec's internal state), -- transformed by the given function, matches the given expected value. -assertParseStateOn :: (HasCallStack, Eq b, Show b, Monoid st) => +assertParseStateOn :: (HasCallStack, Eq b, Show b, Default st) => StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> (st -> b) -> b -> Assertion assertParseStateOn parser input f expected = do - es <- runParserT (execStateT (parser <* eof) mempty) "" input + es <- runParserT (execStateT (parser <* eof) def) "" input case es of Left err -> assertFailure $ (++"\n") $ ("\nparse error at "++) $ customErrorBundlePretty err Right s -> assertEqual "" expected $ f s -- | These "E" variants of the above are suitable for hledger's ErroringJournalParser parsers. assertParseE - :: (HasCallStack, Eq a, Show a, Monoid st) + :: (HasCallStack, Eq a, Show a, Default st) => StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a -> T.Text -> Assertion assertParseE parser input = do let filepath = "" eep <- runExceptT $ - runParserT (evalStateT (parser <* eof) mempty) filepath input + runParserT (evalStateT (parser <* eof) def) filepath input case eep of Left finalErr -> let prettyErr = finalErrorBundlePretty $ attachSource filepath input finalErr @@ -145,7 +146,7 @@ assertParseE parser input = do ep assertParseEqE - :: (Monoid st, Eq a, Show a, HasCallStack) + :: (Default st, Eq a, Show a, HasCallStack) => StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a -> T.Text -> a @@ -153,7 +154,7 @@ assertParseEqE assertParseEqE parser input expected = assertParseEqOnE parser input id expected assertParseEqOnE - :: (HasCallStack, Eq b, Show b, Monoid st) + :: (HasCallStack, Eq b, Show b, Default st) => StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a -> T.Text -> (a -> b) @@ -161,7 +162,7 @@ assertParseEqOnE -> Assertion assertParseEqOnE parser input f expected = do let filepath = "" - eep <- runExceptT $ runParserT (evalStateT (parser <* eof) mempty) filepath input + eep <- runExceptT $ runParserT (evalStateT (parser <* eof) def) filepath input case eep of Left finalErr -> let prettyErr = finalErrorBundlePretty $ attachSource filepath input finalErr @@ -172,14 +173,14 @@ assertParseEqOnE parser input f expected = do ep assertParseErrorE - :: (Monoid st, Eq a, Show a, HasCallStack) + :: (Default st, Eq a, Show a, HasCallStack) => StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a -> T.Text -> String -> Assertion assertParseErrorE parser input errstr = do let filepath = "" - eep <- runExceptT $ runParserT (evalStateT parser mempty) filepath input + eep <- runExceptT $ runParserT (evalStateT parser def) filepath input case eep of Left finalErr -> do let prettyErr = finalErrorBundlePretty $ attachSource filepath input finalErr diff --git a/hledger-web/Hledger/Web/Widget/AddForm.hs b/hledger-web/Hledger/Web/Widget/AddForm.hs index 5309e5d2e..fc60b9c06 100644 --- a/hledger-web/Hledger/Web/Widget/AddForm.hs +++ b/hledger-web/Hledger/Web/Widget/AddForm.hs @@ -166,7 +166,7 @@ validatePostings acctRes amtRes = let foldl (\s a -> s <> parseErrorTextPretty a) "" . bundleErrors) checkAccount = errorToFormMsg . runParser (accountnamep <* eof) "" . T.strip - checkAmount = errorToFormMsg . runParser (evalStateT (amountp <* eof) mempty) "" . T.strip + checkAmount = errorToFormMsg . runParser (evalStateT (amountp <* eof) nulljournal) "" . T.strip -- Add errors to forms with zero or one rows if the form is not a FormMissing result :: [(Text, Text, Either (Maybe Text, Maybe Text) Posting)]