From e63138ef7d2ef85bd0737386433440ad61cb9a8c Mon Sep 17 00:00:00 2001 From: Stephen Morgan Date: Sun, 27 Dec 2020 18:59:30 +1100 Subject: [PATCH] lib,cli: Assorted fixes for older GHC. --- hledger-lib/Hledger/Data/Amount.hs | 4 + hledger-lib/Hledger/Data/Timeclock.hs | 4 + hledger-lib/Hledger/Data/Transaction.hs | 12 ++- hledger-lib/Hledger/Read.hs | 8 +- hledger-lib/Hledger/Utils/Color.hs | 4 + hledger-lib/Hledger/Utils/Regex.hs | 4 +- hledger-lib/Text/Tabular/AsciiWide.hs | 4 + hledger-lib/Text/WideString.hs | 8 ++ hledger/Hledger/Cli/Commands/Aregister.hs | 3 - .../Cli/Commands/Check/Uniqueleafnames.hs | 8 +- hledger/Hledger/Cli/Commands/Checkdates.hs | 76 +++++++++++++++++++ hledger/Hledger/Cli/Commands/Print.hs | 6 +- hledger/Hledger/Cli/Commands/Register.hs | 9 ++- 13 files changed, 133 insertions(+), 17 deletions(-) create mode 100755 hledger/Hledger/Cli/Commands/Checkdates.hs diff --git a/hledger-lib/Hledger/Data/Amount.hs b/hledger-lib/Hledger/Data/Amount.hs index c29308fff..888e1ad3b 100644 --- a/hledger-lib/Hledger/Data/Amount.hs +++ b/hledger-lib/Hledger/Data/Amount.hs @@ -40,6 +40,7 @@ exchange rates. -} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} @@ -143,6 +144,9 @@ import Data.List.NonEmpty (NonEmpty(..), nonEmpty) import qualified Data.Map as M import Data.Map (findWithDefault) import Data.Maybe (fromMaybe) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup ((<>)) +#endif import qualified Data.Text as T import qualified Data.Text.Lazy.Builder as TB import Data.Word (Word8) diff --git a/hledger-lib/Hledger/Data/Timeclock.hs b/hledger-lib/Hledger/Data/Timeclock.hs index 9b51ad8b1..2d5f1fea2 100644 --- a/hledger-lib/Hledger/Data/Timeclock.hs +++ b/hledger-lib/Hledger/Data/Timeclock.hs @@ -6,6 +6,7 @@ converted to 'Transactions' and queried like a ledger. -} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Hledger.Data.Timeclock ( @@ -15,6 +16,9 @@ module Hledger.Data.Timeclock ( where import Data.Maybe (fromMaybe) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup ((<>)) +#endif -- import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (addDays) diff --git a/hledger-lib/Hledger/Data/Transaction.hs b/hledger-lib/Hledger/Data/Transaction.hs index c65de1823..f7a31a029 100644 --- a/hledger-lib/Hledger/Data/Transaction.hs +++ b/hledger-lib/Hledger/Data/Transaction.hs @@ -7,11 +7,12 @@ tags. -} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RecordWildCards #-} module Hledger.Data.Transaction ( -- * Transaction @@ -60,6 +61,9 @@ import Data.Default (def) import Data.List (intercalate, partition) import Data.List.Extra (nubSort) import Data.Maybe (fromMaybe, mapMaybe) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup ((<>)) +#endif import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL diff --git a/hledger-lib/Hledger/Read.hs b/hledger-lib/Hledger/Read.hs index dc0f3418d..006acb992 100644 --- a/hledger-lib/Hledger/Read.hs +++ b/hledger-lib/Hledger/Read.hs @@ -11,8 +11,9 @@ to import modules below this one. -} --- ** language -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} --- ** exports @@ -53,6 +54,9 @@ import Data.List (group, sort, sortBy) import Data.List.NonEmpty (nonEmpty) import Data.Maybe (fromMaybe) import Data.Ord (comparing) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup ((<>)) +#endif import Data.Semigroup (sconcat) import Data.Text (Text) import qualified Data.Text as T diff --git a/hledger-lib/Hledger/Utils/Color.hs b/hledger-lib/Hledger/Utils/Color.hs index 8fb94604b..fb792655d 100644 --- a/hledger-lib/Hledger/Utils/Color.hs +++ b/hledger-lib/Hledger/Utils/Color.hs @@ -1,5 +1,6 @@ -- | Basic color helpers for prettifying console output. +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Hledger.Utils.Color @@ -13,6 +14,9 @@ module Hledger.Utils.Color ) where +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup ((<>)) +#endif import qualified Data.Text.Lazy.Builder as TB import System.Console.ANSI import Hledger.Utils.Text (WideBuilder(..)) diff --git a/hledger-lib/Hledger/Utils/Regex.hs b/hledger-lib/Hledger/Utils/Regex.hs index eeb712abc..4d85c9301 100644 --- a/hledger-lib/Hledger/Utils/Regex.hs +++ b/hledger-lib/Hledger/Utils/Regex.hs @@ -132,11 +132,11 @@ instance RegexContext Regexp String String where -- Convert a Regexp string to a compiled Regex, or return an error message. toRegex :: Text -> Either RegexError Regexp -toRegex = memo $ \s -> mkRegexErr s (Regexp s <$> makeRegexM s) +toRegex = memo $ \s -> mkRegexErr s (Regexp s <$> makeRegexM (T.unpack s)) -- Have to unpack here because Text instance in regex-tdfa only appears in 1.3.1 -- Like toRegex, but make a case-insensitive Regex. toRegexCI :: Text -> Either RegexError Regexp -toRegexCI = memo $ \s -> mkRegexErr s (RegexpCI s <$> makeRegexOptsM defaultCompOpt{caseSensitive=False} defaultExecOpt s) +toRegexCI = memo $ \s -> mkRegexErr s (RegexpCI s <$> makeRegexOptsM defaultCompOpt{caseSensitive=False} defaultExecOpt (T.unpack s)) -- Have to unpack here because Text instance in regex-tdfa only appears in 1.3.1 -- | Make a nice error message for a regexp error. mkRegexErr :: Text -> Maybe a -> Either RegexError a diff --git a/hledger-lib/Text/Tabular/AsciiWide.hs b/hledger-lib/Text/Tabular/AsciiWide.hs index b222403b6..18c144c35 100644 --- a/hledger-lib/Text/Tabular/AsciiWide.hs +++ b/hledger-lib/Text/Tabular/AsciiWide.hs @@ -1,6 +1,7 @@ -- | Text.Tabular.AsciiArt from tabular-0.2.2.7, modified to treat -- wide characters as double width. +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Text.Tabular.AsciiWide where @@ -8,6 +9,9 @@ module Text.Tabular.AsciiWide where import Data.Maybe (fromMaybe) import Data.Default (Default(..)) import Data.List (intersperse, transpose) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup ((<>)) +#endif import Data.Semigroup (stimesMonoid) import Data.Text (Text) import qualified Data.Text as T diff --git a/hledger-lib/Text/WideString.hs b/hledger-lib/Text/WideString.hs index eb2d7e491..a055002a6 100644 --- a/hledger-lib/Text/WideString.hs +++ b/hledger-lib/Text/WideString.hs @@ -1,5 +1,7 @@ -- | Calculate the width of String and Text, being aware of wide characters. +{-# LANGUAGE CPP #-} + module Text.WideString ( -- * wide-character-aware layout strWidth, @@ -11,6 +13,9 @@ module Text.WideString ( wbToText ) where +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup (Semigroup(..)) +#endif import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -28,6 +33,9 @@ instance Semigroup WideBuilder where instance Monoid WideBuilder where mempty = WideBuilder mempty 0 +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) +#endif -- | Convert a WideBuilder to a strict Text. wbToText :: WideBuilder -> Text diff --git a/hledger/Hledger/Cli/Commands/Aregister.hs b/hledger/Hledger/Cli/Commands/Aregister.hs index 1e66be4d8..ade19b59a 100644 --- a/hledger/Hledger/Cli/Commands/Aregister.hs +++ b/hledger/Hledger/Cli/Commands/Aregister.hs @@ -21,9 +21,6 @@ module Hledger.Cli.Commands.Aregister ( import Data.List (intersperse) import Data.Maybe (fromMaybe, isJust) -#if !(MIN_VERSION_base(4,11,0)) -import Data.Semigroup ((<>)) -#endif import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB diff --git a/hledger/Hledger/Cli/Commands/Check/Uniqueleafnames.hs b/hledger/Hledger/Cli/Commands/Check/Uniqueleafnames.hs index 31e6c727f..1fd112a06 100755 --- a/hledger/Hledger/Cli/Commands/Check/Uniqueleafnames.hs +++ b/hledger/Hledger/Cli/Commands/Check/Uniqueleafnames.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Hledger.Cli.Commands.Check.Uniqueleafnames ( @@ -5,10 +6,13 @@ module Hledger.Cli.Commands.Check.Uniqueleafnames ( ) where -import Data.Function -import Data.List +import Data.Function (on) +import Data.List (groupBy, sortBy) import Data.List.Extra (nubSort) import Data.Text (Text) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup ((<>)) +#endif import qualified Data.Text as T import qualified Data.Text.IO as T import Hledger diff --git a/hledger/Hledger/Cli/Commands/Checkdates.hs b/hledger/Hledger/Cli/Commands/Checkdates.hs new file mode 100755 index 000000000..00c1f215c --- /dev/null +++ b/hledger/Hledger/Cli/Commands/Checkdates.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoOverloadedStrings #-} -- prevent trouble if turned on in ghci +{-# LANGUAGE TemplateHaskell #-} + +module Hledger.Cli.Commands.Checkdates ( + checkdatesmode + ,checkdates +) where + +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup ((<>)) +#endif +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Hledger +import Hledger.Cli.CliOptions +import System.Console.CmdArgs.Explicit +import System.Exit + +checkdatesmode :: Mode RawOpts +checkdatesmode = hledgerCommandMode + $(embedFileRelative "Hledger/Cli/Commands/Checkdates.txt") + [flagNone ["unique"] (setboolopt "unique") "require that dates are unique"] + [generalflagsgroup1] + hiddenflags + ([], Just $ argsFlag "[QUERY]") + +checkdates :: CliOpts -> Journal -> IO () +checkdates CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do + let ropts = (rsOpts rspec){accountlistmode_=ALFlat} + let ts = filter (rsQuery rspec `matchesTransaction`) $ + jtxns $ journalSelectingAmountFromOpts ropts j + -- pprint rawopts + let unique = boolopt "--unique" rawopts -- TEMP: it's this for hledger check dates + || boolopt "unique" rawopts -- and this for hledger check-dates (for some reason) + let date = transactionDateFn ropts + let compare a b = + if unique + then date a < date b + else date a <= date b + case checkTransactions compare ts of + FoldAcc{fa_previous=Nothing} -> return () + FoldAcc{fa_error=Nothing} -> return () + FoldAcc{fa_error=Just error, fa_previous=Just previous} -> do + let + uniquestr = T.pack $ if unique then " and/or not unique" else "" + positionstr = T.pack . showGenericSourcePos $ tsourcepos error + txn1str = linesPrepend (T.pack " ") $ showTransaction previous + txn2str = linesPrepend2 (T.pack "> ") (T.pack " ") $ showTransaction error + T.putStrLn $ + T.pack "Error: transaction date is out of order" + <> uniquestr <> T.pack "\nat " <> positionstr <> T.pack ":\n\n" + <> txn1str <> txn2str + exitFailure + +data FoldAcc a b = FoldAcc + { fa_error :: Maybe a + , fa_previous :: Maybe b + } + +foldWhile :: (a -> FoldAcc a b -> FoldAcc a b) -> FoldAcc a b -> [a] -> FoldAcc a b +foldWhile _ acc [] = acc +foldWhile fold acc (a:as) = + case fold a acc of + acc@FoldAcc{fa_error=Just _} -> acc + acc -> foldWhile fold acc as + +checkTransactions :: (Transaction -> Transaction -> Bool) + -> [Transaction] -> FoldAcc Transaction Transaction +checkTransactions compare = foldWhile f FoldAcc{fa_error=Nothing, fa_previous=Nothing} + where + f current acc@FoldAcc{fa_previous=Nothing} = acc{fa_previous=Just current} + f current acc@FoldAcc{fa_previous=Just previous} = + if compare previous current + then acc{fa_previous=Just current} + else acc{fa_error=Just current} diff --git a/hledger/Hledger/Cli/Commands/Print.hs b/hledger/Hledger/Cli/Commands/Print.hs index 7fab06562..5fbcf5eaa 100644 --- a/hledger/Hledger/Cli/Commands/Print.hs +++ b/hledger/Hledger/Cli/Commands/Print.hs @@ -4,8 +4,9 @@ A ledger-compatible @print@ command. -} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} module Hledger.Cli.Commands.Print ( printmode @@ -18,6 +19,9 @@ where import Data.Maybe (isJust) import Data.Text (Text) import Data.List (intersperse) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup ((<>)) +#endif import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL diff --git a/hledger/Hledger/Cli/Commands/Register.hs b/hledger/Hledger/Cli/Commands/Register.hs index 0211d9593..26f552755 100644 --- a/hledger/Hledger/Cli/Commands/Register.hs +++ b/hledger/Hledger/Cli/Commands/Register.hs @@ -4,10 +4,10 @@ A ledger-compatible @register@ command. -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} module Hledger.Cli.Commands.Register ( registermode @@ -20,6 +20,9 @@ module Hledger.Cli.Commands.Register ( import Data.List (intersperse) import Data.Maybe (fromMaybe, isJust) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup ((<>)) +#endif -- import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL