homplexity-0.4.8.0: app/Homplexity.hs

{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE ViewPatterns          #-}
{-# LANGUAGE CPP                   #-}
-- | Main module parsing inputs, and running analysis.
module Main (main) where

import Control.Monad(when)
import Data.Either
import Data.Functor
import Data.List hiding (head)
import Data.Monoid
import Data.Version

import GitHash(giHash, giDirty, giCommitDate, tGitInfoCwdTry, GitInfo)
import HFlags
import Language.Haskell.Exts.Extension
import Language.Haskell.Exts.SrcLoc
import Language.Haskell.Exts.Syntax
import Language.Haskell.Homplexity.Assessment
import Language.Haskell.Homplexity.CabalFiles
import Language.Haskell.Homplexity.CodeFragment
import Language.Haskell.Homplexity.Message
import Language.Haskell.Homplexity.Parse
import System.Directory
import System.Exit
import System.FilePath
import System.IO

import Paths_homplexity(version)

import qualified Prelude as P
import Prelude hiding (head, id, div)
#ifdef HTML_OUTPUT
import qualified Data.ByteString.Lazy as B
import Text.Blaze.Html
import Text.Blaze.Html.Renderer.Utf8
import Text.Blaze.Html4.Strict hiding (map)
--import Text.Blaze.Html4.Strict.Attributes hiding (title, style)
#endif

-- * Command line flag
defineFlag "v:version" False "Show version"

defineFlag "severity" Warning (concat ["level of output verbosity (", severityOptions, ")"])

data OutputFormat =
    Text
#ifdef HTML_OUTPUT
  | HTML
#endif
  deriving (Read, Show)
defineEQFlag "format" [| Text :: OutputFormat |]
#ifdef HTML_OUTPUT
  "{Text|HTML}"
#else
  "{Text}"
#endif
  "What format to use"

-- | Report to standard error output.
report :: String -> IO ()
report  = hPutStrLn stderr

-- * Recursing directory tree in order to list Haskell source files.
-- | Find all Haskell source files within a given path.
-- Recurse down the tree, if the path points to directory.
subTrees          :: FilePath -> IO [FilePath]
-- Recurse to . or .. only at the first level, to prevent looping:
subTrees dir      | dir `elem` [".", ".."] = concatMapM subTrees' =<< getDirectoryPaths dir
subTrees filepath                          = do
  isDir <- doesDirectoryExist filepath
  if isDir
     then subTrees' filepath
     else do
       exists <- doesFileExist filepath
       if exists
          then    return [filepath]
          else do report $ "File does not exist: " ++ filepath
                  return []

-- | Return filepath if normal file, or recurse down the directory if it is not special directory ("." or "..")
subTrees'                       :: FilePath -> IO [FilePath]
subTrees' (takeFileName -> "..") = return []
subTrees' (takeFileName -> "." ) = return []
subTrees'  fp                    = do
  isDir <- doesDirectoryExist fp
  if isDir
    then concatMapM subTrees' =<< getDirectoryPaths fp
    else return $ filter (".hs" `isSuffixOf`) [fp]

-- | Get contents of a given directory, and return their full paths.
getDirectoryPaths        :: FilePath -> IO [FilePath]
getDirectoryPaths dirPath = map (dirPath </>) <$> getDirectoryContents dirPath

-- | Commonly defined function - should be added to base...
concatMapM  :: (Functor m, Monad m) => (a -> m [b]) -> [a] -> m [b]
concatMapM f = fmap concat . mapM f

-- * Analysis
-- | Analyze a set of modules.
analyzeModule :: Module SrcLoc -> IO ()
analyzeModule  = out
               . extract flags_severity
               . mconcat metrics
               . program
               . (:[])
  where
    out msgs = case flags_format of
                    Text -> do
                      putStr . concatMap show $ msgs
#ifdef HTML_OUTPUT
                    HTML -> B.putStr $ renderHtml $ do
                      html $ do
                        head $ do
                          title (string "Homplexity Analysis.")
                        style $ string style_head
                        body $ do
                          toHtml . fmap toHtml $ msgs
    style_head = ".warning  .severity { color: orange; }" <>
                 ".debug    .severity { color: grey;   }" <>
                 ".critical .severity { color: red;    }"
#endif

-- | Process each separate input file.
processFile :: [Extension] -> FilePath -> IO Bool
processFile additionalExtensions filepath =
    parseSource additionalExtensions filepath >>=
        either (\msg              -> report (show msg) >> return False)
               (\(ast, _comments) -> analyzeModule ast >> return True)


-- | This flag exists only to make sure that HFLags work.
defineFlag "cabal" "" "Project cabal file"

-- | This flag exists only to make sure that HFLags work.
defineFlag "fakeFlag" Info "this flag is fake"

gitInfoValue ::Either String GitHash.GitInfo
gitInfoValue  = $$tGitInfoCwdTry

versionString :: String
versionString  = showVersion version <> gitString
  where
    gitString = case gitInfoValue of
                  Left  err     -> ""
                  Right gitInfo -> unwords [
                     "git rev",  giHash       gitInfo
                    ,"dated",    giCommitDate gitInfo
                    ,if          giDirty      gitInfo
                        then     "dirty"
                        else     ""]

-- | Parse arguments and either process inputs (if available), or suggest proper usage.
main :: IO ()
main = do
  args <- $initHFlags ("Homplexity " ++ versionString ++ " - automatic analysis of Haskell code quality")
  if flags_version
     then do report $ unwords ["Homplexity version: ", versionString]
             exitSuccess
     else if null args
             then do report ("Use Haskell source file or directory as an argument, " ++
                             "or use --help to discover options.")
                     exitFailure
             else do exts <- cabalExtensions
                     sums <- mapM (processFile exts) =<< concatMapM subTrees args
                     let successes  = length $ filter P.id sums
                         totalFiles = length               sums
                     report $ unwords ["Correctly parsed", show successes,
                                       "out of",           show totalFiles,
                                       "input files."]
                     if (successes == totalFiles)
                        then exitSuccess
                        else exitFailure

cabalExtensions :: IO [Extension]
cabalExtensions
  | null flags_cabal = return []
  | otherwise =
      parseCabalFile flags_cabal >>=
        either (\msg -> report (show msg) >> return [])
               (\cabal -> return $ languageExtensions Library cabal)