-- 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 (Verbosity -> Verbosity -> Bool
(Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool) -> Eq Verbosity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c== :: Verbosity -> Verbosity -> Bool
Eq, Eq Verbosity
Eq Verbosity
-> (Verbosity -> Verbosity -> Ordering)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Verbosity)
-> (Verbosity -> Verbosity -> Verbosity)
-> Ord Verbosity
Verbosity -> Verbosity -> Bool
Verbosity -> Verbosity -> Ordering
Verbosity -> Verbosity -> Verbosity
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmax :: Verbosity -> Verbosity -> Verbosity
>= :: Verbosity -> Verbosity -> Bool
$c>= :: Verbosity -> Verbosity -> Bool
> :: Verbosity -> Verbosity -> Bool
$c> :: Verbosity -> Verbosity -> Bool
<= :: Verbosity -> Verbosity -> Bool
$c<= :: Verbosity -> Verbosity -> Bool
< :: Verbosity -> Verbosity -> Bool
$c< :: Verbosity -> Verbosity -> Bool
compare :: Verbosity -> Verbosity -> Ordering
$ccompare :: Verbosity -> Verbosity -> Ordering
$cp1Ord :: Eq Verbosity
Ord, Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> String
(Int -> Verbosity -> ShowS)
-> (Verbosity -> String)
-> ([Verbosity] -> ShowS)
-> Show Verbosity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Verbosity] -> ShowS
$cshowList :: [Verbosity] -> ShowS
show :: Verbosity -> String
$cshow :: Verbosity -> String
showsPrec :: Int -> Verbosity -> ShowS
$cshowsPrec :: Int -> Verbosity -> ShowS
Show)

debugPrint :: Verbosity -> String -> [String] -> IO ()
debugPrint :: Verbosity -> String -> [String] -> IO ()
debugPrint Verbosity
verbosity String
header [String]
ls
  | Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
< Verbosity
Loud = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn (String
headerString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
ls)

-- | Returns predicate which says whether filepath is ignored by VCS.
vcsIgnorePred :: Verbosity -> FilePath -> IO (Maybe (FilePath -> Bool))
vcsIgnorePred :: Verbosity -> String -> IO (Maybe (String -> Bool))
vcsIgnorePred Verbosity
verbosity String
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.
  (Maybe (String -> Bool)
gitPred, Maybe (String -> Bool)
hgPred) <-
    IO (Maybe (String -> Bool))
-> IO (Maybe (String -> Bool))
-> IO (Maybe (String -> Bool), Maybe (String -> Bool))
forall a b. IO a -> IO b -> IO (a, b)
concurrently (Verbosity -> String -> IO (Maybe (String -> Bool))
gitIgnorePred Verbosity
verbosity String
fp) (Verbosity -> String -> IO (Maybe (String -> Bool))
hgIgnorePred Verbosity
verbosity String
fp)
  Maybe (String -> Bool) -> IO (Maybe (String -> Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (String -> Bool) -> IO (Maybe (String -> Bool)))
-> Maybe (String -> Bool) -> IO (Maybe (String -> Bool))
forall a b. (a -> b) -> a -> b
$ Maybe (String -> Bool)
gitPred Maybe (String -> Bool)
-> Maybe (String -> Bool) -> Maybe (String -> Bool)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (String -> Bool)
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 -> String -> IO (Maybe (String -> Bool))
gitIgnorePred Verbosity
verbosity String
targetDir = String
-> Verbosity
-> String
-> ([String] -> [String])
-> CreateProcess
-> IO (Maybe (String -> Bool))
ignoreWorker String
"gitIgnorePred: " Verbosity
verbosity String
targetDir [String] -> [String]
forall a. a -> a
id (CreateProcess -> IO (Maybe (String -> Bool)))
-> CreateProcess -> IO (Maybe (String -> Bool))
forall a b. (a -> b) -> a -> b
$
  String -> [String] -> CreateProcess
proc String
"git"
    [ String
"ls-files"
    , String
"--ignored"
    , String
"--exclude-standard"
    , String
"--others"
    , String
"--directory"
    , String
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 -> String -> IO (Maybe (String -> Bool))
hgIgnorePred Verbosity
verbosity String
targetDir =
  -- .hg looks like an extension, so have to add this after the partition
  String
-> Verbosity
-> String
-> ([String] -> [String])
-> CreateProcess
-> IO (Maybe (String -> Bool))
ignoreWorker String
"hgIgnorePred: " Verbosity
verbosity String
targetDir (ShowS
normalise (String
targetDir String -> ShowS
</> String
".hg") String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) (CreateProcess -> IO (Maybe (String -> Bool)))
-> CreateProcess -> IO (Maybe (String -> Bool))
forall a b. (a -> b) -> a -> b
$
    String -> [String] -> CreateProcess
proc String
"hg"
      [ String
"status"
      , String
"--ignored"
      , String
"--no-status"
      , String
"-I"
      , String
"re:.*\\.hs$"
      ]

ignoreWorker
  :: String
  -> Verbosity
  -> FilePath
  -> ([FilePath] -> [FilePath])
  -> CreateProcess
  -> IO (Maybe (FilePath -> Bool))
ignoreWorker :: String
-> Verbosity
-> String
-> ([String] -> [String])
-> CreateProcess
-> IO (Maybe (String -> Bool))
ignoreWorker String
prefix Verbosity
verbosity String
targetDir [String] -> [String]
extraDirs CreateProcess
cmd = (IOError -> IO (Maybe (String -> Bool)))
-> IO (Maybe (String -> Bool)) -> IO (Maybe (String -> Bool))
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (String -> Verbosity -> IOError -> IO (Maybe (String -> Bool))
forall a. String -> Verbosity -> IOError -> IO (Maybe a)
handler String
prefix Verbosity
verbosity) (IO (Maybe (String -> Bool)) -> IO (Maybe (String -> Bool)))
-> IO (Maybe (String -> Bool)) -> IO (Maybe (String -> Bool))
forall a b. (a -> b) -> a -> b
$ do
  let command :: CreateProcess
command = CreateProcess
cmd { cwd :: Maybe String
cwd = String -> Maybe String
forall a. a -> Maybe a
Just String
targetDir }
  (ExitCode
ec, String
fps, String
err) <- CreateProcess -> String -> IO (ExitCode, String, String)
readCreateProcessWithExitCode CreateProcess
command String
""
  case ExitCode
ec of
    ExitCode
ExitSuccess -> do
      let
        (Set String
ifiles, [String]
dirs) = ([String] -> Set String)
-> ([String], [String]) -> (Set String, [String])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList (([String], [String]) -> (Set String, [String]))
-> ([String], [String]) -> (Set String, [String])
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition String -> Bool
hasExtension
          [ ShowS
normalise ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
targetDir String -> ShowS
</> ShowS
dropTrailingPathSeparator String
f
          | String
f <- String -> [String]
lines String
fps ]
        idirs :: [String]
idirs = [String] -> [String]
extraDirs [String]
dirs
      Maybe (String -> Bool) -> IO (Maybe (String -> Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (String -> Bool) -> IO (Maybe (String -> Bool)))
-> Maybe (String -> Bool) -> IO (Maybe (String -> Bool))
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> Maybe (String -> Bool)
forall a. a -> Maybe a
Just
        ((String -> Bool) -> Maybe (String -> Bool))
-> (String -> Bool) -> Maybe (String -> Bool)
forall a b. (a -> b) -> a -> b
$ \String
fp -> String
fp String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
ifiles Bool -> Bool -> Bool
|| (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
fp) [String]
idirs
    ExitFailure Int
_ -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
> Verbosity
Normal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putErrStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err
      Maybe (String -> Bool) -> IO (Maybe (String -> Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (String -> Bool)
forall a. Maybe a
Nothing

handler :: String -> Verbosity -> IOError -> IO (Maybe a)
handler :: String -> Verbosity -> IOError -> IO (Maybe a)
handler String
prefix Verbosity
verbosity IOError
err = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
> Verbosity
Normal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putErrStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ IOError -> String
forall a. Show a => a -> String
show IOError
err
  Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

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

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

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