diff --git a/QA.hs b/QA.hs index 4361e5d..739a15e 100644 --- a/QA.hs +++ b/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" - Just (_, exts) -> qaExts file content exts + Nothing -> do + 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