{-# OPTIONS_GHC -Wunused-imports #-}

-- | Utilities for working with directories.
module Mikan.Utils.IO.Directory
  ( copyDirContent
  , copyIfChanged
  , findWithInfo
  , isCaseSensitive
  )
where

import Control.Exception
import Control.Monad
import Control.Monad.Writer ( WriterT, execWriterT, tell )
import Control.Monad.Trans ( lift )

import Data.ByteString qualified as BS
import Data.Monoid ( Endo(Endo, appEndo) )

import System.Directory
import System.FilePath
import System.FilePath.Find qualified as Find

-- | Search a directory recursively, with recursion controlled by a
-- 'Find.RecursionPredicate'. Lazily return a unsorted list of all files
-- matching the given 'Find.FilterPredicate'.
--
-- Any errors that occur are ignored, with warnings printed to 'System.IO.stderr'.
findWithInfo
  :: Find.RecursionPredicate  -- ^ Control recursion into subdirectories.
  -> Find.FilterPredicate     -- ^ Decide whether a file appears in the result.
  -> FilePath                 -- ^ Directory to start searching.
  -> IO [Find.FileInfo]       -- ^ Files that matched the 'Find.FilterPredicate'.
findWithInfo :: RecursionPredicate
-> RecursionPredicate -> FilePath -> IO [FileInfo]
findWithInfo RecursionPredicate
recurse RecursionPredicate
filt FilePath
dir = RecursionPredicate
-> ([FileInfo] -> FileInfo -> [FileInfo])
-> [FileInfo]
-> FilePath
-> IO [FileInfo]
forall a.
RecursionPredicate -> (a -> FileInfo -> a) -> a -> FilePath -> IO a
Find.fold RecursionPredicate
recurse [FileInfo] -> FileInfo -> [FileInfo]
act [] FilePath
dir
  where
  -- Add file to list front when it matches the filter
  act :: [Find.FileInfo] -> Find.FileInfo -> [Find.FileInfo]
  act :: [FileInfo] -> FileInfo -> [FileInfo]
act [FileInfo]
fs FileInfo
f = if RecursionPredicate -> FileInfo -> Bool
forall a. FindClause a -> FileInfo -> a
Find.evalClause RecursionPredicate
filt FileInfo
f then FileInfo
f FileInfo -> [FileInfo] -> [FileInfo]
forall a. a -> [a] -> [a]
: [FileInfo]
fs else [FileInfo]
fs


-- | @copyDirContent src dest@ recursively copies directory @src@ onto @dest@.
--
-- First, a to-do list of copy actions is created.
-- Then, the to-do list is carried out.
--
-- This avoids copying files we have just created again, which can happen
-- if @src@ and @dest@ are not disjoint.
--
-- See issue [#2705](http://github.com/agda/agda/issues/2705).
copyDirContent :: FilePath -> FilePath -> IO ()
copyDirContent :: FilePath -> FilePath -> IO ()
copyDirContent FilePath
src FilePath
dest = (CopyDirAction -> IO ()) -> [CopyDirAction] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CopyDirAction -> IO ()
performAction ([CopyDirAction] -> IO ()) -> IO [CopyDirAction] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
  (Endo [CopyDirAction] -> [CopyDirAction] -> [CopyDirAction]
forall a. Endo a -> a -> a
`appEndo` []) (Endo [CopyDirAction] -> [CopyDirAction])
-> IO (Endo [CopyDirAction]) -> IO [CopyDirAction]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterT (Endo [CopyDirAction]) IO () -> IO (Endo [CopyDirAction])
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (FilePath -> FilePath -> WriterT (Endo [CopyDirAction]) IO ()
copyDirContentDryRun FilePath
src FilePath
dest)

-- | Action to be carried out for copying a directory recursively.
data CopyDirAction
  = MkDir    FilePath
  -- ^ Create directory if missing.
  | CopyFile FilePath FilePath
  -- ^ Copy file if changed.

-- | Perform scheduled 'CopyDirAction'.
performAction :: CopyDirAction -> IO ()
performAction :: CopyDirAction -> IO ()
performAction = \case
  MkDir FilePath
d           -> Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
d
  CopyFile FilePath
src FilePath
dest -> FilePath -> FilePath -> IO ()
copyIfChanged FilePath
src FilePath
dest

-- | @copyDirContentDryRun src dest@ creates a to-do list
-- for recursively copying directory @src@ onto @dest@.
copyDirContentDryRun :: FilePath -> FilePath -> WriterT (Endo [CopyDirAction]) IO ()
copyDirContentDryRun :: FilePath -> FilePath -> WriterT (Endo [CopyDirAction]) IO ()
copyDirContentDryRun FilePath
src FilePath
dest = do
  Endo [CopyDirAction] -> WriterT (Endo [CopyDirAction]) IO ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Endo [CopyDirAction] -> WriterT (Endo [CopyDirAction]) IO ())
-> Endo [CopyDirAction] -> WriterT (Endo [CopyDirAction]) IO ()
forall a b. (a -> b) -> a -> b
$ ([CopyDirAction] -> [CopyDirAction]) -> Endo [CopyDirAction]
forall a. (a -> a) -> Endo a
Endo (FilePath -> CopyDirAction
MkDir FilePath
dest CopyDirAction -> [CopyDirAction] -> [CopyDirAction]
forall a. a -> [a] -> [a]
:)
  chlds <- IO [FilePath] -> WriterT (Endo [CopyDirAction]) IO [FilePath]
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT (Endo [CopyDirAction]) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO [FilePath] -> WriterT (Endo [CopyDirAction]) IO [FilePath])
-> IO [FilePath] -> WriterT (Endo [CopyDirAction]) IO [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> IO [FilePath]
getDirectoryContents FilePath
src
  forM_ chlds $ \ FilePath
x -> do
    isDir <- IO Bool -> WriterT (Endo [CopyDirAction]) IO Bool
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT (Endo [CopyDirAction]) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Bool -> WriterT (Endo [CopyDirAction]) IO Bool)
-> IO Bool -> WriterT (Endo [CopyDirAction]) IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist (FilePath
src FilePath -> FilePath -> FilePath
</> FilePath
x)
    case isDir of
      Bool
_ | FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"." Bool -> Bool -> Bool
|| FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".." -> () -> WriterT (Endo [CopyDirAction]) IO ()
forall a. a -> WriterT (Endo [CopyDirAction]) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Bool
True  -> FilePath -> FilePath -> WriterT (Endo [CopyDirAction]) IO ()
copyDirContentDryRun (FilePath
src FilePath -> FilePath -> FilePath
</> FilePath
x) (FilePath
dest FilePath -> FilePath -> FilePath
</> FilePath
x)
      Bool
False -> Endo [CopyDirAction] -> WriterT (Endo [CopyDirAction]) IO ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Endo [CopyDirAction] -> WriterT (Endo [CopyDirAction]) IO ())
-> Endo [CopyDirAction] -> WriterT (Endo [CopyDirAction]) IO ()
forall a b. (a -> b) -> a -> b
$ ([CopyDirAction] -> [CopyDirAction]) -> Endo [CopyDirAction]
forall a. (a -> a) -> Endo a
Endo (FilePath -> FilePath -> CopyDirAction
CopyFile (FilePath
src FilePath -> FilePath -> FilePath
</> FilePath
x) (FilePath
dest FilePath -> FilePath -> FilePath
</> FilePath
x) CopyDirAction -> [CopyDirAction] -> [CopyDirAction]
forall a. a -> [a] -> [a]
:)

-- | @copyIfChanged src dst@ makes sure that @dst@ exists
--   and has the same content as @dst@.
--
copyIfChanged :: FilePath -> FilePath -> IO ()
copyIfChanged :: FilePath -> FilePath -> IO ()
copyIfChanged FilePath
src FilePath
dst = do
  exist <- FilePath -> IO Bool
doesFileExist FilePath
dst
  if not exist then copyFile src dst else do
    new <- BS.readFile src
    old <- BS.readFile dst
    unless (old == new) $ copyFile src dst

-- | Is the underlying file system of a directory case-sensitive?
isCaseSensitive :: FilePath -> IO Bool
isCaseSensitive :: FilePath -> IO Bool
isCaseSensitive FilePath
dir = do
  IO () -> (() -> IO ()) -> (() -> IO Bool) -> IO Bool
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
    (FilePath -> FilePath -> IO ()
writeFile (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
"CASE_TEST") FilePath
"")
    (\()
_ -> FilePath -> IO ()
removeFile (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
"CASE_TEST"))
    (\()
_ -> Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Bool
doesFileExist (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
"case_test"))