{-# LANGUAGE DeriveDataTypeable #-}
module Util.UniqueString(
UniqueStringSource,
newUniqueStringSource,
newUniqueString,
maxUniqueStringSources,
UniqueStringCounter,
firstUniqueStringCounter,
stepUniqueStringCounter,
readUniqueStringSource,
createUniqueStringSource,
newNonUnique,
firstUniqueString,
) where
import Data.Array
import Control.Concurrent
import Util.ExtendedPrelude
import Util.Dynamics
printableCharsStr :: String
printableCharsStr =
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!@#$%^&*()"
++ "-_+=|~[];:,<>/?"
printableCharsLen :: Int
printableCharsLen = length printableCharsStr
printableCharsArr :: Array Int Char
printableCharsArr = listArray (0,printableCharsLen-1) printableCharsStr
newtype UniqueStringSource = UniqueStringSource (MVar UniqueStringCounter)
deriving (Typeable)
newUniqueStringSource :: IO UniqueStringSource
newUniqueStringSource =
do
mVar <- newMVar firstUniqueStringCounter
return (UniqueStringSource mVar)
newUniqueString :: UniqueStringSource -> IO String
newUniqueString (UniqueStringSource mVar) =
do
uniqueStringCounter <- takeMVar mVar
let
(str,nextUniqueStringCounter) =
stepUniqueStringCounter uniqueStringCounter
putMVar mVar nextUniqueStringCounter
return str
readUniqueStringSource :: UniqueStringSource -> IO [Int]
readUniqueStringSource (UniqueStringSource mVar) =
do
(UniqueStringCounter l) <- readMVar mVar
return l
createUniqueStringSource :: [Int] -> IO UniqueStringSource
createUniqueStringSource l =
do
mVar <- newMVar (UniqueStringCounter l)
return (UniqueStringSource mVar)
maxUniqueStringSources :: [UniqueStringSource] -> IO UniqueStringSource
maxUniqueStringSources stringSources =
do
stringCounters <- mapM
(\ (UniqueStringSource mVar) -> readMVar mVar)
stringSources
let
maxCounter = foldl max firstUniqueStringCounter stringCounters
mVar <- newMVar maxCounter
return (UniqueStringSource mVar)
newtype UniqueStringCounter = UniqueStringCounter [Int]
firstUniqueStringCounter :: UniqueStringCounter
firstUniqueStringCounter = UniqueStringCounter [0]
stepUniqueStringCounter :: UniqueStringCounter -> (String,UniqueStringCounter)
stepUniqueStringCounter (uniqueStringCounter @ (UniqueStringCounter ilist)) =
(toStringUniqueStringCounter uniqueStringCounter,
UniqueStringCounter (step ilist))
where
step [] = [1]
step (first:rest) =
if first == printableCharsLen -1
then
0:step rest
else
(first+1):rest
toStringUniqueStringCounter :: UniqueStringCounter -> String
toStringUniqueStringCounter (UniqueStringCounter ilist) =
map (\ i -> printableCharsArr ! i) ilist
instance Eq UniqueStringCounter where
(==) = mapEq (\ (UniqueStringCounter l) -> l)
instance Ord UniqueStringCounter where
compare (UniqueStringCounter l1) (UniqueStringCounter l2)
= comp l1 l2
where
comp [] [] = EQ
comp (_:_) [] = GT
comp [] (_:_) = LT
comp (c1:cs1) (c2:cs2) = case comp cs1 cs2 of
EQ -> compare c1 c2
other -> other
firstUniqueString :: String
firstUniqueString =
let
(s,_) = stepUniqueStringCounter firstUniqueStringCounter
in
s
newNonUnique :: String -> String
newNonUnique str = str ++ [printableCharsArr ! 0]