about summary refs log tree commit diff
path: root/src/Xanthous/Game/Prompt.hs
blob: 8e9ec04ccb33cb7246054c2aa2013dc53ddfbfe2 (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
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
{-# 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           Control.Comonad
--------------------------------------------------------------------------------
import           Xanthous.Util (smallestNotIn)
import           Xanthous.Data (Direction, Position)
import           Xanthous.Resource (Name)
import qualified Xanthous.Resource 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 '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 Name -> 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