hstyle-0.2.0.3: src/Main.hs

-- | This is a very simple project containing a few code style checks for use
-- in git hooks for the Snap Framework. Hopefully we'll get some more
-- sophisticated checks and automatic fixes implemented eventually.
{-# LANGUAGE DeriveDataTypeable #-}
module Main
    ( main
    ) where

import Control.Applicative ((<$>))
import System.Directory (doesDirectoryExist, getDirectoryContents)
import System.Exit (ExitCode (..), exitWith)
import System.FilePath (takeExtension, (</>))

import System.Console.CmdArgs

import HStyle

-- | CmdArgs-enabled data-type
data HStyle = HStyle
    { fix   :: Bool
    , quiet :: Bool
    , files :: [FilePath]
    } deriving (Show, Data, Typeable)

-- | CmdArgs configuration
hstyle :: HStyle
hstyle = HStyle
    { fix   = def &= help "Automatically fix (some) problems"
    , quiet = def &= help "Print less output"
    , files = def &= args 
    }

-- | Convert CmdArgs configuration to cleaner datatype
toOptions :: HStyle -> Options
toOptions hs = Options
    { optionsFix   = fix hs
    , optionsQuiet = quiet hs
    }

-- | Recursively list the contents of a directory. Only returns regular files.
getFiles :: FilePath -> IO [FilePath]
getFiles path = do
    isDir <- doesDirectoryExist path
    if not isDir
        then return [path]
        else do
            contents <- filter proper <$> getDirectoryContents path
            concat <$> mapM (getFiles . (path </>)) contents
  where
    proper = not . (`elem` [".", ".."])

-- | Is a file haskell?
isCheckable :: FilePath -> Bool
isCheckable fp = case takeExtension fp of
    ".hs"  -> True
    ".lhs" -> True
    _      -> False

-- | Simple main that takes one command-line parameter of "check" or "fix" and
-- a list of files to be checked.
main :: IO ()
main = do
    config <- cmdArgs hstyle
    -- Expand all files
    files' <- filter isCheckable . concat <$> mapM getFiles (files config)
    ok <- all fileOk <$> mapM (checkStyle $ toOptions config) files'
    exitWith $ if ok then ExitSuccess else ExitFailure 1