1 files changed, 289 insertions, 0 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs b/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs
new file mode 100644
index 000000000000..30b5fe7545e0
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs
@@ -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