intricacy-0.5.5: Init.hs

-- This file is part of Intricacy
-- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation, or any later version.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see http://www.gnu.org/licenses/.

module Init where


import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.State
import Data.Maybe
import System.Exit
import System.Environment
import System.Directory
import System.FilePath
import System.Console.GetOpt

import Lock
import MainState
import Interact
import Util
import Version

data Opt = LockSize Int | ForceCurses | Help | Version
    deriving (Eq, Ord, Show)
options =
    [ Option ['c'] ["curses"] (NoArg ForceCurses) "force curses UI"
    , Option ['s'] ["locksize"] (ReqArg (LockSize . read) "SIZE") "locksize"
    , Option ['h'] ["help"] (NoArg Help) "show usage information"
    , Option ['v'] ["version"] (NoArg Version) "show version information"
    ]

usage :: String
usage = usageInfo header options
    where header = "Usage: intricacy [OPTION...] [file]"

parseArgs :: [String] -> IO ([Opt],[String])
parseArgs argv =
    case getOpt Permute options argv of
	(o,n,[]) -> return (o,n)
	(_,_,errs) -> ioError (userError (concat errs ++ usage))

setup :: IO (Maybe Lock,[Opt],Maybe String)
setup = do
    argv <- getArgs
    (opts,args) <- parseArgs argv
    when (Help `elem` opts) $ putStr usage >> exitSuccess
    when (Version `elem` opts) $ putStrLn version >> exitSuccess
    let size = fromMaybe 8 $ listToMaybe [ size | LockSize size <- opts ]
    curDir <- getCurrentDirectory
    (fromJust <$>) $ runMaybeT $ msum
	[ do
	    path <- liftMaybe ((curDir </>) <$> listToMaybe args)
	    msum [ do
		    lock <- reframe.fst <$> MaybeT (readLock path)
		    return (Just lock,opts,Just path)
		, return (Just $ baseLock size, opts, Just path) ]
	, return (Nothing,opts,Nothing) ]

main' :: (UIMonad s, UIMonad c) =>
	Maybe (s MainState -> IO (Maybe MainState)) ->
	Maybe (c MainState -> IO (Maybe MainState)) -> IO ()
main' msdlUI mcursesUI = do
    (mlock,opts,mpath) <- setup
    initMState <- case mlock of
	    Nothing -> initMetaState
	    Just lock -> return $ newEditState lock Nothing mpath
    void $ runMaybeT $ msum [ do
	    finalState <- msum
		[ do
		    guard $ ForceCurses `notElem` opts
		    sdlUI <- liftMaybe $ msdlUI
		    MaybeT $ sdlUI $ interactUI `execStateT` initMState
		, do
		    cursesUI <- liftMaybe $ mcursesUI
		    MaybeT $ cursesUI $ interactUI `execStateT` initMState
		]
	    when (isNothing mlock) $ lift $ writeMetaState finalState
	    lift $ exitSuccess
	, lift exitFailure ]