content: module Compiler.Mate.Runtime.ClassHierarchy
    ( isInstanceOf
    , addClassEntry
    , addInterfaceEntry
    ) where
  
  import qualified Data.Map as M
  import qualified Data.ByteString.Lazy as B
  import Data.List
  import Control.Monad
  
  import Foreign hiding (unsafePerformIO)
  import System.IO.Unsafe
  import Data.IORef
  
  import Compiler.Mate.Backend.NativeSizes
  import Compiler.Mate.Runtime.ClassPool
  
  
  data Class
    = Class NativeWord [B.ByteString]
    | JavaLangObject
  
  type ClassHier = M.Map NativeWord Class
  classHier :: IORef ClassHier
  {-# NOINLINE classHier #-}
  classHier = unsafePerformIO $ newIORef M.empty
  
  type InterfaceHier = M.Map B.ByteString [B.ByteString]
  interfaceHier :: IORef InterfaceHier
  {-# NOINLINE interfaceHier #-}
  interfaceHier = unsafePerformIO $ newIORef M.empty
  
  readClass :: IO ClassHier
  readClass = readIORef classHier
  readInterface :: IO InterfaceHier
  readInterface = readIORef interfaceHier
  
  writeClass :: ClassHier -> IO ()
  writeClass = writeIORef classHier
  writeInterface :: InterfaceHier -> IO ()
  writeInterface = writeIORef interfaceHier
  
  isInstanceOf :: NativeWord -> B.ByteString -> IO Bool
  isInstanceOf 0 _ = return False
  isInstanceOf obj classname = do
    obj_mtable <- peek (intPtrToPtr . fromIntegral $ obj)
    ch <- readClass
    ih <- readInterface
    if M.member classname ih
      then do -- interface check
        let ai = allInterfaces obj_mtable ch
        return $ checkInterfaces ai classname ih
      else do -- class check
        class_mtable <- getMethodTableNoInit classname
        return $ checkInstance obj_mtable class_mtable ch
  
  allInterfaces :: NativeWord -> ClassHier -> [B.ByteString]
  allInterfaces obj_mtable ch =
    case ch M.! obj_mtable of
      JavaLangObject -> []
      Class superclass ifaces -> ifaces ++ allInterfaces superclass ch
  
  checkInterfaces :: [B.ByteString] -> B.ByteString -> InterfaceHier -> Bool
  checkInterfaces [] _ _ = False
  checkInterfaces ifaces target ih
    | target `elem` ifaces = True
    | otherwise = checkInterfaces (nextifaces \\ ifaces) target ih
      where
        nextifaces = concatMap (\x -> ih M.! x) ifaces
  
  checkInstance :: NativeWord -> NativeWord -> ClassHier -> Bool
  checkInstance obj cl_mtable ch
    | obj == cl_mtable = True
    | otherwise =
        case ch M.! obj of
          Class super _ -> checkInstance super cl_mtable ch
          JavaLangObject -> False
  
  addClassEntry :: NativeWord -> NativeWord -> [B.ByteString] -> IO ()
  addClassEntry mtable 0 _ = do
    ch <- readClass
    writeClass (M.insert mtable JavaLangObject ch)
  addClassEntry mtable super_mtable ifaces = do
    ch <- readClass
    unless (M.member super_mtable ch) $ error "classhierarchy: superclass should be in hierarchy!"
    writeClass (M.insert mtable (Class super_mtable ifaces) ch)
  
  addInterfaceEntry :: B.ByteString -> [B.ByteString] -> IO ()
  addInterfaceEntry iface super_ifaces = do
    ch <- readInterface
    -- TODO: check super if's
    writeInterface (M.insert iface super_ifaces ch)
  