{-# OPTIONS_GHC -fglasgow-exts #-}

module ZMachine.Startup where

import ZMachine.Base
import ZMachine.IO.Gtk
import ZMachine.Ops

import GHC.Prim (unsafeCoerce#)
import Numeric (showHex)
import Data.Word
import Data.Array.IO
import Data.Array.Unboxed

import Control.Exception (throwIO, catch, Exception(..))
import Control.Monad (liftM)
import Control.Monad.State (gets, runStateT, mapStateT)
import Control.Concurrent (writeChan)
import System.IO
import Control.Monad.State.Lazy (StateT) -- for a typesig

import Prelude hiding (catch)

readStory :: String -> IO (UArray Word Word8)
readStory filename = do handle <- openBinaryFile filename ReadMode
                        len <- liftM fromIntegral $ hFileSize handle
                        (buf :: IOUArray Int Word8) <- newArray_ (0,len-1)
                        bytes <- hGetArray handle buf len
                        if bytes /= len
                           then error "unable to read entire story file"
                           else do
                        (arr :: UArray Int Word8) <- freeze buf
                        return (unsafeCoerce# arr :: UArray Word Word8)

startStory :: String -> IO (a, ZState)
startStory filename =
    do storyData <- readStory filename
       let wordAt addr = (fromIntegral $ storyData ! addr)*256
                     + (fromIntegral $ storyData ! (addr+1))
           dynamicSize = wordAt 0xE
           dyn = listArray (0,dynamicSize-1) $
                 map (storyData!) [0..dynamicSize-1]
           startAddr = wordAt 0x6


       let exec' = do ip <- gets ptr
                      -- liftIO $ putStr ('[':'$':showHex ip "]")
                      let f (ErrorCall s) = ErrorCall (g s)
                          f except        = except
                          g s = '$':showHex ip (':':' ':s)

                      let f e = ErrorCall $ '$':showHex ip (':':' ':show e)
                      (mapExceptionStateT f) exec

       (_, ioChan) <- startUI

       runStateT (forever' exec') $ ZState { dynMem = dyn,
                                            story = storyData,
                                            stack = [],
                                            localStack = [],
                                            localVars = listArray (0,0) [],
                                            argCount = 0,
                                            ptr = startAddr,
                                            zs_undo = Nothing,
                                            zs_io_ = writeChan ioChan
                                          }

forever' :: Monad m => m a -> m b
forever' x = loop
    where loop = x >> loop

mapExceptionStateT :: (Exception -> Exception) -> Control.Monad.State.Lazy.StateT s IO a
                   -> Control.Monad.State.Lazy.StateT s IO a
mapExceptionStateT f = mapStateT (\x -> x `catch` (throwIO . f))