about summary refs log tree commit diff
path: root/users/aspen/xanthous/src/Xanthous/Command.hs
blob: 6e6274a02c6f13cfde9b920948c672cef524bbe7 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
module Xanthous.Command
  ( -- * Commands
    Command(..)
  , commandIsHidden
    -- * Keybindings
  , Keybinding(..)
  , keybindings
  , commands
  , commandFromKey
  , directionFromChar
  ) where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding (Left, Right, Down, try)
--------------------------------------------------------------------------------
import           Graphics.Vty.Input (Key(..), Modifier(..))
import qualified Data.Char as Char
import           Data.Aeson (FromJSON (parseJSON), FromJSONKey, FromJSONKeyFunction (FromJSONKeyTextParser))
import qualified Data.Aeson as A
import           Data.Aeson.Generic.DerivingVia
import           Text.Megaparsec (Parsec, errorBundlePretty, parse, eof, try)
import           Text.Megaparsec.Char (string', char', printChar)
import           Data.FileEmbed (embedFile)
import qualified Data.Yaml as Yaml
import           Test.QuickCheck.Arbitrary
import           Data.Aeson.Types (Parser)
--------------------------------------------------------------------------------
import           Xanthous.Data (Direction(..))
import           Xanthous.Util.QuickCheck (GenericArbitrary(..))
--------------------------------------------------------------------------------

data Command
  = Quit
  | Help
  | Move !Direction
  | StartAutoMove !Direction
  | PreviousMessage
  | PickUp
  | Drop
  | Open
  | Close
  | Wait
  | Eat
  | Look
  | Save
  | Read
  | ShowInventory
  | DescribeInventory
  | Wield
  | Fire
  | GoUp
  | GoDown
  | Rest

    -- | TODO replace with `:` commands
  | ToggleRevealAll
  deriving stock (Show, Eq, Generic)
  deriving anyclass (Hashable, NFData)
  deriving Arbitrary via GenericArbitrary Command
  deriving (FromJSON)
       via WithOptions '[ SumEnc UntaggedVal ]
           Command

-- | Should the command be hidden from the help menu?
--
-- Note that this is true for both debug commands and movement commands, as the
-- latter is documented non-automatically
commandIsHidden :: Command -> Bool
commandIsHidden (Move _) = True
commandIsHidden (StartAutoMove _) = True
commandIsHidden ToggleRevealAll = True
commandIsHidden _ = False

--------------------------------------------------------------------------------

data Keybinding = Keybinding !Key ![Modifier]
  deriving stock (Show, Eq, Generic)
  deriving anyclass (Hashable, NFData)

parseKeybindingFromText :: Text -> Parser Keybinding
parseKeybindingFromText
  = either (fail . errorBundlePretty) pure
  . parse keybinding "<JSON>"
  where
    key :: Parsec Void Text Key
    key = KUp <$ string' "<up>"
      <|> KDown <$ string' "<down>"
      <|> KLeft <$ string' "<left>"
      <|> KRight <$ string' "<right>"
      <|> KChar <$> printChar

    modifier :: Parsec Void Text Modifier
    modifier = modf <* char' '-'
      where
        modf = MAlt <$ char' 'a'
          <|> MMeta <$ char' 'm'
          <|> MCtrl  <$ char' 'c'
          <|> MShift  <$ char' 's'

    keybinding :: Parsec Void Text Keybinding
    keybinding = do
      mods <- many (try modifier)
      k <- key
      eof
      pure $ Keybinding k mods

instance FromJSON Keybinding where
  parseJSON = A.withText "Keybinding" parseKeybindingFromText

instance FromJSONKey Keybinding where
  fromJSONKey = FromJSONKeyTextParser parseKeybindingFromText

rawKeybindings :: ByteString
rawKeybindings = $(embedFile "src/Xanthous/keybindings.yaml")

keybindings :: HashMap Keybinding Command
keybindings = either (error . Yaml.prettyPrintParseException) id
  $ Yaml.decodeEither' rawKeybindings

commands :: HashMap Command Keybinding
commands = mapFromList . map swap . itoList $ keybindings

commandFromKey :: Key -> [Modifier] -> Maybe Command
commandFromKey (KChar (directionFromChar -> Just dir)) [] = Just $ Move dir
commandFromKey (KChar c) []
  | Char.isUpper c
  , Just dir <- directionFromChar $ Char.toLower c
  = Just $ StartAutoMove dir
commandFromKey k mods = keybindings ^. at keybinding
  where keybinding = Keybinding k mods

--------------------------------------------------------------------------------

directionFromChar :: Char -> Maybe Direction
directionFromChar 'h' = Just Left
directionFromChar 'j' = Just Down
directionFromChar 'k' = Just Up
directionFromChar 'l' = Just Right
directionFromChar 'y' = Just UpLeft
directionFromChar 'u' = Just UpRight
directionFromChar 'b' = Just DownLeft
directionFromChar 'n' = Just DownRight
directionFromChar '.' = Just Here
directionFromChar _   = Nothing