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 |
