snix/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs

{-# 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