-- | UniqueFile is used for allocating names for temporary files in a directory.
-- To avoid large numbers of files in the same directory, we create sub-
-- directories where necessary.
module Util.UniqueFile(
   UniqueFileCounter,
      -- This represents the state, which needs to be single-threaded.
      -- Instance of Read,Show so it can be transmitted.
   initialUniqueFileCounter, -- :: UniqueFileCounter
      -- This is how you start
   stepUniqueFileCounter, -- :: UniqueFileCounter -> (String,UniqueFileCounter)
      -- And this is how you get a String out.

   -- Here are some independent functions for actually managing the
   -- subdirectories.  We don't require that the file names be generated
   -- from a UniqueFileCounter.
   UniqueFileStore, -- This represents a location on disk where the
      -- unique files are actually stored.  NB - it is not expected that
      -- all files got from the unique file

   newUniqueFileStore,
      -- :: FilePath -> (FilePath -> IO ()) -> IO UniqueFileStore
      -- This creates a new file store.
      -- The FilePath should point do a directory, which must already
      -- exist.
      -- The user should specify the create-directory function in the
      -- second argument, which is assumed to work.  This is given
      -- the name relative to the top directory, not the full name.

   ensureDirectories,
      -- :: UniqueFileStore -> String -> IO ()
   -- ensureDirectories is given the relative location of a
   -- file inside the file store (../. characters not permitted!) and
   -- creates directories appropriately.

   getFilePath, -- :: UniqueFileStore -> String -> FilePath
   -- Get full name of a file in the unique file store.
   ) where

import System.Directory
import Data.Char

import Util.IOExtras
import Util.Registry
import Util.FileNames
import Util.Computation(done)

-- --------------------------------------------------------------
-- UniqueFileCounter
-- --------------------------------------------------------------

{-
   Strategy: each file name has the form
   [char]/[char]/.../[char]
   The [char] is chosen from the 64-character set:

   lower case and upper case letters (52)
   digits (10)
   @+

   Thus each char corresponds to a number between 0 and 63.
   The characters are divided into those with numbers <22
   and those with numbers >=22.  Characters with numbers >=22
   correspond to bits of the directory entry of the file name.
   The ones with numbers <22 correspond to the file name part.
   Thus the file names can get arbitrarily long.  The reason
   for choosing 22 is that it maximises the number of possibilities
   when there are up to three parts, which is 39754.
   -}

newtype UniqueFileCounter = UniqueFileCounter [Int] deriving (Int -> UniqueFileCounter -> ShowS
[UniqueFileCounter] -> ShowS
UniqueFileCounter -> String
(Int -> UniqueFileCounter -> ShowS)
-> (UniqueFileCounter -> String)
-> ([UniqueFileCounter] -> ShowS)
-> Show UniqueFileCounter
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UniqueFileCounter] -> ShowS
$cshowList :: [UniqueFileCounter] -> ShowS
show :: UniqueFileCounter -> String
$cshow :: UniqueFileCounter -> String
showsPrec :: Int -> UniqueFileCounter -> ShowS
$cshowsPrec :: Int -> UniqueFileCounter -> ShowS
Show,ReadPrec [UniqueFileCounter]
ReadPrec UniqueFileCounter
Int -> ReadS UniqueFileCounter
ReadS [UniqueFileCounter]
(Int -> ReadS UniqueFileCounter)
-> ReadS [UniqueFileCounter]
-> ReadPrec UniqueFileCounter
-> ReadPrec [UniqueFileCounter]
-> Read UniqueFileCounter
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [UniqueFileCounter]
$creadListPrec :: ReadPrec [UniqueFileCounter]
readPrec :: ReadPrec UniqueFileCounter
$creadPrec :: ReadPrec UniqueFileCounter
readList :: ReadS [UniqueFileCounter]
$creadList :: ReadS [UniqueFileCounter]
readsPrec :: Int -> ReadS UniqueFileCounter
$creadsPrec :: Int -> ReadS UniqueFileCounter
Read)

initialUniqueFileCounter :: UniqueFileCounter
initialUniqueFileCounter :: UniqueFileCounter
initialUniqueFileCounter = [Int] -> UniqueFileCounter
UniqueFileCounter [Int
0]

stepUniqueFileCounter :: UniqueFileCounter -> (String,UniqueFileCounter)
stepUniqueFileCounter :: UniqueFileCounter -> (String, UniqueFileCounter)
stepUniqueFileCounter (UniqueFileCounter [Int]
ilist) =
      ([Int] -> String
toString [Int]
ilist,[Int] -> UniqueFileCounter
UniqueFileCounter ([Int] -> [Int]
increment [Int]
ilist))
   where
      toString :: [Int] -> String
      toString :: [Int] -> String
toString [] = ShowS
forall a. HasCallStack => String -> a
error String
"UniqueFile.toString"
      toString (Int
first:[Int]
rest) = String -> [Int] -> String
tS [Int -> Char
encodeChar Int
first] [Int]
rest
         where
            tS :: String -> [Int] -> String
            tS :: String -> [Int] -> String
tS String
acc [] = String
acc
            tS String
acc (Int
first:[Int]
rest) = String -> [Int] -> String
tS ((Int -> Char
encodeChar Int
first)Char -> ShowS
forall a. a -> [a] -> [a]
:Char
fileSepChar -> ShowS
forall a. a -> [a] -> [a]
:String
acc) [Int]
rest

      encodeChar :: Int -> Char
      encodeChar :: Int -> Char
encodeChar Int
i=
         if Int
iInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
26 then
            Int -> Char
chr(Char -> Int
ord Char
'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i)
         else if Int
iInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
52 then
            Int -> Char
chr((Char -> Int
ord Char
'A'Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
26)Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
i)
         else if Int
iInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
62 then
            Int -> Char
chr((Char -> Int
ord Char
'0'Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
52)Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
i)
         else case Int
i of
            Int
62 -> Char
'@'
            Int
63 -> Char
'+'
            Int
_ -> String -> Char
forall a. HasCallStack => String -> a
error String
"UniqueFile.encodeChar"

      increment :: [Int] -> [Int]
      increment :: [Int] -> [Int]
increment (Int
file:[Int]
rest) =
         if Int
fileInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==(Int
dividerInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
            then
               Int
0Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:([Int] -> [Int]
incrementDirs [Int]
rest)
            else
               (Int
fileInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
rest
         where
            incrementDirs :: [Int] -> [Int]
            incrementDirs :: [Int] -> [Int]
incrementDirs [] = [Int
divider]
            incrementDirs (Int
first:[Int]
rest) =
               if Int
firstInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==(Int
nCharsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
                  then
                     Int
dividerInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:([Int] -> [Int]
incrementDirs [Int]
rest)
                  else
                     (Int
firstInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
rest


      divider :: Int
      divider :: Int
divider = Int
22

      nChars :: Int
      nChars :: Int
nChars = Int
64

-- --------------------------------------------------------------
-- UniqueFileStore
-- --------------------------------------------------------------

data UniqueFileStore = UniqueFileStore {
   UniqueFileStore -> String
directory :: FilePath, -- We trim a trailing slash, if any.
   UniqueFileStore -> LockedRegistry String ()
alreadyExistsRegistry :: LockedRegistry String (),
      -- This is a cache of subdirectories already known to exist.
      -- Using a locked registry allows ensureDirectories to
      -- be run in several threads simultanesouly, without running concurrently
      -- on the same sub-directory.
   UniqueFileStore -> String -> IO ()
createDirAct :: FilePath -> IO ()
      -- function passed in by newUniqueFileStore
   }

newUniqueFileStore :: FilePath -> (FilePath -> IO ()) -> IO UniqueFileStore
newUniqueFileStore :: String -> (String -> IO ()) -> IO UniqueFileStore
newUniqueFileStore String
directory String -> IO ()
createDirAct =
   do
      Bool
exists <- String -> IO Bool
doesDirectoryExist String
directory
      if Bool
exists
         then
            IO ()
forall (m :: * -> *). Monad m => m ()
done
         else
            String -> IO ()
forall a. HasCallStack => String -> a
error String
"UniqueFile.newUniqueFileStore: directory must alreay exist"
      LockedRegistry String ()
alreadyExistsRegistry <- IO (LockedRegistry String ())
forall registry. NewRegistry registry => IO registry
newRegistry

      UniqueFileStore -> IO UniqueFileStore
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqueFileStore :: String
-> LockedRegistry String () -> (String -> IO ()) -> UniqueFileStore
UniqueFileStore {
         directory :: String
directory = ShowS
trimDir String
directory,
         createDirAct :: String -> IO ()
createDirAct = String -> IO ()
createDirAct,
         alreadyExistsRegistry :: LockedRegistry String ()
alreadyExistsRegistry = LockedRegistry String ()
alreadyExistsRegistry
         })

ensureDirectories :: UniqueFileStore -> String -> IO ()
ensureDirectories :: UniqueFileStore -> String -> IO ()
ensureDirectories (uniqueFileStore :: UniqueFileStore
uniqueFileStore @ UniqueFileStore {directory :: UniqueFileStore -> String
directory = String
directory,
      createDirAct :: UniqueFileStore -> String -> IO ()
createDirAct = String -> IO ()
createDirAct,
      alreadyExistsRegistry :: UniqueFileStore -> LockedRegistry String ()
alreadyExistsRegistry = LockedRegistry String ()
alreadyExistsRegistry}) String
fullName =
   case String -> (String, String)
splitName String
fullName of
      (String
subDir,String
rest)
         | String
subDir String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
thisDir -> IO ()
forall (m :: * -> *). Monad m => m ()
done -- no subdirectories required.
         | Bool
True ->
            LockedRegistry String ()
-> String -> (Maybe () -> IO (Maybe (), ())) -> IO ()
forall registry from to extra.
GetSetRegistry registry from to =>
registry -> from -> (Maybe to -> IO (Maybe to, extra)) -> IO extra
transformValue LockedRegistry String ()
alreadyExistsRegistry String
subDir
               (\ Maybe ()
existsOpt ->
                  do
                     case Maybe ()
existsOpt of
                        Just () -> -- no action required
                           IO ()
forall (m :: * -> *). Monad m => m ()
done
                        Maybe ()
Nothing ->
                           do
                              UniqueFileStore -> String -> IO ()
ensureDirectories UniqueFileStore
uniqueFileStore String
subDir
                              IO () -> IO (Maybe ())
forall a. IO a -> IO (Maybe a)
catchAlreadyExists (String -> IO ()
createDirAct String
subDir)
                              IO ()
forall (m :: * -> *). Monad m => m ()
done
                     (Maybe (), ()) -> IO (Maybe (), ())
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Maybe ()
forall a. a -> Maybe a
Just (),())
                  )


getFilePath :: UniqueFileStore -> String -> FilePath
getFilePath :: UniqueFileStore -> ShowS
getFilePath (UniqueFileStore {directory :: UniqueFileStore -> String
directory = String
directory}) String
file =
   String -> ShowS
combineNames String
directory String
file