about summary refs log tree commit diff
path: root/users/grfn/xanthous/src/Xanthous/App/Prompt.hs
blob: 9b5a3bf24fa7852cd71bc2e0210ed9262f5cbd67 (plain) (blame)
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
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
module Xanthous.App.Prompt
  ( handlePromptEvent
  , clearPrompt
  , prompt
  , prompt_
  , confirm_
  , confirm
  , menu
  , menu_
  ) where
--------------------------------------------------------------------------------
import           Xanthous.Prelude
--------------------------------------------------------------------------------
import           Brick (BrickEvent(..), Next)
import           Brick.Widgets.Edit (handleEditorEvent)
import           Data.Aeson (ToJSON, object)
import           Graphics.Vty.Input.Events (Event(EvKey), Key(..))
import           GHC.TypeLits (ErrorMessage(..))
--------------------------------------------------------------------------------
import           Xanthous.App.Common
import           Xanthous.Data (move)
import           Xanthous.Command (directionFromChar)
import           Xanthous.Data.App (ResourceName, AppEvent)
import           Xanthous.Game.Prompt
import           Xanthous.Game.State
import qualified Xanthous.Messages as Messages
--------------------------------------------------------------------------------

handlePromptEvent
  :: Text -- ^ Prompt message
  -> Prompt AppM
  -> BrickEvent ResourceName AppEvent
  -> AppM (Next GameState)

handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc []))
  = clearPrompt >> continue
handlePromptEvent _ pr (VtyEvent (EvKey KEnter []))
  = clearPrompt >> submitPrompt pr >> continue

handlePromptEvent _ pr@(Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'y') []))
  = clearPrompt >> submitPrompt pr >> continue

handlePromptEvent _ (Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'n') []))
  = clearPrompt >> continue

handlePromptEvent
  msg
  (Prompt c SStringPrompt (StringPromptState edit) pri cb)
  (VtyEvent ev)
  = do
    edit' <- lift $ handleEditorEvent ev edit
    let prompt' = Prompt c SStringPrompt (StringPromptState edit') pri cb
    promptState .= WaitingPrompt msg prompt'
    continue

handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ cb)
  (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
  = clearPrompt >> cb (DirectionResult dir) >> continue
handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ _) _ = continue

handlePromptEvent _ (Prompt _ SMenu _ items' cb) (VtyEvent (EvKey (KChar chr) []))
  | Just (MenuOption _ res) <- items' ^. at chr
  = clearPrompt >> cb (MenuResult res) >> continue
  | otherwise
  = continue

handlePromptEvent
  msg
  (Prompt c SPointOnMap (PointOnMapPromptState pos) pri cb)
  (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
  = let pos' = move dir pos
        prompt' = Prompt c SPointOnMap (PointOnMapPromptState pos') pri cb
    in promptState .= WaitingPrompt msg prompt'
       >> continue
handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue

handlePromptEvent
  _
  (Prompt Cancellable _ _ _ _)
  (VtyEvent (EvKey (KChar 'q') []))
  = clearPrompt >> continue
handlePromptEvent _ _ _ = continue

clearPrompt :: AppM ()
clearPrompt = promptState .= NoPrompt

class NotMenu (pt :: PromptType)
instance NotMenu 'StringPrompt
instance NotMenu 'Confirm
instance NotMenu 'DirectionPrompt
instance NotMenu 'PointOnMap
instance NotMenu 'Continue
instance TypeError ('Text "Cannot use `prompt` or `prompt_` for menu prompts"
                    ':$$: 'Text "Use `menu` or `menu_` instead")
         => NotMenu ('Menu a)

prompt
  :: forall (pt :: PromptType) (params :: Type).
    (ToJSON params, SingPromptType pt, NotMenu pt)
  => [Text]                     -- ^ Message key
  -> params                     -- ^ Message params
  -> PromptCancellable
  -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
  -> AppM ()
prompt msgPath params cancellable cb = do
  let pt = singPromptType @pt
  msg <- Messages.message msgPath params
  p <- case pt of
    SPointOnMap -> do
      charPos <- use characterPosition
      pure $ mkPointOnMapPrompt cancellable charPos cb
    SStringPrompt -> pure $ mkPrompt cancellable pt cb
    SConfirm -> pure $ mkPrompt cancellable pt cb
    SDirectionPrompt -> pure $ mkPrompt cancellable pt cb
    SContinue -> pure $ mkPrompt cancellable pt cb
    SMenu -> error "unreachable"
  promptState .= WaitingPrompt msg p

prompt_
  :: forall (pt :: PromptType).
    (SingPromptType pt, NotMenu pt)
  => [Text] -- ^ Message key
  -> PromptCancellable
  -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
  -> AppM ()
prompt_ msg = prompt msg $ object []

confirm
  :: ToJSON params
  => [Text] -- ^ Message key
  -> params
  -> AppM ()
  -> AppM ()
confirm msgPath params
  = prompt @'Confirm msgPath params Cancellable . const

confirm_ :: [Text] -> AppM () -> AppM ()
confirm_ msgPath = confirm msgPath $ object []

menu :: forall (a :: Type) (params :: Type).
       (ToJSON params)
     => [Text]                            -- ^ Message key
     -> params                            -- ^ Message params
     -> PromptCancellable
     -> Map Char (MenuOption a)           -- ^ Menu items
     -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler
     -> AppM ()
menu msgPath params cancellable items' cb = do
  msg <- Messages.message msgPath params
  let p = mkMenu cancellable items' cb
  promptState .= WaitingPrompt msg p

menu_ :: forall (a :: Type).
        [Text]                            -- ^ Message key
      -> PromptCancellable
      -> Map Char (MenuOption a)           -- ^ Menu items
      -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler
      -> AppM ()
menu_ msgPath = menu msgPath $ object []