Retrie/Util.hs

-- Copyright (c) Facebook, Inc. and its affiliates.
--
-- This source code is licensed under the MIT license found in the
-- LICENSE file in the root directory of this source tree.
--
{-# LANGUAGE ScopedTypeVariables #-}
module Retrie.Util where

import Control.Arrow (first)
import Control.Applicative
import Control.Concurrent.Async
import Control.Exception
import Control.Monad
import Data.List
import qualified Data.Set as Set
import System.Exit
import System.FilePath
import System.Process
import System.IO (hPutStrLn, stderr)

data Verbosity = Silent | Normal | Loud
  deriving (Eq, Ord, Show)

debugPrint :: Verbosity -> String -> [String] -> IO ()
debugPrint verbosity header ls
  | verbosity < Loud = return ()
  | otherwise = mapM_ putStrLn (header:ls)

-- | Returns predicate which says whether filepath is ignored by VCS.
vcsIgnorePred :: Verbosity -> FilePath -> IO (Maybe (FilePath -> Bool))
vcsIgnorePred verbosity fp = do
  -- We just try to run both 'git' and 'hg' here. Only one should succeed,
  -- because a directory can't be both a git repo and an hg repo.
  -- If both fail, then the whole predicate is Nothing and we keep going
  -- without ignoring any files. Not ideal, but ignoring is just a convenience
  -- to save wasted time rewriting ignored files, so not the end of the world.
  (gitPred, hgPred) <-
    concurrently (gitIgnorePred verbosity fp) (hgIgnorePred verbosity fp)
  return $ gitPred <|> hgPred

-- | Read .gitignore in dir and if successful, return predicate for whether
-- given repo path should be ignored.
gitIgnorePred :: Verbosity -> FilePath -> IO (Maybe (FilePath -> Bool))
gitIgnorePred verbosity targetDir = ignoreWorker "gitIgnorePred: " verbosity targetDir id $
  proc "git"
    [ "ls-files"
    , "--ignored"
    , "--exclude-standard"
    , "--others"
    , "--directory"
    , targetDir
    ]

-- | Read .hgignore in dir and if successful, return predicate for whether
-- given repo path should be ignored.
hgIgnorePred :: Verbosity -> FilePath -> IO (Maybe (FilePath -> Bool))
hgIgnorePred verbosity targetDir =
  -- .hg looks like an extension, so have to add this after the partition
  ignoreWorker "hgIgnorePred: " verbosity targetDir (normalise (targetDir </> ".hg") :) $
    proc "hg"
      [ "status"
      , "--ignored"
      , "--no-status"
      , "-I"
      , "re:.*\\.hs$"
      ]

ignoreWorker
  :: String
  -> Verbosity
  -> FilePath
  -> ([FilePath] -> [FilePath])
  -> CreateProcess
  -> IO (Maybe (FilePath -> Bool))
ignoreWorker prefix verbosity targetDir extraDirs cmd = handle (handler prefix verbosity) $ do
  let command = cmd { cwd = Just targetDir }
  (ec, fps, err) <- readCreateProcessWithExitCode command ""
  case ec of
    ExitSuccess -> do
      let
        (ifiles, dirs) = first Set.fromList $ partition hasExtension
          [ normalise $ targetDir </> dropTrailingPathSeparator f
          | f <- lines fps ]
        idirs = extraDirs dirs
      return $ Just
        $ \fp -> fp `Set.member` ifiles || any (`isPrefixOf` fp) idirs
    ExitFailure _ -> do
      when (verbosity > Normal) $ putErrStrLn $ prefix ++ err
      return Nothing

handler :: String -> Verbosity -> IOError -> IO (Maybe a)
handler prefix verbosity err = do
  when (verbosity > Normal) $ putErrStrLn $ prefix ++ show err
  return Nothing

putErrStrLn :: String -> IO ()
putErrStrLn = hPutStrLn stderr

-- | Like 'try', but rethrows async exceptions.
trySync :: IO a -> IO (Either SomeException a)
trySync io = catch (Right <$> io) $ \e ->
  case fromException e of
    Just (_ :: SomeAsyncException) -> throwIO e
    Nothing -> return (Left e)

missingSyntax :: String -> a
missingSyntax constructor = error $ unlines
  [ "Missing syntax support: " ++ constructor
  , "Please file an issue at https://github.com/facebookincubator/retrie/issues"
  , "with an example of the rewrite you are attempting and we'll add it."
  ]