lhae-0.0.2: src/Model.hs

module Model (Model,new,onGrid,setCurrent,addGrid,deleteCurrent)
    where

import Control.Applicative ((<$>))
import Data.IORef
import Data.IntMap (IntMap,Key)
import qualified Data.IntMap as Map
import Model.Grid (Grid)
import qualified Model.Grid as G
import qualified View
import Util (justWhen)

type Current = (Key,Grid)

data Model = Model { grids :: IORef (IntMap Grid)
                   , current :: IORef (Maybe Current)
                   }

new :: IO Model
new = do
  grids <- newIORef $ Map.empty
  current <- newIORef Nothing
  return $ Model grids current

deleteCurrent :: Model -> IO ()
deleteCurrent model =
  onCurrent model $ \(key,_) -> 
      modifyIORef (grids model) $ Map.delete key

onGrid :: Model -> (Grid -> IO a) -> IO a
onGrid model f = onCurrent model $ f . snd

onCurrent :: Model -> (Current -> IO a) -> IO a
onCurrent model f = 
    readIORef (current model) >>= \maybeC ->
        case maybeC of Just c -> f c
                       Nothing -> error "Model.onCurrent: Nothing"

setCurrent :: Key -> Model -> IO ()
setCurrent key model = do
  grid <- Map.lookup key <$> (readIORef $ grids model)
  justWhen grid $ \g -> writeIORef (current model) $ Just (key,g)

addGrid :: Key -> View.Info -> Model -> IO ()
addGrid key viewInfo model = do
  grid <- G.new viewInfo
  modifyIORef (grids model) $ Map.insert key grid
  setCurrent key model