[commit: ghc] master: Rewrite checkUniques and incorporate into validate (e506f02)
git at git.haskell.org
git at git.haskell.org
Tue Nov 24 13:02:59 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/e506f02dd2ff75857e975170eb1988b3c89ff190/ghc
>---------------------------------------------------------------
commit e506f02dd2ff75857e975170eb1988b3c89ff190
Author: Ben Gamari <bgamari.foss at gmail.com>
Date: Tue Nov 24 12:45:27 2015 +0100
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
>---------------------------------------------------------------
e506f02dd2ff75857e975170eb1988b3c89ff190
utils/checkUniques/Makefile | 14 +----
utils/checkUniques/check-uniques.py | 48 +++++++++++++++
utils/checkUniques/checkUniques.hs | 113 ------------------------------------
validate | 2 +
4 files changed, 53 insertions(+), 124 deletions(-)
diff --git a/utils/checkUniques/Makefile b/utils/checkUniques/Makefile
index b017473..b53759c 100644
--- a/utils/checkUniques/Makefile
+++ b/utils/checkUniques/Makefile
@@ -1,16 +1,8 @@
+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)
diff --git a/utils/checkUniques/check-uniques.py b/utils/checkUniques/check-uniques.py
new file mode 100755
index 0000000..42b375e
--- /dev/null
+++ b/utils/checkUniques/check-uniques.py
@@ -0,0 +1,48 @@
+#!/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)
diff --git a/utils/checkUniques/checkUniques.hs b/utils/checkUniques/checkUniques.hs
deleted file mode 100644
index 2eda188..0000000
--- a/utils/checkUniques/checkUniques.hs
+++ /dev/null
@@ -1,113 +0,0 @@
--- 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)
-
diff --git a/validate b/validate
index 4c123fe..3b21002 100755
--- a/validate
+++ b/validate
@@ -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
More information about the ghc-commits
mailing list