{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Feedback.Loop.Filter where

import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Char8 as LB8
import Data.Conduit
import qualified Data.Conduit.Combinators as C
import qualified Data.Conduit.List as CL
import Data.List
import Data.Set
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Feedback.Common.OptParse
import Path
import Path.IO
import System.Exit
import System.Process.Typed as Typed
#ifdef MIN_VERSION_Win32
import System.Win32.MinTTY (isMinTTYHandle)
import System.Win32.Types (withHandleToHANDLE)
#endif
import UnliftIO

#ifdef MIN_VERSION_Win32
getMinTTY :: IO Bool
getMinTTY = withHandleToHANDLE stdin isMinTTYHandle
#else
getMinTTY :: IO Bool
getMinTTY :: IO Bool
getMinTTY = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
#endif

data Filter = Filter
  { Filter -> Path Abs Dir -> Bool
filterDirFilter :: Path Abs Dir -> Bool,
    Filter -> Path Abs File -> Bool
filterFileFilter :: Path Abs File -> Bool
  }

instance Semigroup Filter where
  Filter
f1 <> :: Filter -> Filter -> Filter
<> Filter
f2 =
    Filter
      { filterDirFilter :: Path Abs Dir -> Bool
filterDirFilter = \Path Abs Dir
d -> Filter -> Path Abs Dir -> Bool
filterDirFilter Filter
f1 Path Abs Dir
d Bool -> Bool -> Bool
&& Filter -> Path Abs Dir -> Bool
filterDirFilter Filter
f2 Path Abs Dir
d,
        filterFileFilter :: Path Abs File -> Bool
filterFileFilter = \Path Abs File
f -> Filter -> Path Abs File -> Bool
filterFileFilter Filter
f1 Path Abs File
f Bool -> Bool -> Bool
&& Filter -> Path Abs File -> Bool
filterFileFilter Filter
f2 Path Abs File
f
      }

instance Monoid Filter where
  mempty :: Filter
mempty = Filter {filterDirFilter :: Path Abs Dir -> Bool
filterDirFilter = forall a b. a -> b -> a
const Bool
True, filterFileFilter :: Path Abs File -> Bool
filterFileFilter = forall a b. a -> b -> a
const Bool
True}
  mappend :: Filter -> Filter -> Filter
mappend = forall a. Semigroup a => a -> a -> a
(<>)

fileSetFilter :: Set (Path Abs File) -> Filter
fileSetFilter :: Set (Path Abs File) -> Filter
fileSetFilter Set (Path Abs File)
fileSet =
  let dirSet :: Set (Path Abs Dir)
dirSet = forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map forall b t. Path b t -> Path b Dir
parent Set (Path Abs File)
fileSet
   in Filter
        { filterDirFilter :: Path Abs Dir -> Bool
filterDirFilter = (forall a. Ord a => a -> Set a -> Bool
`S.member` Set (Path Abs Dir)
dirSet),
          filterFileFilter :: Path Abs File -> Bool
filterFileFilter = (forall a. Ord a => a -> Set a -> Bool
`S.member` Set (Path Abs File)
fileSet)
        }

mkCombinedFilter :: Path Abs Dir -> FilterSettings -> IO Filter
mkCombinedFilter :: Path Abs Dir -> FilterSettings -> IO Filter
mkCombinedFilter Path Abs Dir
here FilterSettings
filterSettings =
  forall a. Monoid a => [a] -> a
mconcat
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
      [ Path Abs Dir -> FilterSettings -> IO Filter
mkGitFilter Path Abs Dir
here FilterSettings
filterSettings,
        Path Abs Dir -> FilterSettings -> IO Filter
mkFindFilter Path Abs Dir
here FilterSettings
filterSettings,
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> Filter
standardFilter Path Abs Dir
here
      ]

mkStdinFilter :: Path Abs Dir -> IO Filter
mkStdinFilter :: Path Abs Dir -> IO Filter
mkStdinFilter Path Abs Dir
here = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty Set (Path Abs File) -> Filter
fileSetFilter forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs Dir -> IO (Maybe (Set (Path Abs File)))
getStdinFiles Path Abs Dir
here

getStdinFiles :: Path Abs Dir -> IO (Maybe (Set (Path Abs File)))
getStdinFiles :: Path Abs Dir -> IO (Maybe (Set (Path Abs File)))
getStdinFiles Path Abs Dir
here = do
  Bool
isTerminal <- forall (m :: * -> *). MonadIO m => Handle -> m Bool
hIsTerminalDevice Handle
stdin
  Bool
isMinTTY <- IO Bool
getMinTTY
  if Bool
isTerminal Bool -> Bool -> Bool
|| Bool
isMinTTY
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    else
      (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs Dir -> Handle -> IO (Set (Path Abs File))
handleFileSet Path Abs Dir
here Handle
stdin)
        forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(IOException
_ :: IOException) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)

mkGitFilter :: Path Abs Dir -> FilterSettings -> IO Filter
mkGitFilter :: Path Abs Dir -> FilterSettings -> IO Filter
mkGitFilter Path Abs Dir
here FilterSettings {Bool
Maybe [Char]
filterSettingFind :: FilterSettings -> Maybe [Char]
filterSettingGitignore :: FilterSettings -> Bool
filterSettingFind :: Maybe [Char]
filterSettingGitignore :: Bool
..} = do
  if Bool
filterSettingGitignore
    then do
      Maybe (Set (Path Abs File))
mGitFiles <- Path Abs Dir -> IO (Maybe (Set (Path Abs File)))
gitLsFiles Path Abs Dir
here
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty Set (Path Abs File) -> Filter
fileSetFilter Maybe (Set (Path Abs File))
mGitFiles
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty

gitLsFiles :: Path Abs Dir -> IO (Maybe (Set (Path Abs File)))
gitLsFiles :: Path Abs Dir -> IO (Maybe (Set (Path Abs File)))
gitLsFiles Path Abs Dir
here = do
  let processConfig :: ProcessConfig () () ()
processConfig = [Char] -> ProcessConfig () () ()
shell [Char]
"git ls-files"
  (ExitCode
ec, ByteString
out) <- forall (m :: * -> *) stdin stdoutIgnored stderr.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderr
-> m (ExitCode, ByteString)
readProcessStdout ProcessConfig () () ()
processConfig
  Set (Path Abs File)
set <- Path Abs Dir -> ByteString -> IO (Set (Path Abs File))
bytesFileSet Path Abs Dir
here ByteString
out
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case ExitCode
ec of
    ExitFailure Int
_ -> forall a. Maybe a
Nothing
    ExitCode
ExitSuccess -> forall a. a -> Maybe a
Just Set (Path Abs File)
set

mkFindFilter :: Path Abs Dir -> FilterSettings -> IO Filter
mkFindFilter :: Path Abs Dir -> FilterSettings -> IO Filter
mkFindFilter Path Abs Dir
here FilterSettings {Bool
Maybe [Char]
filterSettingFind :: Maybe [Char]
filterSettingGitignore :: Bool
filterSettingFind :: FilterSettings -> Maybe [Char]
filterSettingGitignore :: FilterSettings -> Bool
..} = case Maybe [Char]
filterSettingFind of
  Maybe [Char]
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
  Just [Char]
args -> Set (Path Abs File) -> Filter
fileSetFilter forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs Dir -> [Char] -> IO (Set (Path Abs File))
filesFromFindArgs Path Abs Dir
here [Char]
args

filesFromFindArgs :: Path Abs Dir -> String -> IO (Set (Path Abs File))
filesFromFindArgs :: Path Abs Dir -> [Char] -> IO (Set (Path Abs File))
filesFromFindArgs Path Abs Dir
here [Char]
args = do
  let processConfig :: ProcessConfig () Handle ()
processConfig = forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
createPipe forall a b. (a -> b) -> a -> b
$ [Char] -> ProcessConfig () () ()
shell forall a b. (a -> b) -> a -> b
$ [Char]
"find " forall a. Semigroup a => a -> a -> a
<> [Char]
args
  (ExitCode
ec, ByteString
out) <- forall (m :: * -> *) stdin stdoutIgnored stderr.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderr
-> m (ExitCode, ByteString)
readProcessStdout ProcessConfig () Handle ()
processConfig
  Set (Path Abs File)
set <- Path Abs Dir -> ByteString -> IO (Set (Path Abs File))
bytesFileSet Path Abs Dir
here ByteString
out
  case ExitCode
ec of
    ExitFailure Int
_ -> forall a. [Char] -> IO a
die forall a b. (a -> b) -> a -> b
$ [Char]
"Find failed: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ExitCode
ec
    ExitCode
ExitSuccess -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Set (Path Abs File)
set

bytesFileSet :: Path Abs Dir -> LB.ByteString -> IO (Set (Path Abs File))
bytesFileSet :: Path Abs Dir -> ByteString -> IO (Set (Path Abs File))
bytesFileSet Path Abs Dir
here ByteString
lb =
  forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList (ByteString -> [ByteString]
LB8.lines ByteString
lb)
      forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
C.map ByteString -> ByteString
LB.toStrict
      forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Path Abs Dir -> ConduitT ByteString Void IO (Set (Path Abs File))
fileSetBuilder Path Abs Dir
here

handleFileSet :: Path Abs Dir -> Handle -> IO (Set (Path Abs File))
handleFileSet :: Path Abs Dir -> Handle -> IO (Set (Path Abs File))
handleFileSet Path Abs Dir
here Handle
h =
  forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
C.sourceHandle Handle
h
      forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) seq.
(Monad m, IsSequence seq, Element seq ~ Word8) =>
ConduitT seq seq m ()
C.linesUnboundedAscii
      forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Path Abs Dir -> ConduitT ByteString Void IO (Set (Path Abs File))
fileSetBuilder Path Abs Dir
here

fileSetBuilder :: Path Abs Dir -> ConduitT ByteString Void IO (Set (Path Abs File))
fileSetBuilder :: Path Abs Dir -> ConduitT ByteString Void IO (Set (Path Abs File))
fileSetBuilder Path Abs Dir
here =
  forall (m :: * -> *) mono a.
(Monad m, MonoFoldable mono) =>
(a -> mono) -> ConduitT a (Element mono) m ()
C.concatMap ByteString -> Either UnicodeException Text
TE.decodeUtf8'
    forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
C.map Text -> [Char]
T.unpack
    forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
C.mapM (forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> [Char] -> m (Path Abs File)
resolveFile Path Abs Dir
here)
    forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) b a o.
(Monad m, Monoid b) =>
(a -> b) -> ConduitT a o m b
C.foldMap forall a. a -> Set a
S.singleton

standardFilter :: Path Abs Dir -> Filter
standardFilter :: Path Abs Dir -> Filter
standardFilter Path Abs Dir
here =
  Filter
    { filterDirFilter :: Path Abs Dir -> Bool
filterDirFilter = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b Dir -> Path b t -> Bool
isHiddenIn Path Abs Dir
here,
      filterFileFilter :: Path Abs File -> Bool
filterFileFilter = \Path Abs File
f ->
        forall (t :: * -> *). Foldable t => t Bool -> Bool
and
          [ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall b t. Path b Dir -> Path b t -> Bool
isHiddenIn Path Abs Dir
here Path Abs File
f,
            -- It's not one of those files that vim makes
            Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ [Char]
"~" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Path Abs File -> [Char]
fromAbsFile Path Abs File
f,
            forall b. Path b File -> Path Rel File
filename Path Abs File
f forall a. Eq a => a -> a -> Bool
/= [relfile|4913|]
          ]
    }

hidden :: Path Rel File -> Bool
hidden :: Path Rel File -> Bool
hidden = Path Rel File -> Bool
goFile
  where
    goFile :: Path Rel File -> Bool
    goFile :: Path Rel File -> Bool
goFile Path Rel File
f = forall b t. Path b Dir -> Path b t -> Bool
isHiddenIn (forall b t. Path b t -> Path b Dir
parent Path Rel File
f) Path Rel File
f Bool -> Bool -> Bool
|| Path Rel Dir -> Bool
goDir (forall b t. Path b t -> Path b Dir
parent Path Rel File
f)
    goDir :: Path Rel Dir -> Bool
    goDir :: Path Rel Dir -> Bool
goDir Path Rel Dir
f
      | forall b t. Path b t -> Path b Dir
parent Path Rel Dir
f forall a. Eq a => a -> a -> Bool
== Path Rel Dir
f = Bool
False
      | Bool
otherwise = forall b t. Path b Dir -> Path b t -> Bool
isHiddenIn (forall b t. Path b t -> Path b Dir
parent Path Rel Dir
f) Path Rel Dir
f Bool -> Bool -> Bool
|| Path Rel Dir -> Bool
goDir (forall b t. Path b t -> Path b Dir
parent Path Rel Dir
f)

isHiddenIn :: Path b Dir -> Path b t -> Bool
isHiddenIn :: forall b t. Path b Dir -> Path b t -> Bool
isHiddenIn Path b Dir
curdir Path b t
ad =
  case forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path b Dir
curdir Path b t
ad of
    Maybe (Path Rel t)
Nothing -> Bool
False
    Just Path Rel t
rp -> [Char]
"." forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` forall b t. Path b t -> [Char]
toFilePath Path Rel t
rp