diff --git a/System/FilePath/Internal.hs b/System/FilePath/Internal.hs index 5b3cfa2b..0c92b3e0 100644 --- a/System/FilePath/Internal.hs +++ b/System/FilePath/Internal.hs @@ -129,8 +129,8 @@ import Data.List(stripPrefix, isSuffixOf, uncons, dropWhileEnd) #define STRING String #define FILEPATH FilePath #else -import Prelude (fromIntegral) -import Control.Exception ( SomeException, evaluate, try, displayException ) +import Prelude (fromIntegral, return, IO, Either(..)) +import Control.Exception ( catch, displayException, evaluate, fromException, toException, throwIO, Exception, SomeAsyncException(..), SomeException ) import Control.DeepSeq (force) import GHC.IO (unsafePerformIO) import qualified Data.Char as C @@ -1270,15 +1270,31 @@ snoc :: String -> Char -> String snoc str = \c -> str <> [c] #else +-- | Like 'try', but rethrows async exceptions. +trySafe :: Exception e => IO a -> IO (Either e a) +trySafe ioA = catch action eHandler + where + action = do + v <- ioA + return (Right v) + eHandler e + | isAsyncException e = throwIO e + | otherwise = return (Left e) + +isAsyncException :: Exception e => e -> Bool +isAsyncException e = + case fromException (toException e) of + Just (SomeAsyncException _) -> True + Nothing -> False #ifdef WINDOWS fromString :: P.String -> STRING fromString str = P.either (P.error . P.show) P.id $ unsafePerformIO $ do - r <- try @SomeException $ GHC.withCStringLen (mkUTF16le ErrorOnCodingFailure) str $ \cstr -> packCStringLen cstr + r <- trySafe @SomeException $ GHC.withCStringLen (mkUTF16le ErrorOnCodingFailure) str $ \cstr -> packCStringLen cstr evaluate $ force $ first displayException r #else fromString :: P.String -> STRING fromString str = P.either (P.error . P.show) P.id $ unsafePerformIO $ do - r <- try @SomeException $ GHC.withCStringLen (mkUTF8 ErrorOnCodingFailure) str $ \cstr -> packCStringLen cstr + r <- trySafe @SomeException $ GHC.withCStringLen (mkUTF8 ErrorOnCodingFailure) str $ \cstr -> packCStringLen cstr evaluate $ force $ first displayException r #endif diff --git a/changelog.md b/changelog.md index fea188c1..08202f3e 100644 --- a/changelog.md +++ b/changelog.md @@ -2,6 +2,10 @@ _Note: below all `FilePath` values are unquoted, so `\\` really means two backslashes._ +## 1.5.4.0 *Nov 2024* + +* Don't catch async exceptions in internal functions wrt https://github.com/haskell/os-string/issues/22 + ## 1.5.3.0 *Jun 2024* * Adjust for `encodeFS`/`decodedFS` deprecation in os-string diff --git a/filepath.cabal b/filepath.cabal index 2174ad2d..82f423ab 100644 --- a/filepath.cabal +++ b/filepath.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: filepath -version: 1.5.3.0 +version: 1.5.4.0 -- NOTE: Don't forget to update ./changelog.md license: BSD-3-Clause