utils/checkUniques/checkUniques.hs

   1 {-# LANGUAGE PatternGuards #-}
   2
   3 -- Some things could be improved, e.g.:
   4 -- * Check that each file given contains at least one instance of the
   5 --   function
   6 -- * Check that we are testing all functions
   7 -- * If a problem is found, give better location information, e.g.
   8 --   which problem the file is in
   9
  10 module Main (main) where
  11
  12 import Control.Concurrent
  13 import Control.Exception
  14 import Control.Monad
  15 import Control.Monad.State
  16 import Data.Char
  17 import Data.Set (Set)
  18 import qualified Data.Set as Set
  19 import System.Environment
  20 import System.Exit
  21 import System.IO
  22 import System.Process
  23
  24 main :: IO ()
  25 main = do args <- getArgs
  26           case args of
  27               function : files ->
  28                   doit function files
  29
  30 die :: String -> IO a
  31 die err = do hPutStrLn stderr err
  32              exitFailure
  33
  34 type M = StateT St IO
  35
  36 data St = St {
  37               stSeen :: Set Int,
  38               stLast :: Maybe Int,
  39               stHadAProblem :: Bool
  40           }
  41
  42 emptyState :: St
  43 emptyState = St {
  44                  stSeen = Set.empty,
  45                  stLast = Nothing,
  46                  stHadAProblem = False
  47              }
  48
  49 use :: Int -> M ()
  50 use n = do st <- get
  51            let seen = stSeen st
  52            put $ st { stSeen = Set.insert n seen, stLast = Just n }
  53            if (n `Set.member` seen)
  54                then problem ("Duplicate " ++ show n)
  55                else case stLast st of
  56                     Just l
  57                      | (l > n) ->
  58                         problem ("Decreasing order for " ++ show l
  59                                                ++ " -> " ++ show n)
  60                     _ ->
  61                         return ()
  62
  63 problem :: String -> M ()
  64 problem str = do lift $ putStrLn str
  65                  st <- get
  66                  put $ st { stHadAProblem = True }
  67
  68 doit :: String -> [FilePath] -> IO ()
  69 doit function files
  70  = do (hIn, hOut, hErr, ph) <- runInteractiveProcess
  71                                    "grep" ("-h" : function : files)
  72                                    Nothing Nothing
  73       hClose hIn
  74       strOut <- hGetContents hOut
  75       strErr <- hGetContents hErr
  76       forkIO $ do evaluate (length strOut)
  77                   return ()
  78       forkIO $ do evaluate (length strErr)
  79                   return ()
  80       ec <- waitForProcess ph
  81       case (ec, strErr) of
  82           (ExitSuccess, "") ->
  83               check function strOut
  84           _ ->
  85               error "grep failed"
  86
  87 check :: String -> String -> IO ()
  88 check function str
  89     = do let ls = lines str
  90              -- filter out lines that start with whitespace. They're
  91              -- from things like:
  92              --     import M ( ...,
  93              --                ..., <function>, ...
  94              ls' = filter (not . all isSpace . take 1) ls
  95          ns <- mapM (parseLine function) ls'
  96          st <- execStateT (do mapM_ use ns
  97                               st <- get
  98                               when (Set.null (stSeen st)) $
  99                                   problem "No values found")
 100                           emptyState
 101          when (stHadAProblem st) exitFailure
 102
 103 parseLine :: String -> String -> IO Int
 104 parseLine function str
 105     = -- words isn't necessarily quite right, e.g. we could have
 106     -- "var=" rather than "var =", but it works for the code
 107     -- we have
 108     case words str of
 109     _var : "=" : fun : numStr : rest
 110      | fun == function,
 111        null rest || "--" == head rest,
 112        [(num, "")] <- reads numStr
 113           -> return num
 114     _ -> error ("Bad line: " ++ show str)
 115