refactor(users/glittershark): Rename to grfn
Rename my //users directory and all places that refer to glittershark to grfn, including nix references and documentation. This may require some extra attention inside of gerrit's database after it lands to allow me to actually push things. Change-Id: I4728b7ec2c60024392c1c1fa6e0d4a59b3e266fa Reviewed-on: https://cl.tvl.fyi/c/depot/+/2933 Tested-by: BuildkiteCI Reviewed-by: tazjin <mail@tazj.in> Reviewed-by: lukegb <lukegb@tvl.fyi> Reviewed-by: glittershark <grfn@gws.fyi>
This commit is contained in:
Griffin Smith
glittershark
parent
968effb5dc
commit
6266c5d32f
362 changed files with 52 additions and 56 deletions
289
users/grfn/xanthous/src/Xanthous/Game/Prompt.hs
Normal file
289
users/grfn/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