1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
-- Some things could be improved, e.g.:
-- * Check that each file given contains at least one instance of the
-- function
-- * Check that we are testing all functions
-- * If a problem is found, give better location information, e.g.
-- which problem the file is in
module Main (main) where
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.State
import Data.Char
import Data.Set (Set)
import qualified Data.Set as Set
import System.Environment
import System.Exit
import System.IO
import System.Process
main :: IO ()
main = do args <- getArgs
case args of
function : files ->
doit function files
die :: String -> IO a
die err = do hPutStrLn stderr err
exitFailure
type M = StateT St IO
data St = St {
stSeen :: Set Int,
stLast :: Maybe Int,
stHadAProblem :: Bool
}
emptyState :: St
emptyState = St {
stSeen = Set.empty,
stLast = Nothing,
stHadAProblem = False
}
use :: Int -> M ()
use n = do st <- get
let seen = stSeen st
put $ st { stSeen = Set.insert n seen, stLast = Just n }
if (n `Set.member` seen)
then problem ("Duplicate " ++ show n)
else case stLast st of
Just l
| (l > n) ->
problem ("Decreasing order for " ++ show l
++ " -> " ++ show n)
_ ->
return ()
problem :: String -> M ()
problem str = do lift $ putStrLn str
st <- get
put $ st { stHadAProblem = True }
doit :: String -> [FilePath] -> IO ()
doit function files
= do (hIn, hOut, hErr, ph) <- runInteractiveProcess
"grep" ("-h" : function : files)
Nothing Nothing
hClose hIn
strOut <- hGetContents hOut
strErr <- hGetContents hErr
forkIO $ do evaluate (length strOut)
return ()
forkIO $ do evaluate (length strErr)
return ()
ec <- waitForProcess ph
case (ec, strErr) of
(ExitSuccess, "") ->
check function strOut
_ ->
error "grep failed"
check :: String -> String -> IO ()
check function str
= do let ls = lines str
-- filter out lines that start with whitespace. They're
-- from things like:
-- import M ( ...,
-- ..., <function>, ...
ls' = filter (not . all isSpace . take 1) ls
ns <- mapM (parseLine function) ls'
st <- execStateT (do mapM_ use ns
st <- get
when (Set.null (stSeen st)) $
problem "No values found")
emptyState
when (stHadAProblem st) exitFailure
parseLine :: String -> String -> IO Int
parseLine function str
= -- words isn't necessarily quite right, e.g. we could have
-- "var=" rather than "var =", but it works for the code
-- we have
case words str of
_var : "=" : fun : numStr : rest
| fun == function,
null rest || "--" == head rest,
[(num, "")] <- reads numStr
-> return num
_ -> error ("Bad line: " ++ show str)
|
