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
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
|
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveFunctor #-}
--------------------------------------------------------------------------------
module Xanthous.Game.Prompt
( PromptType(..)
, SPromptType(..)
, SingPromptType(..)
, PromptCancellable(..)
, PromptResult(..)
, PromptState(..)
, MenuOption(..)
, mkMenuItems
, PromptInput
, Prompt(..)
, mkPrompt
, mkMenu
, mkPointOnMapPrompt
, isCancellable
, submitPrompt
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
import Brick.Widgets.Edit (Editor, editorText, getEditContents)
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.Generic
--------------------------------------------------------------------------------
import Xanthous.Util (smallestNotIn)
import Xanthous.Data (Direction, Position)
import Xanthous.Data.App (ResourceName)
import qualified Xanthous.Data.App as Resource
--------------------------------------------------------------------------------
data PromptType where
StringPrompt :: PromptType
Confirm :: PromptType
Menu :: Type -> PromptType
DirectionPrompt :: PromptType
PointOnMap :: PromptType
Continue :: PromptType
deriving stock (Generic)
instance Show PromptType where
show StringPrompt = "StringPrompt"
show Confirm = "Confirm"
show (Menu _) = "Menu"
show DirectionPrompt = "DirectionPrompt"
show PointOnMap = "PointOnMap"
show Continue = "Continue"
data SPromptType :: PromptType -> Type where
SStringPrompt :: SPromptType 'StringPrompt
SConfirm :: SPromptType 'Confirm
SMenu :: SPromptType ('Menu a)
SDirectionPrompt :: SPromptType 'DirectionPrompt
SPointOnMap :: SPromptType 'PointOnMap
SContinue :: SPromptType 'Continue
instance NFData (SPromptType pt) where
rnf SStringPrompt = ()
rnf SConfirm = ()
rnf SMenu = ()
rnf SDirectionPrompt = ()
rnf SPointOnMap = ()
rnf SContinue = ()
class SingPromptType pt where singPromptType :: SPromptType pt
instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
instance SingPromptType 'Confirm where singPromptType = SConfirm
instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt
instance SingPromptType 'PointOnMap where singPromptType = SPointOnMap
instance SingPromptType 'Continue where singPromptType = SContinue
instance Show (SPromptType pt) where
show SStringPrompt = "SStringPrompt"
show SConfirm = "SConfirm"
show SMenu = "SMenu"
show SDirectionPrompt = "SDirectionPrompt"
show SPointOnMap = "SPointOnMap"
show SContinue = "SContinue"
data PromptCancellable
= Cancellable
| Uncancellable
deriving stock (Show, Eq, Ord, Enum, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
instance Arbitrary PromptCancellable where
arbitrary = genericArbitrary
data PromptResult (pt :: PromptType) where
StringResult :: Text -> PromptResult 'StringPrompt
ConfirmResult :: Bool -> PromptResult 'Confirm
MenuResult :: forall a. a -> PromptResult ('Menu a)
DirectionResult :: Direction -> PromptResult 'DirectionPrompt
PointOnMapResult :: Position -> PromptResult 'PointOnMap
ContinueResult :: PromptResult 'Continue
instance Arbitrary (PromptResult 'StringPrompt) where
arbitrary = StringResult <$> arbitrary
instance Arbitrary (PromptResult 'Confirm) where
arbitrary = ConfirmResult <$> arbitrary
instance Arbitrary a => Arbitrary (PromptResult ('Menu a)) where
arbitrary = MenuResult <$> arbitrary
instance Arbitrary (PromptResult 'DirectionPrompt) where
arbitrary = DirectionResult <$> arbitrary
instance Arbitrary (PromptResult 'PointOnMap) where
arbitrary = PointOnMapResult <$> arbitrary
instance Arbitrary (PromptResult 'Continue) where
arbitrary = pure ContinueResult
--------------------------------------------------------------------------------
data PromptState pt where
StringPromptState
:: Editor Text ResourceName -> PromptState 'StringPrompt
DirectionPromptState :: PromptState 'DirectionPrompt
ContinuePromptState :: PromptState 'Continue
ConfirmPromptState :: PromptState 'Confirm
MenuPromptState :: forall a. PromptState ('Menu a)
PointOnMapPromptState :: Position -> PromptState 'PointOnMap
instance NFData (PromptState pt) where
rnf sps@(StringPromptState ed) = sps `deepseq` ed `deepseq` ()
rnf DirectionPromptState = ()
rnf ContinuePromptState = ()
rnf ConfirmPromptState = ()
rnf MenuPromptState = ()
rnf pomps@(PointOnMapPromptState pos) = pomps `deepseq` pos `deepseq` ()
instance Arbitrary (PromptState 'StringPrompt) where
arbitrary = StringPromptState <$> arbitrary
instance Arbitrary (PromptState 'DirectionPrompt) where
arbitrary = pure DirectionPromptState
instance Arbitrary (PromptState 'Continue) where
arbitrary = pure ContinuePromptState
instance Arbitrary (PromptState ('Menu a)) where
arbitrary = pure MenuPromptState
instance CoArbitrary (PromptState 'StringPrompt) where
coarbitrary (StringPromptState ed) = coarbitrary ed
instance CoArbitrary (PromptState 'DirectionPrompt) where
coarbitrary DirectionPromptState = coarbitrary ()
instance CoArbitrary (PromptState 'Continue) where
coarbitrary ContinuePromptState = coarbitrary ()
instance CoArbitrary (PromptState ('Menu a)) where
coarbitrary MenuPromptState = coarbitrary ()
deriving stock instance Show (PromptState pt)
data MenuOption a = MenuOption Text a
deriving stock (Eq, Generic, Functor)
deriving anyclass (NFData, CoArbitrary, Function)
instance Comonad MenuOption where
extract (MenuOption _ x) = x
extend cok mo@(MenuOption text _) = MenuOption text (cok mo)
mkMenuItems :: (MonoFoldable f, Element f ~ (Char, MenuOption a))
=> f
-> Map Char (MenuOption a)
mkMenuItems = flip foldl' mempty $ \items (chr, option) ->
let chr' = if has (ix chr) items
then smallestNotIn $ keys items
else chr
in items & at chr' ?~ option
instance Show (MenuOption a) where
show (MenuOption m _) = show m
type family PromptInput (pt :: PromptType) :: Type where
PromptInput ('Menu a) = Map Char (MenuOption a)
PromptInput 'PointOnMap = Position -- Character pos
PromptInput _ = ()
data Prompt (m :: Type -> Type) where
Prompt
:: forall (pt :: PromptType)
(m :: Type -> Type).
PromptCancellable
-> SPromptType pt
-> PromptState pt
-> PromptInput pt
-> (PromptResult pt -> m ())
-> Prompt m
instance Show (Prompt m) where
show (Prompt c pt ps pri _)
= "(Prompt "
<> show c <> " "
<> show pt <> " "
<> show ps <> " "
<> showPri
<> " <function>)"
where showPri = case pt of
SMenu -> show pri
_ -> "()"
instance NFData (Prompt m) where
rnf (Prompt c SMenu ps pri cb)
= c
`deepseq` ps
`deepseq` pri
`seq` cb
`seq` ()
rnf (Prompt c spt ps pri cb)
= c
`deepseq` spt
`deepseq` ps
`deepseq` pri
`seq` cb
`seq` ()
instance CoArbitrary (m ()) => CoArbitrary (Prompt m) where
coarbitrary (Prompt c SStringPrompt ps pri cb) =
variant @Int 1 . coarbitrary (c, ps, pri, cb)
coarbitrary (Prompt c SConfirm _ pri cb) = -- TODO fill in prompt state
variant @Int 2 . coarbitrary (c, pri, cb)
coarbitrary (Prompt c SMenu _ps _pri _cb) =
variant @Int 3 . coarbitrary c {-, ps, pri, cb -}
coarbitrary (Prompt c SDirectionPrompt ps pri cb) =
variant @Int 4 . coarbitrary (c, ps, pri, cb)
coarbitrary (Prompt c SPointOnMap _ pri cb) = -- TODO fill in prompt state
variant @Int 5 . coarbitrary (c, pri, cb)
coarbitrary (Prompt c SContinue ps pri cb) =
variant @Int 6 . coarbitrary (c, ps, pri, cb)
-- instance Function (Prompt m) where
-- function = functionMap toTuple _fromTuple
-- where
-- toTuple (Prompt c pt ps pri cb) = (c, pt, ps, pri, cb)
mkPrompt :: (PromptInput pt ~ ()) => PromptCancellable -> SPromptType pt -> (PromptResult pt -> m ()) -> Prompt m
mkPrompt c pt@SStringPrompt cb =
let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
in Prompt c pt ps () cb
mkPrompt c pt@SDirectionPrompt cb = Prompt c pt DirectionPromptState () cb
mkPrompt c pt@SContinue cb = Prompt c pt ContinuePromptState () cb
mkPrompt c pt@SConfirm cb = Prompt c pt ConfirmPromptState () cb
mkMenu
:: forall a m.
PromptCancellable
-> Map Char (MenuOption a) -- ^ Menu items
-> (PromptResult ('Menu a) -> m ())
-> Prompt m
mkMenu c = Prompt c SMenu MenuPromptState
mkPointOnMapPrompt
:: PromptCancellable
-> Position
-> (PromptResult 'PointOnMap -> m ())
-> Prompt m
mkPointOnMapPrompt c pos = Prompt c SPointOnMap (PointOnMapPromptState pos) pos
isCancellable :: Prompt m -> Bool
isCancellable (Prompt Cancellable _ _ _ _) = True
isCancellable (Prompt Uncancellable _ _ _ _) = False
submitPrompt :: Applicative m => Prompt m -> m ()
submitPrompt (Prompt _ pt ps _ cb) =
case (pt, ps) of
(SStringPrompt, StringPromptState edit) ->
cb . StringResult . mconcat . getEditContents $ edit
(SDirectionPrompt, DirectionPromptState) ->
pure () -- Don't use submit with a direction prompt
(SContinue, ContinuePromptState) ->
cb ContinueResult
(SMenu, MenuPromptState) ->
pure () -- Don't use submit with a menu prompt
(SPointOnMap, PointOnMapPromptState pos) ->
cb $ PointOnMapResult pos
(SConfirm, ConfirmPromptState) ->
cb $ ConfirmResult True
|