| ... |
... |
@@ -10,11 +10,13 @@ module LintCodes.Coverage |
|
10
|
10
|
|
|
11
|
11
|
-- base
|
|
12
|
12
|
import Data.Char
|
|
13
|
|
- ( isAlphaNum, isDigit, isSpace )
|
|
|
13
|
+ ( isAlphaNum, isDigit, isSpace, toUpper )
|
|
14
|
14
|
import Data.Maybe
|
|
15
|
15
|
( mapMaybe )
|
|
16
|
16
|
import Data.List
|
|
17
|
17
|
( dropWhileEnd )
|
|
|
18
|
+import System.Info
|
|
|
19
|
+ ( os )
|
|
18
|
20
|
|
|
19
|
21
|
-- bytestring
|
|
20
|
22
|
import qualified Data.ByteString as ByteString
|
| ... |
... |
@@ -28,7 +30,7 @@ import qualified Data.Set as Set |
|
28
|
30
|
|
|
29
|
31
|
-- directory
|
|
30
|
32
|
import System.Directory
|
|
31
|
|
- ( doesDirectoryExist, listDirectory )
|
|
|
33
|
+ ( doesDirectoryExist, listDirectory, makeAbsolute )
|
|
32
|
34
|
|
|
33
|
35
|
-- filepath
|
|
34
|
36
|
import System.FilePath
|
| ... |
... |
@@ -63,7 +65,12 @@ getCoveredCodes = |
|
63
|
65
|
do { top <- dropWhileEnd isSpace
|
|
64
|
66
|
<$> readProcess "git" ["rev-parse", "--show-toplevel"] ""
|
|
65
|
67
|
-- TODO: would be better to avoid using git entirely.
|
|
66
|
|
- ; let testRoot = top </> "testsuite" </> "tests"
|
|
|
68
|
+
|
|
|
69
|
+ -- When run inside an MSYS shell, git may return a Unix-style path
|
|
|
70
|
+ -- like /c/Blah. System.Directory doesn't like that, so we make sure
|
|
|
71
|
+ -- to turn that into C:/Blah. See #25178.
|
|
|
72
|
+ ; top' <- fixupMsysDrive top
|
|
|
73
|
+ ; let testRoot = top' </> "testsuite" </> "tests"
|
|
67
|
74
|
; traverseFilesFrom includeFile diagnosticCodesIn testRoot
|
|
68
|
75
|
}
|
|
69
|
76
|
|
| ... |
... |
@@ -158,3 +165,14 @@ traverseFilesFrom include_file parse_contents = go |
|
158
|
165
|
{ Left _ -> mempty
|
|
159
|
166
|
; Right txt -> parse_contents txt
|
|
160
|
167
|
} } } }
|
|
|
168
|
+
|
|
|
169
|
+-- | On Windows, change MSYS-style @/c/Blah@ to @C:/Blah@. See #25178.
|
|
|
170
|
+fixupMsysDrive :: FilePath -> IO FilePath
|
|
|
171
|
+fixupMsysDrive fp = do
|
|
|
172
|
+ fixedUp <-
|
|
|
173
|
+ if | os == "mingw32" || os == "win32"
|
|
|
174
|
+ , ('/':drv:'/':rest) <- fp
|
|
|
175
|
+ -> return $ toUpper drv : ':':'/':rest
|
|
|
176
|
+ | otherwise
|
|
|
177
|
+ -> return fp
|
|
|
178
|
+ makeAbsolute fixedUp |