content: {-# LANGUAGE DeriveDataTypeable #-}
  module SpeedyString(SString, toString, fromString, (++), concat, filter) where
  
  import Prelude hiding((++), concat, filter)
  import qualified Prelude((++), filter)
  import IOMutVar(MutableVar, newVar, readVar, writeVar)
  import System.IO.Unsafe(unsafePerformIO)
  import qualified Data.IntMap as M
  -- import qualified NotSoSpeedyString
  import ErrorUtil (internalError)
  import qualified Data.Generics as Generic
  
  
  data SString = SString !Int -- unique id
     deriving (Generic.Data, Generic.Typeable)
  
  instance Eq SString where
      (SString i) == (SString i') = i == i'
  
  -- note that Ord is not the usual string ordering
  instance Ord SString where
      compare (SString i) (SString i') = compare i i'
  
  instance Show SString where
      show = show . toString
  
  -- public
  
  toString :: SString -> String
  toString (SString id) = unsafePerformIO $
                          do m <- readVar strings
                             return $ M.findWithDefault err id m
  
  fromString :: String -> SString
  fromString s = unsafePerformIO $
                 do m <- readVar sstrings
                    return $ maybe (newSString s) id $ M.lookup (hashStr s) m >>= lookup s
  
  (++) :: SString -> SString -> SString
  s ++ s' = fromString $ (toString s) Prelude.++ (toString s')
  
  concat :: [SString] -> SString
  concat = fromString . concatMap toString
  
  filter :: (Char -> Bool) -> SString -> SString
  filter pred s = fromString $ Prelude.filter pred (toString s)
  
  -- private
  
  newSString :: String -> SString
  newSString s = unsafePerformIO $
                 do id <- freshInt
                    let ss = SString id
                    sm <- readVar strings
                    ssm <- readVar sstrings
                    writeVar strings $ M.insert id s sm
                    writeVar sstrings $ M.insertWith (Prelude.++)
                                            (hashStr s) [(s,ss)] ssm
                    return ss
  
  err :: a
  err = internalError "SpeedyString: inconsistent representation"
  
  --toNotSoSpeedyString :: SString -> NotSoSpeedyString.SString
  --toNotSoSpeedyString speedy = NotSoSpeedyString.fromString (toString speedy)
  
  --fromNotSoSpeedyString :: NotSoSpeedyString.SString -> SString
  --fromNotSoSpeedyString not_so_speedy =
  --    fromString (NotSoSpeedyString.toString not_so_speedy)
  
  -- internal representation
  
  strings :: MutableVar (M.IntMap String)
  strings = unsafePerformIO $ newVar (M.empty)
  
  sstrings :: MutableVar (M.IntMap [(String, SString)])
  sstrings = unsafePerformIO $ newVar (M.empty)
  
  
  -- string hash function, stolen from FString
  
  hashStr :: String -> Int
  hashStr s = f s 0
          where f "" r = r
                f (c:cs) r = f cs (r*16+r+fromEnum c)
  
  
  -- unique id factory
  
  nextInt :: MutableVar Int
  nextInt = unsafePerformIO $ (newVar 0)
  
  freshInt :: IO Int
  freshInt = do fresh <- readVar nextInt
                writeVar nextInt (fresh + 1)
                return fresh
  