-- 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
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
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
Ord, Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Verbosity] -> ShowS
$cshowList :: [Verbosity] -> ShowS
show :: Verbosity -> FilePath
$cshow :: Verbosity -> FilePath
showsPrec :: Int -> Verbosity -> ShowS
$cshowsPrec :: Int -> Verbosity -> ShowS
Show)

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

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

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

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

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

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

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