Bodigrim pushed to branch wip/warning-for-last-and-init at Glasgow Haskell Compiler / GHC Commits: 86560233 by Andrew Lelechenko at 2025-08-17T19:26:54+01:00 Revert utils - - - - - 6 changed files: - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/ghc-pkg/Main.hs - utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs - utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs Changes: ===================================== utils/check-exact/Transform.hs ===================================== @@ -8,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-x-partial #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.GHC.ExactPrint.Transform @@ -96,7 +97,6 @@ import GHC.Data.FastString import GHC.Types.SrcLoc import Data.Data -import Data.List (unsnoc) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Maybe @@ -213,9 +213,8 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (AnnSig (EpUniTok dca u) mp md) ns ( where -- we want DPs for the distance from the end of the ns to the -- AnnDColon, and to the start of the ty - rd = case unsnoc ns of - Nothing -> error "unexpected empty list in 'ns' variable" - Just (_, L (EpAnn anc' _ _) _) -> epaLocationRealSrcSpan anc' + rd = case last ns of + L (EpAnn anc' _ _) _ -> epaLocationRealSrcSpan anc' dca' = case dca of EpaSpan ss@(RealSrcSpan r _) -> (EpaDelta ss (ss2delta (ss2posEnd rd) r) []) _ -> dca @@ -296,7 +295,7 @@ setEntryDP (L (EpAnn (EpaSpan ss@(RealSrcSpan r _)) an cs) a) dp where cs'' = setPriorComments cs [] csd = L (EpaDelta ss dp NoComments) c:commentOrigDeltas cs' - lc = NE.last (L ca c :| cs') + lc = last $ (L ca c:cs') delta = case getLoc lc of EpaSpan (RealSrcSpan rr _) -> ss2delta (ss2pos rr) r EpaSpan _ -> (SameLine 0) ===================================== utils/check-exact/Utils.hs ===================================== @@ -4,6 +4,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-x-partial #-} module Utils -- ( @@ -37,7 +38,7 @@ import GHC.Base (NonEmpty(..)) import GHC.Parser.Lexer (allocateComments) import Data.Data hiding ( Fixity ) -import Data.List (sortBy, partition, unsnoc) +import Data.List (sortBy, partition) import qualified Data.Map.Strict as Map import Debug.Trace @@ -734,9 +735,8 @@ ghead info [] = error $ "ghead "++info++" []" ghead _info (h:_) = h glast :: String -> [a] -> a -glast info xs = case unsnoc xs of - Nothing -> error $ "glast " ++ info ++ " []" - Just (_, lst) -> lst +glast info [] = error $ "glast " ++ info ++ " []" +glast _info h = last h gtail :: String -> [a] -> [a] gtail info [] = error $ "gtail " ++ info ++ " []" ===================================== utils/ghc-pkg/Main.hs ===================================== @@ -8,7 +8,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-orphans -Wno-x-partial #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-x-partial #-} -- Fine if this comes from make/Hadrian or the pre-built base. #include ===================================== utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs ===================================== @@ -1,6 +1,7 @@ +{-# OPTIONS_GHC -Wno-x-partial #-} module GHC.Toolchain.CheckArm ( findArmIsa ) where -import Data.List (isInfixOf, unsnoc) +import Data.List (isInfixOf) import Data.Maybe (catMaybes) import Control.Monad.IO.Class import System.Process @@ -76,7 +77,8 @@ findArmIsa cc = do _ -> throwE $ "unexpected output from test program: " ++ out lastLine :: String -> String -lastLine = maybe "" snd . unsnoc . lines +lastLine "" = "" +lastLine s = last $ lines s -- | Raspbian unfortunately makes some extremely questionable packaging -- decisions, configuring gcc to compile for ARMv6 despite the fact that the ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs ===================================== @@ -6,7 +6,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wwarn=x-partial #-} +{-# OPTIONS_GHC -Wno-x-partial #-} -- | -- Module : Haddock.Backends.Html @@ -755,7 +755,7 @@ ppHtmlIndex divAlphabet << unordList ( map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $ - [ [c] | c <- initialChars, any (maybe False ((== c) . toUpper . fst) . List.uncons . fst) index + [ [c] | c <- initialChars, any ((== c) . toUpper . head . fst) index ] ++ [merged_name] ) @@ -772,7 +772,7 @@ ppHtmlIndex writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html) where html = indexPage True (Just c) index_part - index_part = [(n, stuff) | (n@(headN : _), stuff) <- this_ix, toUpper headN == c] + index_part = [(n, stuff) | (n, stuff) <- this_ix, toUpper (head n) == c] index :: [(String, Map GHC.Name [(Module, Bool)])] index = sortBy cmp (Map.toAscList full_index) ===================================== utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-x-partial #-} -- | -- Module : Documentation.Haddock.Parser @@ -30,7 +31,7 @@ import Control.Arrow (first) import Control.Monad import Data.Char (chr, isAlpha, isSpace, isUpper) import Data.Functor (($>)) -import Data.List (elemIndex, intercalate, intersperse, unfoldr, unsnoc) +import Data.List (elemIndex, intercalate, intersperse, unfoldr) import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid import qualified Data.Set as Set @@ -870,10 +871,10 @@ codeblock = DocCodeBlock . parseParagraph . dropSpaces <$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@") where - dropSpaces xs = let ys = splitByNl xs in - case unsnoc ys of - Nothing -> xs - Just (_, lastYs) -> case T.uncons lastYs of + dropSpaces xs = + case splitByNl xs of + [] -> xs + ys -> case T.uncons (last ys) of Just (' ', _) -> case mapM dropSpace ys of Nothing -> xs Just zs -> T.intercalate "\n" zs View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/86560233759a674264a1e77ec4c260f9... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/86560233759a674264a1e77ec4c260f9... You're receiving this email because of your account on gitlab.haskell.org.