From 55ba5d2facd542c999c6903a093429441940f95e Mon Sep 17 00:00:00 2001
From: Joris Dral <joris@well-typed.com>
Date: Mon, 3 Jun 2024 14:24:48 +0200
Subject: [PATCH] NFData instances for FsPath, HasFS and Handle

---
 fs-api/CHANGELOG.md               |  1 +
 fs-api/fs-api.cabal               | 17 +++++++++--------
 fs-api/src/System/FS/API.hs       | 22 ++++++++++++++++++++++
 fs-api/src/System/FS/API/Types.hs |  8 +++++---
 4 files changed, 37 insertions(+), 11 deletions(-)

diff --git a/fs-api/CHANGELOG.md b/fs-api/CHANGELOG.md
index 6652a9e..b71c758 100644
--- a/fs-api/CHANGELOG.md
+++ b/fs-api/CHANGELOG.md
@@ -24,6 +24,7 @@
 * Add compound functions, built from the new primitives in `HasFS`:
   `hGetBufExactly`, `hGetBufExactlyAt`, `hPutBufExactly`,  and
   `hPutBufExactlyAt`.
+* `NFData` instances for `FsPath`, `HasFS` and `Handle`.
 
 ## 0.2.0.1 -- 2023-10-30
 
diff --git a/fs-api/fs-api.cabal b/fs-api/fs-api.cabal
index 8b38f97..9893f32 100644
--- a/fs-api/fs-api.cabal
+++ b/fs-api/fs-api.cabal
@@ -39,16 +39,17 @@ library
 
   default-language: Haskell2010
   build-depends:
-    , base        >=4.14 && <4.20
-    , bytestring  >=0.10 && <0.13
-    , containers  >=0.5  && <0.7
+    , base             >=4.14 && <4.20
+    , bytestring       >=0.10 && <0.13
+    , containers       >=0.5  && <0.7
     , deepseq
     , digest
-    , directory   >=1.3  && <1.4
-    , filepath    >=1.4  && <1.5
-    , io-classes  >=0.3  && <1.5
-    , primitive   ^>=0.9
-    , text        >=1.2  && <2.2
+    , directory        >=1.3  && <1.4
+    , filepath         >=1.4  && <1.5
+    , io-classes       >=0.3  && <1.5
+    , primitive        ^>=0.9
+    , safe-wild-cards  ^>=1.0
+    , text             >=1.2  && <2.2
 
   if os(windows)
     hs-source-dirs:  src-win32
diff --git a/fs-api/src/System/FS/API.hs b/fs-api/src/System/FS/API.hs
index e526a57..4533f79 100644
--- a/fs-api/src/System/FS/API.hs
+++ b/fs-api/src/System/FS/API.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TemplateHaskell            #-}
 
 -- | An abstract view over the filesystem.
 module System.FS.API (
@@ -27,6 +28,7 @@ module System.FS.API (
   , hPutBufExactlyAt
   ) where
 
+import           Control.DeepSeq (NFData (..))
 import           Control.Monad.Class.MonadThrow
 import           Control.Monad.Primitive (PrimMonad (..))
 import qualified Data.ByteString as BS
@@ -34,6 +36,7 @@ import           Data.Int (Int64)
 import           Data.Primitive (MutableByteArray)
 import           Data.Set (Set)
 import           Data.Word
+import           SafeWildCards
 import           System.Posix.Types (ByteCount)
 
 import           System.FS.API.Types as Types
@@ -347,3 +350,22 @@ hPutBufExactlyAt hbfs h buf bufOff c off = go c off bufOff
         else go remainingCount'
                 (currentOffset + fromIntegral writtenBytes)
                 (currentBufOff + fromIntegral writtenBytes)
+
+{-------------------------------------------------------------------------------
+  Other
+--------------------------------------------------------------------------------}
+
+-- Without this, the module won't compile because the instance below is in the
+-- same declaration group as the datatype definition. For more info, see
+-- https://blog.monadfix.com/th-groups.
+$(pure[])
+
+instance NFData (HasFS m h) where
+  rnf $(fields 'HasFS) =
+      dumpState `seq` hOpen `seq` hClose `seq` hIsOpen `seq` hSeek `seq`
+      hGetSome `seq`hGetSomeAt `seq` hPutSome `seq` hTruncate `seq`
+      hGetSize `seq` createDirectory `seq` createDirectoryIfMissing `seq`
+      listDirectory `seq` doesDirectoryExist `seq` doesFileExist `seq`
+      removeDirectoryRecursive `seq` removeFile `seq` renameFile `seq`
+      mkFsErrorPath `seq` unsafeToFilePath `seq` hGetBufSome `seq`
+      hGetBufSomeAt `seq` hPutBufSome `seq` hPutBufSomeAt `seq` ()
diff --git a/fs-api/src/System/FS/API/Types.hs b/fs-api/src/System/FS/API/Types.hs
index 3ac7331..fad15c0 100644
--- a/fs-api/src/System/FS/API/Types.hs
+++ b/fs-api/src/System/FS/API/Types.hs
@@ -1,11 +1,9 @@
 {-# LANGUAGE DataKinds                  #-}
 {-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE DerivingStrategies         #-}
 {-# LANGUAGE DerivingVia                #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE StandaloneDeriving         #-}
 
 -- For Show Errno and Condense SeekMode instances
 {-# OPTIONS_GHC -Wno-orphans #-}
@@ -45,7 +43,7 @@ module System.FS.API.Types (
   , ioToFsErrorType
   ) where
 
-import           Control.DeepSeq (force)
+import           Control.DeepSeq (NFData (..), force)
 import           Control.Exception
 import           Data.Function (on)
 import           Data.List (intercalate, stripPrefix)
@@ -100,6 +98,7 @@ allowExisting openMode = case openMode of
 -- | A relative path.
 newtype FsPath = UnsafeFsPath { fsPathToList :: [Strict.Text] }
   deriving (Eq, Ord, Generic)
+  deriving newtype NFData
 
 fsPathFromList :: [Strict.Text] -> FsPath
 fsPathFromList = UnsafeFsPath . force
@@ -184,6 +183,9 @@ data Handle h = Handle {
     }
   deriving (Generic)
 
+instance NFData h => NFData (Handle h) where
+    rnf (Handle handleRaw handlePath) = rnf handleRaw `seq` rnf handlePath
+
 instance Eq h => Eq (Handle h) where
   (==) = (==) `on` handleRaw