bamse-0.9.1: Bamse/IMonad.hs

--
-- (c) 2007, Galois, Inc.
--
-- The 'installer monad'
--
module Bamse.IMonad
	( IM 			-- abstract. Instance of: Monad, Functor
	, doInstall     	-- :: [Table] -- custom table definitions
				-- -> IM a
				-- -> IO (a, [(TableName,[Row])], [Table])
	, ioToIM		-- :: IO a -> IM a				
	, addRow		-- :: Row -> IM ()
	, getTableRows          -- :: TableName -> IM [Row]
	, replaceRow            -- :: ReplaceRow -> IM ()
	, addTable		-- :: Table -> IM ()
	, newId			-- :: IM String
	, getComponents 	-- :: IM [(Id, Id)]
	, addCompMapping	-- :: Id -> Id -> IM ()
	, addDirMapping	        -- :: Id -> Id -> IM ()
	, getDirs       	-- :: IM [(FilePath, Id, Id)]
	
	, addFile
	, replaceFile
	, getFiles

	, Id
	) where

import System.Win32.Com
import Bamse.MSITable
import System.IO.Unsafe ( unsafeInterleaveIO )
import Data.List

type Id = String

data IState 
  = IState { istate_guids    :: [GUID]    -- infinite supply of GUIDs.
  	   , istate_tables   :: [Table]
	   , istate_rows     :: [Row]
	   , istate_replaces :: [ReplaceRow]
	   , istate_dirs     :: [(FilePath, Id)]
	   , istate_feats    :: [(String{-FeatureName-}, Id)]
	   , istate_comps    :: [(Id, Id)]
	   , istate_files    :: [(FilePath, (Id, Id, String, String))]
	   }

newtype IM a = IM (IState -> IO (a, IState))

instance Functor IM where
 fmap f x = x >>= \ v -> return (f v)

instance Monad IM where
  (>>=)  = bindIM
  return = returnIM

bindIM :: IM a -> (a -> IM b) -> IM b
bindIM (IM a) cont = IM $ \ st -> do
  (x,st1) <- a st
  let (IM b) = cont x
  b st1

returnIM x = IM $ \ st -> return (x,st)

doInstall :: [Table] -> IM a -> IO (a, [(TableName, [Row])], [Table], [ReplaceRow])
doInstall custTables (IM ia) = do
   ls      <- new_guids
   let initial_state = 
   	  IState { istate_guids    = ls
	  	 , istate_tables   = (custTables ++ msiTables)
		 , istate_rows     = []
		 , istate_replaces = []
		 , istate_dirs     = []
		 , istate_feats    = []
		 , istate_comps    = []
		 , istate_files    = []
		 }
   (v, is) <- ia initial_state
   let sorted = map (\ ls@((x,_):_) -> (x,ls)) $
   		groupBy (\ (x,_) (y,_) -> x==y) $
		istate_rows is
   return (v, sorted, istate_tables is, istate_replaces is)

ioToIM :: IO a -> IM a
ioToIM act = IM $ \ st -> act >>= \ val -> return (val, st)

addRow :: Row -> IM ()
addRow r = IM $ \ is -> return ((), is{istate_rows=(r:istate_rows is)})

getTableRows :: TableName -> IM [Row]
getTableRows nm = IM $ \ is -> return (filter ((nm==).fst) (istate_rows is), is)

replaceRow :: ReplaceRow -> IM ()
replaceRow r = IM $ \ is -> return ((), is{istate_replaces=(r:istate_replaces is)})

addTable :: Table -> IM ()
addTable t = IM $ \ is -> return ((), is{istate_tables=(t:istate_tables is)})

getComponents :: IM [(Id, Id)]
getComponents = IM $ \ st -> return (istate_comps st, st)

getDirs :: IM [(FilePath, Id)]
getDirs = IM $ \ st -> return (istate_dirs st, st)

addCompMapping :: Id -> Id -> IM ()
addCompMapping compName dirName 
  = IM $ \ st -> return ((), st{istate_comps=(compName,dirName):istate_comps st})

addDirMapping :: FilePath -> Id -> IM ()
addDirMapping dName dKey
  = IM $ \ st -> return ((), st{istate_dirs=(dName,dKey):istate_dirs st})

addFile :: FilePath -> Id -> Id -> String -> String -> IM ()
addFile fName fKey compKey nm fSize 
 = IM $ \ st -> 
    return ((), 
    	    st{istate_files=(fName, (fKey,compKey,nm,fSize)):istate_files st})

replaceFile :: FilePath -> (Id, Id, String, String) -> IM ()
replaceFile fName stuff
 = IM $ \ st -> 
    return ((), 
    	    st{istate_files=(fName, stuff):
	    		    filter ((/=fName).fst) (istate_files st)})

getFiles :: IM [(FilePath, (Id, Id, String, String))]
getFiles = IM $ \ st -> return (istate_files st, st)

newId :: IM String
newId = IM $ \ st ->
   case istate_guids st of 
     (g:gs) -> return (show g, st{istate_guids=gs})

-- an infinite supply of GUIDs.
new_guids :: IO [GUID]
new_guids = do
   x <- newGUID
   xs <- unsafeInterleaveIO new_guids
   return (x : xs)