chore(users): grfn -> aspen r/7511

Change-Id: I6c6847fac56f0a9a1a2209792e00a3aec5e672b9
Reviewed-on: https://cl.tvl.fyi/c/depot/+/10809
Autosubmit: aspen <root@gws.fyi>
Reviewed-by: sterni <sternenseemann@systemli.org>
Tested-by: BuildkiteCI
Reviewed-by: lukegb <lukegb@tvl.fyi>

1 files changed, 359 insertions, 0 deletions

diff --git a/users/aspen/xanthous/src/Xanthous/Game/Prompt.hs b/users/aspen/xanthous/src/Xanthous/Game/Prompt.hs
new file mode 100644
index 000000000000..2d6c0a280f41
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Game/Prompt.hs
@@ -0,0 +1,359 @@
+{-# LANGUAGE DeriveFunctor        #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE StandaloneDeriving   #-}
+{-# LANGUAGE GADTs                #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Prompt
+  ( PromptType(..)
+  , SPromptType(..)
+  , SingPromptType(..)
+  , PromptCancellable(..)
+  , PromptResult(..)
+  , PromptState(..)
+  , promptStatePosition
+  , MenuOption(..)
+  , mkMenuItems
+  , PromptInput
+  , Prompt(..)
+  , mkPrompt
+  , mkStringPrompt
+  , mkStringPromptWithDefault
+  , mkMenu
+  , mkPointOnMapPrompt
+  , mkFirePrompt
+  , 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, AlphaChar (..))
+import           Xanthous.Data (Direction, Position, Tiles)
+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
+  -- | Throw an item or fire a projectile weapon. Prompt is to select the
+  -- direction
+  Fire            :: 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"
+  show Fire = "Fire"
+
+data SPromptType :: PromptType -> Type where
+  SStringPrompt    :: SPromptType 'StringPrompt
+  SConfirm         :: SPromptType 'Confirm
+  SMenu            :: SPromptType ('Menu a)
+  SDirectionPrompt :: SPromptType 'DirectionPrompt
+  SPointOnMap      :: SPromptType 'PointOnMap
+  SContinue        :: SPromptType 'Continue
+  SFire            :: SPromptType 'Fire
+
+instance NFData (SPromptType pt) where
+  rnf SStringPrompt = ()
+  rnf SConfirm = ()
+  rnf SMenu = ()
+  rnf SDirectionPrompt = ()
+  rnf SPointOnMap = ()
+  rnf SContinue = ()
+  rnf SFire = ()
+
+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 SingPromptType 'Fire where singPromptType = SFire
+
+instance Show (SPromptType pt) where
+  show SStringPrompt    = "SStringPrompt"
+  show SConfirm         = "SConfirm"
+  show SMenu            = "SMenu"
+  show SDirectionPrompt = "SDirectionPrompt"
+  show SPointOnMap      = "SPointOnMap"
+  show SContinue        = "SContinue"
+  show SFire            = "SFire"
+
+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
+  FireResult       :: Position  -> PromptResult 'Fire
+  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
+
+instance Arbitrary (PromptResult 'Fire) where
+  arbitrary = FireResult <$> arbitrary
+
+--------------------------------------------------------------------------------
+
+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
+  FirePromptState       :: Position -> PromptState 'Fire
+
+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` ()
+  rnf fps@(FirePromptState pos) = fps `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 Arbitrary (PromptState 'Fire) where
+  arbitrary = FirePromptState <$> arbitrary
+
+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 ()
+
+instance CoArbitrary (PromptState 'Fire) where
+  coarbitrary (FirePromptState pos) = coarbitrary pos
+
+deriving stock instance Show (PromptState pt)
+
+-- | Traversal over the position for the prompt types with positions in their
+-- prompt state (currently 'Fire' and 'PointOnMap')
+promptStatePosition :: forall pt. Traversal' (PromptState pt) Position
+promptStatePosition _ ps@(StringPromptState _) = pure ps
+promptStatePosition _ DirectionPromptState = pure DirectionPromptState
+promptStatePosition _ ContinuePromptState = pure ContinuePromptState
+promptStatePosition _ ConfirmPromptState = pure ConfirmPromptState
+promptStatePosition _ MenuPromptState = pure MenuPromptState
+promptStatePosition f (PointOnMapPromptState p) = PointOnMapPromptState <$> f p
+promptStatePosition f (FirePromptState p) = FirePromptState <$> f p
+
+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 getAlphaChar . smallestNotIn . map AlphaChar $ 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 'Fire         = (Position, Tiles) -- Nearest enemy, range
+  PromptInput 'StringPrompt = Maybe Text -- Default value
+  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)
+  coarbitrary (Prompt c SFire ps pri cb) =
+    variant @Int 7 . 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       -- ^ Is the prompt cancellable or not?
+  -> SPromptType pt          -- ^ The type of the prompt
+  -> (PromptResult pt -> m ()) -- ^ Function to call when the prompt is complete
+  -> Prompt m
+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
+
+mkStringPrompt
+  :: PromptCancellable                  -- ^ Is the prompt cancellable or not?
+  -> (PromptResult 'StringPrompt -> m ()) -- ^ Function to call when the prompt is complete
+  -> Prompt m
+mkStringPrompt c =
+  let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
+  in Prompt c SStringPrompt ps Nothing
+
+mkStringPromptWithDefault
+  :: PromptCancellable                  -- ^ Is the prompt cancellable or not?
+  -> Text                               -- ^ Default value for the prompt
+  -> (PromptResult 'StringPrompt -> m ()) -- ^ Function to call when the prompt is complete
+  -> Prompt m
+mkStringPromptWithDefault c def =
+  let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
+  in Prompt c SStringPrompt ps (Just def)
+
+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
+
+mkFirePrompt
+  :: PromptCancellable
+  -> Position -- ^ Initial position
+  -> Tiles    -- ^ Range
+  -> (PromptResult 'Fire -> m ())
+  -> Prompt m
+mkFirePrompt c pos range = Prompt c SFire (FirePromptState pos) (pos, range)
+
+isCancellable :: Prompt m -> Bool
+isCancellable (Prompt Cancellable _ _ _ _)   = True
+isCancellable (Prompt Uncancellable _ _ _ _) = False
+
+submitPrompt :: Applicative m => Prompt m -> m ()
+submitPrompt (Prompt _ pt ps pri cb) =
+  case (pt, ps, pri) of
+    (SStringPrompt, StringPromptState edit, mDef) ->
+      let inputVal = mconcat . getEditContents $ edit
+          val | null inputVal, Just def <- mDef = def
+              | otherwise = inputVal
+      in cb $ StringResult val
+    (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
+    (SFire, FirePromptState pos, _) ->
+      cb $ FireResult pos