diff options
Diffstat (limited to 'users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs')
| -rw-r--r-- | users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs | 289 |
1 files changed, 0 insertions, 289 deletions
diff --git a/users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs b/users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs deleted file mode 100644 index 30b5fe7545..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs +++ /dev/null @@ -1,289 +0,0 @@ -{-# 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 |