Add 'users/glittershark/xanthous/' from commit '53b56744f4'
git-subtree-dir: users/glittershark/xanthous git-subtree-mainline:91f53f02d8git-subtree-split:53b56744f4
This commit is contained in:
Vincent Ambo
commit
2edb963b97
96 changed files with 10030 additions and 0 deletions
289
users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs
Normal file
289
users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs
Normal file
|
|
@ -0,0 +1,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
|
||||
Loading…
Add table
Add a link
Reference in a new issue