diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/Main.hs | 2 | ||||
-rw-r--r-- | src/Sequence/Utils.hs | 22 |
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 | |||
100 | remove :: Sh GameState () | 100 | remove :: Sh GameState () |
101 | remove = withFocus $ \ident -> do | 101 | remove = 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 | ||
3 | module Sequence.Utils | 3 | module 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 | ||
11 | import Control.Monad.State.Strict | 11 | import Control.Monad.State.Strict |
12 | 12 | ||
13 | import Control.Monad | ||
13 | import Control.Lens | 14 | import Control.Lens |
14 | 15 | ||
15 | import Data.Bimap (Bimap) | 16 | import Data.Bimap (Bimap) |
@@ -32,6 +33,8 @@ import System.Console.Shell | |||
32 | import System.Console.Shell.ShellMonad | 33 | import System.Console.Shell.ShellMonad |
33 | import System.Console.Shell.Backend.Haskeline | 34 | import System.Console.Shell.Backend.Haskeline |
34 | 35 | ||
36 | import System.Console.Readline (readline) | ||
37 | |||
35 | 38 | ||
36 | class Argument a st | a -> st where | 39 | class 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 | ||
49 | askBool :: String -> Bool -> Sh st Bool | 52 | askBool :: String -> Bool -> Sh st Bool |
50 | askBool prompt initial = liftIO $ runShell (initialShellDescription { shellCommands = [cmd "y" yes "yes", cmd "n" no "no"], commandStyle = SingleCharCommands, prompt = const $ return prompt, historyEnabled = False }) haskelineBackend initial | 53 | askBool 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 | |||
61 | askQ :: String -> (Maybe String -> a) -> Sh st a | ||
62 | askQ prompt eval = eval <$> liftIO (readline $ prompt ++ " ") | ||
63 | |||
56 | unaligned = view faction' def | 64 | unaligned = view faction' def |
57 | 65 | ||
58 | toName :: MonadState GameState m => EntityIdentifier -> m String | 66 | toName :: MonadState GameState m => EntityIdentifier -> m String |