module TclTrie where
import TrieIO
import IOExts
import Monad 
import Utils
import List
import Remover

instance Show (IORef a) where
 show a = "<IORef>"

data TrieObj = TrieObj {
	isalive :: ! Bool,
	deleteObj :: ! Remover,
	menuObjs :: ! (Int,[String]),
	boundArgs :: ! [(String,[String],Remover)]
	}


type TrieObjV = IORef TrieObj

initTrieObj :: Bool -> TrieObj
initTrieObj b = TrieObj b (return ()) (0,[]) []

newTrieObjV :: IO TrieObjV 
newTrieObjV = newIORef $! initTrieObj True 

insertItem :: [String] -> String -> Int -> [String]
insertItem xs s 0 = s:xs
insertItem (x:xs) s n = x:insertItem xs s (n-1)
insertItem [] s _ = [s]

removeItem :: [String] -> String -> ([String],Maybe Int)
removeItem xs s = remove [] xs s 0 
 where
  remove bef (x:xs) s n = 
     if x == s then (reverse bef ++ xs,Just n)
     else remove (x:bef) xs s (n + 1)
  remove bef [] _ _ = (reverse bef,Nothing)

sizeItems :: TrieObjV -> IO Int
sizeItems r = fmap (fst . menuObjs) $ readIORef r

indexItem :: [String] -> String -> Maybe Int
indexItem xs s = findIndex (== s) xs

insertItemObj :: TrieObjV -> String -> Int -> IO ()
insertItemObj ref s n = do
 updIORef ref (\o -> o {menuObjs = case menuObjs o of
				    (num,xs) -> 
				      (num+1,insertItem xs s n)})

 
removeItemObj :: TrieObjV -> String -> IO (Maybe Int)
removeItemObj ref s = do
 o <- readIORef ref
 case menuObjs o of
  (num,xs) ->  
   case removeItem xs s of
    (xs,Nothing) -> do 
		       return Nothing
    (xs,just) -> do
      writeIORef ref (o {menuObjs = (num - 1,xs)}) 
      return just 

indexItemObj :: TrieObjV -> String -> IO (Maybe Int)
indexItemObj ref s = do
 o <- readIORef ref
 return $! indexItem (snd $ menuObjs o) s

atIndexItemObj :: TrieObjV -> Int -> IO (Maybe String)
atIndexItemObj ref n = do
 (num,os) <- fmap menuObjs $ readIORef ref
 return $! if n + 1 > num then Nothing
	   else Just $ os !! n  

addFinaliserW :: TrieObjV -> Remover -> IO ()
addFinaliserW ref rm = 
  updIORef ref (\o -> o {deleteObj = rm >> deleteObj o})

checkAlive :: TrieObjV -> IO Bool
checkAlive ref = fmap isalive $ readIORef ref

type TclTrie = IORef (TrieIO TrieObjV)

mkTclTrie :: IO TclTrie
mkTclTrie = do
     o <- newTrieObjV
     t <- initTrie "." o
     newIORef t

clearTclTrie :: TclTrie -> IO ()
clearTclTrie trie = do
 o <- newIORef $ initTrieObj False
 t <- initTrie "." o
 writeIORef trie t

register_ :: TclTrie -> String -> IO TrieObjV
register_ trie s = do
 o <- newTrieObjV
 t <- readIORef trie
 o <- registerInTrie t s o
 return o

lookupTrieObj' :: TclTrie -> String -> IO (Maybe TrieObjV)
lookupTrieObj' trie s = do
 t <- readIORef trie
 lookupTrie t s

checkAlive_ :: TclTrie -> String -> IO Bool
checkAlive_ trie s = lookupTrieObj' trie s
		       >>= maybe (return False) (fmap isalive . readIORef)

updateTrieObj :: TclTrie -> String -> (TrieObjV -> IO ()) -> IO ()
updateTrieObj trie s f = lookupTrieObj' trie s >>= maybe (return ()) f

addFinaliserW_ :: TclTrie -> String -> Remover -> IO ()
addFinaliserW_ trie s r = updateTrieObj trie s $ flip addFinaliserW r

doDelete :: TclTrie -> String -> IO Bool
doDelete trie s = do
 t <- readIORef trie
 (isdead,dead,ds) <- deleteFromTrie s t
 when dead $ clearTclTrie trie
 if isdead then do
   mapM_ (\ref -> readIORef ref >>= dodelete ref) ds
   return True
  else  do
   when (not (null ds)) $
     putStrLn $ "error: "++s++" already dead but still "++ show (length ds) ++ " children"
   return False
  where
     dodelete ref t@(TrieObj {deleteObj = act,boundArgs = bs}) = do
       mapM_ (\ (_,_,die) -> die) bs
       act
       writeIORef ref $ initTrieObj False
       return ()

updBinding :: TrieObjV -> String -> String -> Bool -> Maybe Remover 
           -> IO (Maybe Remover)
updBinding v s evval clearall rm = do
 o <- readIORef v
 case partition (\(a,_,_) -> a == s) (boundArgs o) of
  ([(a,all,rm')],rest) -> 
    if clearall then do
      writeIORef v $ o {boundArgs = maybe rest (\rm -> (s,[evval],rm):rest) rm}
      return $ Just rm'
    else do
      writeIORef v $ o {boundArgs = maybe (boundArgs o) 
					  (\rm -> (s,evval:all,rm >> rm'):rest)
					  rm}
      return Nothing
  ([],rest) -> do
     writeIORef v $ o {boundArgs = maybe rest (\rm -> (s,[evval],rm):rest) rm}
     return Nothing

getBoundArgs :: TrieObjV -> IO [String]
getBoundArgs v = do
 fmap (get . boundArgs) $ readIORef v
  where
   get vs = case find (\ (a,_,_) -> a == "command") vs of
	      Nothing -> []
	      Just (_,cs,_) -> cs