Commit ecfc67d5 authored by Ian Lynagh's avatar Ian Lynagh

Add a tool for checking for problems in the built-in uniques

parent b5a358ee
GHC = ghc
PREL_NAMES = ../../compiler/prelude/PrelNames.lhs
DS_META = ../../compiler/deSugar/DsMeta.hs
.PHONY: check
check: checkUniques
./checkUniques mkPreludeClassUnique $(PREL_NAMES)
./checkUniques mkPreludeTyConUnique $(PREL_NAMES) $(DS_META)
./checkUniques mkPreludeDataConUnique $(PREL_NAMES)
./checkUniques mkPreludeMiscIdUnique $(PREL_NAMES) $(DS_META)
checkUniques: checkUniques.hs
$(GHC) --make $@
{-# LANGUAGE PatternGuards #-}
-- 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)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment