Skip to content

Commit d5c1fad

Browse files
committed
Separate semaphore per canonicalised golden file path
1 parent e348245 commit d5c1fad

File tree

2 files changed

+45
-17
lines changed

2 files changed

+45
-17
lines changed

hedgehog-extras.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,7 @@ common aeson-pretty { build-depends: aeson-pretty
2121
common async { build-depends: async }
2222
common base { build-depends: base >= 4.12 && < 4.22 }
2323
common bytestring { build-depends: bytestring }
24+
common containers { build-depends: containers }
2425
common deepseq { build-depends: deepseq }
2526
common Diff { build-depends: Diff }
2627
common directory { build-depends: directory }
@@ -81,6 +82,7 @@ library
8182
aeson,
8283
async,
8384
bytestring,
85+
containers,
8486
deepseq,
8587
Diff,
8688
directory,

src/Hedgehog/Extras/Test/New/Golden.hs

Lines changed: 43 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@ module Hedgehog.Extras.Test.New.Golden
66
) where
77

88
import Control.Applicative
9+
import qualified Control.Concurrent.STM as STM
910
import Control.Monad
1011
import Control.Monad.Catch
1112
import Control.Monad.IO.Class (MonadIO (liftIO))
@@ -14,35 +15,36 @@ import Data.Algorithm.DiffOutput (ppDiff)
1415
import Data.Bool
1516
import Data.Eq
1617
import Data.Function
18+
import Data.Map (Map)
1719
import Data.Maybe
1820
import Data.Monoid
1921
import Data.String
2022
import GHC.Stack (HasCallStack, callStack)
2123
import Hedgehog (MonadTest)
2224
import Hedgehog.Extras.Test.Base (failMessage)
23-
import System.FilePath (takeDirectory)
24-
import System.IO (FilePath)
25+
import System.Directory (canonicalizePath, getCurrentDirectory)
26+
import System.FilePath (takeDirectory, makeRelative)
27+
import System.IO (IO, FilePath)
28+
import System.IO.Unsafe (unsafePerformIO)
29+
import qualified System.IO as IO
2530

2631
import qualified Control.Concurrent.QSem as IO
2732
import qualified Data.List as List
33+
import qualified Data.Map as Map
2834
import qualified GHC.Stack as GHC
2935
import qualified Hedgehog.Extras.Test as H
3036
import qualified Hedgehog.Internal.Property as H
3137
import qualified System.Directory as IO
3238
import qualified System.Environment as IO
33-
import qualified System.IO as IO
3439
import qualified System.IO.Unsafe as IO
3540

36-
sem :: IO.QSem
37-
sem = IO.unsafePerformIO $ IO.newQSem 1
38-
{-# NOINLINE sem #-}
39-
4041
semBracket :: ()
4142
=> MonadIO m
4243
=> MonadMask m
43-
=> m a
44+
=> IO.QSem
4445
-> m a
45-
semBracket =
46+
-> m a
47+
semBracket sem =
4648
bracket_
4749
(liftIO (IO.waitQSem sem))
4850
(liftIO (IO.signalQSem sem))
@@ -110,6 +112,23 @@ checkAgainstGoldenFile goldenFile actualLines = GHC.withFrozenCallStack $ do
110112
]
111113
failMessage callStack $ ppDiff difference
112114

115+
tvGoldenFileSems :: STM.TVar (Map FilePath IO.QSem)
116+
tvGoldenFileSems = unsafePerformIO $ STM.newTVarIO mempty
117+
{-# NOINLINE tvGoldenFileSems #-}
118+
119+
getGoldenFileSem :: FilePath -> IO IO.QSem
120+
getGoldenFileSem filePath = do
121+
newSem <- IO.newQSem 1
122+
123+
STM.atomically $ do
124+
sems <- STM.readTVar tvGoldenFileSems
125+
case Map.lookup filePath sems of
126+
Just sem -> return sem
127+
Nothing -> do
128+
let newGoldenFileSems = Map.insert filePath newSem sems
129+
STM.writeTVar tvGoldenFileSems newGoldenFileSems
130+
return newSem
131+
113132
-- | Diff contents against the golden file. If CREATE_GOLDEN_FILES environment is
114133
-- set to "1", then should the golden file not exist it would be created. If
115134
-- RECREATE_GOLDEN_FILES is set to "1", then should the golden file exist it would
@@ -133,18 +152,25 @@ diffVsGoldenFile
133152
=> String -- ^ Actual content
134153
-> FilePath -- ^ Reference file
135154
-> m ()
136-
diffVsGoldenFile actualContent goldenFile =
137-
GHC.withFrozenCallStack $ semBracket $ do
155+
diffVsGoldenFile actualContent goldenFile = do
156+
realPath <- liftIO $ canonicalizePath goldenFile
157+
cwd <- liftIO getCurrentDirectory
158+
159+
let relativeGoldenPath = makeRelative cwd realPath
160+
161+
sem <- liftIO $ getGoldenFileSem relativeGoldenPath
162+
163+
GHC.withFrozenCallStack $ semBracket sem $ do
138164
forM_ mGoldenFileLogFile $ \logFile ->
139-
liftIO $ IO.appendFile logFile $ goldenFile <> "\n"
165+
liftIO $ IO.appendFile logFile $ relativeGoldenPath <> "\n"
140166

141-
fileExists <- liftIO $ IO.doesFileExist goldenFile
167+
fileExists <- liftIO $ IO.doesFileExist relativeGoldenPath
142168

143169
if
144-
| recreateGoldenFiles -> writeGoldenFile goldenFile actualContent
145-
| fileExists -> checkAgainstGoldenFile goldenFile actualLines
146-
| createGoldenFiles -> writeGoldenFile goldenFile actualContent
147-
| otherwise -> reportGoldenFileMissing goldenFile
170+
| recreateGoldenFiles -> writeGoldenFile relativeGoldenPath actualContent
171+
| fileExists -> checkAgainstGoldenFile relativeGoldenPath actualLines
172+
| createGoldenFiles -> writeGoldenFile relativeGoldenPath actualContent
173+
| otherwise -> reportGoldenFileMissing relativeGoldenPath
148174

149175
where
150176
actualLines = List.lines actualContent

0 commit comments

Comments
 (0)