{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeApplications #-}

module System.UnionMount
  ( -- * Mount endpoints
    mount,
    unionMount,
    unionMount',

    -- * Types
    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)

-- | Simplified version of `unionMount` with exactly one layer.
mount ::
  forall model m b.
  ( MonadIO m,
    MonadUnliftIO m,
    MonadLogger m,
    Show b,
    Ord b
  ) =>
  -- | The directory to mount.
  FilePath ->
  -- | Only include these files (exclude everything else)
  [(b, FilePattern)] ->
  -- | Ignore these patterns
  [FilePattern] ->
  -- | Initial value of model, onto which to apply updates.
  model ->
  -- | How to update the model given a file action.
  --
  -- `b` is the tag associated with the `FilePattern` that selected this
  -- `FilePath`. `FileAction` is the operation performed on this path. This
  -- should return a function (in monadic context) that will update the model,
  -- to reflect the given `FileAction`.
  --
  -- If the action throws an exception, it will be logged and ignored.
  (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
    -- Monadic version of `chain`
    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
        -- Apply the list of actions in the given order to an initial argument.
        --
        -- chain [f1, f2, ...] a = ... (f2 (f1 x))
        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
($)

-- | Union mount a set of sources (directories) into a model.
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)

-- Log and ignore exceptions
--
-- TODO: Make user define-able?
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

-------------------------------------
-- Candidate for moving to a library
-------------------------------------

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)

-- | Like `unionMount` but without exception interrupting or re-mounting.
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
    -- Initial traversal of sources
    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
          -- Run fsnotify on sources
          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
                              -- We don't know yet how to deal with folder events. Just reboot the mount.
                              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 -- Exit, asking user to remokunt
                        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

-- | Like `filesMatching` but with a tag associated with a pattern so as to be
-- able to tell which pattern a resulting filepath is associated with.
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 -- `fp` is an absolute path (because of use of symlinks), so let's
        -- be more lenient in matching it. Note that this does meat we might
        -- match files the user may not have originally intended. This is
        -- the trade offs with using symlinks.
          [(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
  = -- | No recent change. Just notifying of file's existance
    Existing
  | -- | New file got created
    New
  | -- | The already existing file was updated.
    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
  = -- | A new file, or updated file, is available
    Refresh RefreshAction a
  | -- | The file just got deleted.
    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)

-- | This is not an action on file, rather an action on a directory (which
-- may contain files, which would be outside the scope of this fsnotify event,
-- and so the user must manually deal with them.)
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)] ->
  -- | The filepath is relative to the folder being monitored, unless if its
  -- ancestor is a symlink.
  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
  -- 100ms is a reasonable wait period to gather (possibly related) events.
  -- One such related event is a MOVE, which fsnotify doesn't native support;
  -- and spits out a DELETE and ADD instead.
  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
      -- NOTE: It is important to use canonical path, because this will allow us to
      -- transform fsnotify event's (absolute) path into one that is relative to
      -- @parent'@ (as passed by user), which is what @f@ will expect.
      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
    -- Unreachable
    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"

-- TODO: Abstract in module with StateT / MonadState
newtype OverlayFs source = OverlayFs (Map FilePath (Set source))

-- TODO: Replace this with a function taking `NonEmpty 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)

-- Files matched by each tag pattern, each represented by their corresponding
-- file (absolute path) in the individual sources. It is up to the user to union
-- them (for now).
type Change source tag = Map tag (Map FilePath (FileAction (NonEmpty (source, FilePath))))

-- | Report a change to overlay fs
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
    -- First, register this change in the overlayFs
    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 ->
          -- We don't track per-source action (not ideal), so use 'Existing'
          -- only if the current action is 'Deleted'. In every other scenario,
          -- re-use the current action for all overlay files.
          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