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

debugPrint :: Verbosity -> String -> [String] -> IO ()
debugPrint :: Verbosity -> FilePath -> [FilePath] -> IO ()
debugPrint Verbosity
verbosity FilePath
header [FilePath]
ls
  | Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
< Verbosity
Loud = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
putStrLn (FilePath
headerFilePath -> [FilePath] -> [FilePath]
forall 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) <-
    IO (Maybe (FilePath -> Bool))
-> IO (Maybe (FilePath -> Bool))
-> IO (Maybe (FilePath -> Bool), Maybe (FilePath -> Bool))
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)
  Maybe (FilePath -> Bool) -> IO (Maybe (FilePath -> Bool))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FilePath -> Bool) -> IO (Maybe (FilePath -> Bool)))
-> Maybe (FilePath -> Bool) -> IO (Maybe (FilePath -> Bool))
forall a b. (a -> b) -> a -> b
$ Maybe (FilePath -> Bool)
gitPred Maybe (FilePath -> Bool)
-> Maybe (FilePath -> Bool) -> Maybe (FilePath -> Bool)
forall a. Maybe a -> Maybe a -> Maybe a
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 [FilePath] -> [FilePath]
forall a. a -> a
id (CreateProcess -> IO (Maybe (FilePath -> Bool)))
-> CreateProcess -> IO (Maybe (FilePath -> Bool))
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") FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:) (CreateProcess -> IO (Maybe (FilePath -> Bool)))
-> CreateProcess -> IO (Maybe (FilePath -> Bool))
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 = (IOError -> IO (Maybe (FilePath -> Bool)))
-> IO (Maybe (FilePath -> Bool)) -> IO (Maybe (FilePath -> Bool))
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (FilePath -> Verbosity -> IOError -> IO (Maybe (FilePath -> Bool))
forall a. FilePath -> Verbosity -> IOError -> IO (Maybe a)
handler FilePath
prefix Verbosity
verbosity) (IO (Maybe (FilePath -> Bool)) -> IO (Maybe (FilePath -> Bool)))
-> IO (Maybe (FilePath -> Bool)) -> IO (Maybe (FilePath -> Bool))
forall a b. (a -> b) -> a -> b
$ do
  let command :: CreateProcess
command = CreateProcess
cmd { cwd = Just 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) = ([FilePath] -> Set FilePath)
-> ([FilePath], [FilePath]) -> (Set FilePath, [FilePath])
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
Set.fromList (([FilePath], [FilePath]) -> (Set FilePath, [FilePath]))
-> ([FilePath], [FilePath]) -> (Set FilePath, [FilePath])
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> ([FilePath], [FilePath])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition FilePath -> Bool
hasExtension
          [ ShowS
normalise ShowS -> ShowS
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
      Maybe (FilePath -> Bool) -> IO (Maybe (FilePath -> Bool))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (FilePath -> Bool) -> IO (Maybe (FilePath -> Bool)))
-> Maybe (FilePath -> Bool) -> IO (Maybe (FilePath -> Bool))
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> Maybe (FilePath -> Bool)
forall a. a -> Maybe a
Just
        ((FilePath -> Bool) -> Maybe (FilePath -> Bool))
-> (FilePath -> Bool) -> Maybe (FilePath -> Bool)
forall a b. (a -> b) -> a -> b
$ \FilePath
fp -> FilePath
fp FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set FilePath
ifiles Bool -> Bool -> Bool
|| (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
fp) [FilePath]
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
$ FilePath -> IO ()
putErrStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
prefix FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
err
      Maybe (FilePath -> Bool) -> IO (Maybe (FilePath -> Bool))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (FilePath -> Bool)
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
  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
$ FilePath -> IO ()
putErrStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
prefix FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ IOError -> FilePath
forall a. Show a => a -> FilePath
show IOError
err
  Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
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 = 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 a. a -> IO 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 :: forall a. FilePath -> a
missingSyntax FilePath
constructor = FilePath -> a
forall a. HasCallStack => FilePath -> a
error (FilePath -> a) -> FilePath -> a
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines
  [ FilePath
"Missing syntax support: " FilePath -> ShowS
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."
  ]