dev: fix some partial head/tails, silence ghc 9.8's new warnings

Note the headErr/tailErr calls will print stack traces if they fail
(small ones: five lines, one of which is the useful location info),
which may or may not be best UX.
This commit is contained in:
Simon Michael 2024-02-28 15:36:20 -10:00
parent 697e5a5671
commit 8f1ae401f4
22 changed files with 73 additions and 55 deletions

View File

@ -311,7 +311,7 @@ elideAccountName width s
elideparts :: Int -> [Text] -> [Text] -> [Text]
elideparts w done ss
| realLength (accountNameFromComponents $ done++ss) <= w = done++ss
| length ss > 1 = elideparts w (done++[textTakeWidth 2 $ head ss]) (tail ss)
| length ss > 1 = elideparts w (done++[textTakeWidth 2 $ headErr ss]) (tailErr ss) -- PARTIAL headErr, tailErr will succeed because length > 1
| otherwise = done++ss
-- | Keep only the first n components of an account name, where n

View File

@ -46,6 +46,7 @@ import qualified Data.Set as S
import qualified Data.Text as T
import Data.Time.Calendar (fromGregorian)
import qualified Data.Map as M
import Safe (headErr)
import Text.Printf (printf)
import Hledger.Utils
@ -834,7 +835,7 @@ tests_Balancing =
[posting {paccount = "a", pamount = mixedAmount (usd 1)}, posting {paccount = "b", pamount = missingmixedamt}])) @?=
Right (mixedAmount $ usd (-1))
,testCase "conversion price is inferred" $
(pamount . head . tpostings <$>
(pamount . headErr . tpostings <$> -- PARTIAL headErr succeeds because non-null postings list
balanceTransaction defbalancingopts
(Transaction
0
@ -1026,7 +1027,7 @@ tests_Balancing =
transaction (fromGregorian 2019 01 01) [ vpost' "a" missingamt (balassert (num 1)) ]
]}
assertRight ej
case ej of Right j -> (jtxns j & head & tpostings & head & pamount & amountsRaw) @?= [num 1]
case ej of Right j -> (jtxns j & headErr & tpostings & headErr & pamount & amountsRaw) @?= [num 1] -- PARTIAL headErrs succeed because non-null txns & postings lists given
Left _ -> error' "balance-assignment test: shouldn't happen"
,testCase "same-day-1" $ do

View File

@ -105,7 +105,7 @@ import Data.Time.Calendar
import Data.Time.Calendar.OrdinalDate (fromMondayStartWeek, mondayStartWeek)
import Data.Time.Clock (UTCTime, diffUTCTime)
import Data.Time.LocalTime (getZonedTime, localDay, zonedTimeToLocalTime)
import Safe (headMay, lastMay, maximumMay, minimumMay)
import Safe (headErr, headMay, lastMay, maximumMay, minimumMay)
import Text.Megaparsec
import Text.Megaparsec.Char (char, char', digitChar, string, string')
import Text.Megaparsec.Char.Lexer (decimal, signed)
@ -900,7 +900,7 @@ weekday = do
show wday <> " in " <> show (weekdays ++ weekdayabbrevs)
weekdaysp :: TextParser m [Int]
weekdaysp = fmap head . group . sort <$> sepBy1 weekday (string' ",")
weekdaysp = fmap headErr . group . sort <$> sepBy1 weekday (string' ",") -- PARTIAL headErr will succeed because of sepBy1
-- | Parse a period expression, specifying a date span and optionally
-- a reporting interval. Requires a reference "today" date for

View File

@ -9,6 +9,7 @@ import Data.Function (on)
import Data.List (groupBy, sortBy)
import Data.Text (Text)
import qualified Data.Text as T
import Safe (headErr)
import Text.Printf (printf)
import Hledger.Data.AccountName (accountLeafName)
@ -55,10 +56,14 @@ journalCheckUniqueleafnames j = do
finddupes :: (Ord leaf, Eq full) => [(leaf, full)] -> [(leaf, [full])]
finddupes leafandfullnames = zip dupLeafs dupAccountNames
where dupLeafs = map (fst . head) d
dupAccountNames = map (map snd) d
d = dupes' leafandfullnames
dupes' = filter ((> 1) . length)
where
dupAccountNames = map (map snd) dupes
dupLeafs = case dupes of
[] -> []
_ -> map (fst . headErr) dupes -- PARTIAL headErr succeeds because of pattern
dupes = fnddupes leafandfullnames
where
fnddupes = filter ((> 1) . length)
. groupBy ((==) `on` fst)
. sortBy (compare `on` fst)

View File

@ -80,7 +80,7 @@ ledgerRootAccount = headDef nullacct . laccounts
-- | List a ledger's top-level accounts (the ones below the root), in tree order.
ledgerTopAccounts :: Ledger -> [Account]
ledgerTopAccounts = asubs . head . laccounts
ledgerTopAccounts = asubs . headDef nullacct . laccounts
-- | List a ledger's bottom-level (subaccount-less) accounts, in tree order.
ledgerLeafAccounts :: Ledger -> [Account]

View File

@ -19,6 +19,7 @@ import qualified Data.Map as M
import Data.Maybe (catMaybes)
import qualified Data.Text as T
import Data.Time.Calendar (Day)
import Safe (headDef)
import Hledger.Data.Types
import Hledger.Data.Amount
import Hledger.Data.Dates
@ -127,7 +128,7 @@ tmPostingRuleToFunction verbosetags styles query querytxt tmpr =
Just n -> \p ->
-- Multiply the old posting's amount by the posting rule's multiplier.
let
pramount = dbg6 "pramount" . head . amountsRaw $ pamount pr
pramount = dbg6 "pramount" . headDef nullamt . amountsRaw $ pamount pr
matchedamount = dbg6 "matchedamount" . filterMixedAmount (symq `matchesAmount`) $ pamount p
-- Handle a matched amount with a total price carefully so as to keep the transaction balanced (#928).
-- Approach 1: convert to a unit price and increase the display precision slightly

View File

@ -82,7 +82,7 @@ import Data.Maybe (fromMaybe, isJust, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day, fromGregorian )
import Safe (readDef, readMay, maximumByMay, maximumMay, minimumMay)
import Safe (headErr, readDef, readMay, maximumByMay, maximumMay, minimumMay)
import Text.Megaparsec (between, noneOf, sepBy, try, (<?>), notFollowedBy)
import Text.Megaparsec.Char (char, string, string')
@ -494,14 +494,14 @@ simplifyQuery q0 =
where
simplify (And []) = Any
simplify (And [q]) = simplify q
simplify (And qs) | same qs = simplify $ head qs
simplify (And qs) | same qs = simplify $ headErr qs -- PARTIAL headErr succeeds because pattern ensures non-null qs
| None `elem` qs = None
| all queryIsDate qs = Date $ spansIntersect $ mapMaybe queryTermDateSpan qs
| otherwise = And $ map simplify dateqs ++ map simplify otherqs
where (dateqs, otherqs) = partition queryIsDate $ filter (/=Any) qs
simplify (Or []) = Any
simplify (Or [q]) = simplifyQuery q
simplify (Or qs) | same qs = simplify $ head qs
simplify (Or qs) | same qs = simplify $ headErr qs -- PARTIAL headErr succeeds because pattern ensures non-null qs
| Any `elem` qs = Any
-- all queryIsDate qs = Date $ spansUnion $ mapMaybe queryTermDateSpan qs ?
| otherwise = Or $ map simplify $ filter (/=None) qs

View File

@ -948,8 +948,8 @@ readJournalFromCsv merulesfile csvfile csvtext sep = do
newestfirst = dbg6 "newest-first" $ isJust $ getDirective "newest-first" rules
mdatalooksnewestfirst = dbg6 "mdatalooksnewestfirst" $
case nub $ map tdate txns of
ds | length ds > 1 -> Just $ head ds > last ds
_ -> Nothing
ds@(d:_) -> Just $ d > last ds
[] -> Nothing
txns2 = dbg7 "txns2" $
(if newestfirst || mdatalooksnewestfirst == Just True then reverse else id) txns1
-- 3. Disordered dates: in case the CSV records were ordered by chaos,

View File

@ -143,8 +143,10 @@ zipWithPadded _ [] bs = bs
-- | Figure out the overall date span of a PeriodicReport
periodicReportSpan :: PeriodicReport a b -> DateSpan
periodicReportSpan (PeriodicReport [] _ _) = DateSpan Nothing Nothing
periodicReportSpan (PeriodicReport colspans _ _) = DateSpan (fmap Exact . spanStart $ head colspans) (fmap Exact . spanEnd $ last colspans)
periodicReportSpan (PeriodicReport colspans _ _) =
case colspans of
[] -> DateSpan Nothing Nothing
s:_ -> DateSpan (Exact <$> spanStart s) (Exact <$> spanEnd (last colspans))
-- | Map a function over the row names.
prMapName :: (a -> b) -> PeriodicReport a c -> PeriodicReport b c

View File

@ -51,6 +51,7 @@ where
import Control.Monad (when)
import qualified Data.Text as T
import Safe (tailErr)
import Text.Megaparsec
import Text.Printf
import Control.Monad.State.Strict (StateT, evalStateT)
@ -163,7 +164,7 @@ showParseError e = "parse error at " ++ show e
showDateParseError
:: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> String
showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e)
showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tailErr $ lines $ show e) -- PARTIAL tailError won't be null because showing a parse error
isNewline :: Char -> Bool
isNewline '\n' = True

View File

@ -41,6 +41,7 @@ module Hledger.Utils.String (
import Data.Char (isSpace, toLower, toUpper)
import Data.List (intercalate, dropWhileEnd)
import qualified Data.Text as T
import Safe (headErr, tailErr)
import Text.Megaparsec ((<|>), between, many, noneOf, sepBy)
import Text.Megaparsec.Char (char)
import Text.Printf (printf)
@ -203,12 +204,12 @@ unwords' = unwords . map quoteIfNeeded
-- | Strip one matching pair of single or double quotes on the ends of a string.
stripquotes :: String -> String
stripquotes s = if isSingleQuoted s || isDoubleQuoted s then init $ tail s else s
stripquotes s = if isSingleQuoted s || isDoubleQuoted s then init $ tailErr s else s -- PARTIAL tailErr won't fail because isDoubleQuoted
isSingleQuoted s@(_:_:_) = head s == '\'' && last s == '\''
isSingleQuoted s@(_:_:_) = headErr s == '\'' && last s == '\'' -- PARTIAL headErr, last will succeed because of pattern
isSingleQuoted _ = False
isDoubleQuoted s@(_:_:_) = head s == '"' && last s == '"'
isDoubleQuoted s@(_:_:_) = headErr s == '"' && last s == '"' -- PARTIAL headErr, last will succeed because of pattern
isDoubleQuoted _ = False
-- Functions below treat wide (eg CJK) characters as double-width.

View File

@ -21,9 +21,10 @@ import qualified Data.Map as M
import Data.Maybe
import Graphics.Vty
import Brick
import Safe (headErr)
defaultTheme :: AttrMap
defaultTheme = fromMaybe (snd $ head themesList) $ getTheme "white"
defaultTheme = fromMaybe (snd $ headErr themesList) $ getTheme "white" -- PARTIAL headErr succeeds because themesList is non-null
-- the theme named here should exist;
-- otherwise it will take the first one from the list,
-- which must be non-empty.

View File

@ -89,6 +89,7 @@ where
import Control.Monad (when)
import Data.List
import qualified Data.List.NonEmpty as NE
import Safe
import qualified System.Console.CmdArgs.Explicit as C
import System.Environment
@ -261,7 +262,7 @@ main = do
_ | cmd `elem` ["demo","help","test"] -> cmdaction opts journallesserror
-- these commands should create the journal if missing
_ | cmd `elem` ["add","import"] -> do
ensureJournalFileExists . head =<< journalFilePathFromOpts opts
ensureJournalFileExists . NE.head =<< journalFilePathFromOpts opts
withJournalDo opts (cmdaction opts)
-- other commands read the journal and should fail if it's missing
_ -> withJournalDo opts (cmdaction opts)

View File

@ -80,6 +80,7 @@ import Data.Char
import Data.Default
import Data.Either (fromRight, isRight)
import Data.List.Extra (groupSortOn, intercalate, isInfixOf, nubSort)
import qualified Data.List.NonEmpty as NE (NonEmpty, fromList, head, nonEmpty, singleton)
import Data.List.Split (splitOn)
import Data.Maybe
--import Data.String.Here
@ -534,7 +535,7 @@ rawOptsToCliOpts rawopts = do
(`getCapability` termColumns) <$> setupTermFromEnv
-- XXX Throws a SetupTermError if the terminfo database could not be read, should catch
#endif
let availablewidth = head $ catMaybes [mcolumns, mtermwidth, Just defaultWidth]
let availablewidth = NE.head $ NE.fromList $ catMaybes [mcolumns, mtermwidth, Just defaultWidth] -- PARTIAL: fromList won't fail because non-null list
return defcliopts {
rawopts_ = rawopts
,command_ = stringopt "command" rawopts
@ -612,13 +613,14 @@ getHledgerCliOpts mode' = do
-- Actually, returns one or more file paths. There will be more
-- than one if multiple -f options were provided.
-- File paths can have a READER: prefix naming a reader/data format.
journalFilePathFromOpts :: CliOpts -> IO [String]
journalFilePathFromOpts :: CliOpts -> IO (NE.NonEmpty String)
journalFilePathFromOpts opts = do
f <- defaultJournalPath
d <- getCurrentDirectory
case file_ opts of
[] -> return [f]
fs -> mapM (expandPathPreservingPrefix d) fs
maybe
(return $ NE.singleton f)
(mapM (expandPathPreservingPrefix d))
$ NE.nonEmpty $ file_ opts
expandPathPreservingPrefix :: FilePath -> PrefixedFilePath -> IO PrefixedFilePath
expandPathPreservingPrefix d prefixedf = do

View File

@ -57,6 +57,7 @@ import Data.List.Extra (nubSort)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar
import Safe (headErr)
import String.ANSI
import System.Environment (withArgs)
import System.Console.CmdArgs.Explicit as C
@ -396,19 +397,19 @@ tests_Commands = testGroup "Commands" [
,testCase "preserves \"virtual\" posting type" $ do
j <- readJournal' "apply account test\n2008/12/07 One\n (from) $-1\n (to) $1\n" -- PARTIAL:
let p = head $ tpostings $ head $ jtxns j
let p = headErr $ tpostings $ headErr $ jtxns j -- PARTIAL headErrs succeed because txns & postings provided
paccount p @?= "test:from"
ptype p @?= VirtualPosting
]
,testCase "alias directive" $ do
j <- readJournal' "!alias expenses = equity:draw:personal\n1/1\n (expenses:food) 1\n" -- PARTIAL:
let p = head $ tpostings $ head $ jtxns j
let p = headErr $ tpostings $ headErr $ jtxns j -- PARTIAL headErrs succeed because txns & postings provided
paccount p @?= "equity:draw:personal:food"
,testCase "Y default year directive" $ do
j <- readJournal' defaultyear_journal_txt -- PARTIAL:
tdate (head $ jtxns j) @?= fromGregorian 2009 1 1
tdate (headErr $ jtxns j) @?= fromGregorian 2009 1 1 -- PARTIAL headErr succeeds because defaultyear_journal_txt has a txn
,testCase "ledgerAccountNames" $
(ledgerAccountNames ledger7)

View File

@ -51,6 +51,7 @@ import Control.Applicative ((<|>))
import Data.ByteString as B (ByteString)
import Data.Maybe
import qualified Data.ByteString.Char8 as B
import Safe (tailMay)
import System.IO.Temp (withSystemTempFile)
import System.IO (hClose)
import System.Console.CmdArgs.Explicit (flagReq)
@ -128,8 +129,7 @@ readDemo content = Demo title content
where
readTitle s
| "\"title\":" `isPrefixOf` s = takeWhile (/='"') $ drop 1 $ lstrip $ drop 8 s
| null s = ""
| otherwise = readTitle $ tail s
| otherwise = maybe "" readTitle $ tailMay s
findDemo :: [Demo] -> String -> Maybe Demo
findDemo ds s =

View File

@ -20,6 +20,7 @@ import Data.Time (diffDays)
import Data.Either (partitionEithers)
import qualified Data.Text.IO as T
import Lens.Micro (set)
import Safe (headDef)
import System.Exit (exitFailure)
import Hledger
@ -47,7 +48,7 @@ pptxn :: PostingWithPath -> Transaction
pptxn = fromJust . ptransaction . ppposting
ppamountqty :: PostingWithPath -> Quantity
ppamountqty = aquantity . head . amounts . pamount . ppposting
ppamountqty = aquantity . headDef nullamt . amounts . pamount . ppposting
allPostingsWithPath :: Journal -> [PostingWithPath]
allPostingsWithPath j = do

View File

@ -27,6 +27,7 @@ import Numeric.RootFinding
import Data.Decimal
import qualified Data.Text as T
import qualified Data.Text.Lazy.IO as TL
import Safe (headDef, tailDef)
import System.Console.CmdArgs.Explicit as CmdArgs
import Text.Tabular.AsciiWide as Tab
@ -218,14 +219,14 @@ timeWeightedReturn styles showCashFlow prettyTables investmentsQuery trans mixed
aggregateByDate datedAmounts =
-- Aggregate all entries for a single day, assuming that intraday interest is negligible
sort
$ map (\date_cash -> let (dates, cash) = unzip date_cash in (head dates, maSum cash))
$ map (\datecashes -> let (dates, cash) = unzip datecashes in (headDef (error' "Roi.hs: datecashes was null, please report a bug") dates, maSum cash))
$ groupBy ((==) `on` fst)
$ sortOn fst
$ map (second maNegate)
$ datedAmounts
let units =
tail $
tailDef (error' "Roi.hs units was null, please report a bug") $
scanl
(\(_, _, unitCost, unitBalance) (date, amt) ->
let valueOnDate = unMix $ mixedAmountValue end date $ total trans (And [investmentsQuery, Date (DateSpan Nothing (Just $ Exact date))])

View File

@ -22,6 +22,7 @@ import Data.Time.Calendar (Day, addDays)
import System.Console.CmdArgs.Explicit as C
import Hledger.Read.CsvUtils (CSV, printCSV, printTSV)
import Lucid as L hiding (value_)
import Safe (tailDef)
import Text.Tabular.AsciiWide as Tab hiding (render)
import Hledger
@ -261,7 +262,7 @@ compoundBalanceReportAsCsv ropts (CompoundPeriodicReport title colspans subrepor
-- | Add a subreport title row and drop the heading row.
subreportAsCsv ropts1 (subreporttitle, multibalreport, _) =
padRow subreporttitle :
tail (multiBalanceReportAsCsv ropts1 multibalreport)
tailDef [] (multiBalanceReportAsCsv ropts1 multibalreport)
padRow s = take numcols $ s : repeat ""
where
numcols

View File

@ -31,6 +31,7 @@ where
import Control.Monad.Except (ExceptT)
import Control.Monad.IO.Class (liftIO)
import Data.List
import qualified Data.List.NonEmpty as NE (toList)
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
@ -72,7 +73,7 @@ withJournalDo opts cmd = do
-- it's stdin, or it doesn't exist and we are adding. We read it strictly
-- to let the add command work.
journalpaths <- journalFilePathFromOpts opts
j <- runExceptT $ journalTransform opts <$> readJournalFiles (inputopts_ opts) journalpaths
j <- runExceptT $ journalTransform opts <$> readJournalFiles (inputopts_ opts) (NE.toList journalpaths)
either error' cmd j -- PARTIAL:
-- | Apply some extra post-parse transformations to the journal, if enabled by options.
@ -145,15 +146,14 @@ journalReloadIfChanged opts _d j = do
let maybeChangedFilename f = do newer <- journalFileIsNewer j f
return $ if newer then Just f else Nothing
changedfiles <- liftIO $ catMaybes <$> mapM maybeChangedFilename (journalFilePaths j)
if not $ null changedfiles
then do
-- XXX not sure why we use cmdarg's verbosity here, but keep it for now
verbose <- liftIO isLoud
when (verbose || debugLevel >= 6) . liftIO $ printf "%s has changed, reloading\n" (head changedfiles)
newj <- journalReload opts
return (newj, True)
else
return (j, False)
case changedfiles of
[] -> return (j, False)
f:_ -> do
-- XXX not sure why we use cmdarg's verbosity here, but keep it for now
verbose <- liftIO isLoud
when (verbose || debugLevel >= 6) . liftIO $ printf "%s has changed, reloading\n" f
newj <- journalReload opts
return (newj, True)
-- | Re-read the journal file(s) specified by options, applying any
-- transformations specified by options. Or return an error string.
@ -161,7 +161,7 @@ journalReloadIfChanged opts _d j = do
journalReload :: CliOpts -> ExceptT String IO Journal
journalReload opts = do
journalpaths <- liftIO $ dbg6 "reloading files" <$> journalFilePathFromOpts opts
journalTransform opts <$> readJournalFiles (inputopts_ opts) journalpaths
journalTransform opts <$> readJournalFiles (inputopts_ opts) (NE.toList journalpaths)
-- | Has the specified file changed since the journal was last read ?
-- Typically this is one of the journal's journalFilePaths. These are

View File

@ -20,10 +20,8 @@ nix:
pure: false
packages: [perl gmp ncurses zlib]
ghc-options:
# XXX silence 9.8's new partial warnings for now
"$locals": -Wno-x-partial
# ghc-options:
# "$locals": -Wno-x-partial
# "$locals": -fplugin Debug.Breakpoint
# # for precise profiling, per https://www.tweag.io/posts/2020-01-30-haskell-profiling.html:

View File

@ -19,6 +19,7 @@ import Data.List
import Data.Time.Calendar
import Data.Time.LocalTime
import Numeric
import Safe (tailErr)
import System.Environment
import Text.Printf
-- import Hledger.Utils.Debug
@ -35,7 +36,7 @@ main = do
let comms = cycle ['A'..'Z']
let rates = [0.70, 0.71 .. 1.3]
mapM_ (\(n,d,(a,b),c,p) -> putStr $ showtxn n d a b c p) $ take numtxns $ zip5 [1..] dates accts comms (drop 1 comms)
mapM_ (\(d,rate) -> putStr $ showmarketprice d rate) $ take numtxns $ zip dates (cycle $ rates ++ init (tail (reverse rates)))
mapM_ (\(d,rate) -> putStr $ showmarketprice d rate) $ take numtxns $ zip dates (cycle $ rates ++ init (tailErr (reverse rates))) -- PARTIAL tailErr succeeds because non-null rates list
showtxn :: Int -> Day -> String -> String -> Char -> Char -> String
showtxn txnno date acct1 acct2 comm pricecomm =
@ -79,7 +80,7 @@ sequences :: Show a => Int -> [a] -> [[a]]
sequences n l = go l
where
go [] = []
go l' = s : go (tail l')
go l' = s : go (tailErr l') -- PARTIAL tailErr succeeds because of pattern
where
s' = take n l'
s | length s' == n = s'