System/Directory/Internal/Common.hs

    module System.Directory.Internal.Common where
    import Prelude ()
    import System.Directory.Internal.Prelude
    import System.FilePath ((</>), isPathSeparator, isRelative,
                            pathSeparator, splitDrive, takeDrive)

    -- | A generator with side-effects.
    newtype ListT m a = ListT { unListT :: m (Maybe (a, ListT m a)) }

    emptyListT :: Applicative m => ListT m a
    emptyListT = ListT (pure Nothing)

    maybeToListT :: Applicative m => m (Maybe a) -> ListT m a
    maybeToListT m = ListT (((\ x -> (x, emptyListT)) <$>) <$> m)

    listToListT :: Applicative m => [a] -> ListT m a
    listToListT [] = emptyListT
    listToListT (x : xs) = ListT (pure (Just (x, listToListT xs)))

    liftJoinListT :: Monad m => m (ListT m a) -> ListT m a
    liftJoinListT m = ListT (m >>= unListT)

    listTHead :: Functor m => ListT m a -> m (Maybe a)
    listTHead (ListT m) = (fst <$>) <$> m

    listTToList :: Monad m => ListT m a -> m [a]
    listTToList (ListT m) = do
      mx <- m
      case mx of
        Nothing -> return []
        Just (x, m') -> do
          xs <- listTToList m'
          return (x : xs)

    andM :: Monad m => m Bool -> m Bool -> m Bool
    andM mx my = do
      x <- mx
      if x
        then my
        else return x

    sequenceWithIOErrors_ :: [IO ()] -> IO ()
    sequenceWithIOErrors_ actions = go (Right ()) actions
      where

        go :: Either IOError () -> [IO ()] -> IO ()
        go (Left e)   []       = ioError e
        go (Right ()) []       = pure ()
        go s          (m : ms) = s `seq` do
          r <- tryIOError m
          go (thenEither s r) ms

        -- equivalent to (*>) for Either, defined here to retain compatibility
        -- with base prior to 4.3
        thenEither :: Either b a -> Either b a -> Either b a
        thenEither x@(Left _) _ = x
        thenEither _          y = y

    -- | Similar to 'try' but only catches a specify kind of 'IOError' as
    --   specified by the predicate.
    tryIOErrorType :: (IOError -> Bool) -> IO a -> IO (Either IOError a)
    tryIOErrorType check action = do
      result <- tryIOError action
      case result of
        Left  err -> if check err then pure (Left err) else throwIO err
        Right val -> pure (Right val)

    -- | Attempt to perform the given action, silencing any IO exception thrown by
    -- it.
    ignoreIOExceptions :: IO () -> IO ()
    ignoreIOExceptions io = io `catchIOError` (\_ -> pure ())

    specializeErrorString :: String -> (IOError -> Bool) -> IO a -> IO a
    specializeErrorString str errType action = do
      mx <- tryIOErrorType errType action
      case mx of
        Left  e -> throwIO (ioeSetErrorString e str)
        Right x -> pure x

    ioeAddLocation :: IOError -> String -> IOError
    ioeAddLocation e loc = do
      ioeSetLocation e newLoc
      where
        newLoc = loc <> if null oldLoc then "" else ":" <> oldLoc
        oldLoc = ioeGetLocation e

    data FileType = File
                  | SymbolicLink -- ^ POSIX: either file or directory link; Windows: file link
                  | Directory
                  | DirectoryLink -- ^ Windows only: directory link
                  deriving (Bounded, Enum, Eq, Ord, Read, Show)

    -- | Check whether the given 'FileType' is considered a directory by the
    -- operating system.  This affects the choice of certain functions
    -- e.g. `removeDirectory` vs `removeFile`.
    fileTypeIsDirectory :: FileType -> Bool
    fileTypeIsDirectory Directory     = True
    fileTypeIsDirectory DirectoryLink = True
    fileTypeIsDirectory _             = False

    -- | Return whether the given 'FileType' is a link.
    fileTypeIsLink :: FileType -> Bool
    fileTypeIsLink SymbolicLink  = True
    fileTypeIsLink DirectoryLink = True
    fileTypeIsLink _             = False

    data Permissions
      = Permissions
      { readable :: Bool
      , writable :: Bool
      , executable :: Bool
      , searchable :: Bool
      } deriving (Eq, Ord, Read, Show)

    -- | Convert a path into an absolute path.  If the given path is relative, the
    -- current directory is prepended.  If the path is already absolute, the path
    -- is returned unchanged.  The function preserves the presence or absence of
    -- the trailing path separator.
    --
    -- If the path is already absolute, the operation never fails.  Otherwise, the
    -- operation may fail with the same exceptions as 'getCurrentDirectory'.
    --
    -- (internal API)
    prependCurrentDirectoryWith :: IO FilePath -> FilePath -> IO FilePath
    prependCurrentDirectoryWith getCurrentDirectory path =
      ((`ioeAddLocation` "prependCurrentDirectory") .
       (`ioeSetFileName` path)) `modifyIOError` do
        if isRelative path -- avoid the call to `getCurrentDirectory` if we can
        then do
          cwd <- getCurrentDirectory
          let curDrive = takeWhile (not . isPathSeparator) (takeDrive cwd)
          let (drive, subpath) = splitDrive path
          -- handle drive-relative paths (Windows only)
          pure . (</> subpath) $
            case drive of
              _ : _ | (toUpper <$> drive) /= (toUpper <$> curDrive) ->
                        drive <> [pathSeparator]
              _ -> cwd
        else pure path

    -- | Truncate the destination file and then copy the contents of the source
    -- file to the destination file.  If the destination file already exists, its
    -- attributes shall remain unchanged.  Otherwise, its attributes are reset to
    -- the defaults.
    copyFileContents :: FilePath            -- ^ Source filename
                     -> FilePath            -- ^ Destination filename
                     -> IO ()
    copyFileContents fromFPath toFPath =
      (`ioeAddLocation` "copyFileContents") `modifyIOError` do
        withBinaryFile toFPath WriteMode $ \ hTo ->
          copyFileToHandle fromFPath hTo

    -- | Copy all data from a file to a handle.
    copyFileToHandle :: FilePath            -- ^ Source file
                     -> Handle              -- ^ Destination handle
                     -> IO ()
    copyFileToHandle fromFPath hTo =
      (`ioeAddLocation` "copyFileToHandle") `modifyIOError` do
        withBinaryFile fromFPath ReadMode $ \ hFrom ->
          copyHandleData hFrom hTo

    -- | Copy data from one handle to another until end of file.
    copyHandleData :: Handle                -- ^ Source handle
                   -> Handle                -- ^ Destination handle
                   -> IO ()
    copyHandleData hFrom hTo =
      (`ioeAddLocation` "copyData") `modifyIOError` do
        allocaBytes bufferSize go
      where
        bufferSize = 131072 -- 128 KiB, as coreutils `cp` uses as of May 2014 (see ioblksize.h)
        go buffer = do
          count <- hGetBuf hFrom buffer bufferSize
          when (count > 0) $ do
            hPutBuf hTo buffer count
            go buffer

    -- | Special directories for storing user-specific application data,
    --   configuration, and cache files, as specified by the
    --   <http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html XDG Base Directory Specification>.
    --
    --   Note: On Windows, 'XdgData' and 'XdgConfig' map to the same directory.
    --
    --   @since 1.2.3.0
    data XdgDirectory
      = XdgData
        -- ^ For data files (e.g. images).
        --   Defaults to @~\/.local\/share@ and can be
        --   overridden by the @XDG_DATA_HOME@ environment variable.
        --   On Windows, it is @%APPDATA%@
        --   (e.g. @C:\/Users\//\<user\>/\/AppData\/Roaming@).
        --   Can be considered as the user-specific equivalent of @\/usr\/share@.
      | XdgConfig
        -- ^ For configuration files.
        --   Defaults to @~\/.config@ and can be
        --   overridden by the @XDG_CONFIG_HOME@ environment variable.
        --   On Windows, it is @%APPDATA%@
        --   (e.g. @C:\/Users\//\<user\>/\/AppData\/Roaming@).
        --   Can be considered as the user-specific equivalent of @\/etc@.
      | XdgCache
        -- ^ For non-essential files (e.g. cache).
        --   Defaults to @~\/.cache@ and can be
        --   overridden by the @XDG_CACHE_HOME@ environment variable.
        --   On Windows, it is @%LOCALAPPDATA%@
        --   (e.g. @C:\/Users\//\<user\>/\/AppData\/Local@).
        --   Can be considered as the user-specific equivalent of @\/var\/cache@.
      deriving (Bounded, Enum, Eq, Ord, Read, Show)

    -- | Search paths for various application data, as specified by the
    --   <http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html XDG Base Directory Specification>.
    --
    --   Note: On Windows, 'XdgDataDirs' and 'XdgConfigDirs' yield the same result.
    --
    --   @since 1.3.2.0
    data XdgDirectoryList
      = XdgDataDirs
        -- ^ For data files (e.g. images).
        --   Defaults to @/usr/local/share/@ and @/usr/share/@ and can be
        --   overridden by the @XDG_DATA_DIRS@ environment variable.
        --   On Windows, it is @%PROGRAMDATA%@ or @%ALLUSERSPROFILE%@
        --   (e.g. @C:\/ProgramData@).
      | XdgConfigDirs
        -- ^ For configuration files.
        --   Defaults to @/etc/xdg@ and can be
        --   overridden by the @XDG_CONFIG_DIRS@ environment variable.
        --   On Windows, it is @%PROGRAMDATA%@ or @%ALLUSERSPROFILE%@
        --   (e.g. @C:\/ProgramData@).
      deriving (Bounded, Enum, Eq, Ord, Read, Show)