    --  Compiler Toolkit: operations on file
    --
    --  Author : Manuel M T Chakravarty
    --  Created: 6 November 1999
    --
    --  Version $Revision: 1.1.1.1 $ from $Date: 2004/11/13 16:42:49 $
    --
    --  Copyright (c) [1999..2003] Manuel M T Chakravarty
    --
    --  This file is free software; you can redistribute it and/or modify
    --  it under the terms of the GNU General Public License as published by
    --  the Free Software Foundation; either version 2 of the License, or
    --  (at your option) any later version.
    --
    --  This file is distributed in the hope that it will be useful,
    --  but WITHOUT ANY WARRANTY; without even the implied warranty of
    --  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    --  GNU General Public License for more details.
    --
    --- DESCRIPTION ---------------------------------------------------------------
    --
    --  Typical operations needed when manipulating file names.
    --
    --- DOCU ----------------------------------------------------------------------
    --
    --  language: Haskell 98
    --
    --- TODO ----------------------------------------------------------------------
    --

    module FileOps (fileFindIn, mktemp)
    where

    import Prelude hiding (catch)
    -- standard libs
    import Data.Char      (chr, ord)
    import System.Directory (doesFileExist)
    import System.IO         (Handle, IOMode(..), openFile)
    import Control.Monad     (liftM)
    import Control.Exception (catch, SomeException)
    import System.Random    (newStdGen, randomRs)

    import FNameOps  (dirname, stripDirname, addPath)

    -- search for the given file in the given list of directories (EXPORTED)
    --
    --  * if the file does not exist, an exception is raised
    --
    --  * if the given file name is absolute, it is first tried whether this file
    --   exists, afterwards the path component is stripped and the given
    --   directories are searched; otherwise, if the file name is not absolute,
    --   the path component is retained while searching the directories
    --
    fileFindIn              :: FilePath -> [FilePath] -> IO FilePath
    ""   fileFindIn :: FilePath -> [FilePath] -> IO FilePath
    `fileFindIn` paths :: [FilePath]
    paths  = FilePath -> IO FilePath
    forall (m :: * -> *) a. MonadFail m => FilePath -> m a
    fail "Empty file name"
    file :: FilePath
    file `fileFindIn` paths :: [FilePath]
    paths  =
      do
        let (paths' :: [FilePath]
    paths', file' :: FilePath
    file') = if FilePath -> Char
    forall a. [a] -> a
    head FilePath
    file Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == '/'
                              then (FilePath -> FilePath
    dirname FilePath
    file FilePath -> [FilePath] -> [FilePath]
    forall a. a -> [a] -> [a]
    : [FilePath]
    paths, FilePath -> FilePath
    stripDirname FilePath
    file)
                              else ([FilePath]
    paths, FilePath
    file)
            files :: [FilePath]
    files  = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
    forall a b. (a -> b) -> [a] -> [b]
    map (FilePath -> FilePath -> FilePath
    `addPath` FilePath
    file') [FilePath]
    paths'
        [Bool]
    existsFlags <- (FilePath -> IO Bool) -> [FilePath] -> IO [Bool]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM FilePath -> IO Bool
    doesFileExist [FilePath]
    files
        let existingFiles :: [FilePath]
    existingFiles = [FilePath
    file | (file :: FilePath
    file, flag :: Bool
    flag) <- [FilePath] -> [Bool] -> [(FilePath, Bool)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [FilePath]
    files [Bool]
    existsFlags, Bool
    flag]
        if [FilePath] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [FilePath]
    existingFiles
          then FilePath -> IO FilePath
    forall (m :: * -> *) a. MonadFail m => FilePath -> m a
    fail (FilePath
    file FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ ": File does not exist")
          else FilePath -> IO FilePath
    forall (m :: * -> *) a. Monad m => a -> m a
    return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
    forall a b. (a -> b) -> a -> b
    $ [FilePath] -> FilePath
    forall a. [a] -> a
    head [FilePath]
    existingFiles

    -- |Create a temporary file with a unique name.
    --
    --  * A unique sequence of at least six characters and digits is added
    --   inbetween the two given components (the latter of which must include the
    --   file suffix if any is needed)
    --
    --  * Default permissions are used, which might not be optimal, but
    --   unfortunately the Haskell standard libs don't support proper permission
    --   management.
    --
    --  * We make 100 attempts on getting a unique filename before giving up.
    --
    mktemp :: FilePath -> FilePath -> IO (Handle, FilePath)
    mktemp :: FilePath -> FilePath -> IO (Handle, FilePath)
    mktemp pre :: FilePath
    pre post :: FilePath
    post =
      do
        [Int]
    rs <- (StdGen -> [Int]) -> IO StdGen -> IO [Int]
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM ((Int, Int) -> StdGen -> [Int]
    forall a g. (Random a, RandomGen g) => (a, a) -> g -> [a]
    randomRs (0, 61)) IO StdGen
    newStdGen
                             -- range for lower and upper case letters plus digits
        Int -> [Int] -> IO (Handle, FilePath)
    createLoop 100 [Int]
    rs
      where
        createLoop :: Int -> [Int] -> IO (Handle, FilePath)
    createLoop 0        _  = FilePath -> IO (Handle, FilePath)
    forall (m :: * -> *) a. MonadFail m => FilePath -> m a
    fail "mktemp: failed 100 times"
        createLoop attempts :: Int
    attempts rs :: [Int]
    rs = let
                                   (rs' :: [Int]
    rs', fname :: FilePath
    fname) = [Int] -> ([Int], FilePath)
    nextName [Int]
    rs
                                 in do
                                   Handle
    h <- FilePath -> IOMode -> IO Handle
    openFile FilePath
    fname IOMode
    ReadWriteMode
                                   (Handle, FilePath) -> IO (Handle, FilePath)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Handle
    h, FilePath
    fname)
                                 IO (Handle, FilePath)
    -> (SomeException -> IO (Handle, FilePath))
    -> IO (Handle, FilePath)
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    `catch` Int -> [Int] -> SomeException -> IO (Handle, FilePath)
    handler Int
    attempts [Int]
    rs'
        --
        handler :: Int -> [Int] -> SomeException -> IO (Handle,FilePath)
        handler :: Int -> [Int] -> SomeException -> IO (Handle, FilePath)
    handler attempts :: Int
    attempts rs' :: [Int]
    rs' _ = Int -> [Int] -> IO (Handle, FilePath)
    createLoop (Int
    attempts Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - 1) [Int]
    rs'

        sixChars :: [Int] -> ([Int], String)
        sixChars :: [Int] -> ([Int], FilePath)
    sixChars is :: [Int]
    is =
          let
            (sixInts :: [Int]
    sixInts, is' :: [Int]
    is') = Int -> [Int] -> ([Int], [Int])
    forall a. Int -> [a] -> ([a], [a])
    splitAt 6 [Int]
    is
            --
            toChar :: Int -> Char
    toChar i :: Int
    i | Int
    i Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < 10    = Int -> Char
    chr (Int -> Char) -> (Int -> Int) -> Int -> Char
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Int
    ord '0' Int -> Int -> Int
    forall a. Num a => a -> a -> a
    +)                 (Int -> Char) -> Int -> Char
    forall a b. (a -> b) -> a -> b
    $ Int
    i
                     | Int
    i Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < 36    = Int -> Char
    chr (Int -> Char) -> (Int -> Int) -> Int -> Char
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Int
    ord 'A' Int -> Int -> Int
    forall a. Num a => a -> a -> a
    +) (Int -> Int) -> (Int -> Int) -> Int -> Int
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Int -> Int -> Int
    forall a. Num a => a -> a -> a
    subtract 10) (Int -> Char) -> Int -> Char
    forall a b. (a -> b) -> a -> b
    $ Int
    i
                     | Bool
    otherwise = Int -> Char
    chr (Int -> Char) -> (Int -> Int) -> Int -> Char
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Int
    ord 'a' Int -> Int -> Int
    forall a. Num a => a -> a -> a
    +) (Int -> Int) -> (Int -> Int) -> Int -> Int
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Int -> Int -> Int
    forall a. Num a => a -> a -> a
    subtract 36) (Int -> Char) -> Int -> Char
    forall a b. (a -> b) -> a -> b
    $ Int
    i
            in
            ([Int]
    is', (Int -> Char) -> [Int] -> FilePath
    forall a b. (a -> b) -> [a] -> [b]
    map Int -> Char
    toChar [Int]
    sixInts)
        --
        nextName :: [Int] -> ([Int], String)
        nextName :: [Int] -> ([Int], FilePath)
    nextName is :: [Int]
    is = let
                        (is' :: [Int]
    is', rndChars :: FilePath
    rndChars) = [Int] -> ([Int], FilePath)
    sixChars [Int]
    is
                      in
                      ([Int]
    is', FilePath
    pre FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    rndChars FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    post)