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
|
{-# 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
deriving stock (Generic)
instance Show PromptType where
show StringPrompt = "StringPrompt"
show Confirm = "Confirm"
show (Menu _) = "Menu"
show DirectionPrompt = "DirectionPrompt"
show PointOnMap = "PointOnMap"
data SPromptType :: PromptType -> Type where
SStringPrompt :: SPromptType 'StringPrompt
SConfirm :: SPromptType 'Confirm
SMenu :: forall a. SPromptType ('Menu a)
SDirectionPrompt :: SPromptType 'DirectionPrompt
SPointOnMap :: SPromptType 'PointOnMap
class SingPromptType pt where singPromptType :: SPromptType pt
instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt
instance Show (SPromptType pt) where
show SStringPrompt = "SStringPrompt"
show SConfirm = "SConfirm"
show SMenu = "SMenu"
show SDirectionPrompt = "SDirectionPrompt"
show SPointOnMap = "SPointOnMap"
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
data PromptState pt where
StringPromptState :: Editor Text Name -> PromptState 'StringPrompt
DirectionPromptState :: PromptState 'DirectionPrompt
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 _ _ _ = 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
_ -> undefined
-- data PromptInput :: PromptType -> Type where
-- StringInput :: PromptInput 'StringPrompt
|
