diff options
author | Aspen Smith <grfn@gws.fyi> | 2024-02-12T03·00-0500 |
---|---|---|
committer | clbot <clbot@tvl.fyi> | 2024-02-14T19·37+0000 |
commit | 82ecd61f5c699cf3af6c4eadf47a1c52b1d696c6 (patch) | |
tree | 429c5e078528000591742ec3211bc768ae913a78 /users/grfn/xanthous/src/Xanthous/Command.hs | |
parent | 0ba476a4266015f278f18d74094299de74a5a111 (diff) |
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>
Diffstat (limited to 'users/grfn/xanthous/src/Xanthous/Command.hs')
-rw-r--r-- | users/grfn/xanthous/src/Xanthous/Command.hs | 145 |
1 files changed, 0 insertions, 145 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/Command.hs b/users/grfn/xanthous/src/Xanthous/Command.hs deleted file mode 100644 index 6e6274a02c6f..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Command.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# 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 |