lib: Remove non-law-abiding Monoid instance for Journal.

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 {

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.

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
 

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

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"
     ]

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

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)]