minesweeper-0.9: Minesweeper.hs

{-# LANGUAGE RankNTypes #-}
import Log
import Driver.Log
import Event
import Transition.Managed
import GTK

import Control.Concurrent
import Control.Monad.Fix
import System.FilePath ((</>), takeDirectory)
import System.Directory
import System.Environment
import Random ()
import qualified Data.ByteString.Lazy as B

import Data.ChangeMap
import qualified Data.Map as MM
import Data.ChangeSet
import Core.Square
import Preferences
import State (ScoreEntry)
import Step
import Random

import Data.Data

import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import Data.Binary.Generic
import Data.Binary.Generic.Extensions

--------------------------------------

main :: IO ()
main = getArgs >>= mainWithArgs

mainWithArgs :: [String] -> IO ()
mainWithArgs args = do

    -- init logging
    logState <- case args of
        ["-"] -> return stdOutLog
        [fn] -> fileLog fn
        _ -> return noLog

    -- find preferences file
    dir <- getAppUserDataDirectory "minesweeper"
    let prefFile = dir </> "preferences"

    -- init program state
    userName    <- getEnv "USER"
    seed        <- newRandomSeed
    b <- doesFileExist prefFile
    st <- if b 
        then fmap (runGet myGet) $ B.readFile prefFile
        else return $ initState userName seed

    -- init driver state
    dst <- initDriverState st

    -- init GUI state
    gui <- mfix $ \gui -> guiState (handleEvent logState gui dst) (writeState prefFile dst)

    -- wake up the program
    let initActions = [Init]
    mapM_ (forkIO . handleEvent logState gui dst) initActions

    -- start GUI
    startGUI gui


handleEvent :: LogState -> GUIState -> DriverState State Event -> Event -> IO ()
handleEvent logState gui dst e =
    applyTransition logState dst (handleResponses gui) transition e


writeState :: FilePath -> DriverState State a -> IO ()
writeState prefFile dst = do
    st <- takeState dst
    createDirectoryIfMissing True $ takeDirectory prefFile
    B.writeFile prefFile $ runPut $ myPut $ stopState st
--    encodeFile prefFile $ stopState st

---------------------------

myPut :: Data a => a -> Put
myPut = putExtDef (putGenericByCallback myPut)

myGet   :: Data a => Get a
myGet = getExtDef (getGenericByCallback myGet)

getExtDef    :: Typeable a => Get a -> Get a
getExtDef = extGet (get :: Get (MM.Map Preferences [ScoreEntry]))
          . extGet (get :: Get (Set Square))
          . extGet (get :: Get (Map Square (Maybe Int)))
          . extGet (get :: Get (Map Square Int))
          . extGet (get :: Get (RandomSeed))
          . extGet (get :: Get (SquareConstraints))
          . getExtDefault

putExtDef    :: Typeable a => (a -> Put) -> a -> Put
putExtDef = extPut (put :: MM.Map Preferences [ScoreEntry] -> Put)
          . extPut (put :: Set Square -> Put)
          . extPut (put :: Map Square (Maybe Int) -> Put)
          . extPut (put :: Map Square Int -> Put)
          . extPut (put :: RandomSeed -> Put)
          . extPut (put :: SquareConstraints -> Put)
          . putExtDefault