module ALife.Creatur.Checklist
(
Checklist(..),
PersistentChecklist,
mkPersistentChecklist
) where
import ALife.Creatur.Util (modifyLift)
import Control.Monad (when, unless)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.State (StateT, get, gets, put)
import qualified Data.List as L
import System.Directory (doesFileExist)
import System.IO (hGetContents, withFile, Handle, IOMode(ReadMode))
import Text.Read (readEither)
type Status = ([String], [String])
class Checklist t where
status :: StateT t IO Status
markDone :: String -> StateT t IO ()
done :: StateT t IO Bool
setItems :: [String] -> StateT t IO ()
delete :: String -> StateT t IO ()
data PersistentChecklist = PersistentChecklist {
tInitialised :: Bool,
tStatus :: Status,
tFilename :: FilePath
} deriving (Show, Eq)
mkPersistentChecklist :: FilePath -> PersistentChecklist
mkPersistentChecklist f = PersistentChecklist False ([],[]) f
instance Checklist PersistentChecklist where
status = initIfNeeded >> gets tStatus
markDone x = do
t <- get
let (ys,zs) = tStatus t
when (x `elem` ys) $ do
let t' = t { tStatus=(L.delete x ys,zs ++ [x]) }
put t'
liftIO $ store t'
done = gets (null . fst . tStatus)
setItems ts = do
t <- get
let t' = t { tStatus=(ts,[]) }
put t'
liftIO $ store t'
delete tOld = do
t <- get
let (xs,ys) = tStatus t
let t' = t { tStatus=(L.delete tOld xs,L.delete tOld ys) }
put t'
liftIO $ store t'
initIfNeeded :: StateT PersistentChecklist IO ()
initIfNeeded = do
isInitialised <- gets tInitialised
unless isInitialised $ modifyLift initialise
initialise :: PersistentChecklist -> IO PersistentChecklist
initialise t = do
let f = tFilename t
fExists <- doesFileExist f
if fExists
then do
s <- withFile f ReadMode readChecklist
case s of
Left msg ->
error $ "Unable to read checklist from " ++ f ++ ": " ++ msg
Right s' -> return $ t { tInitialised=True, tStatus=s' }
else return $ t { tInitialised=True }
readChecklist :: Handle -> IO (Either String Status)
readChecklist h = do
x <- hGetContents h
let s = readEither x
case s of
Left msg -> return $ Left (msg ++ "\"" ++ x ++ "\"")
Right c -> return $ Right c
store :: PersistentChecklist -> IO ()
store t = writeFile (tFilename t) $ show (tStatus t)