{-# 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)
vcsIgnorePred :: Verbosity -> FilePath -> IO (Maybe (FilePath -> Bool))
vcsIgnorePred :: Verbosity -> String -> IO (Maybe (String -> Bool))
vcsIgnorePred Verbosity
verbosity String
fp = do
(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
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
]
hgIgnorePred :: Verbosity -> FilePath -> IO (Maybe (FilePath -> Bool))
hgIgnorePred :: Verbosity -> String -> IO (Maybe (String -> Bool))
hgIgnorePred Verbosity
verbosity String
targetDir =
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
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."
]