blob: f0a8849933043be94000d8ce0fff157e57d173ce (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
{-# LANGUAGE ViewPatterns, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, OverloadedStrings #-}
module Sequence.Utils
( withArg, withFocus
, askQ, askBool
, toName, fromName
) where
import Sequence.Types
import Control.Monad.State.Strict
import Control.Monad
import Control.Lens
import Data.Bimap (Bimap)
import qualified Data.Bimap as Bimap
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Function
import Data.Default
import Data.Maybe
import Text.Read (readMaybe)
import Data.List
import System.Console.Shell
import System.Console.Shell.ShellMonad
import System.Console.Shell.Backend.Haskeline
import System.Console.Readline (readline)
class Argument a st | a -> st where
arg :: String -> Sh st (Maybe a)
withArg :: Argument a st => (a -> Sh st ()) -> (Completable a -> Sh st ())
withArg f (Completable str) = arg str >>= \a -> case a of
Nothing -> shellPutErrLn $ "Could not parse ‘" ++ str ++ "’"
Just a -> f a
withFocus :: (EntityIdentifier -> Sh GameState ()) -> Sh GameState ()
withFocus f = use gFocus >>= \focus -> case focus of
Nothing -> shellPutErrLn $ "Currently not focusing any entity"
Just id -> f id
askBool :: MonadIO m => String -> Bool -> m Bool
askBool prompt initial = askQ prompt $ fromMaybe initial . join . fmap (eval . CI.mk)
where
eval "yes" = Just True
eval "y" = Just True
eval "no" = Just False
eval "n" = Just False
eval _ = Nothing
askQ :: MonadIO m => String -> (Maybe String -> a) -> m a
askQ prompt eval = eval <$> liftIO (readline $ prompt ++ " ")
unaligned = view faction' def
toName :: MonadState GameState m => EntityIdentifier -> m String
toName id = fromMaybe (show $ id ^. entityId) . fmap (CI.original . view entityName) . Bimap.lookup id <$> use gEntityNames
fromName :: MonadState GameState m => String -> m (Maybe EntityIdentifier)
fromName (readMaybe -> (Just (EntityIdentifier -> n))) = (n <$) . guard . Map.member n <$> use gEntities
fromName (EntityName . CI.mk -> name) = Bimap.lookupR name <$> use gEntityNames
instance Completion EntityIdentifier GameState where
completableLabel _ = "<entity>"
complete _ st prefix = return . filter ((isPrefixOf `on` CI.foldCase) prefix) . map ((evalState ?? st) . toName) . Map.keys $ st ^. gEntities
instance Argument EntityIdentifier GameState where
arg = fromName
instance Completion Faction GameState where
completableLabel _ = "<faction>"
complete _ st prefix = return . filter ((isPrefixOf `on` CI.foldCase) prefix) . nub . sort $ unaligned : map (view faction') (st ^. inhabitedFactions)
instance Argument Faction GameState where
arg = return . Just . flip (set faction') def
|
