    {-# LANGUAGE PatternGuards, DeriveDataTypeable #-}

    -- | Interned strings
    module General.IString(
        IString, fromIString, toIString
        ) where

    import Data.Data
    import Data.IORef
    import Control.DeepSeq
    import Data.String
    import qualified Data.Map as Map
    import System.IO.Unsafe

    data IString = IString {-# UNPACK #-} !Int !String
        deriving (Data,Typeable)

    instance Eq IString where
        IString x _ == IString y _ = x == y

    instance Ord IString where
        compare (IString x1 x2) (IString y1 y2)
            | x1 == y1 = EQ
            | otherwise = compare x2 y2

    instance Show IString where show = fromIString
    instance Read IString where readsPrec _ x = [(toIString x,"")]
    instance IsString IString where fromString = toIString
    instance NFData IString where rnf (IString _ _) = () -- we force the string at construction time

    {-# NOINLINE istrings #-}
    istrings :: IORef (Map.Map String IString)
    istrings = unsafePerformIO $ newIORef Map.empty

    fromIString :: IString -> String
    fromIString (IString _ x) = x

    toIString :: String -> IString
    toIString x | () <- rnf x = unsafePerformIO $ atomicModifyIORef istrings $ \mp -> case Map.lookup x mp of
        Just v -> (mp, v)
        Nothing -> let res = IString (Map.size mp) x in (Map.insert x res mp, res)