sensei-0.5.0: src/Util.hs

{-# LANGUAGE CPP, OverloadedStrings, LambdaCase, RecordWildCards, ViewPatterns #-}
module Util (
  Color(..)
, withColor
, withInfoColor
, isBoring
, filterGitIgnoredFiles
, normalizeTypeSignatures
, dotGhciWritableByOthers

#ifdef TEST
, filterGitIgnoredFiles_
, writableByOthers
#endif
) where

import           Imports

import           System.Console.ANSI
import           System.FilePath
import           System.Process
import           System.Posix.Files
import           System.Posix.Types
import qualified Data.Text as T

withInfoColor :: IO a -> IO a
withInfoColor = withColor Magenta

withColor :: Color -> IO a -> IO a
withColor c = bracket_ set reset
  where
    set = setSGR [SetColor Foreground Dull c]
    reset = setSGR []

isBoring :: FilePath -> Bool
isBoring p = ".git" `elem` dirs || "dist" `elem` dirs || isEmacsAutoSave p
  where
    dirs = splitDirectories p
    isEmacsAutoSave = isPrefixOf ".#" . takeFileName

filterGitIgnoredFiles :: [FilePath] -> IO [FilePath]
filterGitIgnoredFiles files = do
  (feedback, ignoredFiles) <- filterGitIgnoredFiles_ files
  printFeedback feedback
  return $ ignoredFiles
  where
    printFeedback :: Feedback -> IO ()
    printFeedback = mapM_ $ \ (color, err) -> withColor color $ putStrLn ('\n' : err)

type Feedback = Maybe (Color, String)

filterGitIgnoredFiles_ :: [FilePath] -> IO (Feedback, [FilePath])
filterGitIgnoredFiles_ files = fmap (files \\) <$> gitCheckIgnore files

gitCheckIgnore :: [FilePath] -> IO (Feedback, [FilePath])
gitCheckIgnore files = do
  (_, ignoredFiles, err) <- readProcessWithExitCode "git" ["check-ignore", "--stdin", "-z"] $ join_ files
  return (feedback err, split ignoredFiles)
  where
    join_ = intercalate "\0"
    split = map T.unpack . T.split (== '\0') . T.pack
    feedback err
      | err == "fatal: not a git repository (or any of the parent directories): .git\n" = Just (Cyan, "warning: not a git repository - .gitignore support not available\n")
      | err == "" = Nothing
      | otherwise = Just (Red, err)

normalizeTypeSignatures :: String -> String
normalizeTypeSignatures = normalize . concatMap replace
  where
    normalize = \case
      xs | "\n  :: " `isPrefixOf` xs -> normalizeTypeSignatures (drop 2 xs)
      x : xs -> x : normalizeTypeSignatures xs
      [] -> []

    replace c = case c of
      '\8759' -> "::"
      '\8594' -> "->"
      _ -> [c]

dotGhciWritableByOthers :: IO Bool
dotGhciWritableByOthers = do
  exists <- fileExist ".ghci"
  if exists then do
    mode <- fileMode <$> getFileStatus ".ghci"
    dirMode <- fileMode <$> getFileStatus "."
    return (writableByOthers mode || writableByOthers dirMode)
  else
    return False

writableByOthers :: FileMode -> Bool
writableByOthers mode = m /= nullFileMode
  where
    m = intersectFileModes (unionFileModes otherWriteMode groupWriteMode) mode