summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--sequence.cabal1
-rw-r--r--sequence.nix7
-rw-r--r--src/Main.hs2
-rw-r--r--src/Sequence/Utils.hs22
4 files changed, 21 insertions, 11 deletions
diff --git a/sequence.cabal b/sequence.cabal
index 3d9e66f..ada1546 100644
--- a/sequence.cabal
+++ b/sequence.cabal
@@ -33,5 +33,6 @@ executable sequence
33 , mtl 33 , mtl
34 , table-layout 34 , table-layout
35 , game-probability 35 , game-probability
36 , readline
36 hs-source-dirs: src 37 hs-source-dirs: src
37 default-language: Haskell2010 \ No newline at end of file 38 default-language: Haskell2010 \ No newline at end of file
diff --git a/sequence.nix b/sequence.nix
index 4533ad2..ff36401 100644
--- a/sequence.nix
+++ b/sequence.nix
@@ -1,6 +1,7 @@
1{ mkDerivation, base, bimap, case-insensitive, containers 1{ mkDerivation, base, bimap, case-insensitive, containers
2, data-default, directory, filepath, game-probability, lens, mtl 2, data-default, directory, filepath, game-probability, lens, mtl
3, Shellac, Shellac-haskeline, stdenv, table-layout, xdg-basedir 3, readline, Shellac, Shellac-haskeline, stdenv, table-layout
4, xdg-basedir
4}: 5}:
5mkDerivation { 6mkDerivation {
6 pname = "sequence"; 7 pname = "sequence";
@@ -10,8 +11,8 @@ mkDerivation {
10 isExecutable = true; 11 isExecutable = true;
11 executableHaskellDepends = [ 12 executableHaskellDepends = [
12 base bimap case-insensitive containers data-default directory 13 base bimap case-insensitive containers data-default directory
13 filepath game-probability lens mtl Shellac Shellac-haskeline 14 filepath game-probability lens mtl readline Shellac
14 table-layout xdg-basedir 15 Shellac-haskeline table-layout xdg-basedir
15 ]; 16 ];
16 license = stdenv.lib.licenses.mit; 17 license = stdenv.lib.licenses.mit;
17} 18}
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