[QA] improve reporting

QA.hs

@@ -9,6 +9,8 @@ import System.Directory
 import System.FilePath
 import System.Posix.Files
 import System.Process
+import System.Environment
+import Control.Arrow
 import Control.Monad
 import Control.Applicative ((<$>), (<*>))
 import Control.Exception
@@ -46,37 +48,108 @@ perModuleAllowedModules =
       )
     ]
 
+data Issue =
+      Issue_FailedToParseExtension
+    | Issue_FailedToParseModule SrcLoc String
+    | Issue_Extension String
+    | Issue_Import ModuleName ModuleName
+    deriving (Eq)
+
+prettyIssue Issue_FailedToParseExtension = "failed to parse extension"
+prettyIssue (Issue_FailedToParseModule loc p) = "failed to parse module : " ++ show loc ++ " : " ++ p
+prettyIssue (Issue_Extension e) = "extension not authorized: " ++ e
+prettyIssue (Issue_Import (ModuleName old) (ModuleName new)) = "import : " ++ old ++ " should be : " ++ show new
+
+data IssueLevel =
+      IssueFatal
+    | IssueError
+    | IssueWarning
+    | IssueUnknown
+    deriving (Show,Eq)
+
+getIssueLevel :: Issue -> IssueLevel
+getIssueLevel Issue_FailedToParseExtension   = IssueFatal
+getIssueLevel (Issue_FailedToParseModule {}) = IssueFatal
+getIssueLevel _ = IssueUnknown
+
+data InfoVal =
+      InfoValList [String]
+    | InfoValString String
+    deriving (Show,Eq)
+
 data ModuleState = ModuleState
-    { mWarnings :: IORef Int
+    { mInfo   :: IORef [(String, InfoVal)]
-    , mErrors   :: IORef Int
+    , mIssues :: IORef [Issue]
     }
 
+data ModuleQA = ModuleQA FilePath [(String, InfoVal)] [Issue]
+    deriving (Eq)
+
+moduleGetIssues :: ModuleQA -> [Issue]
+moduleGetIssues (ModuleQA _ _ is) = is
+
 newState :: IO ModuleState
-newState = ModuleState <$> newIORef 0 <*> newIORef 0
+newState = ModuleState <$> newIORef [] <*> newIORef []
 
-incrWarnings :: ModuleState -> IO ()
+freezeState :: FilePath -> ModuleState -> IO ModuleQA
-incrWarnings st = modifyIORef (mWarnings st) (+1)
+freezeState file (ModuleState info issues) = ModuleQA file <$> readIORef info <*> readIORef issues
 
-incrErrors :: ModuleState -> IO ()
+data Options = Options
-incrErrors st = modifyIORef (mErrors st) (+1)
+    { optionWarningIsError :: Bool
+    }
+
+defaultOptions = Options
+    { optionWarningIsError = False
+    }
+
+parseArgs opts []     = opts
+parseArgs opts (x:xs) =
+    let nopts = case x of
+                "-Werror" -> opts { optionWarningIsError = True }
+                _         -> opts
+     in parseArgs nopts xs
 
 main = do
+    options <- parseArgs defaultOptions <$> getArgs
     modules <- findAllModules
-    mapM_ qa modules
+    qas     <- mapM checkModule modules
-  where qa file = do
+    mapM_ report qas
-            st <- newState
+    summary qas
 
-            printHeader ("[# " ++ file ++ " #]")
+  where
+        summary :: [ModuleQA] -> IO ()
+        summary l = do
+            let (failed, succeeded) = (length *** length) $ partition (null . moduleGetIssues) l
+            putStrLn ("failed: " ++ show failed ++ " succeeded: " ++ show succeeded)
+
+        report :: ModuleQA -> IO ()
+        report (ModuleQA f infos issues)
+            | null issues = do
+                setColor Cyan >> putStr f >> setSGR [] >> putStr padding
+                setColor Green >> putStrLn "SUCCESS" >> setSGR []
+            | otherwise   = do
+                setColor Cyan >> putStr f >> setSGR [] >> putStr padding
+                setColor Red >> putStrLn "FAILED" >> setSGR []
+                mapM_ reportIssue issues
+          where
+                padding = replicate padN ' '
+                padN    = 64 - length f
+
+                reportIssue issue = setColor Red >> putStr "  " >> putStrLn (prettyIssue issue) >> setSGR []
+
+        setColor c = setSGR [SetColor Foreground Vivid c]
+
+        checkModule file = do
+            st      <- newState
             content <- readFile file
-            let mexts = readExtensions content
+            case readExtensions content of
-            case mexts of
+                Nothing        -> recordIssue st Issue_FailedToParseExtension
-                Nothing        -> do
-                    printError st "failed to parsed extensions"
-                    printReport st file
                 Just (_, exts) -> qaExts st file content exts
+            freezeState file st
+
 
         qaExts st file contentRaw exts = do
-            printInfo "extensions" (intercalate ", " $ map show (getEnabledExts exts))
+            recordInfo st "extensions" (intercalate ", " $ map show (getEnabledExts exts))
 
             let hasCPP = EnableExtension CPP `elem` exts
 
@@ -86,17 +159,16 @@ main = do
 
             case parseModuleWithMode mode content of
                 ParseFailed srcLoc s -> do
-                    printError st ("failed to parse module: " ++ show srcLoc ++ " : " ++ s)
+                    recordIssue st $ Issue_FailedToParseModule srcLoc s
-                    printReport st file
                 ParseOk mod          -> do
                     let imports = getModulesImports mod
-                    printInfo "modules" (intercalate ", "  (map (prettyPrint . importModule) imports))
+                    recordInfo st "modules" $ InfoValList (map (prettyPrint . importModule) imports)
 
                     -- check for allowed extensions
                     forM_ (getEnabledExts exts) $ \ext -> do
                         let allowed = elem ext allowedExtensions
                             allowed' = allowed || maybe False (\z -> elem ext z) (lookup file perModuleAllowedExtensions)
-                        unless allowed' $ printWarningExtension st ext
+                        unless allowed' $ recordIssue st (Issue_Extension $ show ext)
 
                     -- check for disallowed modules
                     forM_ (map importModule $ getModulesImports mod) $ \impMod ->
@@ -107,12 +179,8 @@ main = do
                                 let allowed = case lookup file perModuleAllowedModules of
                                                  Nothing          -> False
                                                  Just allowedMods -> elem impMod allowedMods
-                                unless allowed $ printWarningImport st impMod newMod
+                                unless allowed $ recordIssue st (Issue_Import impMod newMod)
-                    printReport st file
 
-        report warnings errors =
-            putStrLn ""
-                    
         moduleToFile (ModuleName m) =
             intercalate "/" (wordsWhen (== '.') m) ++ ".hs"
 
@@ -139,35 +207,11 @@ processCPP file content = do
 
 ------------------------------------------------------------------------
 
-printHeader s =
+recordIssue st s =
-    setSGR [SetColor Foreground Vivid Cyan] >> putStrLn s >> setSGR []
+    modifyIORef (mIssues st) ((:) s)
-printInfo k v =
-    setSGR [SetColor Foreground Vivid Blue] >> putStr k >> setSGR [] >> putStr ": " >> putStrLn v
-printError st s = do
-    setSGR [SetColor Foreground Vivid Red] >> putStrLn s >> setSGR []
 
-printReport st m =
+recordInfo st n f = return ()
-    ((,) <$> 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: using module " ++ expected ++ " , should use " ++ actual) >> setSGR []
-
-printWarningExtension st ext = do
-    incrWarnings st
-    setSGR [SetColor Foreground Vivid Yellow] >> putStrLn ("warning: use extension " ++ show ext) >> setSGR []
 getModulesImports (Module _ _ _ _ _ imports _) = imports
 
 getEnabledExts = foldl doAcc []