about summary refs log tree commit diff
path: root/users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs
diff options
context:
space:
mode:
Diffstat (limited to 'users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs')
-rw-r--r--users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs289
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 30b5fe7545e0..000000000000
--- 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