diff options
-rw-r--r-- | sequence.cabal | 1 | ||||
-rw-r--r-- | sequence.nix | 7 | ||||
-rw-r--r-- | src/Main.hs | 2 | ||||
-rw-r--r-- | src/Sequence/Utils.hs | 22 |
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 | }: |
5 | mkDerivation { | 6 | mkDerivation { |
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 | |||
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 |