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

2 files changed, 131 insertions, 0 deletions

diff --git a/utils/checkUniques/Makefile b/utils/checkUniques/Makefile
new file mode 100644
index 0000000000..a7b2df17e2
--- /dev/null
+++ b/utils/checkUniques/Makefile
@@ -0,0 +1,16 @@
+
+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 $@
diff --git a/utils/checkUniques/checkUniques.hs b/utils/checkUniques/checkUniques.hs
new file mode 100644
index 0000000000..d8858dee26
--- /dev/null
+++ b/utils/checkUniques/checkUniques.hs
@@ -0,0 +1,115 @@
+{-# 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)
+