    --  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 from :: Int
    from, Name to :: 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 from :: Int
    from, Name to :: Int
    to) (Name idx :: 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 from :: Int
    from, Name to :: Int
    to) (Name idx :: 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 i :: 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 1)

    -- Split a name supply into a stream of supplies (EXPORTED)
    --
    splitSupply   :: NameSupply -> [NameSupply]
    splitSupply :: NameSupply -> [NameSupply]
    splitSupply s :: 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 s :: IORef Int
    s)  =
      IORef Int -> [Name]
    theNames IORef Int
    s
      where
        theNames :: IORef Int -> [Name]
    theNames s :: 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 ref :: 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 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 val :: Int
    val) =
      case NameSupply
    rootSupply of
        NameSupply ref :: 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
    > 1) (String -> IO ()
    forall a. HasCallStack => String -> a
    error "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 ref :: IORef Int
    ref -> IORef Int -> Int -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef IORef Int
    ref 1

    {-! for Name derive : GhcBinary !-}
    {-* Generated by DrIFT : Look, but Don't Touch. *-}
    instance Binary Name where
        put_ :: BinHandle -> Name -> IO ()
    put_ bh :: BinHandle
    bh (Name aa :: Int
    aa) = do
                BinHandle -> Int -> IO ()
    forall a. Binary a => BinHandle -> a -> IO ()
    put_ BinHandle
    bh Int
    aa
        get :: BinHandle -> IO Name
    get bh :: 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 i :: 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 mv :: 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
    <1) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
                                     String -> IO ()
    forall a. HasCallStack => String -> a
    error "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
    + 1)
                                   Int -> IO Int
    forall (m :: * -> *) a. Monad m => a -> m a
    return Int
    v