--  The HiPar Toolkit: generates unique names
--
--  Author : Manuel M T Chakravarty
--  Created: 3 April 98
--
--  Version $Revision: 1.2 $ from $Date: 2004/11/13 17:26:50 $
--
--  Copyright (C) [1998..2003] Manuel M T Chakravarty
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--- DESCRIPTION ---------------------------------------------------------------
--
--  Generates unqiue names according to a method of L. Augustsson, M. Rittri
--  & D. Synek ``Functional pearl: On generating unique names'', Journal of
--  Functional Programming 4(1), pp 117-123, 1994.
--
--  WARNING: DON'T tinker with the implementation!  It uses UNSAFE low-level
--           operations!
--
--- DOCU ----------------------------------------------------------------------
--
--  language: Haskell 98
--
--  * This module provides an ordering relation on names (e.g., for using
--    `Maps'), but no assumption maybe made on the order in which names
--    are generated from the name space.  Furthermore, names are instances of
--    `Ix' to allow to use them as indicies.
--
--  * A supply should be used *at most* once to *either* split it or extract a
--    stream of names.  A supply used repeatedly will always generate the same
--    set of names (otherwise, the whole thing wouldn't be referential
--    transparent).
--
--  * If you ignored the warning below, looked at the implementation, and lost
--    faith, consider that laziness means call-by-need *and* sharing, and that
--    sharing is realized by updating evaluated thunks.
--
--  * ATTENTION: No clever CSE or unnecessary argument elimination may be
--    applied to the function `names'!
--
--- TODO
--

module UNames (NameSupply, Name,
               rootSupply, splitSupply, names,
               saveRootNameSupply, restoreRootNameSupply, unsafeResetRootNameSupply)
where

import Control.Monad  (when)
import Data.Ix
import System.IO.Unsafe (unsafePerformIO)
import Data.IORef       (IORef, newIORef, readIORef, writeIORef)
import Binary (Binary(..))


-- Name supply definition (EXPORTED ABSTRACTLY)
--
newtype NameSupply = NameSupply (IORef Int)

-- Name (EXPORTED ABSTRACTLY)
--
newtype Name = Name Int
--             deriving (Show, Eq, Ord, Ix)
-- FIXME: nhc98, v1.08 can't derive Ix
             deriving (Name -> Name -> Bool
(Name -> Name -> Bool) -> (Name -> Name -> Bool) -> Eq Name
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Name -> Name -> Bool
$c/= :: Name -> Name -> Bool
== :: Name -> Name -> Bool
$c== :: Name -> Name -> Bool
Eq, Eq Name
Eq Name
-> (Name -> Name -> Ordering)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Name)
-> (Name -> Name -> Name)
-> Ord Name
Name -> Name -> Bool
Name -> Name -> Ordering
Name -> Name -> Name
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Name -> Name -> Name
$cmin :: Name -> Name -> Name
max :: Name -> Name -> Name
$cmax :: Name -> Name -> Name
>= :: Name -> Name -> Bool
$c>= :: Name -> Name -> Bool
> :: Name -> Name -> Bool
$c> :: Name -> Name -> Bool
<= :: Name -> Name -> Bool
$c<= :: Name -> Name -> Bool
< :: Name -> Name -> Bool
$c< :: Name -> Name -> Bool
compare :: Name -> Name -> Ordering
$ccompare :: Name -> Name -> Ordering
$cp1Ord :: Eq Name
Ord)
instance Ix Name where
  range :: (Name, Name) -> [Name]
range   (Name Int
from, Name Int
to)            = (Int -> Name) -> [Int] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Name
Name ((Int, Int) -> [Int]
forall a. Ix a => (a, a) -> [a]
range (Int
from, Int
to))
  index :: (Name, Name) -> Name -> Int
index   (Name Int
from, Name Int
to) (Name Int
idx) = (Int, Int) -> Int -> Int
forall a. Ix a => (a, a) -> a -> Int
index   (Int
from, Int
to) Int
idx
  inRange :: (Name, Name) -> Name -> Bool
inRange (Name Int
from, Name Int
to) (Name Int
idx) = (Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Int
from, Int
to) Int
idx

-- we want to show the number only, to be useful for generating unqiue
-- printable names
--
instance Show Name where
  show :: Name -> String
show (Name Int
i) = Int -> String
forall a. Show a => a -> String
show Int
i


--                    *** DON'T TOUCH THE FOLLOWING ***
--  and if you believe in the lambda calculus better also don't look at it
--          ! here lives the daemon of unordered destructive updates !

-- The initial supply (EXPORTED)
--
rootSupply :: NameSupply
{-# NOINLINE rootSupply #-}
rootSupply :: NameSupply
rootSupply  = IORef Int -> NameSupply
NameSupply (Int -> IORef Int
unsafeNewIntRef Int
1)

-- Split a name supply into a stream of supplies (EXPORTED)
--
splitSupply   :: NameSupply -> [NameSupply]
splitSupply :: NameSupply -> [NameSupply]
splitSupply NameSupply
s  = NameSupply -> [NameSupply]
forall a. a -> [a]
repeat NameSupply
s

-- Given a name supply, yield a stream of names (EXPORTED)
--
names                :: NameSupply -> [Name]
--
--  The recursion of `theNames' where `s' is passed as an argument is crucial,
--  as it forces the creation of a new closure for `unsafeReadAndIncIntRef s'
--  in each recursion step.  Sharing a single closure or building a cyclic
--  graph for a nullary `theNames' would always result in the same name!  If
--  the compiler ever gets clever enough to optimize this, we have to prevent
--  it from doing so.
--
names :: NameSupply -> [Name]
names (NameSupply IORef Int
s)  =
  IORef Int -> [Name]
theNames IORef Int
s
  where
    theNames :: IORef Int -> [Name]
theNames IORef Int
s = Int -> Name
Name (IORef Int -> Int
unsafeReadAndIncIntRef IORef Int
s) Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: IORef Int -> [Name]
theNames IORef Int
s

-- Actions for saving and restoring the state of the whole program. (EXPORTED)
-- The rules for these functions are as follows:
--   you must not use the root name supply after saving it
--   you must not use the root namue supply before restoring it
-- Otherwise bad things will happen, your unique Ids will no longer be unique
saveRootNameSupply :: IO Name
saveRootNameSupply :: IO Name
saveRootNameSupply =
  case NameSupply
rootSupply of
    NameSupply IORef Int
ref -> do
      Int
val <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ref
      IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
ref Int
0
      Name -> IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Name
Name Int
val)

restoreRootNameSupply :: Name -> IO ()
restoreRootNameSupply :: Name -> IO ()
restoreRootNameSupply (Name Int
val) =
  case NameSupply
rootSupply of
    NameSupply IORef Int
ref -> do
      Int
prev <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ref
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
prev Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (String -> IO ()
forall a. HasCallStack => String -> a
error String
"UName: root name supply used before restoring")
      IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
ref Int
val

-- Resets the root name supply
--   you must not do this unless you are done with all the names
unsafeResetRootNameSupply :: IO ()
unsafeResetRootNameSupply :: IO ()
unsafeResetRootNameSupply =
  case NameSupply
rootSupply of
    NameSupply IORef Int
ref -> IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
ref Int
1

{-! for Name derive : GhcBinary !-}
{-* Generated by DrIFT : Look, but Don't Touch. *-}
instance Binary Name where
    put_ :: BinHandle -> Name -> IO ()
put_ BinHandle
bh (Name Int
aa) = do
            BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
aa
    get :: BinHandle -> IO Name
get BinHandle
bh = do
    Int
aa <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
    Name -> IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Name
Name Int
aa)

-- UNSAFE mutable variables
-- ------------------------

-- WARNING: The following does not exist, or at least, it belongs to another
--          world.  And if you believe into the lambda calculus, you don't
--          want to know about this other world.
--
--                 *** DON'T TOUCH NOR USE THIS STUFF ***
--              (unless you really know what you are doing!)

-- UNSAFELY create a mutable integer (EXPORTED)
--
unsafeNewIntRef   :: Int -> IORef Int
unsafeNewIntRef :: Int -> IORef Int
unsafeNewIntRef Int
i  = IO (IORef Int) -> IORef Int
forall a. IO a -> a
unsafePerformIO (Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
i)

-- UNSAFELY increment a mutable integer and yield its value before the
-- increment (EXPORTED)
--
unsafeReadAndIncIntRef    :: IORef Int -> Int
unsafeReadAndIncIntRef :: IORef Int -> Int
unsafeReadAndIncIntRef IORef Int
mv  = IO Int -> Int
forall a. IO a -> a
unsafePerformIO (IO Int -> Int) -> IO Int -> Int
forall a b. (a -> b) -> a -> b
$ do
                               Int
v <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
mv
                               Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
vInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                                 String -> IO ()
forall a. HasCallStack => String -> a
error String
"UName: root name supply used after saving"
                               IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
mv (Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                               Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
v