[Git][ghc/ghc][master] 2 commits: Assorted fixes to avoid Data.List.{head,tail}
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Nov 25 09:38:45 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
5943e739 by Bodigrim at 2022-11-25T04:38:28-05:00
Assorted fixes to avoid Data.List.{head,tail}
- - - - -
1f1b99b8 by sheaf at 2022-11-25T04:38:28-05:00
Review suggestions for assorted fixes to avoid Data.List.{head,tail}
- - - - -
10 changed files:
- libraries/base/GHC/Fingerprint.hs
- libraries/ghc-boot/GHC/BaseDir.hs
- libraries/ghc-boot/GHC/Data/ShortText.hs
- libraries/ghc-boot/GHC/Utils/Encoding.hs
- libraries/ghci/GHCi/InfoTable.hsc
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs
- libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs
- utils/ghc-pkg/Main.hs
- utils/hpc/HpcUtils.hs
Changes:
=====================================
libraries/base/GHC/Fingerprint.hs
=====================================
@@ -43,7 +43,7 @@ fingerprint0 = Fingerprint 0 0
fingerprintFingerprints :: [Fingerprint] -> Fingerprint
fingerprintFingerprints fs = unsafeDupablePerformIO $
withArrayLen fs $ \len p ->
- fingerprintData (castPtr p) (len * sizeOf (head fs))
+ fingerprintData (castPtr p) (len * sizeOf (undefined :: Fingerprint))
fingerprintData :: Ptr Word8 -> Int -> IO Fingerprint
fingerprintData buf len =
=====================================
libraries/ghc-boot/GHC/BaseDir.hs
=====================================
@@ -17,6 +17,7 @@ module GHC.BaseDir where
import Prelude -- See Note [Why do we import Prelude here?]
import Data.List (stripPrefix)
+import Data.Maybe (listToMaybe)
import System.FilePath
-- Windows
@@ -37,7 +38,7 @@ expandTopDir = expandPathVar "topdir"
expandPathVar :: String -> FilePath -> String -> String
expandPathVar var value str
| Just str' <- stripPrefix ('$':var) str
- , null str' || isPathSeparator (head str')
+ , maybe True isPathSeparator (listToMaybe str')
= value ++ expandPathVar var value str'
expandPathVar var value (x:xs) = x : expandPathVar var value xs
expandPathVar _ _ [] = []
=====================================
libraries/ghc-boot/GHC/Data/ShortText.hs
=====================================
@@ -101,8 +101,10 @@ splitFilePath st = DeepSeq.force $ map (ShortText . SBS.toShort) $ B8.splitWith
-- non-printable characters.
head :: ShortText -> Char
head st
- | SBS.null $ contents st = error "head: Empty ShortText"
- | otherwise = Prelude.head $ unpack st
+ | hd:_ <- unpack st
+ = hd
+ | otherwise
+ = error "head: Empty ShortText"
-- | /O(n)/ The 'stripPrefix' function takes two 'ShortText's and returns 'Just' the remainder of
-- the second iff the first is its prefix, and otherwise Nothing.
=====================================
libraries/ghc-boot/GHC/Utils/Encoding.hs
=====================================
@@ -145,8 +145,10 @@ encode_ch '%' = "zv"
encode_ch c = encode_as_unicode_char c
encode_as_unicode_char :: Char -> EncodedString
-encode_as_unicode_char c = 'z' : if isDigit (head hex_str) then hex_str
- else '0':hex_str
+encode_as_unicode_char c = 'z' : case hex_str of
+ hd : _
+ | isDigit hd -> hex_str
+ _ -> '0' : hex_str
where hex_str = showHex (ord c) "U"
-- ToDo: we could improve the encoding here in various ways.
-- eg. strings of unicode characters come out as 'z1234Uz5678U', we
=====================================
libraries/ghci/GHCi/InfoTable.hsc
=====================================
@@ -299,8 +299,8 @@ sizeOfEntryCode tables_next_to_code
| otherwise = do
code' <- mkJumpToAddr undefined
pure $ case code' of
- Left xs -> sizeOf (head xs) * length xs
- Right xs -> sizeOf (head xs) * length xs
+ Left (xs :: [Word8]) -> sizeOf (undefined :: Word8) * length xs
+ Right (xs :: [Word32]) -> sizeOf (undefined :: Word32) * length xs
-- Note: Must return proper pointer for use in a closure
newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -1133,8 +1133,9 @@ addrToByteArrayName = helper
where
helper :: HasCallStack => Name
helper =
- case head (getCallStack ?callStack) of
- (_, SrcLoc{..}) -> mkNameG_v srcLocPackage srcLocModule "addrToByteArray"
+ case getCallStack ?callStack of
+ [] -> error "addrToByteArrayName: empty call stack"
+ (_, SrcLoc{..}) : _ -> mkNameG_v srcLocPackage srcLocModule "addrToByteArray"
addrToByteArray :: Int -> Addr# -> ByteArray
=====================================
libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs
=====================================
@@ -600,7 +600,7 @@ hasTrailingPathSeparator x = isPathSeparator (last x)
hasLeadingPathSeparator :: FilePath -> Bool
hasLeadingPathSeparator "" = False
-hasLeadingPathSeparator x = isPathSeparator (head x)
+hasLeadingPathSeparator (hd : _) = isPathSeparator hd
-- | Add a trailing file path separator if one is not already present.
@@ -824,7 +824,7 @@ makeRelative root path
where (a,b) = break isPathSeparator $ dropWhile isPathSeparator x
-- on windows, need to drop '/' which is kind of absolute, but not a drive
- dropAbs x | hasLeadingPathSeparator x && not (hasDrive x) = tail x
+ dropAbs x | hasLeadingPathSeparator x && not (hasDrive x) = drop 1 x
dropAbs x = dropDrive x
takeAbs x | hasLeadingPathSeparator x && not (hasDrive x) = [pathSeparator]
=====================================
libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs
=====================================
@@ -600,7 +600,7 @@ hasTrailingPathSeparator x = isPathSeparator (last x)
hasLeadingPathSeparator :: FilePath -> Bool
hasLeadingPathSeparator "" = False
-hasLeadingPathSeparator x = isPathSeparator (head x)
+hasLeadingPathSeparator (hd : _) = isPathSeparator hd
-- | Add a trailing file path separator if one is not already present.
@@ -824,7 +824,7 @@ makeRelative root path
where (a,b) = break isPathSeparator $ dropWhile isPathSeparator x
-- on windows, need to drop '/' which is kind of absolute, but not a drive
- dropAbs x | hasLeadingPathSeparator x && not (hasDrive x) = tail x
+ dropAbs x | hasLeadingPathSeparator x && not (hasDrive x) = drop 1 x
dropAbs x = dropDrive x
takeAbs x | hasLeadingPathSeparator x && not (hasDrive x) = [pathSeparator]
=====================================
utils/ghc-pkg/Main.hs
=====================================
@@ -390,7 +390,7 @@ runit verbosity cli nonopts = do
splitFields fields = unfoldr splitComma (',':fields)
where splitComma "" = Nothing
- splitComma fs = Just $ break (==',') (tail fs)
+ splitComma (_ : fs) = Just $ break (==',') fs
-- | Parses a glob into a predicate which tests if a string matches
-- the glob. Returns Nothing if the string in question is not a glob.
@@ -1962,10 +1962,11 @@ checkUnitId ipi db_stack update = do
checkDuplicates :: PackageDBStack -> InstalledPackageInfo
-> Bool -> Bool-> Validate ()
-checkDuplicates db_stack pkg multi_instance update = do
+checkDuplicates [] _ _ _ = pure ()
+checkDuplicates (hd : _) pkg multi_instance update = do
let
pkgid = mungedId pkg
- pkgs = packages (head db_stack)
+ pkgs = packages hd
--
-- Check whether this package id already exists in this DB
--
=====================================
utils/hpc/HpcUtils.hs
=====================================
@@ -13,8 +13,10 @@ dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) []
grabHpcPos :: Map.Map Int String -> HpcPos -> String
grabHpcPos hsMap srcspan =
case lns of
+ [] -> error "grabHpcPos: invalid source span"
[ln] -> (take ((c2 - c1) + 1) $ drop (c1 - 1) ln)
- _ -> let lns1 = drop (c1 -1) (head lns) : tail lns
+ hd : tl ->
+ let lns1 = drop (c1 -1) hd : tl
lns2 = init lns1 ++ [take (c2 + 1) (last lns1) ]
in foldl1 (\ xs ys -> xs ++ "\n" ++ ys) lns2
where (l1,c1,l2,c2) = fromHpcPos srcspan
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d198a19ae08fec797121e3907ca93c5840db0c53...1f1b99b86ab2b005604aea08b0614279a8ad1244
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d198a19ae08fec797121e3907ca93c5840db0c53...1f1b99b86ab2b005604aea08b0614279a8ad1244
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221125/0cc893ac/attachment-0001.html>
More information about the ghc-commits
mailing list