Commit e506f02d authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari

Rewrite checkUniques and incorporate into validate

This should catch duplicate uniques in the future before Bad Things
happen.

Test Plan: Introduce a duplicate unique and validate

Reviewers: austin, hvr, thomie

Reviewed By: hvr, thomie

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1521
parent 6d147939
TOP = ../..
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) -O -XHaskell2010 --make $@
check:
./check-uniques.py $(TOP)
#!/usr/bin/env python
from __future__ import print_function
import os.path
import sys
import re
import glob
from collections import defaultdict
# keyed on unique type, values are lists of (unique, name) pairs
def find_uniques(source_files):
uniques = defaultdict(lambda: defaultdict(lambda: set()))
unique_re = re.compile(r"([\w\d]+)\s*=\s*mk([\w\d']+)Unique\s+(\d+)")
for f in source_files:
ms = unique_re.findall(open(f).read())
for m in ms:
name = m[0]
_type = m[1]
n = int(m[2])
uniques[_type][n].add(name)
return uniques
def print_all(uniques):
for _type, uniqs in uniques.items():
print('{_type} uniques'.format(**locals()))
for n,names in uniqs.items():
all_names = ', '.join(names)
print(' {n} = {all_names}'.format(**locals()))
def find_conflicts(uniques):
return [ (uniqueType, number, names)
for uniqueType, uniqs in uniques.items()
for number, names in uniqs.items()
if len(names) > 1
]
top_dir = sys.argv[1]
uniques = find_uniques(glob.glob(os.path.join(top_dir, 'compiler', 'prelude', '*.hs')))
#print_all(uniques)
conflicts = find_conflicts(uniques)
if len(conflicts) > 0:
print("Error: check-uniques: Found Unique conflict")
print()
for (ty, n, names) in conflicts:
print(' %s unique %d conflict: %s' % (ty, n, ', '.join(names)))
print()
sys.exit(1)
-- 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)
......@@ -157,6 +157,8 @@ if [ $be_quiet -eq 1 ]; then
make="$make -s"
fi
$make -C utils/checkUniques
if [ $testsuite_only -eq 0 ]; then
if [ $no_clean -eq 0 ]; then
......
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