git-vogue-0.3.0.0: src/git-vogue-ghc-mod.hs

--
-- Copyright © 2013-2015 Anchor Systems, Pty Ltd and Others
--
-- The code in this file, and the program it is a part of, is
-- made available to you by its authors as open source software:
-- you can redistribute it and/or modify it under the terms of
-- the 3-clause BSD licence.
--

{-# LANGUAGE LambdaCase #-}

-- | Description: Check with "cabal check".
module Main where

import           Control.Applicative
import           Control.Monad
import           Data.Char
import           Data.Foldable
import           Data.List              hiding (and)
import           Data.Maybe
import           Data.Monoid
import           Data.Traversable
import           GhcMod
import           GhcMod.Monad
import           Git.Vogue.PluginCommon
import           Prelude                hiding (and)
import           System.Exit

main :: IO ()
main =
    f =<< getPluginCommand
            "Check your Haskell project for ghc-mod problems."
            "git-vogue-ghc-mod - check for ghc-mod problems"
  where
    f CmdName  = putStrLn "ghc-mod"
    f (CmdCheck check_fs_list all_fs_list) = do
        check_fs <- read <$> readFile check_fs_list
        all_fs <- read <$> readFile all_fs_list
        -- Have to change to the project directory for each ghc-mod run or it
        -- will be sad.
        --
        -- We run ghcModCheck in each, which will exit on the first failure.
        rs <- forProjects (hsProjects check_fs all_fs) $ \fs ->
            -- HLint.hs is weird and more of a config file than a source file, so
            -- ghc-mod doesn't like it.
            --
            -- Setup.hs can import cabal things magically, without requiring it to
            -- be mentioned in cabal (which ghc-mod hates)
            ghcModCheck $ filter (\x ->    not ("HLint.hs" `isSuffixOf` x)
                                        && not ("Setup.hs" `isSuffixOf` x)
                                        && ".hs" `isSuffixOf` x) fs

        unless (and rs) exitFailure

    f CmdFix{} = do
        outputBad $ "There are outstanding ghc-mod failures, you need to fix this "
                <> "manually and then re-run check"
        exitFailure

-- | Try to help the user out with some munging of error messages
explain :: String -> String
explain s
    -- A terrible heuristic, but it may help some people
    | "test" `isInfixOf` fmap toLower s && "hidden package" `isInfixOf` s =
        s <> "\n\tSuggestion: cabal configure --enable-tests\n"
    | "bench" `isInfixOf` fmap toLower s && "hidden package" `isInfixOf` s =
        s <> "\n\tSuggestion: cabal configure --enable-benchmarks\n"
    | "hGetContents: invalid argument" `isInfixOf` s =
        s <> "\n\tSuggestion: use cabal < 1.22\n"
    | otherwise = s

-- | ghc-mod check all of the given files from the current directory
--
-- This will print out output, and return a bool representing success.
ghcModCheck :: [FilePath] -> IO Bool
ghcModCheck files = do
    -- We can't actually check all at once, or ghc-mod gets confused, so we
    -- traverse
    (r,_) <- runGmOutT defaultOptions $ runGhcModT defaultOptions (traverse (check . pure) files)

    -- Seriously guys? Eithers within eithers?
    warn_errs <- case r of
            -- This is some kind of outer-error, we don't fail on it.
            Left e -> do
                outputUnfortunate . lineWrap 74 $ show e
                return []
            -- And these are the warnings and errors.
            Right rs ->
                return rs

    -- Traverse the errors, picking errors and warnings out
    maybe_ws <- for warn_errs $
        \case
            -- Errors in files
            Left e ->
                return . Just $ explain e
            -- Warnings, sometimes empty strings
            Right warn ->
                return $ if null warn then Nothing else Just warn

    let warns = catMaybes maybe_ws
    if null warns
        then do
            outputGood $ "Checked " <> show (length files)  <> " file(s)"
            return True
        else do
            traverse_ outputBad warns
            return False