never executed always true always false
1 module TestCore.SpecPreprocessor (run, runPure) where
2
3 import Control.Exception (IOException, displayException, try)
4 import Control.Monad.Except (ExceptT, throwError)
5 import Control.Monad.IO.Class (liftIO)
6 import Core.System.Path (normalizePath)
7 import Data.Char (isSpace)
8 import Data.List (intercalate, stripPrefix)
9 import System.Directory (makeAbsolute)
10 import System.FilePath (normalise, splitDirectories, takeBaseName)
11 import System.IO (IOMode (ReadMode), hGetContents, withFile)
12
13 run :: [String] -> ExceptT String IO ()
14 run args = do
15 let (hsSourceDir, fileArgs) = parseArgs "test" [] args
16 case fileArgs of
17 [input, output] ->
18 processFile hsSourceDir input output
19 -- GHC may pass the input file twice, we check to prevent an actual 3 positional argument call
20 [input, input', output]
21 | input == input' ->
22 processFile hsSourceDir input output
23 _ -> throwError "spec-preprocessor: expected input and output file arguments"
24 where
25 processFile hsSourceDir input output = tryIO $ do
26 absolutePath <- makeAbsolute input
27 withFile input ReadMode $ \handle -> do
28 contents <- hGetContents handle
29 writeFile output $ runPure hsSourceDir absolutePath contents
30
31 tryIO :: IO a -> ExceptT String IO a
32 tryIO action = do
33 result <- liftIO $ try action
34 case result of
35 Left (e :: IOException) -> throwError $ "spec-preprocessor: " ++ displayException e
36 Right a -> pure a
37
38 runPure :: String -> String -> String -> String
39 runPure hsSourceDir absolutePath contents =
40 unlines $ process 1 (inferModuleName hsSourceDir absolutePath) $ lines contents
41 where
42 process :: Int -> String -> [String] -> [String]
43 process inputLine moduleName (header : rest) =
44 let trimmed = dropWhile isSpace header
45 in case stripSpecPragma trimmed of
46 Just remainder
47 | all isSpace remainder ->
48 let (importCount, imports, remaining) = processTillEndOfImports rest
49 -- LINE pragma points to the first line of remaining content in the original file:
50 -- inputLine (current) + 1 (SPEC pragma) + importCount (imports we're copying)
51 originalLineOfRemaining = inputLine + 1 + importCount
52 in [ "module " ++ moduleName ++ " (spec) where",
53 "",
54 "import TestCore.Prelude"
55 ]
56 ++ imports
57 ++ [ "spec :: Spec",
58 "{-# LINE " ++ show originalLineOfRemaining ++ " \"" ++ normalizePath absolutePath ++ "\" #-}"
59 ]
60 ++ remaining
61 _ -> header : process (inputLine + 1) moduleName rest
62 -- Empty file case
63 process _ _ [] = []
64
65 -- We are making sure that for the line with {-# SPEC #-}, at most the rest is whitespace
66 stripSpecPragma :: String -> Maybe String
67 stripSpecPragma ('{' : '-' : '#' : xs) =
68 let afterStart = dropWhile isSpace xs
69 in case afterStart of
70 'S' : 'P' : 'E' : 'C' : rest' ->
71 let afterSpec = dropWhile isSpace rest'
72 in case afterSpec of
73 '#' : '-' : '}' : r -> Just r
74 _ -> Nothing
75 _ -> Nothing
76 stripSpecPragma _ = Nothing
77
78 -- Process lines until we reach a line that is not an import or comment or empty
79 -- These are added after our added imports but before the spec definition
80 -- Returns (count, imports, remaining)
81 processTillEndOfImports :: [String] -> (Int, [String], [String])
82 processTillEndOfImports (header : rest) =
83 let trimmed = dropWhile isSpace header
84 in if keep trimmed
85 then
86 let (count, imports, remaining) = processTillEndOfImports rest
87 in (count + 1, header : imports, remaining)
88 else (0, [], header : rest)
89 where
90 -- If line is empty or whitespace,
91 keep [] = True
92 -- Or if first non-whitespace characters are for comment or import, add it and continue
93 keep ('-' : '-' : _) = True
94 keep ('i' : 'm' : 'p' : 'o' : 'r' : 't' : ' ' : _) = True
95 -- Otherwise, stop processing imports
96 keep _ = False
97 processTillEndOfImports [] = (0, [], [])
98
99 -- Parse arguments to extract hs-source-dir option and file arguments
100 -- Returns (hsSourceDir, fileArgs) where hsSourceDir defaults to "test"
101 parseArgs :: String -> [String] -> [String] -> (String, [String])
102 parseArgs hsSourceDir files [] = (hsSourceDir, files)
103 parseArgs hsSourceDir files (arg : rest) =
104 case stripPrefix "hs-source-dir=" arg of
105 Just dir -> parseArgs dir files rest
106 Nothing -> parseArgs hsSourceDir (files ++ [arg]) rest
107
108 -- Infer module name from file path hierarchy
109 -- Goes up directories until hitting hs-source-dir
110 -- Returns module name as dotted namespace
111 inferModuleName :: String -> String -> String
112 inferModuleName hsSourceDir absolutePath =
113 case absolutePath of
114 [] ->
115 let defaultModule = "Spec"
116 in null hsSourceDir `seq` buildModuleName [] defaultModule
117 _ ->
118 let pathParts = splitDirectories $ normalise absolutePath
119 baseName = takeBaseName absolutePath
120 in case findModuleSegments pathParts hsSourceDir of
121 Just segments -> buildModuleName segments baseName
122 Nothing -> baseName
123 where
124 buildModuleName segments baseName =
125 let parts = filter (not . null) (segments ++ [baseName])
126 in intercalate "." parts
127
128 -- Find module segments by going up from file until hitting source directory
129 -- Returns Nothing if source directory is not found (fallback to basename)
130 findModuleSegments :: [String] -> String -> Maybe [String]
131 findModuleSegments pathParts sourceDir =
132 let dirParts = take (max 0 (length pathParts - 1)) pathParts
133 reversedDirs = reverse dirParts
134 (between, after) = break (== sourceDir) reversedDirs
135 in case after of
136 [] -> Nothing
137 _ : _ -> Just (reverse between)