-- | NewNames is used for generating new names for Node's, Arc's,
-- NodeType's and ArcType's in a graph on a globally unique basis.
 module Graphs.NewNames (
   NameSource,
   NameSourceBranch, -- instance of Show/Read
   branch, -- :: NameSource -> IO NameSourceBranch
   useBranch, -- :: NameSourceBranch -> IO NameSource
   -- To make a new separate root use branch followed by useBranch
   initialBranch, -- :: NameSourceBranch
   -- Use this with useBranch to start the thing off.

   getNewName, -- :: NameSource -> IO String
   -- These strings always begin with a '.'.

   FrozenNameSource,  -- instance of Read/Show

   freezeNameSource, -- :: NameSource -> IO FrozenNameSource
   defrostNameSource, -- :: NameSource -> FrozenNameSource -> IO ()
   -- freeze/defrostNameSource convert and restore the current name source
   -- to and from a string.
   -- defrostNameSource should be handed a NameSource created from the
   -- same NameSourceBranch as that for which freezeNameSource was
   -- called, otherwise it raises an error.
   ) where

import Util.Computation

import Control.Concurrent

data NameSource = NameSource {
   NameSource -> [Int]
nameSourceId :: [Int],
   NameSource -> MVar Int
branchCounter :: MVar Int,
   NameSource -> MVar Int
nameCounter :: MVar Int
   -- Locking policy.  Either branchCounter or nameCounter can be emptied
   -- separately, but may only remain empty for a short time in which
   -- no other locking/unlocking operations are done.
   -- If the two are emptied together, branchCounter should be emptied
   -- first.
   }

-----------------------------------------------------------------------------
-- Creating and branching NameSource's
-----------------------------------------------------------------------------

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

branch :: NameSource -> IO NameSourceBranch
branch :: NameSource -> IO NameSourceBranch
branch (NameSource
      {nameSourceId :: NameSource -> [Int]
nameSourceId = [Int]
nameSourceId,branchCounter :: NameSource -> MVar Int
branchCounter = MVar Int
branchCounter}) =
   do
      Int
branchNo <- MVar Int -> IO Int
forall a. MVar a -> IO a
takeMVar MVar Int
branchCounter
      MVar Int -> Int -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Int
branchCounter (Int
branchNoInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
      NameSourceBranch -> IO NameSourceBranch
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> NameSourceBranch
NameSourceBranch (Int
branchNoInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
nameSourceId))

useBranch :: NameSourceBranch -> IO NameSource
useBranch :: NameSourceBranch -> IO NameSource
useBranch (NameSourceBranch [Int]
nameSourceId) =
   do
      MVar Int
branchCounter <- Int -> IO (MVar Int)
forall a. a -> IO (MVar a)
newMVar Int
0
      MVar Int
nameCounter <- Int -> IO (MVar Int)
forall a. a -> IO (MVar a)
newMVar Int
0
      NameSource -> IO NameSource
forall (m :: * -> *) a. Monad m => a -> m a
return (NameSource :: [Int] -> MVar Int -> MVar Int -> NameSource
NameSource {
         nameSourceId :: [Int]
nameSourceId = [Int]
nameSourceId,
         branchCounter :: MVar Int
branchCounter = MVar Int
branchCounter,
         nameCounter :: MVar Int
nameCounter = MVar Int
nameCounter
         })


initialBranch :: NameSourceBranch
initialBranch :: NameSourceBranch
initialBranch = [Int] -> NameSourceBranch
NameSourceBranch []

-----------------------------------------------------------------------------
-- Getting new strings
-----------------------------------------------------------------------------

getNewName :: NameSource -> IO String
getNewName :: NameSource -> IO String
getNewName
      (NameSource {nameSourceId :: NameSource -> [Int]
nameSourceId = [Int]
nameSourceId,nameCounter :: NameSource -> MVar Int
nameCounter=MVar Int
nameCounter}) =
   do
      Int
nameNo <- MVar Int -> IO Int
forall a. MVar a -> IO a
takeMVar MVar Int
nameCounter
      MVar Int -> Int -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Int
nameCounter (Int
nameNoInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
      String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> String
listToString (Int
nameNoInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
nameSourceId))

listToString :: [Int] -> String
-- produces compact representation of the argument beginning with a period.
listToString :: [Int] -> String
listToString [Int]
numbers = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ Int
n -> Char
'.'Char -> ShowS
forall a. a -> [a] -> [a]
:(Int -> String
forall a. Show a => a -> String
show Int
n)) [Int]
numbers)

-----------------------------------------------------------------------------
-- freeze/restoreNameSource
-----------------------------------------------------------------------------

data FrozenNameSource = FrozenNameSource {
   FrozenNameSource -> [Int]
frozenId :: [Int],
   FrozenNameSource -> Int
frozenBranch :: Int,
   FrozenNameSource -> Int
frozenName :: Int
   } deriving (ReadPrec [FrozenNameSource]
ReadPrec FrozenNameSource
Int -> ReadS FrozenNameSource
ReadS [FrozenNameSource]
(Int -> ReadS FrozenNameSource)
-> ReadS [FrozenNameSource]
-> ReadPrec FrozenNameSource
-> ReadPrec [FrozenNameSource]
-> Read FrozenNameSource
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FrozenNameSource]
$creadListPrec :: ReadPrec [FrozenNameSource]
readPrec :: ReadPrec FrozenNameSource
$creadPrec :: ReadPrec FrozenNameSource
readList :: ReadS [FrozenNameSource]
$creadList :: ReadS [FrozenNameSource]
readsPrec :: Int -> ReadS FrozenNameSource
$creadsPrec :: Int -> ReadS FrozenNameSource
Read,Int -> FrozenNameSource -> ShowS
[FrozenNameSource] -> ShowS
FrozenNameSource -> String
(Int -> FrozenNameSource -> ShowS)
-> (FrozenNameSource -> String)
-> ([FrozenNameSource] -> ShowS)
-> Show FrozenNameSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FrozenNameSource] -> ShowS
$cshowList :: [FrozenNameSource] -> ShowS
show :: FrozenNameSource -> String
$cshow :: FrozenNameSource -> String
showsPrec :: Int -> FrozenNameSource -> ShowS
$cshowsPrec :: Int -> FrozenNameSource -> ShowS
Show)

freezeNameSource :: NameSource -> IO FrozenNameSource
freezeNameSource :: NameSource -> IO FrozenNameSource
freezeNameSource (NameSource {
      nameSourceId :: NameSource -> [Int]
nameSourceId = [Int]
nameSourceId,
      branchCounter :: NameSource -> MVar Int
branchCounter = MVar Int
branchCounter,
      nameCounter :: NameSource -> MVar Int
nameCounter = MVar Int
nameCounter
      }) =
   do
      Int
frozenBranch <- MVar Int -> IO Int
forall a. MVar a -> IO a
takeMVar MVar Int
branchCounter
      Int
frozenName <- MVar Int -> IO Int
forall a. MVar a -> IO a
takeMVar MVar Int
nameCounter
      MVar Int -> Int -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Int
nameCounter Int
frozenName
      MVar Int -> Int -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Int
branchCounter Int
frozenBranch
      FrozenNameSource -> IO FrozenNameSource
forall (m :: * -> *) a. Monad m => a -> m a
return (FrozenNameSource :: [Int] -> Int -> Int -> FrozenNameSource
FrozenNameSource {
         frozenId :: [Int]
frozenId = [Int]
nameSourceId,
         frozenBranch :: Int
frozenBranch = Int
frozenBranch,
         frozenName :: Int
frozenName = Int
frozenName
         })

defrostNameSource :: NameSource -> FrozenNameSource -> IO ()
defrostNameSource :: NameSource -> FrozenNameSource -> IO ()
defrostNameSource
   (NameSource {
      nameSourceId :: NameSource -> [Int]
nameSourceId = [Int]
nameSourceId,
      branchCounter :: NameSource -> MVar Int
branchCounter = MVar Int
branchCounter,
      nameCounter :: NameSource -> MVar Int
nameCounter = MVar Int
nameCounter
      })
   (FrozenNameSource {
      frozenId :: FrozenNameSource -> [Int]
frozenId = [Int]
frozenId,
      frozenBranch :: FrozenNameSource -> Int
frozenBranch = Int
frozenBranch,
      frozenName :: FrozenNameSource -> Int
frozenName = Int
frozenName
      }) =
   do
      let
         fail :: String -> IO a
fail String
mess =
            IOError -> IO a
forall a. IOError -> IO a
ioError(String -> IOError
userError(String
"NewNames.defrostNameSource: "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
mess))

      if ([Int]
nameSourceId [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Int]
frozenId)
         then
            String -> IO ()
forall a. String -> IO a
fail String
"Name source mismatch"
         else
            IO ()
forall (m :: * -> *). Monad m => m ()
done

      Int
oldBranch <- MVar Int -> IO Int
forall a. MVar a -> IO a
takeMVar MVar Int
branchCounter
      MVar Int -> Int -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Int
branchCounter Int
frozenBranch

      Int
oldName <- MVar Int -> IO Int
forall a. MVar a -> IO a
takeMVar MVar Int
nameCounter
      MVar Int -> Int -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Int
nameCounter Int
frozenName