{-# LANGUAGE DeriveDataTypeable #-}

-- |
-- Description : Generate Unique Strings
--
-- This module generates short non-empty unique printable strings (IE without
-- funny characters).  Quotes and backslashes are not included, so printing
-- should not be too hard.  Periods are also not included, for the
-- benefit of NewNames.hs.
module Util.UniqueString(
   UniqueStringSource, -- A source of unique strings.  Instance of Typeable
   newUniqueStringSource, -- :: IO UniqueStringSource
   newUniqueString, -- :: UniqueStringSource -> IO String


   maxUniqueStringSources, -- :: [UniqueStringSource] -> IO UniqueStringSource

   -- Here is a "pure" interface.
   UniqueStringCounter,

   firstUniqueStringCounter, -- :: UniqueStringCounter
      -- This is what you start with
   stepUniqueStringCounter, -- :: UniqueStringCounter
      -- -> (String,UniqueStringCounter)
      -- and this is how you get a new String out.


   -- read/createUniqueStringSource are used by types/CodedValue
   -- to import and export string sources.
   readUniqueStringSource, -- :: UniqueStringSource -> IO [Int]
   createUniqueStringSource, -- :: [Int] -> IO UniqueStringSource

   -- Create non-conflicting string which cannot be produced by
   -- newUniqueString.  This is useful for exceptional cases.
   newNonUnique, -- :: String -> String

   -- The first string generated by newUniqueString or stepUniqueStringCounter
   firstUniqueString, -- :: String
   ) where

import Data.Array

import Control.Concurrent

import Util.ExtendedPrelude
import Util.Dynamics

-- The list of "printable" characters that may occur in one of these
-- strings.
--
-- 20.9.02.  {} characters eliminated because daVinci doesn't like them.
printableCharsStr :: String
printableCharsStr :: String
printableCharsStr =
   String
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!@#$%^&*()"
   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-_+=|~[];:,<>/?"

-- The same, as an array and length.
printableCharsLen :: Int
printableCharsLen :: Int
printableCharsLen = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
printableCharsStr

printableCharsArr :: Array Int Char
printableCharsArr :: Array Int Char
printableCharsArr = (Int, Int) -> String -> Array Int Char
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
printableCharsLenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) String
printableCharsStr

-- -------------------------------------------------------------------
-- The impure interface.
-- -------------------------------------------------------------------

newtype UniqueStringSource = UniqueStringSource (MVar UniqueStringCounter)
   deriving (Typeable)

newUniqueStringSource :: IO UniqueStringSource
newUniqueStringSource :: IO UniqueStringSource
newUniqueStringSource =
   do
      MVar UniqueStringCounter
mVar <- UniqueStringCounter -> IO (MVar UniqueStringCounter)
forall a. a -> IO (MVar a)
newMVar UniqueStringCounter
firstUniqueStringCounter
      UniqueStringSource -> IO UniqueStringSource
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar UniqueStringCounter -> UniqueStringSource
UniqueStringSource MVar UniqueStringCounter
mVar)

newUniqueString :: UniqueStringSource -> IO String
newUniqueString :: UniqueStringSource -> IO String
newUniqueString (UniqueStringSource MVar UniqueStringCounter
mVar) =
   do
      UniqueStringCounter
uniqueStringCounter <- MVar UniqueStringCounter -> IO UniqueStringCounter
forall a. MVar a -> IO a
takeMVar MVar UniqueStringCounter
mVar
      let
         (String
str,UniqueStringCounter
nextUniqueStringCounter) =
            UniqueStringCounter -> (String, UniqueStringCounter)
stepUniqueStringCounter UniqueStringCounter
uniqueStringCounter
      MVar UniqueStringCounter -> UniqueStringCounter -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar UniqueStringCounter
mVar UniqueStringCounter
nextUniqueStringCounter
      String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
str

-- | readUniqueStringSource is used by types\/CodedValue.hs to export values.
readUniqueStringSource :: UniqueStringSource -> IO [Int]
readUniqueStringSource :: UniqueStringSource -> IO [Int]
readUniqueStringSource (UniqueStringSource MVar UniqueStringCounter
mVar) =
   do
      (UniqueStringCounter [Int]
l) <- MVar UniqueStringCounter -> IO UniqueStringCounter
forall a. MVar a -> IO a
readMVar MVar UniqueStringCounter
mVar
      [Int] -> IO [Int]
forall (m :: * -> *) a. Monad m => a -> m a
return [Int]
l

-- | createUniqueStringSource is the inverse of readUniqueStringSource.
createUniqueStringSource :: [Int] -> IO UniqueStringSource
createUniqueStringSource :: [Int] -> IO UniqueStringSource
createUniqueStringSource [Int]
l =
   do
      MVar UniqueStringCounter
mVar <- UniqueStringCounter -> IO (MVar UniqueStringCounter)
forall a. a -> IO (MVar a)
newMVar ([Int] -> UniqueStringCounter
UniqueStringCounter [Int]
l)
      UniqueStringSource -> IO UniqueStringSource
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar UniqueStringCounter -> UniqueStringSource
UniqueStringSource MVar UniqueStringCounter
mVar)


{- unused
compareUniqueStringSource :: UniqueStringSource -> UniqueStringSource
   -> IO Ordering
compareUniqueStringSource (UniqueStringSource mVar1) (UniqueStringSource mVar2)
      =
   do
      c1 <- readMVar mVar1
      c2 <- readMVar mVar2
      return (compare c1 c2)
-}

maxUniqueStringSources :: [UniqueStringSource] -> IO UniqueStringSource
maxUniqueStringSources :: [UniqueStringSource] -> IO UniqueStringSource
maxUniqueStringSources [UniqueStringSource]
stringSources =
   do
      [UniqueStringCounter]
stringCounters <- (UniqueStringSource -> IO UniqueStringCounter)
-> [UniqueStringSource] -> IO [UniqueStringCounter]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
         (\ (UniqueStringSource MVar UniqueStringCounter
mVar) -> MVar UniqueStringCounter -> IO UniqueStringCounter
forall a. MVar a -> IO a
readMVar MVar UniqueStringCounter
mVar)
         [UniqueStringSource]
stringSources
      let
         maxCounter :: UniqueStringCounter
maxCounter = (UniqueStringCounter -> UniqueStringCounter -> UniqueStringCounter)
-> UniqueStringCounter
-> [UniqueStringCounter]
-> UniqueStringCounter
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl UniqueStringCounter -> UniqueStringCounter -> UniqueStringCounter
forall a. Ord a => a -> a -> a
max UniqueStringCounter
firstUniqueStringCounter [UniqueStringCounter]
stringCounters
      MVar UniqueStringCounter
mVar <- UniqueStringCounter -> IO (MVar UniqueStringCounter)
forall a. a -> IO (MVar a)
newMVar UniqueStringCounter
maxCounter
      UniqueStringSource -> IO UniqueStringSource
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar UniqueStringCounter -> UniqueStringSource
UniqueStringSource MVar UniqueStringCounter
mVar)

-- -------------------------------------------------------------------
-- The pure interface.
-- -------------------------------------------------------------------


-- UniqueStringCounter is a list of numbers from 0 to printableCharsLen-1.
-- The last number is at least 1.
newtype UniqueStringCounter = UniqueStringCounter [Int]

firstUniqueStringCounter :: UniqueStringCounter
firstUniqueStringCounter :: UniqueStringCounter
firstUniqueStringCounter = [Int] -> UniqueStringCounter
UniqueStringCounter [Int
0]

stepUniqueStringCounter :: UniqueStringCounter -> (String,UniqueStringCounter)
stepUniqueStringCounter :: UniqueStringCounter -> (String, UniqueStringCounter)
stepUniqueStringCounter (uniqueStringCounter :: UniqueStringCounter
uniqueStringCounter @ (UniqueStringCounter [Int]
ilist)) =
      (UniqueStringCounter -> String
toStringUniqueStringCounter UniqueStringCounter
uniqueStringCounter,
         [Int] -> UniqueStringCounter
UniqueStringCounter ([Int] -> [Int]
step [Int]
ilist))
   where
      step :: [Int] -> [Int]
step [] = [Int
1]
      step (Int
first:[Int]
rest) =
         if Int
first Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
printableCharsLen Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1
            then
               Int
0Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int] -> [Int]
step [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

toStringUniqueStringCounter :: UniqueStringCounter -> String
toStringUniqueStringCounter :: UniqueStringCounter -> String
toStringUniqueStringCounter (UniqueStringCounter [Int]
ilist) =
   (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map (\ Int
i -> Array Int Char
printableCharsArr Array Int Char -> Int -> Char
forall i e. Ix i => Array i e -> i -> e
! Int
i) [Int]
ilist

instance Eq UniqueStringCounter where
   == :: UniqueStringCounter -> UniqueStringCounter -> Bool
(==) = (UniqueStringCounter -> [Int])
-> UniqueStringCounter -> UniqueStringCounter -> Bool
forall a b. Eq a => (b -> a) -> b -> b -> Bool
mapEq (\ (UniqueStringCounter [Int]
l) -> [Int]
l)

instance Ord UniqueStringCounter where
   compare :: UniqueStringCounter -> UniqueStringCounter -> Ordering
compare (UniqueStringCounter [Int]
l1) (UniqueStringCounter [Int]
l2)
         = [Int] -> [Int] -> Ordering
forall a. Ord a => [a] -> [a] -> Ordering
comp [Int]
l1 [Int]
l2
      where
         comp :: [a] -> [a] -> Ordering
comp [] [] = Ordering
EQ
         comp (a
_:[a]
_) [] = Ordering
GT
         comp [] (a
_:[a]
_) = Ordering
LT
         comp (a
c1:[a]
cs1) (a
c2:[a]
cs2) = case [a] -> [a] -> Ordering
comp [a]
cs1 [a]
cs2 of
            Ordering
EQ -> a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
c1 a
c2
            Ordering
other -> Ordering
other

-- -------------------------------------------------------------------
-- firstUniqueString
-- -------------------------------------------------------------------

firstUniqueString :: String
firstUniqueString :: String
firstUniqueString =
   let
      (String
s,UniqueStringCounter
_) = UniqueStringCounter -> (String, UniqueStringCounter)
stepUniqueStringCounter UniqueStringCounter
firstUniqueStringCounter
   in
      String
s

-- -------------------------------------------------------------------
-- newNonUnique
-- -------------------------------------------------------------------

-- | Create non-conflicting string which cannot be produced by
-- newUniqueString.  This is useful for exceptional cases.
-- We add this by adding a character with integer value 0 at the end.
newNonUnique :: String -> String
newNonUnique :: String -> String
newNonUnique String
str = String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Array Int Char
printableCharsArr Array Int Char -> Int -> Char
forall i e. Ix i => Array i e -> i -> e
! Int
0]