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

4 files changed, 53 insertions, 124 deletions

diff --git a/utils/checkUniques/Makefile b/utils/checkUniques/Makefile
index b017473da3..b53759c734 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 0000000000..42b375e379
--- /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 2eda188e3c..0000000000
--- 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 4c123fe844..3b2100235b 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