module Graphs.NewNames (
NameSource,
NameSourceBranch,
branch,
useBranch,
initialBranch,
getNewName,
FrozenNameSource,
freezeNameSource,
defrostNameSource,
) where
import Util.Computation
import Control.Concurrent
data NameSource = NameSource {
nameSourceId :: [Int],
branchCounter :: MVar Int,
nameCounter :: MVar Int
}
newtype NameSourceBranch = NameSourceBranch [Int] deriving (Read,Show)
branch :: NameSource -> IO NameSourceBranch
branch (NameSource
{nameSourceId = nameSourceId,branchCounter = branchCounter}) =
do
branchNo <- takeMVar branchCounter
putMVar branchCounter (branchNo+1)
return (NameSourceBranch (branchNo:nameSourceId))
useBranch :: NameSourceBranch -> IO NameSource
useBranch (NameSourceBranch nameSourceId) =
do
branchCounter <- newMVar 0
nameCounter <- newMVar 0
return (NameSource {
nameSourceId = nameSourceId,
branchCounter = branchCounter,
nameCounter = nameCounter
})
initialBranch :: NameSourceBranch
initialBranch = NameSourceBranch []
getNewName :: NameSource -> IO String
getNewName
(NameSource {nameSourceId = nameSourceId,nameCounter=nameCounter}) =
do
nameNo <- takeMVar nameCounter
putMVar nameCounter (nameNo+1)
return (listToString (nameNo:nameSourceId))
listToString :: [Int] -> String
listToString numbers = concat (map (\ n -> '.':(show n)) numbers)
data FrozenNameSource = FrozenNameSource {
frozenId :: [Int],
frozenBranch :: Int,
frozenName :: Int
} deriving (Read,Show)
freezeNameSource :: NameSource -> IO FrozenNameSource
freezeNameSource (NameSource {
nameSourceId = nameSourceId,
branchCounter = branchCounter,
nameCounter = nameCounter
}) =
do
frozenBranch <- takeMVar branchCounter
frozenName <- takeMVar nameCounter
putMVar nameCounter frozenName
putMVar branchCounter frozenBranch
return (FrozenNameSource {
frozenId = nameSourceId,
frozenBranch = frozenBranch,
frozenName = frozenName
})
defrostNameSource :: NameSource -> FrozenNameSource -> IO ()
defrostNameSource
(NameSource {
nameSourceId = nameSourceId,
branchCounter = branchCounter,
nameCounter = nameCounter
})
(FrozenNameSource {
frozenId = frozenId,
frozenBranch = frozenBranch,
frozenName = frozenName
}) =
do
let
fail mess =
ioError(userError("NewNames.defrostNameSource: "++mess))
if (nameSourceId /= frozenId)
then
fail "Name source mismatch"
else
done
oldBranch <- takeMVar branchCounter
putMVar branchCounter frozenBranch
oldName <- takeMVar nameCounter
putMVar nameCounter frozenName