{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeApplications #-}
module System.UnionMount
(
mount,
unionMount,
unionMount',
FileAction (..),
RefreshAction (..),
Change,
)
where
import Control.Concurrent (threadDelay)
import Control.Monad.Logger
( LogLevel (LevelDebug, LevelError, LevelInfo, LevelWarn),
MonadLogger,
logWithoutLoc,
)
import qualified Data.LVar as LVar
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Time.Clock (NominalDiffTime)
import System.Directory (canonicalizePath)
import System.FSNotify
( ActionPredicate,
Debounce (Debounce),
Event (..),
StopListening,
WatchConfig (..),
WatchManager,
defaultConfig,
eventIsDirectory,
eventPath,
watchTree,
withManagerConf,
)
import System.FilePath (isRelative, makeRelative)
import System.FilePattern (FilePattern, (?==))
import System.FilePattern.Directory (getDirectoryFilesIgnore)
import UnliftIO (MonadUnliftIO, finally, newTBQueueIO, race, try, withRunInIO, writeTBQueue)
import UnliftIO.STM (TBQueue, readTBQueue)
mount ::
forall model m b.
( MonadIO m,
MonadUnliftIO m,
MonadLogger m,
Show b,
Ord b
) =>
FilePath ->
[(b, FilePattern)] ->
[FilePattern] ->
model ->
(b -> FilePath -> FileAction () -> m (model -> model)) ->
m (model, (model -> m ()) -> m ())
mount :: FilePath
-> [(b, FilePath)]
-> [FilePath]
-> model
-> (b -> FilePath -> FileAction () -> m (model -> model))
-> m (model, (model -> m ()) -> m ())
mount FilePath
folder [(b, FilePath)]
pats [FilePath]
ignore model
var0 b -> FilePath -> FileAction () -> m (model -> model)
toAction' =
let tag0 :: ()
tag0 = ()
sources :: Set ((), FilePath)
sources = OneItem (Set ((), FilePath)) -> Set ((), FilePath)
forall x. One x => OneItem x -> x
one (()
tag0, FilePath
folder)
in Set ((), FilePath)
-> [(b, FilePath)]
-> [FilePath]
-> model
-> (Change () b -> m (model -> model))
-> m (model, (model -> m ()) -> m ())
forall source tag model (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLogger m, Ord source, Ord tag) =>
Set (source, FilePath)
-> [(tag, FilePath)]
-> [FilePath]
-> model
-> (Change source tag -> m (model -> model))
-> m (model, (model -> m ()) -> m ())
unionMount Set ((), FilePath)
sources [(b, FilePath)]
pats [FilePath]
ignore model
var0 ((Change () b -> m (model -> model))
-> m (model, (model -> m ()) -> m ()))
-> (Change () b -> m (model -> model))
-> m (model, (model -> m ()) -> m ())
forall a b. (a -> b) -> a -> b
$ \Change () b
ch -> do
let fsSet :: [(b, [(FilePath, FileAction ())])]
fsSet = (((b, [(FilePath, FileAction (NonEmpty ((), FilePath)))])
-> (b, [(FilePath, FileAction ())]))
-> [(b, [(FilePath, FileAction (NonEmpty ((), FilePath)))])]
-> [(b, [(FilePath, FileAction ())])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((b, [(FilePath, FileAction (NonEmpty ((), FilePath)))])
-> (b, [(FilePath, FileAction ())]))
-> [(b, [(FilePath, FileAction (NonEmpty ((), FilePath)))])]
-> [(b, [(FilePath, FileAction ())])])
-> ((FileAction (NonEmpty ((), FilePath)) -> FileAction ())
-> (b, [(FilePath, FileAction (NonEmpty ((), FilePath)))])
-> (b, [(FilePath, FileAction ())]))
-> (FileAction (NonEmpty ((), FilePath)) -> FileAction ())
-> [(b, [(FilePath, FileAction (NonEmpty ((), FilePath)))])]
-> [(b, [(FilePath, FileAction ())])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(FilePath, FileAction (NonEmpty ((), FilePath)))]
-> [(FilePath, FileAction ())])
-> (b, [(FilePath, FileAction (NonEmpty ((), FilePath)))])
-> (b, [(FilePath, FileAction ())])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([(FilePath, FileAction (NonEmpty ((), FilePath)))]
-> [(FilePath, FileAction ())])
-> (b, [(FilePath, FileAction (NonEmpty ((), FilePath)))])
-> (b, [(FilePath, FileAction ())]))
-> ((FileAction (NonEmpty ((), FilePath)) -> FileAction ())
-> [(FilePath, FileAction (NonEmpty ((), FilePath)))]
-> [(FilePath, FileAction ())])
-> (FileAction (NonEmpty ((), FilePath)) -> FileAction ())
-> (b, [(FilePath, FileAction (NonEmpty ((), FilePath)))])
-> (b, [(FilePath, FileAction ())])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath, FileAction (NonEmpty ((), FilePath)))
-> (FilePath, FileAction ()))
-> [(FilePath, FileAction (NonEmpty ((), FilePath)))]
-> [(FilePath, FileAction ())]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((FilePath, FileAction (NonEmpty ((), FilePath)))
-> (FilePath, FileAction ()))
-> [(FilePath, FileAction (NonEmpty ((), FilePath)))]
-> [(FilePath, FileAction ())])
-> ((FileAction (NonEmpty ((), FilePath)) -> FileAction ())
-> (FilePath, FileAction (NonEmpty ((), FilePath)))
-> (FilePath, FileAction ()))
-> (FileAction (NonEmpty ((), FilePath)) -> FileAction ())
-> [(FilePath, FileAction (NonEmpty ((), FilePath)))]
-> [(FilePath, FileAction ())]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileAction (NonEmpty ((), FilePath)) -> FileAction ())
-> (FilePath, FileAction (NonEmpty ((), FilePath)))
-> (FilePath, FileAction ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) FileAction (NonEmpty ((), FilePath)) -> FileAction ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ([(b, [(FilePath, FileAction (NonEmpty ((), FilePath)))])]
-> [(b, [(FilePath, FileAction ())])])
-> [(b, [(FilePath, FileAction (NonEmpty ((), FilePath)))])]
-> [(b, [(FilePath, FileAction ())])]
forall a b. (a -> b) -> a -> b
$ (Map FilePath (FileAction (NonEmpty ((), FilePath)))
-> [(FilePath, FileAction (NonEmpty ((), FilePath)))])
-> (b, Map FilePath (FileAction (NonEmpty ((), FilePath))))
-> (b, [(FilePath, FileAction (NonEmpty ((), FilePath)))])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map FilePath (FileAction (NonEmpty ((), FilePath)))
-> [(FilePath, FileAction (NonEmpty ((), FilePath)))]
forall k a. Map k a -> [(k, a)]
Map.toList ((b, Map FilePath (FileAction (NonEmpty ((), FilePath))))
-> (b, [(FilePath, FileAction (NonEmpty ((), FilePath)))]))
-> [(b, Map FilePath (FileAction (NonEmpty ((), FilePath))))]
-> [(b, [(FilePath, FileAction (NonEmpty ((), FilePath)))])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Change () b
-> [(b, Map FilePath (FileAction (NonEmpty ((), FilePath))))]
forall k a. Map k a -> [(k, a)]
Map.toList Change () b
ch
(\(b
tag, [(FilePath, FileAction ())]
xs) -> (FilePath -> FileAction () -> m (model -> model))
-> (FilePath, FileAction ()) -> m (model -> model)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (b -> FilePath -> FileAction () -> m (model -> model)
toAction' b
tag) ((FilePath, FileAction ()) -> m (model -> model))
-> [(FilePath, FileAction ())] -> m (model -> model)
forall x a. Monad m => (x -> m (a -> a)) -> [x] -> m (a -> a)
`chainM` [(FilePath, FileAction ())]
xs) ((b, [(FilePath, FileAction ())]) -> m (model -> model))
-> [(b, [(FilePath, FileAction ())])] -> m (model -> model)
forall x a. Monad m => (x -> m (a -> a)) -> [x] -> m (a -> a)
`chainM` [(b, [(FilePath, FileAction ())])]
fsSet
where
chainM :: Monad m => (x -> m (a -> a)) -> [x] -> m (a -> a)
chainM :: (x -> m (a -> a)) -> [x] -> m (a -> a)
chainM x -> m (a -> a)
f =
([a -> a] -> a -> a) -> m [a -> a] -> m (a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a -> a] -> a -> a
forall a. [a -> a] -> a -> a
chain (m [a -> a] -> m (a -> a))
-> ([x] -> m [a -> a]) -> [x] -> m (a -> a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> m (a -> a)) -> [x] -> m [a -> a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM x -> m (a -> a)
f
where
chain :: [a -> a] -> a -> a
chain :: [a -> a] -> a -> a
chain = (a -> [a -> a] -> a) -> [a -> a] -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a -> [a -> a] -> a) -> [a -> a] -> a -> a)
-> (a -> [a -> a] -> a) -> [a -> a] -> a -> a
forall a b. (a -> b) -> a -> b
$ (a -> (a -> a) -> a) -> a -> [a -> a] -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((a -> (a -> a) -> a) -> a -> [a -> a] -> a)
-> (a -> (a -> a) -> a) -> a -> [a -> a] -> a
forall a b. (a -> b) -> a -> b
$ ((a -> a) -> a -> a) -> a -> (a -> a) -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
($)
unionMount ::
forall source tag model m.
( MonadIO m,
MonadUnliftIO m,
MonadLogger m,
Ord source,
Ord tag
) =>
Set (source, FilePath) ->
[(tag, FilePattern)] ->
[FilePattern] ->
model ->
(Change source tag -> m (model -> model)) ->
m (model, (model -> m ()) -> m ())
unionMount :: Set (source, FilePath)
-> [(tag, FilePath)]
-> [FilePath]
-> model
-> (Change source tag -> m (model -> model))
-> m (model, (model -> m ()) -> m ())
unionMount Set (source, FilePath)
sources [(tag, FilePath)]
pats [FilePath]
ignore model
model0 Change source tag -> m (model -> model)
handleAction = do
(Change source tag
x0, (Change source tag -> m ()) -> m Cmd
xf) <- Set (source, FilePath)
-> [(tag, FilePath)]
-> [FilePath]
-> m (Change source tag, (Change source tag -> m ()) -> m Cmd)
forall source tag (m :: * -> *) (m1 :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLogger m, MonadLogger m1,
MonadIO m1, Ord source, Ord tag) =>
Set (source, FilePath)
-> [(tag, FilePath)]
-> [FilePath]
-> m1 (Change source tag, (Change source tag -> m ()) -> m Cmd)
unionMount' Set (source, FilePath)
sources [(tag, FilePath)]
pats [FilePath]
ignore
model -> model
x0' <- (model -> model) -> m (model -> model) -> m (model -> model)
forall (m :: * -> *) a.
(MonadIO m, MonadUnliftIO m, MonadLogger m) =>
a -> m a -> m a
interceptExceptions model -> model
forall a. a -> a
id (m (model -> model) -> m (model -> model))
-> m (model -> model) -> m (model -> model)
forall a b. (a -> b) -> a -> b
$ Change source tag -> m (model -> model)
handleAction Change source tag
x0
let initial :: model
initial = model -> model
x0' model
model0
LVar model
lvar <- model -> m (LVar model)
forall a (m :: * -> *). MonadIO m => a -> m (LVar a)
LVar.new model
initial
let sender :: (model -> m ()) -> m ()
sender model -> m ()
send = do
Cmd
Cmd_Remount <- (Change source tag -> m ()) -> m Cmd
xf ((Change source tag -> m ()) -> m Cmd)
-> (Change source tag -> m ()) -> m Cmd
forall a b. (a -> b) -> a -> b
$ \Change source tag
change -> do
model -> model
change' <- (model -> model) -> m (model -> model) -> m (model -> model)
forall (m :: * -> *) a.
(MonadIO m, MonadUnliftIO m, MonadLogger m) =>
a -> m a -> m a
interceptExceptions model -> model
forall a. a -> a
id (m (model -> model) -> m (model -> model))
-> m (model -> model) -> m (model -> model)
forall a b. (a -> b) -> a -> b
$ Change source tag -> m (model -> model)
handleAction Change source tag
change
LVar model -> (model -> model) -> m ()
forall (m :: * -> *) a. MonadIO m => LVar a -> (a -> a) -> m ()
LVar.modify LVar model
lvar model -> model
change'
model
x <- LVar model -> m model
forall (m :: * -> *) a. MonadIO m => LVar a -> m a
LVar.get LVar model
lvar
model -> m ()
send model
x
LogLevel -> Text -> m ()
forall (m :: * -> *). MonadLogger m => LogLevel -> Text -> m ()
log LogLevel
LevelInfo Text
"Remounting..."
(model
a, (model -> m ()) -> m ()
b) <- Set (source, FilePath)
-> [(tag, FilePath)]
-> [FilePath]
-> model
-> (Change source tag -> m (model -> model))
-> m (model, (model -> m ()) -> m ())
forall source tag model (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLogger m, Ord source, Ord tag) =>
Set (source, FilePath)
-> [(tag, FilePath)]
-> [FilePath]
-> model
-> (Change source tag -> m (model -> model))
-> m (model, (model -> m ()) -> m ())
unionMount Set (source, FilePath)
sources [(tag, FilePath)]
pats [FilePath]
ignore model
model0 Change source tag -> m (model -> model)
handleAction
model -> m ()
send model
a
(model -> m ()) -> m ()
b model -> m ()
send
(model, (model -> m ()) -> m ())
-> m (model, (model -> m ()) -> m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (model -> model
x0' model
model0, (model -> m ()) -> m ()
sender)
interceptExceptions :: (MonadIO m, MonadUnliftIO m, MonadLogger m) => a -> m a -> m a
interceptExceptions :: a -> m a -> m a
interceptExceptions a
default_ m a
f = do
m a -> m (Either SomeException a)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try m a
f m (Either SomeException a)
-> (Either SomeException a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left (SomeException
ex :: SomeException) -> do
LogLevel -> Text -> m ()
forall (m :: * -> *). MonadLogger m => LogLevel -> Text -> m ()
log LogLevel
LevelError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Change handler exception: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall b a. (Show a, IsString b) => a -> b
show SomeException
ex
a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
default_
Right a
v ->
a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
data Evt source tag
= Evt_Change (Change source tag)
| Evt_Unhandled
deriving (Evt source tag -> Evt source tag -> Bool
(Evt source tag -> Evt source tag -> Bool)
-> (Evt source tag -> Evt source tag -> Bool)
-> Eq (Evt source tag)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall source tag.
(Eq tag, Eq source) =>
Evt source tag -> Evt source tag -> Bool
/= :: Evt source tag -> Evt source tag -> Bool
$c/= :: forall source tag.
(Eq tag, Eq source) =>
Evt source tag -> Evt source tag -> Bool
== :: Evt source tag -> Evt source tag -> Bool
$c== :: forall source tag.
(Eq tag, Eq source) =>
Evt source tag -> Evt source tag -> Bool
Eq, Int -> Evt source tag -> ShowS
[Evt source tag] -> ShowS
Evt source tag -> FilePath
(Int -> Evt source tag -> ShowS)
-> (Evt source tag -> FilePath)
-> ([Evt source tag] -> ShowS)
-> Show (Evt source tag)
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
forall source tag.
(Show tag, Show source) =>
Int -> Evt source tag -> ShowS
forall source tag.
(Show tag, Show source) =>
[Evt source tag] -> ShowS
forall source tag.
(Show tag, Show source) =>
Evt source tag -> FilePath
showList :: [Evt source tag] -> ShowS
$cshowList :: forall source tag.
(Show tag, Show source) =>
[Evt source tag] -> ShowS
show :: Evt source tag -> FilePath
$cshow :: forall source tag.
(Show tag, Show source) =>
Evt source tag -> FilePath
showsPrec :: Int -> Evt source tag -> ShowS
$cshowsPrec :: forall source tag.
(Show tag, Show source) =>
Int -> Evt source tag -> ShowS
Show)
data Cmd
= Cmd_Remount
deriving (Cmd -> Cmd -> Bool
(Cmd -> Cmd -> Bool) -> (Cmd -> Cmd -> Bool) -> Eq Cmd
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cmd -> Cmd -> Bool
$c/= :: Cmd -> Cmd -> Bool
== :: Cmd -> Cmd -> Bool
$c== :: Cmd -> Cmd -> Bool
Eq, Int -> Cmd -> ShowS
[Cmd] -> ShowS
Cmd -> FilePath
(Int -> Cmd -> ShowS)
-> (Cmd -> FilePath) -> ([Cmd] -> ShowS) -> Show Cmd
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Cmd] -> ShowS
$cshowList :: [Cmd] -> ShowS
show :: Cmd -> FilePath
$cshow :: Cmd -> FilePath
showsPrec :: Int -> Cmd -> ShowS
$cshowsPrec :: Int -> Cmd -> ShowS
Show)
unionMount' ::
forall source tag m m1.
( MonadIO m,
MonadUnliftIO m,
MonadLogger m,
MonadLogger m1,
MonadIO m1,
Ord source,
Ord tag
) =>
Set (source, FilePath) ->
[(tag, FilePattern)] ->
[FilePattern] ->
m1
( Change source tag,
(Change source tag -> m ()) ->
m Cmd
)
unionMount' :: Set (source, FilePath)
-> [(tag, FilePath)]
-> [FilePath]
-> m1 (Change source tag, (Change source tag -> m ()) -> m Cmd)
unionMount' Set (source, FilePath)
sources [(tag, FilePath)]
pats [FilePath]
ignore = do
(((Change source tag, (Change source tag -> m ()) -> m Cmd),
OverlayFs source)
-> (Change source tag, (Change source tag -> m ()) -> m Cmd))
-> m1
((Change source tag, (Change source tag -> m ()) -> m Cmd),
OverlayFs source)
-> m1 (Change source tag, (Change source tag -> m ()) -> m Cmd)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Change source tag, (Change source tag -> m ()) -> m Cmd),
OverlayFs source)
-> (Change source tag, (Change source tag -> m ()) -> m Cmd)
forall a b. (a, b) -> a
fst (m1
((Change source tag, (Change source tag -> m ()) -> m Cmd),
OverlayFs source)
-> m1 (Change source tag, (Change source tag -> m ()) -> m Cmd))
-> (StateT
(OverlayFs source)
m1
(Change source tag, (Change source tag -> m ()) -> m Cmd)
-> m1
((Change source tag, (Change source tag -> m ()) -> m Cmd),
OverlayFs source))
-> StateT
(OverlayFs source)
m1
(Change source tag, (Change source tag -> m ()) -> m Cmd)
-> m1 (Change source tag, (Change source tag -> m ()) -> m Cmd)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT
(OverlayFs source)
m1
(Change source tag, (Change source tag -> m ()) -> m Cmd)
-> OverlayFs source
-> m1
((Change source tag, (Change source tag -> m ()) -> m Cmd),
OverlayFs source))
-> OverlayFs source
-> StateT
(OverlayFs source)
m1
(Change source tag, (Change source tag -> m ()) -> m Cmd)
-> m1
((Change source tag, (Change source tag -> m ()) -> m Cmd),
OverlayFs source)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
(OverlayFs source)
m1
(Change source tag, (Change source tag -> m ()) -> m Cmd)
-> OverlayFs source
-> m1
((Change source tag, (Change source tag -> m ()) -> m Cmd),
OverlayFs source)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Ord source => OverlayFs source
forall source. Ord source => OverlayFs source
emptyOverlayFs @source) (StateT
(OverlayFs source)
m1
(Change source tag, (Change source tag -> m ()) -> m Cmd)
-> m1 (Change source tag, (Change source tag -> m ()) -> m Cmd))
-> StateT
(OverlayFs source)
m1
(Change source tag, (Change source tag -> m ()) -> m Cmd)
-> m1 (Change source tag, (Change source tag -> m ()) -> m Cmd)
forall a b. (a -> b) -> a -> b
$ do
Change source tag
changes0 :: Change source tag <-
(((), Change source tag) -> Change source tag)
-> StateT (OverlayFs source) m1 ((), Change source tag)
-> StateT (OverlayFs source) m1 (Change source tag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((), Change source tag) -> Change source tag
forall a b. (a, b) -> b
snd (StateT (OverlayFs source) m1 ((), Change source tag)
-> StateT (OverlayFs source) m1 (Change source tag))
-> (StateT (Change source tag) (StateT (OverlayFs source) m1) ()
-> StateT (OverlayFs source) m1 ((), Change source tag))
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ()
-> StateT (OverlayFs source) m1 (Change source tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT (Change source tag) (StateT (OverlayFs source) m1) ()
-> Change source tag
-> StateT (OverlayFs source) m1 ((), Change source tag))
-> Change source tag
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ()
-> StateT (OverlayFs source) m1 ((), Change source tag)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Change source tag) (StateT (OverlayFs source) m1) ()
-> Change source tag
-> StateT (OverlayFs source) m1 ((), Change source tag)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Change source tag
forall k a. Map k a
Map.empty (StateT (Change source tag) (StateT (OverlayFs source) m1) ()
-> StateT (OverlayFs source) m1 (Change source tag))
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ()
-> StateT (OverlayFs source) m1 (Change source tag)
forall a b. (a -> b) -> a -> b
$ do
Set (source, FilePath)
-> ((source, FilePath)
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ())
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set (source, FilePath)
sources (((source, FilePath)
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ())
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ())
-> ((source, FilePath)
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ())
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ()
forall a b. (a -> b) -> a -> b
$ \(source
src, FilePath
folder) -> do
[(tag, [FilePath])]
taggedFiles <- FilePath
-> [(tag, FilePath)]
-> [FilePath]
-> StateT
(Change source tag)
(StateT (OverlayFs source) m1)
[(tag, [FilePath])]
forall (m :: * -> *) b.
(MonadIO m, MonadLogger m, Ord b) =>
FilePath -> [(b, FilePath)] -> [FilePath] -> m [(b, [FilePath])]
filesMatchingWithTag FilePath
folder [(tag, FilePath)]
pats [FilePath]
ignore
[(tag, [FilePath])]
-> ((tag, [FilePath])
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ())
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(tag, [FilePath])]
taggedFiles (((tag, [FilePath])
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ())
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ())
-> ((tag, [FilePath])
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ())
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ()
forall a b. (a -> b) -> a -> b
$ \(tag
tag, [FilePath]
fs) -> do
[FilePath]
-> (FilePath
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ())
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
fs ((FilePath
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ())
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ())
-> (FilePath
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ())
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ()
forall a b. (a -> b) -> a -> b
$ \FilePath
fp -> do
Change source tag
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Change source tag
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ())
-> StateT
(Change source tag)
(StateT (OverlayFs source) m1)
(Change source tag)
-> StateT (Change source tag) (StateT (OverlayFs source) m1) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT (OverlayFs source) m1 (Change source tag)
-> StateT
(Change source tag)
(StateT (OverlayFs source) m1)
(Change source tag)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (OverlayFs source) m1 (Change source tag)
-> StateT
(Change source tag)
(StateT (OverlayFs source) m1)
(Change source tag))
-> (Change source tag
-> StateT (OverlayFs source) m1 (Change source tag))
-> Change source tag
-> StateT
(Change source tag)
(StateT (OverlayFs source) m1)
(Change source tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. source
-> tag
-> FilePath
-> FileAction ()
-> Change source tag
-> StateT (OverlayFs source) m1 (Change source tag)
forall source tag (m :: * -> *).
(Ord source, Ord tag, MonadState (OverlayFs source) m) =>
source
-> tag
-> FilePath
-> FileAction ()
-> Change source tag
-> m (Change source tag)
changeInsert source
src tag
tag FilePath
fp (RefreshAction -> () -> FileAction ()
forall a. RefreshAction -> a -> FileAction a
Refresh RefreshAction
Existing ()) (Change source tag
-> StateT
(Change source tag)
(StateT (OverlayFs source) m1)
(Change source tag))
-> StateT
(Change source tag)
(StateT (OverlayFs source) m1)
(Change source tag)
-> StateT
(Change source tag)
(StateT (OverlayFs source) m1)
(Change source tag)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT
(Change source tag)
(StateT (OverlayFs source) m1)
(Change source tag)
forall s (m :: * -> *). MonadState s m => m s
get
OverlayFs source
ofs <- StateT (OverlayFs source) m1 (OverlayFs source)
forall s (m :: * -> *). MonadState s m => m s
get
(Change source tag, (Change source tag -> m ()) -> m Cmd)
-> StateT
(OverlayFs source)
m1
(Change source tag, (Change source tag -> m ()) -> m Cmd)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Change source tag
changes0,
\Change source tag -> m ()
reportChange -> do
TBQueue
(source, FilePath, Either (FolderAction ()) (FileAction ()))
q :: TBQueue (x, FilePath, Either (FolderAction ()) (FileAction ())) <- IO
(TBQueue
(source, FilePath, Either (FolderAction ()) (FileAction ())))
-> m (TBQueue
(source, FilePath, Either (FolderAction ()) (FileAction ())))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
(TBQueue
(source, FilePath, Either (FolderAction ()) (FileAction ())))
-> m (TBQueue
(source, FilePath, Either (FolderAction ()) (FileAction ()))))
-> IO
(TBQueue
(source, FilePath, Either (FolderAction ()) (FileAction ())))
-> m (TBQueue
(source, FilePath, Either (FolderAction ()) (FileAction ())))
forall a b. (a -> b) -> a -> b
$ Natural
-> IO
(TBQueue
(source, FilePath, Either (FolderAction ()) (FileAction ())))
forall (m :: * -> *) a. MonadIO m => Natural -> m (TBQueue a)
newTBQueueIO Natural
1
(Either Cmd Cmd -> Cmd) -> m (Either Cmd Cmd) -> m Cmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Cmd -> Cmd) -> (Cmd -> Cmd) -> Either Cmd Cmd -> Cmd
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Cmd -> Cmd
forall a. a -> a
id Cmd -> Cmd
forall a. a -> a
id) (m (Either Cmd Cmd) -> m Cmd) -> m (Either Cmd Cmd) -> m Cmd
forall a b. (a -> b) -> a -> b
$
m Cmd -> m Cmd -> m (Either Cmd Cmd)
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> m b -> m (Either a b)
race (TBQueue
(source, FilePath, Either (FolderAction ()) (FileAction ()))
-> [(source, FilePath)] -> m Cmd
forall x (m :: * -> *).
(MonadIO m, MonadLogger m, MonadUnliftIO m) =>
TBQueue (x, FilePath, Either (FolderAction ()) (FileAction ()))
-> [(x, FilePath)] -> m Cmd
onChange TBQueue
(source, FilePath, Either (FolderAction ()) (FileAction ()))
q (Set (source, FilePath) -> [(source, FilePath)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set (source, FilePath)
sources)) (m Cmd -> m (Either Cmd Cmd)) -> m Cmd -> m (Either Cmd Cmd)
forall a b. (a -> b) -> a -> b
$
((Cmd, OverlayFs source) -> Cmd)
-> m (Cmd, OverlayFs source) -> m Cmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Cmd, OverlayFs source) -> Cmd
forall a b. (a, b) -> a
fst (m (Cmd, OverlayFs source) -> m Cmd)
-> (StateT (OverlayFs source) m Cmd -> m (Cmd, OverlayFs source))
-> StateT (OverlayFs source) m Cmd
-> m Cmd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT (OverlayFs source) m Cmd
-> OverlayFs source -> m (Cmd, OverlayFs source))
-> OverlayFs source
-> StateT (OverlayFs source) m Cmd
-> m (Cmd, OverlayFs source)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (OverlayFs source) m Cmd
-> OverlayFs source -> m (Cmd, OverlayFs source)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT OverlayFs source
ofs (StateT (OverlayFs source) m Cmd -> m Cmd)
-> StateT (OverlayFs source) m Cmd -> m Cmd
forall a b. (a -> b) -> a -> b
$ do
let loop :: StateT (OverlayFs source) m Cmd
loop = do
(source
src, FilePath
fp, Either (FolderAction ()) (FileAction ())
actE) <- STM (source, FilePath, Either (FolderAction ()) (FileAction ()))
-> StateT
(OverlayFs source)
m
(source, FilePath, Either (FolderAction ()) (FileAction ()))
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (source, FilePath, Either (FolderAction ()) (FileAction ()))
-> StateT
(OverlayFs source)
m
(source, FilePath, Either (FolderAction ()) (FileAction ())))
-> STM (source, FilePath, Either (FolderAction ()) (FileAction ()))
-> StateT
(OverlayFs source)
m
(source, FilePath, Either (FolderAction ()) (FileAction ()))
forall a b. (a -> b) -> a -> b
$ TBQueue
(source, FilePath, Either (FolderAction ()) (FileAction ()))
-> STM (source, FilePath, Either (FolderAction ()) (FileAction ()))
forall a. TBQueue a -> STM a
readTBQueue TBQueue
(source, FilePath, Either (FolderAction ()) (FileAction ()))
q
let shouldIgnore :: Bool
shouldIgnore = (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePath -> FilePath -> Bool
?== FilePath
fp) [FilePath]
ignore
case Either (FolderAction ()) (FileAction ())
actE of
Left FolderAction ()
_ -> do
let reason :: Text
reason = Text
"Unhandled folder event on '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
fp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
if Bool
shouldIgnore
then do
LogLevel -> Text -> StateT (OverlayFs source) m ()
forall (m :: * -> *). MonadLogger m => LogLevel -> Text -> m ()
log LogLevel
LevelWarn (Text -> StateT (OverlayFs source) m ())
-> Text -> StateT (OverlayFs source) m ()
forall a b. (a -> b) -> a -> b
$ Text
reason Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" on an ignored path"
StateT (OverlayFs source) m Cmd
loop
else do
LogLevel -> Text -> StateT (OverlayFs source) m ()
forall (m :: * -> *). MonadLogger m => LogLevel -> Text -> m ()
log LogLevel
LevelWarn (Text -> StateT (OverlayFs source) m ())
-> Text -> StateT (OverlayFs source) m ()
forall a b. (a -> b) -> a -> b
$ Text
reason Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; suggesting a re-mount"
Cmd -> StateT (OverlayFs source) m Cmd
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cmd
Cmd_Remount
Right FileAction ()
act -> do
case Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not Bool
shouldIgnore) Maybe () -> Maybe tag -> Maybe tag
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(tag, FilePath)] -> FilePath -> Maybe tag
forall b. [(b, FilePath)] -> FilePath -> Maybe b
getTag [(tag, FilePath)]
pats FilePath
fp of
Maybe tag
Nothing -> StateT (OverlayFs source) m Cmd
loop
Just tag
tag -> do
Change source tag
changes <- (((), Change source tag) -> Change source tag)
-> StateT (OverlayFs source) m ((), Change source tag)
-> StateT (OverlayFs source) m (Change source tag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((), Change source tag) -> Change source tag
forall a b. (a, b) -> b
snd (StateT (OverlayFs source) m ((), Change source tag)
-> StateT (OverlayFs source) m (Change source tag))
-> (StateT (Change source tag) (StateT (OverlayFs source) m) ()
-> StateT (OverlayFs source) m ((), Change source tag))
-> StateT (Change source tag) (StateT (OverlayFs source) m) ()
-> StateT (OverlayFs source) m (Change source tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT (Change source tag) (StateT (OverlayFs source) m) ()
-> Change source tag
-> StateT (OverlayFs source) m ((), Change source tag))
-> Change source tag
-> StateT (Change source tag) (StateT (OverlayFs source) m) ()
-> StateT (OverlayFs source) m ((), Change source tag)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Change source tag) (StateT (OverlayFs source) m) ()
-> Change source tag
-> StateT (OverlayFs source) m ((), Change source tag)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Change source tag
forall k a. Map k a
Map.empty (StateT (Change source tag) (StateT (OverlayFs source) m) ()
-> StateT (OverlayFs source) m (Change source tag))
-> StateT (Change source tag) (StateT (OverlayFs source) m) ()
-> StateT (OverlayFs source) m (Change source tag)
forall a b. (a -> b) -> a -> b
$ do
Change source tag
-> StateT (Change source tag) (StateT (OverlayFs source) m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Change source tag
-> StateT (Change source tag) (StateT (OverlayFs source) m) ())
-> StateT
(Change source tag)
(StateT (OverlayFs source) m)
(Change source tag)
-> StateT (Change source tag) (StateT (OverlayFs source) m) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT (OverlayFs source) m (Change source tag)
-> StateT
(Change source tag)
(StateT (OverlayFs source) m)
(Change source tag)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (OverlayFs source) m (Change source tag)
-> StateT
(Change source tag)
(StateT (OverlayFs source) m)
(Change source tag))
-> (Change source tag
-> StateT (OverlayFs source) m (Change source tag))
-> Change source tag
-> StateT
(Change source tag)
(StateT (OverlayFs source) m)
(Change source tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. source
-> tag
-> FilePath
-> FileAction ()
-> Change source tag
-> StateT (OverlayFs source) m (Change source tag)
forall source tag (m :: * -> *).
(Ord source, Ord tag, MonadState (OverlayFs source) m) =>
source
-> tag
-> FilePath
-> FileAction ()
-> Change source tag
-> m (Change source tag)
changeInsert source
src tag
tag FilePath
fp FileAction ()
act (Change source tag
-> StateT
(Change source tag)
(StateT (OverlayFs source) m)
(Change source tag))
-> StateT
(Change source tag)
(StateT (OverlayFs source) m)
(Change source tag)
-> StateT
(Change source tag)
(StateT (OverlayFs source) m)
(Change source tag)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT
(Change source tag)
(StateT (OverlayFs source) m)
(Change source tag)
forall s (m :: * -> *). MonadState s m => m s
get
m () -> StateT (OverlayFs source) m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT (OverlayFs source) m ())
-> m () -> StateT (OverlayFs source) m ()
forall a b. (a -> b) -> a -> b
$ Change source tag -> m ()
reportChange Change source tag
changes
StateT (OverlayFs source) m Cmd
loop
StateT (OverlayFs source) m Cmd
loop
)
filesMatching :: (MonadIO m, MonadLogger m) => FilePath -> [FilePattern] -> [FilePattern] -> m [FilePath]
filesMatching :: FilePath -> [FilePath] -> [FilePath] -> m [FilePath]
filesMatching FilePath
parent' [FilePath]
pats [FilePath]
ignore = do
FilePath
parent <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
canonicalizePath FilePath
parent'
LogLevel -> Text -> m ()
forall (m :: * -> *). MonadLogger m => LogLevel -> Text -> m ()
log LogLevel
LevelInfo (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
forall a. ToText a => a -> Text
toText (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
"Traversing " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
parent FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" for files matching " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
forall b a. (Show a, IsString b) => a -> b
show [FilePath]
pats FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
", ignoring " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
forall b a. (Show a, IsString b) => a -> b
show [FilePath]
ignore
IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> [FilePath] -> IO [FilePath]
getDirectoryFilesIgnore FilePath
parent [FilePath]
pats [FilePath]
ignore
filesMatchingWithTag :: (MonadIO m, MonadLogger m, Ord b) => FilePath -> [(b, FilePattern)] -> [FilePattern] -> m [(b, [FilePath])]
filesMatchingWithTag :: FilePath -> [(b, FilePath)] -> [FilePath] -> m [(b, [FilePath])]
filesMatchingWithTag FilePath
parent' [(b, FilePath)]
pats [FilePath]
ignore = do
[FilePath]
fs <- FilePath -> [FilePath] -> [FilePath] -> m [FilePath]
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
FilePath -> [FilePath] -> [FilePath] -> m [FilePath]
filesMatching FilePath
parent' ((b, FilePath) -> FilePath
forall a b. (a, b) -> b
snd ((b, FilePath) -> FilePath) -> [(b, FilePath)] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(b, FilePath)]
pats) [FilePath]
ignore
let m :: Map b [FilePath]
m = ([FilePath] -> [FilePath] -> [FilePath])
-> [(b, [FilePath])] -> Map b [FilePath]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
(<>) ([(b, [FilePath])] -> Map b [FilePath])
-> [(b, [FilePath])] -> Map b [FilePath]
forall a b. (a -> b) -> a -> b
$
((FilePath -> Maybe (b, [FilePath]))
-> [FilePath] -> [(b, [FilePath])])
-> [FilePath]
-> (FilePath -> Maybe (b, [FilePath]))
-> [(b, [FilePath])]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (FilePath -> Maybe (b, [FilePath]))
-> [FilePath] -> [(b, [FilePath])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [FilePath]
fs ((FilePath -> Maybe (b, [FilePath])) -> [(b, [FilePath])])
-> (FilePath -> Maybe (b, [FilePath])) -> [(b, [FilePath])]
forall a b. (a -> b) -> a -> b
$ \FilePath
fp -> do
b
tag <- [(b, FilePath)] -> FilePath -> Maybe b
forall b. [(b, FilePath)] -> FilePath -> Maybe b
getTag [(b, FilePath)]
pats FilePath
fp
(b, [FilePath]) -> Maybe (b, [FilePath])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
tag, OneItem [FilePath] -> [FilePath]
forall x. One x => OneItem x -> x
one FilePath
OneItem [FilePath]
fp)
[(b, [FilePath])] -> m [(b, [FilePath])]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(b, [FilePath])] -> m [(b, [FilePath])])
-> [(b, [FilePath])] -> m [(b, [FilePath])]
forall a b. (a -> b) -> a -> b
$ Map b [FilePath] -> [(b, [FilePath])]
forall k a. Map k a -> [(k, a)]
Map.toList Map b [FilePath]
m
getTag :: [(b, FilePattern)] -> FilePath -> Maybe b
getTag :: [(b, FilePath)] -> FilePath -> Maybe b
getTag [(b, FilePath)]
pats FilePath
fp =
let pull :: [(a, FilePath)] -> Maybe a
pull [(a, FilePath)]
patterns =
[a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe ([a] -> Maybe a) -> [a] -> Maybe a
forall a b. (a -> b) -> a -> b
$
(((a, FilePath) -> Maybe a) -> [(a, FilePath)] -> [a])
-> [(a, FilePath)] -> ((a, FilePath) -> Maybe a) -> [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a, FilePath) -> Maybe a) -> [(a, FilePath)] -> [a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [(a, FilePath)]
patterns (((a, FilePath) -> Maybe a) -> [a])
-> ((a, FilePath) -> Maybe a) -> [a]
forall a b. (a -> b) -> a -> b
$ \(a
tag, FilePath
pattern) -> do
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ FilePath
pattern FilePath -> FilePath -> Bool
?== FilePath
fp
a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
tag
in if FilePath -> Bool
isRelative FilePath
fp
then [(b, FilePath)] -> Maybe b
forall a. [(a, FilePath)] -> Maybe a
pull [(b, FilePath)]
pats
else
[(b, FilePath)] -> Maybe b
forall a. [(a, FilePath)] -> Maybe a
pull ([(b, FilePath)] -> Maybe b) -> [(b, FilePath)] -> Maybe b
forall a b. (a -> b) -> a -> b
$ ShowS -> (b, FilePath) -> (b, FilePath)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (FilePath
"**/" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ((b, FilePath) -> (b, FilePath))
-> [(b, FilePath)] -> [(b, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(b, FilePath)]
pats
data RefreshAction
=
Existing
|
New
|
Update
deriving (RefreshAction -> RefreshAction -> Bool
(RefreshAction -> RefreshAction -> Bool)
-> (RefreshAction -> RefreshAction -> Bool) -> Eq RefreshAction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RefreshAction -> RefreshAction -> Bool
$c/= :: RefreshAction -> RefreshAction -> Bool
== :: RefreshAction -> RefreshAction -> Bool
$c== :: RefreshAction -> RefreshAction -> Bool
Eq, Int -> RefreshAction -> ShowS
[RefreshAction] -> ShowS
RefreshAction -> FilePath
(Int -> RefreshAction -> ShowS)
-> (RefreshAction -> FilePath)
-> ([RefreshAction] -> ShowS)
-> Show RefreshAction
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [RefreshAction] -> ShowS
$cshowList :: [RefreshAction] -> ShowS
show :: RefreshAction -> FilePath
$cshow :: RefreshAction -> FilePath
showsPrec :: Int -> RefreshAction -> ShowS
$cshowsPrec :: Int -> RefreshAction -> ShowS
Show)
data FileAction a
=
Refresh RefreshAction a
|
Delete
deriving (FileAction a -> FileAction a -> Bool
(FileAction a -> FileAction a -> Bool)
-> (FileAction a -> FileAction a -> Bool) -> Eq (FileAction a)
forall a. Eq a => FileAction a -> FileAction a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileAction a -> FileAction a -> Bool
$c/= :: forall a. Eq a => FileAction a -> FileAction a -> Bool
== :: FileAction a -> FileAction a -> Bool
$c== :: forall a. Eq a => FileAction a -> FileAction a -> Bool
Eq, Int -> FileAction a -> ShowS
[FileAction a] -> ShowS
FileAction a -> FilePath
(Int -> FileAction a -> ShowS)
-> (FileAction a -> FilePath)
-> ([FileAction a] -> ShowS)
-> Show (FileAction a)
forall a. Show a => Int -> FileAction a -> ShowS
forall a. Show a => [FileAction a] -> ShowS
forall a. Show a => FileAction a -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [FileAction a] -> ShowS
$cshowList :: forall a. Show a => [FileAction a] -> ShowS
show :: FileAction a -> FilePath
$cshow :: forall a. Show a => FileAction a -> FilePath
showsPrec :: Int -> FileAction a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> FileAction a -> ShowS
Show, a -> FileAction b -> FileAction a
(a -> b) -> FileAction a -> FileAction b
(forall a b. (a -> b) -> FileAction a -> FileAction b)
-> (forall a b. a -> FileAction b -> FileAction a)
-> Functor FileAction
forall a b. a -> FileAction b -> FileAction a
forall a b. (a -> b) -> FileAction a -> FileAction b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> FileAction b -> FileAction a
$c<$ :: forall a b. a -> FileAction b -> FileAction a
fmap :: (a -> b) -> FileAction a -> FileAction b
$cfmap :: forall a b. (a -> b) -> FileAction a -> FileAction b
Functor)
newtype FolderAction a = FolderAction a
deriving (FolderAction a -> FolderAction a -> Bool
(FolderAction a -> FolderAction a -> Bool)
-> (FolderAction a -> FolderAction a -> Bool)
-> Eq (FolderAction a)
forall a. Eq a => FolderAction a -> FolderAction a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FolderAction a -> FolderAction a -> Bool
$c/= :: forall a. Eq a => FolderAction a -> FolderAction a -> Bool
== :: FolderAction a -> FolderAction a -> Bool
$c== :: forall a. Eq a => FolderAction a -> FolderAction a -> Bool
Eq, Int -> FolderAction a -> ShowS
[FolderAction a] -> ShowS
FolderAction a -> FilePath
(Int -> FolderAction a -> ShowS)
-> (FolderAction a -> FilePath)
-> ([FolderAction a] -> ShowS)
-> Show (FolderAction a)
forall a. Show a => Int -> FolderAction a -> ShowS
forall a. Show a => [FolderAction a] -> ShowS
forall a. Show a => FolderAction a -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [FolderAction a] -> ShowS
$cshowList :: forall a. Show a => [FolderAction a] -> ShowS
show :: FolderAction a -> FilePath
$cshow :: forall a. Show a => FolderAction a -> FilePath
showsPrec :: Int -> FolderAction a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> FolderAction a -> ShowS
Show, a -> FolderAction b -> FolderAction a
(a -> b) -> FolderAction a -> FolderAction b
(forall a b. (a -> b) -> FolderAction a -> FolderAction b)
-> (forall a b. a -> FolderAction b -> FolderAction a)
-> Functor FolderAction
forall a b. a -> FolderAction b -> FolderAction a
forall a b. (a -> b) -> FolderAction a -> FolderAction b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> FolderAction b -> FolderAction a
$c<$ :: forall a b. a -> FolderAction b -> FolderAction a
fmap :: (a -> b) -> FolderAction a -> FolderAction b
$cfmap :: forall a b. (a -> b) -> FolderAction a -> FolderAction b
Functor)
refreshAction :: FileAction a -> Maybe RefreshAction
refreshAction :: FileAction a -> Maybe RefreshAction
refreshAction = \case
Refresh RefreshAction
act a
_ -> RefreshAction -> Maybe RefreshAction
forall a. a -> Maybe a
Just RefreshAction
act
FileAction a
_ -> Maybe RefreshAction
forall a. Maybe a
Nothing
onChange ::
forall x m.
(MonadIO m, MonadLogger m, MonadUnliftIO m) =>
TBQueue (x, FilePath, Either (FolderAction ()) (FileAction ())) ->
[(x, FilePath)] ->
m Cmd
onChange :: TBQueue (x, FilePath, Either (FolderAction ()) (FileAction ()))
-> [(x, FilePath)] -> m Cmd
onChange TBQueue (x, FilePath, Either (FolderAction ()) (FileAction ()))
q [(x, FilePath)]
roots = do
let NominalDiffTime
debounceDurationSecs :: NominalDiffTime = NominalDiffTime
0.1
cfg :: WatchConfig
cfg = WatchConfig
defaultConfig {confDebounce :: Debounce
confDebounce = NominalDiffTime -> Debounce
Debounce NominalDiffTime
debounceDurationSecs}
WatchConfig -> (WatchManager -> m Cmd) -> m Cmd
forall (m :: * -> *) a.
(MonadIO m, MonadUnliftIO m) =>
WatchConfig -> (WatchManager -> m a) -> m a
withManagerM WatchConfig
cfg ((WatchManager -> m Cmd) -> m Cmd)
-> (WatchManager -> m Cmd) -> m Cmd
forall a b. (a -> b) -> a -> b
$ \WatchManager
mgr -> do
[StopListening]
stops <- [(x, FilePath)]
-> ((x, FilePath) -> m StopListening) -> m [StopListening]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(x, FilePath)]
roots (((x, FilePath) -> m StopListening) -> m [StopListening])
-> ((x, FilePath) -> m StopListening) -> m [StopListening]
forall a b. (a -> b) -> a -> b
$ \(x
x, FilePath
rootRel) -> do
FilePath
root <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
canonicalizePath FilePath
rootRel
LogLevel -> Text -> m ()
forall (m :: * -> *). MonadLogger m => LogLevel -> Text -> m ()
log LogLevel
LevelInfo (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
forall a. ToText a => a -> Text
toText (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
"Monitoring " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
root FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" for changes"
WatchManager
-> FilePath
-> ActionPredicate
-> (Event -> m ())
-> m StopListening
forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m) =>
WatchManager
-> FilePath
-> ActionPredicate
-> (Event -> m ())
-> m StopListening
watchTreeM WatchManager
mgr FilePath
root (Bool -> ActionPredicate
forall a b. a -> b -> a
const Bool
True) ((Event -> m ()) -> m StopListening)
-> (Event -> m ()) -> m StopListening
forall a b. (a -> b) -> a -> b
$ \Event
event -> do
LogLevel -> Text -> m ()
forall (m :: * -> *). MonadLogger m => LogLevel -> Text -> m ()
log LogLevel
LevelDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Event -> Text
forall b a. (Show a, IsString b) => a -> b
show Event
event
let rel :: ShowS
rel = FilePath -> ShowS
makeRelative FilePath
root
f :: x -> FilePath -> Either (FolderAction ()) (FileAction ()) -> m ()
f x
a FilePath
fp Either (FolderAction ()) (FileAction ())
act = STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TBQueue (x, FilePath, Either (FolderAction ()) (FileAction ()))
-> (x, FilePath, Either (FolderAction ()) (FileAction ()))
-> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (x, FilePath, Either (FolderAction ()) (FileAction ()))
q (x
a, FilePath
fp, Either (FolderAction ()) (FileAction ())
act)
if ActionPredicate
eventIsDirectory Event
event
then x -> FilePath -> Either (FolderAction ()) (FileAction ()) -> m ()
forall (m :: * -> *).
MonadIO m =>
x -> FilePath -> Either (FolderAction ()) (FileAction ()) -> m ()
f x
x (ShowS
rel ShowS -> (Event -> FilePath) -> Event -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> FilePath
eventPath (Event -> FilePath) -> Event -> FilePath
forall a b. (a -> b) -> a -> b
$ Event
event) (Either (FolderAction ()) (FileAction ()) -> m ())
-> Either (FolderAction ()) (FileAction ()) -> m ()
forall a b. (a -> b) -> a -> b
$ FolderAction () -> Either (FolderAction ()) (FileAction ())
forall a b. a -> Either a b
Left (FolderAction () -> Either (FolderAction ()) (FileAction ()))
-> FolderAction () -> Either (FolderAction ()) (FileAction ())
forall a b. (a -> b) -> a -> b
$ () -> FolderAction ()
forall a. a -> FolderAction a
FolderAction ()
else case Event
event of
Added (ShowS
rel -> FilePath
fp) UTCTime
_ Bool
_ -> x -> FilePath -> Either (FolderAction ()) (FileAction ()) -> m ()
forall (m :: * -> *).
MonadIO m =>
x -> FilePath -> Either (FolderAction ()) (FileAction ()) -> m ()
f x
x FilePath
fp (Either (FolderAction ()) (FileAction ()) -> m ())
-> Either (FolderAction ()) (FileAction ()) -> m ()
forall a b. (a -> b) -> a -> b
$ FileAction () -> Either (FolderAction ()) (FileAction ())
forall a b. b -> Either a b
Right (FileAction () -> Either (FolderAction ()) (FileAction ()))
-> FileAction () -> Either (FolderAction ()) (FileAction ())
forall a b. (a -> b) -> a -> b
$ RefreshAction -> () -> FileAction ()
forall a. RefreshAction -> a -> FileAction a
Refresh RefreshAction
New ()
Modified (ShowS
rel -> FilePath
fp) UTCTime
_ Bool
_ -> x -> FilePath -> Either (FolderAction ()) (FileAction ()) -> m ()
forall (m :: * -> *).
MonadIO m =>
x -> FilePath -> Either (FolderAction ()) (FileAction ()) -> m ()
f x
x FilePath
fp (Either (FolderAction ()) (FileAction ()) -> m ())
-> Either (FolderAction ()) (FileAction ()) -> m ()
forall a b. (a -> b) -> a -> b
$ FileAction () -> Either (FolderAction ()) (FileAction ())
forall a b. b -> Either a b
Right (FileAction () -> Either (FolderAction ()) (FileAction ()))
-> FileAction () -> Either (FolderAction ()) (FileAction ())
forall a b. (a -> b) -> a -> b
$ RefreshAction -> () -> FileAction ()
forall a. RefreshAction -> a -> FileAction a
Refresh RefreshAction
Update ()
Removed (ShowS
rel -> FilePath
fp) UTCTime
_ Bool
_ -> x -> FilePath -> Either (FolderAction ()) (FileAction ()) -> m ()
forall (m :: * -> *).
MonadIO m =>
x -> FilePath -> Either (FolderAction ()) (FileAction ()) -> m ()
f x
x FilePath
fp (Either (FolderAction ()) (FileAction ()) -> m ())
-> Either (FolderAction ()) (FileAction ()) -> m ()
forall a b. (a -> b) -> a -> b
$ FileAction () -> Either (FolderAction ()) (FileAction ())
forall a b. b -> Either a b
Right FileAction ()
forall a. FileAction a
Delete
Unknown (ShowS
rel -> FilePath
fp) UTCTime
_ FilePath
_ -> x -> FilePath -> Either (FolderAction ()) (FileAction ()) -> m ()
forall (m :: * -> *).
MonadIO m =>
x -> FilePath -> Either (FolderAction ()) (FileAction ()) -> m ()
f x
x FilePath
fp (Either (FolderAction ()) (FileAction ()) -> m ())
-> Either (FolderAction ()) (FileAction ()) -> m ()
forall a b. (a -> b) -> a -> b
$ FileAction () -> Either (FolderAction ()) (FileAction ())
forall a b. b -> Either a b
Right FileAction ()
forall a. FileAction a
Delete
StopListening -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> StopListening
threadDelay Int
forall a. Bounded a => a
maxBound)
m () -> m () -> m ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` do
LogLevel -> Text -> m ()
forall (m :: * -> *). MonadLogger m => LogLevel -> Text -> m ()
log LogLevel
LevelInfo Text
"Stopping fsnotify monitor."
StopListening -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (StopListening -> m ()) -> StopListening -> m ()
forall a b. (a -> b) -> a -> b
$ [StopListening]
-> (StopListening -> StopListening) -> StopListening
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [StopListening]
stops StopListening -> StopListening
forall a. a -> a
id
Cmd -> m Cmd
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cmd
Cmd_Remount
withManagerM ::
(MonadIO m, MonadUnliftIO m) =>
WatchConfig ->
(WatchManager -> m a) ->
m a
withManagerM :: WatchConfig -> (WatchManager -> m a) -> m a
withManagerM WatchConfig
cfg WatchManager -> m a
f = do
((forall a. m a -> IO a) -> IO a) -> m a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run ->
WatchConfig -> (WatchManager -> IO a) -> IO a
forall a. WatchConfig -> (WatchManager -> IO a) -> IO a
withManagerConf WatchConfig
cfg ((WatchManager -> IO a) -> IO a) -> (WatchManager -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \WatchManager
mgr -> m a -> IO a
forall a. m a -> IO a
run (WatchManager -> m a
f WatchManager
mgr)
watchTreeM ::
forall m.
(MonadIO m, MonadUnliftIO m) =>
WatchManager ->
FilePath ->
ActionPredicate ->
(Event -> m ()) ->
m StopListening
watchTreeM :: WatchManager
-> FilePath
-> ActionPredicate
-> (Event -> m ())
-> m StopListening
watchTreeM WatchManager
wm FilePath
fp ActionPredicate
pr Event -> m ()
f =
((forall a. m a -> IO a) -> IO StopListening) -> m StopListening
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO StopListening) -> m StopListening)
-> ((forall a. m a -> IO a) -> IO StopListening) -> m StopListening
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run ->
WatchManager
-> FilePath -> ActionPredicate -> Action -> IO StopListening
watchTree WatchManager
wm FilePath
fp ActionPredicate
pr (Action -> IO StopListening) -> Action -> IO StopListening
forall a b. (a -> b) -> a -> b
$ \Event
evt -> m () -> StopListening
forall a. m a -> IO a
run (Event -> m ()
f Event
evt)
log :: MonadLogger m => LogLevel -> Text -> m ()
log :: LogLevel -> Text -> m ()
log = Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Text -> LogLevel -> msg -> m ()
logWithoutLoc Text
"System.UnionMount"
newtype OverlayFs source = OverlayFs (Map FilePath (Set source))
emptyOverlayFs :: Ord source => OverlayFs source
emptyOverlayFs :: OverlayFs source
emptyOverlayFs = Map FilePath (Set source) -> OverlayFs source
forall source. Map FilePath (Set source) -> OverlayFs source
OverlayFs Map FilePath (Set source)
forall a. Monoid a => a
mempty
overlayFsModify :: FilePath -> (Set src -> Set src) -> OverlayFs src -> OverlayFs src
overlayFsModify :: FilePath -> (Set src -> Set src) -> OverlayFs src -> OverlayFs src
overlayFsModify FilePath
k Set src -> Set src
f (OverlayFs Map FilePath (Set src)
m) =
Map FilePath (Set src) -> OverlayFs src
forall source. Map FilePath (Set source) -> OverlayFs source
OverlayFs (Map FilePath (Set src) -> OverlayFs src)
-> Map FilePath (Set src) -> OverlayFs src
forall a b. (a -> b) -> a -> b
$
FilePath
-> Set src -> Map FilePath (Set src) -> Map FilePath (Set src)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FilePath
k (Set src -> Set src
f (Set src -> Set src) -> Set src -> Set src
forall a b. (a -> b) -> a -> b
$ Set src -> Maybe (Set src) -> Set src
forall a. a -> Maybe a -> a
fromMaybe Set src
forall a. Set a
Set.empty (Maybe (Set src) -> Set src) -> Maybe (Set src) -> Set src
forall a b. (a -> b) -> a -> b
$ FilePath -> Map FilePath (Set src) -> Maybe (Set src)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
k Map FilePath (Set src)
m) Map FilePath (Set src)
m
overlayFsAdd :: Ord src => FilePath -> src -> OverlayFs src -> OverlayFs src
overlayFsAdd :: FilePath -> src -> OverlayFs src -> OverlayFs src
overlayFsAdd FilePath
fp src
src =
FilePath -> (Set src -> Set src) -> OverlayFs src -> OverlayFs src
forall src.
FilePath -> (Set src -> Set src) -> OverlayFs src -> OverlayFs src
overlayFsModify FilePath
fp ((Set src -> Set src) -> OverlayFs src -> OverlayFs src)
-> (Set src -> Set src) -> OverlayFs src -> OverlayFs src
forall a b. (a -> b) -> a -> b
$ src -> Set src -> Set src
forall a. Ord a => a -> Set a -> Set a
Set.insert src
src
overlayFsRemove :: Ord src => FilePath -> src -> OverlayFs src -> OverlayFs src
overlayFsRemove :: FilePath -> src -> OverlayFs src -> OverlayFs src
overlayFsRemove FilePath
fp src
src =
FilePath -> (Set src -> Set src) -> OverlayFs src -> OverlayFs src
forall src.
FilePath -> (Set src -> Set src) -> OverlayFs src -> OverlayFs src
overlayFsModify FilePath
fp ((Set src -> Set src) -> OverlayFs src -> OverlayFs src)
-> (Set src -> Set src) -> OverlayFs src -> OverlayFs src
forall a b. (a -> b) -> a -> b
$ src -> Set src -> Set src
forall a. Ord a => a -> Set a -> Set a
Set.delete src
src
overlayFsLookup :: FilePath -> OverlayFs source -> Maybe (NonEmpty (source, FilePath))
overlayFsLookup :: FilePath -> OverlayFs source -> Maybe (NonEmpty (source, FilePath))
overlayFsLookup FilePath
fp (OverlayFs Map FilePath (Set source)
m) = do
NonEmpty source
sources <- [source] -> Maybe (NonEmpty source)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([source] -> Maybe (NonEmpty source))
-> (Set source -> [source])
-> Set source
-> Maybe (NonEmpty source)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set source -> [source]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set source -> Maybe (NonEmpty source))
-> Maybe (Set source) -> Maybe (NonEmpty source)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> Map FilePath (Set source) -> Maybe (Set source)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
fp Map FilePath (Set source)
m
NonEmpty (source, FilePath) -> Maybe (NonEmpty (source, FilePath))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty (source, FilePath)
-> Maybe (NonEmpty (source, FilePath)))
-> NonEmpty (source, FilePath)
-> Maybe (NonEmpty (source, FilePath))
forall a b. (a -> b) -> a -> b
$ NonEmpty source
sources NonEmpty source
-> (source -> (source, FilePath)) -> NonEmpty (source, FilePath)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (,FilePath
fp)
type Change source tag = Map tag (Map FilePath (FileAction (NonEmpty (source, FilePath))))
changeInsert ::
(Ord source, Ord tag, MonadState (OverlayFs source) m) =>
source ->
tag ->
FilePath ->
FileAction () ->
Change source tag ->
m (Change source tag)
changeInsert :: source
-> tag
-> FilePath
-> FileAction ()
-> Change source tag
-> m (Change source tag)
changeInsert source
src tag
tag FilePath
fp FileAction ()
act Change source tag
ch = do
(((), Change source tag) -> Change source tag)
-> m ((), Change source tag) -> m (Change source tag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((), Change source tag) -> Change source tag
forall a b. (a, b) -> b
snd (m ((), Change source tag) -> m (Change source tag))
-> (StateT (Change source tag) m () -> m ((), Change source tag))
-> StateT (Change source tag) m ()
-> m (Change source tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT (Change source tag) m ()
-> Change source tag -> m ((), Change source tag))
-> Change source tag
-> StateT (Change source tag) m ()
-> m ((), Change source tag)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Change source tag) m ()
-> Change source tag -> m ((), Change source tag)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Change source tag
ch (StateT (Change source tag) m () -> m (Change source tag))
-> StateT (Change source tag) m () -> m (Change source tag)
forall a b. (a -> b) -> a -> b
$ do
m () -> StateT (Change source tag) m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT (Change source tag) m ())
-> m () -> StateT (Change source tag) m ()
forall a b. (a -> b) -> a -> b
$
(OverlayFs source -> OverlayFs source) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((OverlayFs source -> OverlayFs source) -> m ())
-> (OverlayFs source -> OverlayFs source) -> m ()
forall a b. (a -> b) -> a -> b
$
(if FileAction ()
act FileAction () -> FileAction () -> Bool
forall a. Eq a => a -> a -> Bool
== FileAction ()
forall a. FileAction a
Delete then FilePath -> source -> OverlayFs source -> OverlayFs source
forall src.
Ord src =>
FilePath -> src -> OverlayFs src -> OverlayFs src
overlayFsRemove else FilePath -> source -> OverlayFs source -> OverlayFs source
forall src.
Ord src =>
FilePath -> src -> OverlayFs src -> OverlayFs src
overlayFsAdd)
FilePath
fp
source
src
FileAction (NonEmpty (source, FilePath))
overlays <-
m (Maybe (NonEmpty (source, FilePath)))
-> StateT
(Change source tag) m (Maybe (NonEmpty (source, FilePath)))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((OverlayFs source -> Maybe (NonEmpty (source, FilePath)))
-> m (Maybe (NonEmpty (source, FilePath)))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((OverlayFs source -> Maybe (NonEmpty (source, FilePath)))
-> m (Maybe (NonEmpty (source, FilePath))))
-> (OverlayFs source -> Maybe (NonEmpty (source, FilePath)))
-> m (Maybe (NonEmpty (source, FilePath)))
forall a b. (a -> b) -> a -> b
$ FilePath -> OverlayFs source -> Maybe (NonEmpty (source, FilePath))
forall source.
FilePath -> OverlayFs source -> Maybe (NonEmpty (source, FilePath))
overlayFsLookup FilePath
fp) StateT (Change source tag) m (Maybe (NonEmpty (source, FilePath)))
-> (Maybe (NonEmpty (source, FilePath))
-> FileAction (NonEmpty (source, FilePath)))
-> StateT
(Change source tag) m (FileAction (NonEmpty (source, FilePath)))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
Maybe (NonEmpty (source, FilePath))
Nothing -> FileAction (NonEmpty (source, FilePath))
forall a. FileAction a
Delete
Just NonEmpty (source, FilePath)
fs ->
let combinedAction :: RefreshAction
combinedAction = RefreshAction -> Maybe RefreshAction -> RefreshAction
forall a. a -> Maybe a -> a
fromMaybe RefreshAction
Existing (Maybe RefreshAction -> RefreshAction)
-> Maybe RefreshAction -> RefreshAction
forall a b. (a -> b) -> a -> b
$ FileAction () -> Maybe RefreshAction
forall a. FileAction a -> Maybe RefreshAction
refreshAction FileAction ()
act
in RefreshAction
-> NonEmpty (source, FilePath)
-> FileAction (NonEmpty (source, FilePath))
forall a. RefreshAction -> a -> FileAction a
Refresh RefreshAction
combinedAction NonEmpty (source, FilePath)
fs
(Change source tag
-> Maybe (Map FilePath (FileAction (NonEmpty (source, FilePath)))))
-> StateT
(Change source tag)
m
(Maybe (Map FilePath (FileAction (NonEmpty (source, FilePath)))))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (tag
-> Change source tag
-> Maybe (Map FilePath (FileAction (NonEmpty (source, FilePath))))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup tag
tag) StateT
(Change source tag)
m
(Maybe (Map FilePath (FileAction (NonEmpty (source, FilePath)))))
-> (Maybe (Map FilePath (FileAction (NonEmpty (source, FilePath))))
-> StateT (Change source tag) m ())
-> StateT (Change source tag) m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Map FilePath (FileAction (NonEmpty (source, FilePath))))
Nothing ->
(Change source tag -> Change source tag)
-> StateT (Change source tag) m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Change source tag -> Change source tag)
-> StateT (Change source tag) m ())
-> (Change source tag -> Change source tag)
-> StateT (Change source tag) m ()
forall a b. (a -> b) -> a -> b
$ tag
-> Map FilePath (FileAction (NonEmpty (source, FilePath)))
-> Change source tag
-> Change source tag
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert tag
tag (Map FilePath (FileAction (NonEmpty (source, FilePath)))
-> Change source tag -> Change source tag)
-> Map FilePath (FileAction (NonEmpty (source, FilePath)))
-> Change source tag
-> Change source tag
forall a b. (a -> b) -> a -> b
$ FilePath
-> FileAction (NonEmpty (source, FilePath))
-> Map FilePath (FileAction (NonEmpty (source, FilePath)))
forall k a. k -> a -> Map k a
Map.singleton FilePath
fp FileAction (NonEmpty (source, FilePath))
overlays
Just Map FilePath (FileAction (NonEmpty (source, FilePath)))
files ->
(Change source tag -> Change source tag)
-> StateT (Change source tag) m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Change source tag -> Change source tag)
-> StateT (Change source tag) m ())
-> (Change source tag -> Change source tag)
-> StateT (Change source tag) m ()
forall a b. (a -> b) -> a -> b
$ tag
-> Map FilePath (FileAction (NonEmpty (source, FilePath)))
-> Change source tag
-> Change source tag
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert tag
tag (Map FilePath (FileAction (NonEmpty (source, FilePath)))
-> Change source tag -> Change source tag)
-> Map FilePath (FileAction (NonEmpty (source, FilePath)))
-> Change source tag
-> Change source tag
forall a b. (a -> b) -> a -> b
$ FilePath
-> FileAction (NonEmpty (source, FilePath))
-> Map FilePath (FileAction (NonEmpty (source, FilePath)))
-> Map FilePath (FileAction (NonEmpty (source, FilePath)))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FilePath
fp FileAction (NonEmpty (source, FilePath))
overlays Map FilePath (FileAction (NonEmpty (source, FilePath)))
files