[QA] improve reporting

QA.hs

@@ -4,12 +4,13 @@ module Main where
 import Language.Haskell.Exts
 import Language.Haskell.Exts.Pretty
 import Data.List
+import Data.IORef
 import System.Directory
 import System.FilePath
 import System.Posix.Files
 import System.Process
 import Control.Monad
-import Control.Applicative ((<$>))
+import Control.Applicative ((<$>), (<*>))
 import Control.Exception
 
 import System.Console.ANSI
@@ -34,21 +35,42 @@ perModuleAllowedModules =
             [ ModuleName "Control.Applicative"
             ]
       )
+    , ("Crypto/Internal/Memory.hs",
+            [ ModuleName "Data.SecureMem"
+            ]
+      )
     ]
 
+data ModuleState = ModuleState
+    { mWarnings :: IORef Int
+    , mErrors   :: IORef Int
+    }
+
+newState :: IO ModuleState
+newState = ModuleState <$> newIORef 0 <*> newIORef 0
+
+incrWarnings :: ModuleState -> IO ()
+incrWarnings st = modifyIORef (mWarnings st) (+1)
+
+incrErrors :: ModuleState -> IO ()
+incrErrors st = modifyIORef (mErrors st) (+1)
 
 main = do
     modules <- findAllModules
     mapM_ qa modules
   where qa file = do
-            printHeader ("==== " ++ file)
+            st <- newState
+
+            printHeader ("[# " ++ file ++ " #]")
             content <- readFile file
             let mexts = readExtensions content
             case mexts of
-                Nothing        -> printError "failed to parsed extensions"
+                Nothing        -> do
-                Just (_, exts) -> qaExts file content exts
+                    printError st "failed to parsed extensions"
+                    printReport st file
+                Just (_, exts) -> qaExts st file content exts
 
-        qaExts file contentRaw exts = do
+        qaExts st file contentRaw exts = do
             printInfo "extensions" (intercalate ", " $ map show (getEnabledExts exts))
 
             let hasCPP = EnableExtension CPP `elem` exts
@@ -58,7 +80,9 @@ main = do
             let mode = defaultParseMode { parseFilename = file, extensions = exts }
 
             case parseModuleWithMode mode content of
-                ParseFailed srcLoc s -> printError ("failed to parse module: " ++ show srcLoc ++ " : " ++ s)
+                ParseFailed srcLoc s -> do
+                    printError st ("failed to parse module: " ++ show srcLoc ++ " : " ++ s)
+                    printReport st file
                 ParseOk mod          -> do
                     let imports = getModulesImports mod
                     printInfo "modules" (intercalate ", "  (map (prettyPrint . importModule) imports))
@@ -67,7 +91,7 @@ main = do
                     forM_ (getEnabledExts exts) $ \ext -> do
                         let allowed = elem ext allowedExtensions
                             allowed' = allowed || maybe False (\z -> elem ext z) (lookup file perModuleAllowedExtensions)
-                        unless allowed' $ printWarningExtension ext
+                        unless allowed' $ printWarningExtension st ext
 
                     -- check for disallowed modules
                     forM_ (map importModule $ getModulesImports mod) $ \impMod ->
@@ -78,7 +102,11 @@ main = do
                                 let allowed = case lookup file perModuleAllowedModules of
                                                  Nothing          -> False
                                                  Just allowedMods -> elem impMod allowedMods
-                                unless allowed $ printWarningImport impMod newMod
+                                unless allowed $ printWarningImport st impMod newMod
+                    printReport st file
+
+        report warnings errors =
+            putStrLn ""
                     
         moduleToFile (ModuleName m) =
             intercalate "/" (wordsWhen (== '.') m) ++ ".hs"
@@ -107,16 +135,33 @@ processCPP file content = do
 ------------------------------------------------------------------------
 
 printHeader s =
-    setSGR [SetColor Foreground Vivid Green] >> putStrLn s >> setSGR []
+    setSGR [SetColor Foreground Vivid Cyan] >> putStrLn s >> setSGR []
 printInfo k v =
     setSGR [SetColor Foreground Vivid Blue] >> putStr k >> setSGR [] >> putStr ": " >> putStrLn v
-printError s =
+printError st s = do
     setSGR [SetColor Foreground Vivid Red] >> putStrLn s >> setSGR []
 
-printWarningImport (ModuleName expected) (ModuleName actual) =
+printReport st m =
+    ((,) <$> readIORef (mWarnings st) <*> readIORef (mErrors st)) >>= uncurry doPrint
+  where doPrint :: Int -> Int -> IO ()
+        doPrint warnings errors
+            | warnings == 0 && errors == 0 = do
+                start
+                setSGR [SetColor Foreground Vivid Green] >> putStrLn "SUCCESS" >> setSGR []
+            | otherwise = do
+                let color = if errors == 0 then Yellow else Red
+                start
+                setSGR [SetColor Foreground Vivid color] >> putStrLn (show errors ++ " errors " ++ show warnings ++ " warnings") >> setSGR []
+        start = do
+            setSGR [SetColor Foreground Vivid Cyan] >> putStr "===> " >> setSGR []
+            putStr (m ++ " : ")
+
+printWarningImport st (ModuleName expected) (ModuleName actual) = do
+    incrWarnings st
     setSGR [SetColor Foreground Vivid Yellow] >> putStrLn ("warning: use module " ++ expected ++ " instead of " ++ actual) >> setSGR []
 
-printWarningExtension ext =
+printWarningExtension st ext = do
+    incrWarnings st
     setSGR [SetColor Foreground Vivid Yellow] >> putStrLn ("warning: use extension " ++ show ext) >> setSGR []
 getModulesImports (Module _ _ _ _ _ imports _) = imports