summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Main.hs2
-rw-r--r--src/Sequence/Utils.hs22
2 files changed, 16 insertions, 8 deletions
diff --git a/src/Main.hs b/src/Main.hs
index e480f4b..96e3fef 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -100,7 +100,7 @@ setFocus = withArg $ \ident -> gFocus .= Just ident
100remove :: Sh GameState () 100remove :: Sh GameState ()
101remove = withFocus $ \ident -> do 101remove = withFocus $ \ident -> do
102 name <- toName ident 102 name <- toName ident
103 confirmation <- askBool ("Are you sure you want to remove ‘" ++ name ++ "’? ") False 103 confirmation <- askBool ("Are you sure you want to remove ‘" ++ name ++ "’?") False
104 when confirmation $ do 104 when confirmation $ do
105 gEntities %= Map.delete ident 105 gEntities %= Map.delete ident
106 gEntityNames %= Bimap.delete ident 106 gEntityNames %= Bimap.delete ident
diff --git a/src/Sequence/Utils.hs b/src/Sequence/Utils.hs
index aea853d..32f8239 100644
--- a/src/Sequence/Utils.hs
+++ b/src/Sequence/Utils.hs
@@ -1,8 +1,8 @@
1{-# LANGUAGE ViewPatterns, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} 1{-# LANGUAGE ViewPatterns, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, OverloadedStrings #-}
2 2
3module Sequence.Utils 3module Sequence.Utils
4 ( withArg, withFocus 4 ( withArg, withFocus
5 , askBool 5 , askQ, askBool
6 , toName, fromName 6 , toName, fromName
7 ) where 7 ) where
8 8
@@ -10,6 +10,7 @@ import Sequence.Types
10 10
11import Control.Monad.State.Strict 11import Control.Monad.State.Strict
12 12
13import Control.Monad
13import Control.Lens 14import Control.Lens
14 15
15import Data.Bimap (Bimap) 16import Data.Bimap (Bimap)
@@ -32,6 +33,8 @@ import System.Console.Shell
32import System.Console.Shell.ShellMonad 33import System.Console.Shell.ShellMonad
33import System.Console.Shell.Backend.Haskeline 34import System.Console.Shell.Backend.Haskeline
34 35
36import System.Console.Readline (readline)
37
35 38
36class Argument a st | a -> st where 39class Argument a st | a -> st where
37 arg :: String -> Sh st (Maybe a) 40 arg :: String -> Sh st (Maybe a)
@@ -47,12 +50,17 @@ withFocus f = use gFocus >>= \focus -> case focus of
47 Just id -> f id 50 Just id -> f id
48 51
49askBool :: String -> Bool -> Sh st Bool 52askBool :: String -> Bool -> Sh st Bool
50askBool prompt initial = liftIO $ runShell (initialShellDescription { shellCommands = [cmd "y" yes "yes", cmd "n" no "no"], commandStyle = SingleCharCommands, prompt = const $ return prompt, historyEnabled = False }) haskelineBackend initial 53askBool prompt initial = askQ prompt $ fromMaybe initial . join . fmap (eval . CI.mk)
51 where 54 where
52 yes, no :: Sh Bool () 55 eval "yes" = Just True
53 yes = put True 56 eval "y" = Just True
54 no = put False 57 eval "no" = Just False
55 58 eval "n" = Just False
59 eval _ = Nothing
60
61askQ :: String -> (Maybe String -> a) -> Sh st a
62askQ prompt eval = eval <$> liftIO (readline $ prompt ++ " ")
63
56unaligned = view faction' def 64unaligned = view faction' def
57 65
58toName :: MonadState GameState m => EntityIdentifier -> m String 66toName :: MonadState GameState m => EntityIdentifier -> m String