diff options
Diffstat (limited to 'src/Sequence/Utils.hs')
-rw-r--r-- | src/Sequence/Utils.hs | 17 |
1 files changed, 16 insertions, 1 deletions
diff --git a/src/Sequence/Utils.hs b/src/Sequence/Utils.hs index aa92081..aea853d 100644 --- a/src/Sequence/Utils.hs +++ b/src/Sequence/Utils.hs | |||
@@ -1,7 +1,9 @@ | |||
1 | {-# LANGUAGE ViewPatterns, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} | 1 | {-# LANGUAGE ViewPatterns, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} |
2 | 2 | ||
3 | module Sequence.Utils | 3 | module Sequence.Utils |
4 | ( withArg, toName, fromName | 4 | ( withArg, withFocus |
5 | , askBool | ||
6 | , toName, fromName | ||
5 | ) where | 7 | ) where |
6 | 8 | ||
7 | import Sequence.Types | 9 | import Sequence.Types |
@@ -28,6 +30,7 @@ import Data.List | |||
28 | 30 | ||
29 | import System.Console.Shell | 31 | import System.Console.Shell |
30 | import System.Console.Shell.ShellMonad | 32 | import System.Console.Shell.ShellMonad |
33 | import System.Console.Shell.Backend.Haskeline | ||
31 | 34 | ||
32 | 35 | ||
33 | class Argument a st | a -> st where | 36 | class Argument a st | a -> st where |
@@ -38,6 +41,18 @@ withArg f (Completable str) = arg str >>= \a -> case a of | |||
38 | Nothing -> shellPutErrLn $ "Could not parse ‘" ++ str ++ "’" | 41 | Nothing -> shellPutErrLn $ "Could not parse ‘" ++ str ++ "’" |
39 | Just a -> f a | 42 | Just a -> f a |
40 | 43 | ||
44 | withFocus :: (EntityIdentifier -> Sh GameState ()) -> Sh GameState () | ||
45 | withFocus f = use gFocus >>= \focus -> case focus of | ||
46 | Nothing -> shellPutErrLn $ "Currently not focusing any entity" | ||
47 | Just id -> f id | ||
48 | |||
49 | 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 | ||
51 | where | ||
52 | yes, no :: Sh Bool () | ||
53 | yes = put True | ||
54 | no = put False | ||
55 | |||
41 | unaligned = view faction' def | 56 | unaligned = view faction' def |
42 | 57 | ||
43 | toName :: MonadState GameState m => EntityIdentifier -> m String | 58 | toName :: MonadState GameState m => EntityIdentifier -> m String |