@@ -6,6 +6,7 @@ module Hedgehog.Extras.Test.New.Golden
6
6
) where
7
7
8
8
import Control.Applicative
9
+ import qualified Control.Concurrent.STM as STM
9
10
import Control.Monad
10
11
import Control.Monad.Catch
11
12
import Control.Monad.IO.Class (MonadIO (liftIO ))
@@ -14,35 +15,36 @@ import Data.Algorithm.DiffOutput (ppDiff)
14
15
import Data.Bool
15
16
import Data.Eq
16
17
import Data.Function
18
+ import Data.Map (Map )
17
19
import Data.Maybe
18
20
import Data.Monoid
19
21
import Data.String
20
22
import GHC.Stack (HasCallStack , callStack )
21
23
import Hedgehog (MonadTest )
22
24
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
25
30
26
31
import qualified Control.Concurrent.QSem as IO
27
32
import qualified Data.List as List
33
+ import qualified Data.Map as Map
28
34
import qualified GHC.Stack as GHC
29
35
import qualified Hedgehog.Extras.Test as H
30
36
import qualified Hedgehog.Internal.Property as H
31
37
import qualified System.Directory as IO
32
38
import qualified System.Environment as IO
33
- import qualified System.IO as IO
34
39
import qualified System.IO.Unsafe as IO
35
40
36
- sem :: IO. QSem
37
- sem = IO. unsafePerformIO $ IO. newQSem 1
38
- {-# NOINLINE sem #-}
39
-
40
41
semBracket :: ()
41
42
=> MonadIO m
42
43
=> MonadMask m
43
- => m a
44
+ => IO. QSem
44
45
-> m a
45
- semBracket =
46
+ -> m a
47
+ semBracket sem =
46
48
bracket_
47
49
(liftIO (IO. waitQSem sem))
48
50
(liftIO (IO. signalQSem sem))
@@ -110,6 +112,23 @@ checkAgainstGoldenFile goldenFile actualLines = GHC.withFrozenCallStack $ do
110
112
]
111
113
failMessage callStack $ ppDiff difference
112
114
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
+
113
132
-- | Diff contents against the golden file. If CREATE_GOLDEN_FILES environment is
114
133
-- set to "1", then should the golden file not exist it would be created. If
115
134
-- RECREATE_GOLDEN_FILES is set to "1", then should the golden file exist it would
@@ -133,18 +152,25 @@ diffVsGoldenFile
133
152
=> String -- ^ Actual content
134
153
-> FilePath -- ^ Reference file
135
154
-> 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
138
164
forM_ mGoldenFileLogFile $ \ logFile ->
139
- liftIO $ IO. appendFile logFile $ goldenFile <> " \n "
165
+ liftIO $ IO. appendFile logFile $ relativeGoldenPath <> " \n "
140
166
141
- fileExists <- liftIO $ IO. doesFileExist goldenFile
167
+ fileExists <- liftIO $ IO. doesFileExist relativeGoldenPath
142
168
143
169
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
148
174
149
175
where
150
176
actualLines = List. lines actualContent
0 commit comments