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
|
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
--------------------------------------------------------------------------------
module Xanthous.Game.Prompt
( PromptType(..)
, SPromptType(..)
, SingPromptType(..)
, PromptCancellable(..)
, PromptResult(..)
, PromptState(..)
, Prompt(..)
, mkPrompt
, isCancellable
, submitPrompt
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
import Brick.Widgets.Edit (Editor, editorText, getEditContents)
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.Generic
--------------------------------------------------------------------------------
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 :: forall a. SPromptType ('Menu a)
SDirectionPrompt :: SPromptType 'DirectionPrompt
SPointOnMap :: SPromptType 'PointOnMap
SContinue :: SPromptType 'Continue
class SingPromptType pt where singPromptType :: SPromptType pt
instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt
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
data PromptState pt where
StringPromptState :: Editor Text Name -> PromptState 'StringPrompt
DirectionPromptState :: PromptState 'DirectionPrompt
ContinuePromptState :: PromptState 'Continue
deriving stock instance Show (PromptState pt)
data Prompt (m :: Type -> Type) where
Prompt
:: forall (pt :: PromptType)
(m :: Type -> Type).
PromptCancellable
-> SPromptType pt
-> PromptState pt
-> (PromptResult pt -> m ())
-> Prompt m
instance Show (Prompt m) where
show (Prompt c pt ps _)
= "(Prompt "
<> show c <> " "
<> show pt <> " "
<> show ps
<> " <function> )"
mkPrompt :: 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 _ _ _ = undefined
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 -- Don't use submit with a direction prompt
_ -> undefined
-- data PromptInput :: PromptType -> Type where
-- StringInput :: PromptInput 'StringPrompt
|
