htoolkit-cvs

[<kr_...@us...>]

Update of /cvsroot/htoolkit/port/src/Port
In directory sc8-pr-cvs1:/tmp/cvs-serv22788/src/Port

Added Files:
	Document.hs 
Log Message:
Initial support for Document model


--- NEW FILE: Document.hs ---
{-# OPTIONS -fglasgow-exts #-}
-----------------------------------------------------------------------------------------
{-| Module      :  Document
    Copyright   :  (c) Krasimir Angelov 2003
    License     :  BSD-style

    Maintainer  :  ka2...@ya...
    Stability   :  provisional
    Portability :  portable

    Documents
-}
-----------------------------------------------------------------------------------------

module Graphics.UI.Port.Document
		(
		-- * Document templates
		  DocumentTemplate(..), registerDocTemplate
		-- * Documents
		, registerDocument, unregisterDocument, setDocumentModified
		)where

import Graphics.UI.Port.Types
import Graphics.UI.Port.PtrMap
import Control.Concurrent.MVar
import System.IO.Unsafe( unsafePerformIO )

data Document = forall a . Document a (DocumentTemplate a) Bool

data DocumentTemplate a = DocumentTemplate
	{ dtExtensions  :: [String]
	, dtDescription :: String
	, dtNewDocument :: IO a
	, dtOpenDocument :: String -> IO a
	, dtSaveDocument :: a -> IO ()
	, dtSaveDocumentAs :: String -> a -> IO ()
	, dtCloseDocument :: a -> IO ()
	}
	
data DTHolder = forall a . DTHolder (DocumentTemplate a)

{-----------------------------------------------------------------------------------------
  Document templeates
-----------------------------------------------------------------------------------------}

{-# NOINLINE documentTemplates #-}
documentTemplates :: MVar [DTHolder]
documentTemplates = unsafePerformIO (newMVar [])

registerDocTemplate :: DocumentTemplate a -> IO ()
registerDocTemplate template = do
	templates <- takeMVar documentTemplates
	putMVar documentTemplates ((DTHolder template):templates)

{-----------------------------------------------------------------------------------------
  Documents
-----------------------------------------------------------------------------------------}

{-# NOINLINE documents #-}
documents :: MVar (PtrMap WindowHandle Document)
documents = unsafePerformIO (newMVar empty)

registerDocument :: WindowHandle -> a -> DocumentTemplate a -> IO ()
registerDocument handle doc template = do
	docs <- takeMVar documents
	putMVar documents (insertWith const handle (Document doc template False) docs)

unregisterDocument :: WindowHandle -> a -> DocumentTemplate a -> IO ()
unregisterDocument handle doc template = do
	docs <- takeMVar documents
	putMVar documents (delete handle docs)

setDocumentModified :: WindowHandle -> Bool -> IO ()
setDocumentModified handle flag = do
	docs <- takeMVar documents
	putMVar documents (adjust upd handle docs)
	where
		upd (Document doc template _) = Document doc template flag