slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

lib, cli, ui: start using Control.Monad.Fail, allow base-compat 0.11

Browse Source 
fail is moving out of Monad and into it's own MonadFail class.
This will be enforced in GHC 8.8 (I think).

base-compat/base-compat-batteries 0.11.0 have adapted to this,
and are approaching stackage nightly
(https://github.com/commercialhaskell/stackage/issues/4802).

hledger is now ready to build with base-compat-batteries 0.11.0, once
all of our deps do (eg aeson). We are still compatible with the older
0.10.x and GHC 7.10.3 as well.

For now we are using both fails:

- new fail (from Control.Monad.Fail), used in our parsers, imported
  via base-compat-batteries Control.Monad.Fail.Compat to work with
  older GHC versions.

- old fail (from GHC.Base, exported by Prelude, Control.Monad,
  Control.Monad.State.Strict, Prelude.Compat, ...), used in easytest's
  Test, since I couldn't find their existing fail implementation to update.

To reduce (my) confusion, these are imported carefully, consistently,
and qualified everywhere as Fail.fail and Prelude.fail, with clashing
re-exports suppressed, like so:

import Prelude hiding (fail)
import qualified Prelude (fail)
import Control.Monad.State.Strict hiding (fail)
import "base-compat-batteries" Prelude.Compat hiding (fail)
import qualified "base-compat-batteries" Control.Monad.Fail.Compat as Fail
This commit is contained in:
Simon Michael 2019-09-08 17:13:47 -07:00
parent c7746131fc
commit 499e20c0b2
12 changed files with 49 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
hledger-lib/Hledger/Data/Dates.hs
View File

@ -77,9 +77,10 @@ module Hledger.Data.Dates (
where where
import Prelude () import Prelude ()
import "base-compat-batteries" Prelude.Compat import "base-compat-batteries" Prelude.Compat hiding (fail)
import qualified "base-compat-batteries" Control.Monad.Fail.Compat as Fail (MonadFail, fail)
import Control.Applicative.Permutations import Control.Applicative.Permutations
import Control.Monad import Control.Monad (unless)
import "base-compat-batteries" Data.List.Compat import "base-compat-batteries" Data.List.Compat
import Data.Default import Data.Default
import Data.Maybe import Data.Maybe
@ -771,10 +772,10 @@ validYear s = length s >= 4 && isJust (readMay s :: Maybe Year)
validMonth s = maybe False (\n -> n>=1 && n<=12) $ readMay s validMonth s = maybe False (\n -> n>=1 && n<=12) $ readMay s
validDay s = maybe False (\n -> n>=1 && n<=31) $ readMay s validDay s = maybe False (\n -> n>=1 && n<=31) $ readMay s
failIfInvalidYear, failIfInvalidMonth, failIfInvalidDay :: (Monad m) => String -> m () failIfInvalidYear, failIfInvalidMonth, failIfInvalidDay :: (Fail.MonadFail m) => String -> m ()
failIfInvalidYear s = unless (validYear s) $ fail $ "bad year number: " ++ s failIfInvalidYear s = unless (validYear s) $ Fail.fail $ "bad year number: " ++ s
failIfInvalidMonth s = unless (validMonth s) $ fail $ "bad month number: " ++ s failIfInvalidMonth s = unless (validMonth s) $ Fail.fail $ "bad month number: " ++ s
failIfInvalidDay s = unless (validDay s) $ fail $ "bad day number: " ++ s failIfInvalidDay s = unless (validDay s) $ Fail.fail $ "bad day number: " ++ s
yyyymmdd :: TextParser m SmartDate yyyymmdd :: TextParser m SmartDate
yyyymmdd = do yyyymmdd = do
@ -864,8 +865,8 @@ weekday = do
wday <- T.toLower <$> (choice . map string' $ weekdays ++ weekdayabbrevs) wday <- T.toLower <$> (choice . map string' $ weekdays ++ weekdayabbrevs)
case catMaybes $ [wday `elemIndex` weekdays, wday `elemIndex` weekdayabbrevs] of case catMaybes $ [wday `elemIndex` weekdays, wday `elemIndex` weekdayabbrevs] of
(i:_) -> return (i+1) (i:_) -> return (i+1)
[] -> fail $ "weekday: should not happen: attempted to find " <> [] -> Fail.fail $ "weekday: should not happen: attempted to find " <>
show wday <> " in " <> show (weekdays ++ weekdayabbrevs) show wday <> " in " <> show (weekdays ++ weekdayabbrevs)
today,yesterday,tomorrow :: TextParser m SmartDate today,yesterday,tomorrow :: TextParser m SmartDate
today = string' "today" >> return ("","","today") today = string' "today" >> return ("","","today")

12
hledger-lib/Hledger/Read/Common.hs
View File

@ -100,10 +100,10 @@ module Hledger.Read.Common (
where where
--- * imports --- * imports
import Prelude () import Prelude ()
import "base-compat-batteries" Prelude.Compat hiding (readFile) import "base-compat-batteries" Prelude.Compat hiding (fail, readFile)
import "base-compat-batteries" Control.Monad.Compat import qualified "base-compat-batteries" Control.Monad.Fail.Compat as Fail (fail)
import Control.Monad.Except (ExceptT(..), runExceptT, throwError) import Control.Monad.Except (ExceptT(..), runExceptT, throwError)
import Control.Monad.State.Strict import Control.Monad.State.Strict hiding (fail)
import Data.Bifunctor (bimap, second) import Data.Bifunctor (bimap, second)
import Data.Char import Data.Char
import Data.Data import Data.Data
@ -781,7 +781,7 @@ numberp suggestedStyle = label "number" $ do
dbg8 "numberp suggestedStyle" suggestedStyle `seq` return () dbg8 "numberp suggestedStyle" suggestedStyle `seq` return ()
case dbg8 "numberp quantity,precision,mdecimalpoint,mgrps" case dbg8 "numberp quantity,precision,mdecimalpoint,mgrps"
$ fromRawNumber rawNum mExp of $ fromRawNumber rawNum mExp of
Left errMsg -> fail errMsg Left errMsg -> Fail.fail errMsg
Right (q, p, d, g) -> pure (sign q, p, d, g) Right (q, p, d, g) -> pure (sign q, p, d, g)
exponentp :: TextParser m Int exponentp :: TextParser m Int
@ -883,7 +883,7 @@ rawnumberp = label "number" $ do
-- Guard against mistyped numbers -- Guard against mistyped numbers
mExtraDecimalSep <- optional $ lookAhead $ satisfy isDecimalPointChar mExtraDecimalSep <- optional $ lookAhead $ satisfy isDecimalPointChar
when (isJust mExtraDecimalSep) $ when (isJust mExtraDecimalSep) $
fail "invalid number (invalid use of separator)" Fail.fail "invalid number (invalid use of separator)"
mExtraFragment <- optional $ lookAhead $ try $ mExtraFragment <- optional $ lookAhead $ try $
char ' ' *> getOffset <* digitChar char ' ' *> getOffset <* digitChar
@ -1273,7 +1273,7 @@ bracketeddatetagsp mYear1 = do
$ between (char '[') (char ']') $ between (char '[') (char ']')
$ takeWhile1P Nothing isBracketedDateChar $ takeWhile1P Nothing isBracketedDateChar
unless (T.any isDigit s && T.any isDateSepChar s) $ unless (T.any isDigit s && T.any isDateSepChar s) $
fail "not a bracketed date" Fail.fail "not a bracketed date"
-- Looks sufficiently like a bracketed date to commit to parsing a date -- Looks sufficiently like a bracketed date to commit to parsing a date
between (char '[') (char ']') $ do between (char '[') (char ']') $ do

7
hledger-lib/Hledger/Read/CsvReader.hs
View File

@ -31,7 +31,8 @@ module Hledger.Read.CsvReader (
) )
where where
import Prelude () import Prelude ()
import "base-compat-batteries" Prelude.Compat import "base-compat-batteries" Prelude.Compat hiding (fail)
import qualified "base-compat-batteries" Control.Monad.Fail.Compat as Fail (fail)
import Control.Exception hiding (try) import Control.Exception hiding (try)
import Control.Monad import Control.Monad
import Control.Monad.Except import Control.Monad.Except
@ -599,7 +600,7 @@ conditionalblockp = do
ms <- some recordmatcherp ms <- some recordmatcherp
as <- many (lift (skipSome spacenonewline) >> fieldassignmentp) as <- many (lift (skipSome spacenonewline) >> fieldassignmentp)
when (null as) $ when (null as) $
fail "start of conditional block found, but no assignment rules afterward\n(assignment rules in a conditional block should be indented)\n" Fail.fail "start of conditional block found, but no assignment rules afterward\n(assignment rules in a conditional block should be indented)\n"
return (ms, as) return (ms, as)
<?> "conditional block" <?> "conditional block"
@ -610,7 +611,7 @@ recordmatcherp = do
_ <- optional (matchoperatorp >> lift (skipMany spacenonewline) >> optional newline) _ <- optional (matchoperatorp >> lift (skipMany spacenonewline) >> optional newline)
ps <- patternsp ps <- patternsp
when (null ps) $ when (null ps) $
fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)\n" Fail.fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)\n"
return ps return ps
<?> "record matcher" <?> "record matcher"

17
hledger-lib/Hledger/Read/JournalReader.hs
View File

@ -63,12 +63,15 @@ module Hledger.Read.JournalReader (
) )
where where
--- * imports --- * imports
import Prelude () import qualified Prelude (fail)
import "base-compat-batteries" Prelude.Compat hiding (readFile) import "base-compat-batteries" Prelude.Compat hiding (fail, readFile)
import qualified "base-compat-batteries" Control.Monad.Fail.Compat as Fail (fail)
import qualified Control.Exception as C import qualified Control.Exception as C
import Control.Monad import Control.Monad (forM_, when, void)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Except (ExceptT(..), runExceptT) import Control.Monad.Except (ExceptT(..), runExceptT)
import Control.Monad.State.Strict import Control.Monad.State.Strict (get,modify',put)
import Control.Monad.Trans.Class (lift)
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Text (Text) import Data.Text (Text)
import Data.String import Data.String
@ -215,7 +218,7 @@ includedirectivep = do
let parentfilestack = jincludefilestack parentj let parentfilestack = jincludefilestack parentj
when (filepath `elem` parentfilestack) $ when (filepath `elem` parentfilestack) $
fail ("Cyclic include: " ++ filepath) Fail.fail ("Cyclic include: " ++ filepath)
childInput <- lift $ readFilePortably filepath childInput <- lift $ readFilePortably filepath
`orRethrowIOError` (show parentpos ++ " reading " ++ filepath) `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)
@ -251,7 +254,7 @@ orRethrowIOError io msg = do
eResult <- liftIO $ (Right <$> io) `C.catch` \(e::C.IOException) -> pure $ Left $ printf "%s:\n%s" msg (show e) eResult <- liftIO $ (Right <$> io) `C.catch` \(e::C.IOException) -> pure $ Left $ printf "%s:\n%s" msg (show e)
case eResult of case eResult of
Right res -> pure res Right res -> pure res
Left errMsg -> fail errMsg Left errMsg -> Fail.fail errMsg
-- Parse an account directive, adding its info to the journal's -- Parse an account directive, adding its info to the journal's
-- list of account declarations. -- list of account declarations.
@ -682,7 +685,7 @@ tests_JournalReader = tests "JournalReader" [
test "yearless date with default year" $ do test "yearless date with default year" $ do
let s = "1/1" let s = "1/1"
ep <- parseWithState mempty{jparsedefaultyear=Just 2018} datep s ep <- parseWithState mempty{jparsedefaultyear=Just 2018} datep s
either (fail.("parse error at "++).customErrorBundlePretty) (const ok) ep either (Prelude.fail . ("parse error at "++) . customErrorBundlePretty) (const ok) ep
test "no leading zero" $ expectParse datep "2018/1/1" test "no leading zero" $ expectParse datep "2018/1/1"
,test "datetimep" $ do ,test "datetimep" $ do

8
hledger-lib/hledger-lib.cabal
View File

@ -4,7 +4,7 @@ cabal-version: 1.12
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: 567ed725b211714a0f6db5e17a68d670789c7e603020b42d6b8f18e7af5ceb63 -- hash: c4535c00ecf88919b278f19cdd8f72caf2212d43fb3dc6ee21299451ee977ea0
name: hledger-lib name: hledger-lib
version: 1.15.2 version: 1.15.2
@ -108,7 +108,7 @@ library
, ansi-terminal >=0.6.2.3 , ansi-terminal >=0.6.2.3
, array , array
, base >=4.8 && <4.13 , base >=4.8 && <4.13
, base-compat-batteries >=0.10.1 && <0.11 , base-compat-batteries >=0.10.1 && <0.12
, blaze-markup >=0.5.1 , blaze-markup >=0.5.1
, bytestring , bytestring
, call-stack , call-stack
@ -211,7 +211,7 @@ test-suite doctests
, ansi-terminal >=0.6.2.3 , ansi-terminal >=0.6.2.3
, array , array
, base >=4.8 && <4.13 , base >=4.8 && <4.13
, base-compat-batteries >=0.10.1 && <0.11 , base-compat-batteries >=0.10.1 && <0.12
, blaze-markup >=0.5.1 , blaze-markup >=0.5.1
, bytestring , bytestring
, call-stack , call-stack
@ -317,7 +317,7 @@ test-suite easytests
, ansi-terminal >=0.6.2.3 , ansi-terminal >=0.6.2.3
, array , array
, base >=4.8 && <4.13 , base >=4.8 && <4.13
, base-compat-batteries >=0.10.1 && <0.11 , base-compat-batteries >=0.10.1 && <0.12
, blaze-markup >=0.5.1 , blaze-markup >=0.5.1
, bytestring , bytestring
, call-stack , call-stack

2
hledger-lib/package.yaml
View File

@ -40,7 +40,7 @@ extra-source-files:
dependencies: dependencies:
- base >=4.8 && <4.13 - base >=4.8 && <4.13
- base-compat-batteries >=0.10.1 && <0.11 - base-compat-batteries >=0.10.1 && <0.12
- ansi-terminal >=0.6.2.3 - ansi-terminal >=0.6.2.3
- array - array
- blaze-markup >=0.5.1 - blaze-markup >=0.5.1

4
hledger-ui/hledger-ui.cabal
View File

@ -4,7 +4,7 @@ cabal-version: 1.12
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: 0deef0df7a1a0ef153ebf7e31ddd57882a2671941a0f801bc2980dae7080501f -- hash: b157e8031b886cdba4226a4710189f672b05418f5bb4889477f6b3b6369c6f4d
name: hledger-ui name: hledger-ui
version: 1.15 version: 1.15
@ -69,7 +69,7 @@ executable hledger-ui
ansi-terminal >=0.6.2.3 ansi-terminal >=0.6.2.3
, async , async
, base >=4.8 && <4.13 , base >=4.8 && <4.13
, base-compat-batteries >=0.10.1 && <0.11 , base-compat-batteries >=0.10.1 && <0.12
, cmdargs >=0.8 , cmdargs >=0.8
, containers , containers
, data-default , data-default

2
hledger-ui/package.yaml
View File

@ -45,7 +45,7 @@ dependencies:
- ansi-terminal >=0.6.2.3 - ansi-terminal >=0.6.2.3
- async - async
- base >=4.8 && <4.13 - base >=4.8 && <4.13
- base-compat-batteries >=0.10.1 && <0.11 - base-compat-batteries >=0.10.1 && <0.12
- cmdargs >=0.8 - cmdargs >=0.8
- containers - containers
- data-default - data-default

6
hledger/Hledger/Cli/Commands/Add.hs
View File

@ -16,9 +16,9 @@ module Hledger.Cli.Commands.Add (
where where
import Prelude () import Prelude ()
import "base-compat-batteries" Prelude.Compat import "base-compat-batteries" Prelude.Compat hiding (fail)
import Control.Exception as E import Control.Exception as E
import Control.Monad import Control.Monad (when)
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Control.Monad.State.Strict (evalState, evalStateT) import Control.Monad.State.Strict (evalState, evalStateT)
import Control.Monad.Trans (liftIO) import Control.Monad.Trans (liftIO)
@ -118,7 +118,7 @@ getAndAddTransactions :: EntryState -> IO ()
getAndAddTransactions es@EntryState{..} = (do getAndAddTransactions es@EntryState{..} = (do
mt <- runInputT (setComplete noCompletion defaultSettings) (System.Console.Wizard.run $ haskeline $ confirmedTransactionWizard es) mt <- runInputT (setComplete noCompletion defaultSettings) (System.Console.Wizard.run $ haskeline $ confirmedTransactionWizard es)
case mt of case mt of
Nothing -> fail "urk ?" Nothing -> error "Could not interpret the input, restarting" -- caught below causing a restart, I believe
Just t -> do Just t -> do
j <- if debug_ esOpts > 0 j <- if debug_ esOpts > 0
then do hPrintf stderr "Skipping journal add due to debug mode.\n" then do hPrintf stderr "Skipping journal add due to debug mode.\n"

10
hledger/hledger.cabal
View File

@ -4,7 +4,7 @@ cabal-version: 1.12
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: f839c60877b230c5cb9cffe709ab8f7f6d770f16c15c68c25b3aed3cc0c65bb0 -- hash: f7a17b233540faa8cabd06b8cdac862fff8b1c1dfcaa46d74467bff5a0f1853b
name: hledger name: hledger
version: 1.15.2 version: 1.15.2
@ -152,7 +152,7 @@ library
, Diff , Diff
, ansi-terminal >=0.6.2.3 , ansi-terminal >=0.6.2.3
, base >=4.8 && <4.13 , base >=4.8 && <4.13
, base-compat-batteries >=0.10.1 && <0.11 , base-compat-batteries >=0.10.1 && <0.12
, bytestring , bytestring
, cmdargs >=0.10 , cmdargs >=0.10
, containers , containers
@ -204,7 +204,7 @@ executable hledger
Decimal Decimal
, ansi-terminal >=0.6.2.3 , ansi-terminal >=0.6.2.3
, base >=4.8 && <4.13 , base >=4.8 && <4.13
, base-compat-batteries >=0.10.1 && <0.11 , base-compat-batteries >=0.10.1 && <0.12
, bytestring , bytestring
, cmdargs >=0.10 , cmdargs >=0.10
, containers , containers
@ -258,7 +258,7 @@ test-suite test
Decimal Decimal
, ansi-terminal >=0.6.2.3 , ansi-terminal >=0.6.2.3
, base >=4.8 && <4.13 , base >=4.8 && <4.13
, base-compat-batteries >=0.10.1 && <0.11 , base-compat-batteries >=0.10.1 && <0.12
, bytestring , bytestring
, cmdargs >=0.10 , cmdargs >=0.10
, containers , containers
@ -311,7 +311,7 @@ benchmark bench
Decimal Decimal
, ansi-terminal >=0.6.2.3 , ansi-terminal >=0.6.2.3
, base >=4.8 && <4.13 , base >=4.8 && <4.13
, base-compat-batteries >=0.10.1 && <0.11 , base-compat-batteries >=0.10.1 && <0.12
, bytestring , bytestring
, cmdargs >=0.10 , cmdargs >=0.10
, containers , containers

2
hledger/package.yaml
View File

@ -111,7 +111,7 @@ dependencies:
- hledger-lib >=1.15.2 && <1.16 - hledger-lib >=1.15.2 && <1.16
- ansi-terminal >=0.6.2.3 - ansi-terminal >=0.6.2.3
- base >=4.8 && <4.13 - base >=4.8 && <4.13
- base-compat-batteries >=0.10.1 && <0.11 - base-compat-batteries >=0.10.1 && <0.12
- bytestring - bytestring
- cmdargs >=0.10 - cmdargs >=0.10
- containers - containers

3
stack.yaml
View File

@ -18,6 +18,9 @@ nix:
extra-deps: extra-deps:
# for hledger-lib: # for hledger-lib:
# testing:
# - base-compat-batteries-0.11.0
# - base-compat-0.11.0
# for hledger: # for hledger:
# for hledger-ui: # for hledger-ui:
# for hledger-web: # for hledger-web: