mirror of https://github.com/voidlizard/hbs2
131 lines
3.5 KiB
Haskell
131 lines
3.5 KiB
Haskell
{-# Language MultiWayIf #-}
|
|
module Data.Config.Suckless.Script.File where
|
|
|
|
import Data.Config.Suckless
|
|
import Data.Config.Suckless.Script.Internal
|
|
|
|
import Control.Monad
|
|
import Control.Monad.Trans.Class
|
|
import Control.Monad.Trans.Cont
|
|
import Data.Maybe
|
|
import Data.Either
|
|
import Data.Foldable
|
|
import System.Directory
|
|
import System.FilePath
|
|
import System.FilePattern
|
|
import Data.HashSet qualified as HS
|
|
|
|
import Lens.Micro.Platform
|
|
import UnliftIO
|
|
import Control.Concurrent.STM qualified as STM
|
|
import Streaming.Prelude qualified as S
|
|
|
|
import Data.List.Split (chunksOf)
|
|
|
|
glob :: forall m . MonadIO m
|
|
=> [FilePattern] -- ^ search patterns
|
|
-> [FilePattern] -- ^ ignore patterns
|
|
-> FilePath -- ^ directory
|
|
-> (FilePath -> m Bool) -- ^ file action
|
|
-> m ()
|
|
|
|
glob pat ignore dir action = do
|
|
|
|
go dir
|
|
|
|
where
|
|
|
|
ppat = zip (repeat True) pat
|
|
spat = zip (repeat True) ignore
|
|
|
|
go f = do
|
|
isF <- liftIO $ doesFileExist f
|
|
|
|
when isF do
|
|
liftIO $ print f
|
|
|
|
isD <- liftIO $ doesDirectoryExist f
|
|
|
|
when isD do
|
|
co <- liftIO (try @_ @IOError $ listDirectory f)
|
|
<&> fromRight mempty
|
|
|
|
let fns = matchMany ppat [ (f </> x, x) | x <- co ]
|
|
let stop = matchMany spat [ (f </> x, x) | x <- co ]
|
|
let ss = HS.fromList $ (fmap (view _2)) stop
|
|
|
|
-- matchMany :: [(a, FilePattern)] -> [(b, FilePath)] -> [(a, b, [String])]
|
|
|
|
liftIO $ print spat
|
|
liftIO $ print stop
|
|
-- for_ co $ \p -> do
|
|
-- liftIO $ print p
|
|
-- unless (HS.member p ss) do
|
|
-- go (f </> p)
|
|
|
|
-- q <- newTQueueIO
|
|
|
|
-- a <- liftIO $ async do
|
|
-- flip fix seed $ \next items -> do
|
|
-- case items of
|
|
-- [] -> atomically (writeTQueue q Nothing)
|
|
-- (p:rest) -> do
|
|
-- isD <- liftIO (doesDirectoryExist p)
|
|
-- if isD && not (skip p) then do
|
|
-- content <- liftIO (try @_ @IOError $ listDirectory p)
|
|
-- <&> fromRight mempty
|
|
|
|
-- let found = [ p </> x | x <- content ]
|
|
|
|
-- forConcurrently_ found $ \f -> do
|
|
-- glob pat ignore f $ \fn -> do
|
|
-- atomically $ writeTQueue q (Just fn)
|
|
-- pure True
|
|
|
|
-- next []
|
|
|
|
-- else do
|
|
-- isF <- liftIO (doesFileExist p)
|
|
-- when (isF && matches pat p ) do
|
|
-- atomically (writeTQueue q (Just p))
|
|
|
|
-- next rest
|
|
|
|
-- fix \next -> do
|
|
-- r <- atomically (readTQueue q)
|
|
-- case r of
|
|
-- Nothing -> pure ()
|
|
-- Just e -> void (action e) >> next
|
|
|
|
-- where
|
|
-- matches p f = or [ i ?== f | i <- p ]
|
|
-- skip p = or [ i ?== p | i <- ignore ]
|
|
|
|
entries :: forall c m . ( IsContext c
|
|
, Exception (BadFormException c)
|
|
, MonadUnliftIO m)
|
|
=> MakeDictM c m ()
|
|
entries = do
|
|
entry $ bindMatch "glob" $ \syn -> do
|
|
|
|
(p,i,d) <- case syn of
|
|
[] -> pure (["*"], [], ".")
|
|
|
|
[StringLike d, StringLike i] -> do
|
|
pure ([i], [], d)
|
|
|
|
[StringLike d, StringLike i, StringLike e] -> do
|
|
pure ([i], [e], d)
|
|
|
|
[StringLike d, ListVal (StringLikeList i), ListVal (StringLikeList e)] -> do
|
|
pure (i, e, d)
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|
|
r <- S.toList_ $ glob p i d $ \fn -> do
|
|
S.yield (mkStr @c fn) -- do
|
|
pure True
|
|
|
|
pure (mkList r)
|
|
|