From 34cabba896507f2b6523d6aec344ec1c88e453be Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Mon, 11 May 2020 23:03:21 -0400 Subject: Add a very basic, naive auto-move command Add a very basic, naive auto-move command, which just steps the player in a direction until they collide with something, regardless of any surrounding beasties who might want to eat them. There's a lot of other stuff going on here - in order to get this working the way I wanted with a slight (I settled on 50ms) delay between every step in these autocommands while still redrawing in between I had to do all the extra machinery for custom Brick events with a channel, and then at the same time adding the bits for actually executing autocommands in a general fashion (because there will definitely be more!) hit my threshold for size for App.hs which sent me on a big journey to break it up into smaller files -- which seems actually like it was quite successful. Hopefully this will help with compile times too, though App.hs is still pretty slow (maybe more to do here). --- src/Main.hs | 34 ++++-- src/Xanthous/App.hs | 235 ++++----------------------------------- src/Xanthous/App/Autocommands.hs | 44 ++++++++ src/Xanthous/App/Common.hs | 67 +++++++++++ src/Xanthous/App/Prompt.hs | 161 +++++++++++++++++++++++++++ src/Xanthous/App/Time.hs | 40 +++++++ src/Xanthous/Command.hs | 6 + src/Xanthous/Data.hs | 2 +- src/Xanthous/Data/App.hs | 39 +++++++ src/Xanthous/Game/Arbitrary.hs | 2 +- src/Xanthous/Game/Draw.hs | 24 ++-- src/Xanthous/Game/Env.hs | 19 ++++ src/Xanthous/Game/Lenses.hs | 1 + src/Xanthous/Game/Prompt.hs | 17 +-- src/Xanthous/Game/State.hs | 94 ++++++++++++++-- src/Xanthous/Monad.hs | 29 ++++- src/Xanthous/Resource.hs | 31 ------ 17 files changed, 556 insertions(+), 289 deletions(-) create mode 100644 src/Xanthous/App/Autocommands.hs create mode 100644 src/Xanthous/App/Common.hs create mode 100644 src/Xanthous/App/Prompt.hs create mode 100644 src/Xanthous/App/Time.hs create mode 100644 src/Xanthous/Data/App.hs create mode 100644 src/Xanthous/Game/Env.hs delete mode 100644 src/Xanthous/Resource.hs (limited to 'src') diff --git a/src/Main.hs b/src/Main.hs index 95cfc9edbaff..dcd31afff9c7 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,6 +2,8 @@ module Main ( main ) where -------------------------------------------------------------------------------- import Xanthous.Prelude hiding (finally) import Brick +import qualified Brick.BChan +import qualified Graphics.Vty as Vty import qualified Options.Applicative as Opt import System.Random import Control.Monad.Random (getRandom) @@ -9,6 +11,7 @@ import Control.Exception (finally) import System.Exit (die) -------------------------------------------------------------------------------- import qualified Xanthous.Game as Game +import Xanthous.Game.Env (GameEnv(..)) import Xanthous.App import Xanthous.Generators ( GeneratorInput @@ -92,9 +95,8 @@ optParser = Opt.info thanks :: IO () thanks = putStr "\n\n" >> putStrLn "Thanks for playing Xanthous!" -runGame :: RunParams -> IO () -runGame rparams = do - app <- makeApp NewGame +newGame :: RunParams -> IO () +newGame rparams = do gameSeed <- maybe getRandom pure $ seed rparams when (isNothing $ seed rparams) . putStrLn @@ -102,23 +104,33 @@ runGame rparams = do let initialState = Game.initialStateFromSeed gameSeed &~ do for_ (characterName rparams) $ \cn -> Game.character . Character.characterName ?= cn - _game' <- defaultMain app initialState `finally` do - putStr "\n\n" - putStrLn "Thanks for playing Xanthous!" + runGame NewGame initialState `finally` do + thanks when (isNothing $ seed rparams) . putStrLn $ "Seed: " <> tshow gameSeed putStr "\n\n" - pure () loadGame :: FilePath -> IO () loadGame saveFile = do - app <- makeApp LoadGame gameState <- maybe (die "Invalid save file!") pure =<< Game.loadGame . fromStrict <$> readFile @IO saveFile - _game' <- gameState `deepseq` defaultMain app gameState `finally` thanks - pure () + gameState `deepseq` runGame LoadGame gameState +runGame :: RunType -> Game.GameState -> IO () +runGame rt gameState = do + eventChan <- Brick.BChan.newBChan 10 + let gameEnv = GameEnv eventChan + app <- makeApp gameEnv rt + let buildVty = Vty.mkVty Vty.defaultConfig + initialVty <- buildVty + _game' <- customMain + initialVty + buildVty + (Just eventChan) + app + gameState + pure () runGenerate :: GeneratorInput -> Dimensions -> Maybe Int -> IO () runGenerate input dims mSeed = do @@ -139,7 +151,7 @@ runGenerate input dims mSeed = do putStrLn $ showCells res runCommand :: Command -> IO () -runCommand (Run runParams) = runGame runParams +runCommand (Run runParams) = newGame runParams runCommand (Load saveFile) = loadGame saveFile runCommand (Generate input dims mSeed) = runGenerate input dims mSeed diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index f7013076d594..672aa93f6b32 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -9,11 +9,9 @@ module Xanthous.App import Xanthous.Prelude import Brick hiding (App, halt, continue, raw) import qualified Brick -import Brick.Widgets.Edit (handleEditorEvent) import Graphics.Vty.Attributes (defAttr) -import Graphics.Vty.Input.Events (Event(EvKey), Key(..)) -import Control.Monad.State (get, gets, MonadState) -import Control.Monad.Random (MonadRandom) +import Graphics.Vty.Input.Events (Event(EvKey)) +import Control.Monad.State (get, gets) import Control.Monad.State.Class (modify) import Data.Aeson (object, ToJSON) import qualified Data.Aeson as A @@ -21,8 +19,11 @@ import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Vector as V import System.Exit import System.Directory (doesFileExist) -import GHC.TypeLits (TypeError, ErrorMessage(..)) -------------------------------------------------------------------------------- +import Xanthous.App.Common +import Xanthous.App.Time +import Xanthous.App.Prompt +import Xanthous.App.Autocommands import Xanthous.Command import Xanthous.Data ( move @@ -30,20 +31,18 @@ import Xanthous.Data , positioned , position , Position - , Ticks , (|*|) ) -import Xanthous.Data.EntityMap (EntityMap) +import Xanthous.Data.App (ResourceName, Panel(..), AppEvent(..)) import qualified Xanthous.Data.EntityMap as EntityMap import Xanthous.Data.Levels (prevLevel, nextLevel) import qualified Xanthous.Data.Levels as Levels import Xanthous.Data.Entities (blocksObject) import Xanthous.Game import Xanthous.Game.State +import Xanthous.Game.Env import Xanthous.Game.Draw (drawGame) import Xanthous.Game.Prompt -import Xanthous.Monad -import Xanthous.Resource (Name, Panel(..)) import qualified Xanthous.Messages as Messages import Xanthous.Random import Xanthous.Util (removeVectorIndex) @@ -66,24 +65,24 @@ import qualified Xanthous.Generators.CaveAutomata as CaveAutomata import qualified Xanthous.Generators.Dungeon as Dungeon -------------------------------------------------------------------------------- -type App = Brick.App GameState () Name +type App = Brick.App GameState AppEvent ResourceName data RunType = NewGame | LoadGame deriving stock (Eq) -makeApp :: RunType -> IO App -makeApp rt = pure $ Brick.App +makeApp :: GameEnv -> RunType -> IO App +makeApp env rt = pure $ Brick.App { appDraw = drawGame , appChooseCursor = const headMay - , appHandleEvent = \game event -> runAppM (handleEvent event) game + , appHandleEvent = \game event -> runAppM (handleEvent event) env game , appStartEvent = case rt of - NewGame -> runAppM $ startEvent >> get + NewGame -> runAppM (startEvent >> get) env LoadGame -> pure , appAttrMap = const $ attrMap defAttr [] } -runAppM :: AppM a -> GameState -> EventM Name a -runAppM appm = fmap fst . runAppT appm +runAppM :: AppM a -> GameEnv -> GameState -> EventM ResourceName a +runAppM appm ge = fmap fst . runAppT appm ge startEvent :: AppM () startEvent = do @@ -104,39 +103,20 @@ initLevel = do -------------------------------------------------------------------------------- -stepGameBy :: Ticks -> AppM () -stepGameBy ticks = do - ents <- uses entities EntityMap.toEIDsAndPositioned - for_ ents $ \(eid, pEntity) -> do - pEntity' <- step ticks pEntity - entities . ix eid .= pEntity' - - modify updateCharacterVision - - whenM (uses character isDead) - . prompt_ @'Continue ["dead"] Uncancellable - . const . lift . liftIO - $ exitSuccess - -ticksPerTurn :: Ticks -ticksPerTurn = 100 - -stepGame :: AppM () -stepGame = stepGameBy ticksPerTurn - --------------------------------------------------------------------------------- - -handleEvent :: BrickEvent Name () -> AppM (Next GameState) +handleEvent :: BrickEvent ResourceName AppEvent -> AppM (Next GameState) handleEvent ev = use promptState >>= \case NoPrompt -> handleNoPromptEvent ev WaitingPrompt msg pr -> handlePromptEvent msg pr ev -handleNoPromptEvent :: BrickEvent Name () -> AppM (Next GameState) +handleNoPromptEvent :: BrickEvent ResourceName AppEvent -> AppM (Next GameState) handleNoPromptEvent (VtyEvent (EvKey k mods)) | Just command <- commandFromKey k mods = do messageHistory %= nextTurn handleCommand command +handleNoPromptEvent (AppEvent AutoContinue) = do + preuse (autocommand . _ActiveAutocommand . _1) >>= traverse_ autoStep + continue handleNoPromptEvent _ = continue handleCommand :: Command -> AppM (Next GameState) @@ -347,6 +327,10 @@ handleCommand GoDown = do continue +handleCommand (StartAutoMove dir) = do + runAutocommand $ AutoMove dir + continue + -- handleCommand ToggleRevealAll = do @@ -355,177 +339,6 @@ handleCommand ToggleRevealAll = do continue -------------------------------------------------------------------------------- - -handlePromptEvent - :: Text -- ^ Prompt message - -> Prompt AppM - -> BrickEvent Name () - -> AppM (Next GameState) - -handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc [])) - = clearPrompt >> continue -handlePromptEvent _ pr (VtyEvent (EvKey KEnter [])) - = clearPrompt >> submitPrompt pr >> continue - -handlePromptEvent _ pr@(Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'y') [])) - = clearPrompt >> submitPrompt pr >> continue - -handlePromptEvent _ (Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'n') [])) - = clearPrompt >> continue - -handlePromptEvent - msg - (Prompt c SStringPrompt (StringPromptState edit) pri cb) - (VtyEvent ev) - = do - edit' <- lift $ handleEditorEvent ev edit - let prompt' = Prompt c SStringPrompt (StringPromptState edit') pri cb - promptState .= WaitingPrompt msg prompt' - continue - -handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ cb) - (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) [])) - = clearPrompt >> cb (DirectionResult dir) >> continue -handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ _) _ = continue - -handlePromptEvent _ (Prompt _ SMenu _ items' cb) (VtyEvent (EvKey (KChar chr) [])) - | Just (MenuOption _ res) <- items' ^. at chr - = clearPrompt >> cb (MenuResult res) >> continue - | otherwise - = continue - -handlePromptEvent - msg - (Prompt c SPointOnMap (PointOnMapPromptState pos) pri cb) - (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) [])) - = let pos' = move dir pos - prompt' = Prompt c SPointOnMap (PointOnMapPromptState pos') pri cb - in promptState .= WaitingPrompt msg prompt' - >> continue -handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue - -handlePromptEvent - _ - (Prompt Cancellable _ _ _ _) - (VtyEvent (EvKey (KChar 'q') [])) - = clearPrompt >> continue -handlePromptEvent _ _ _ = continue - -clearPrompt :: AppM () -clearPrompt = promptState .= NoPrompt - -class NotMenu (pt :: PromptType) -instance NotMenu 'StringPrompt -instance NotMenu 'Confirm -instance NotMenu 'DirectionPrompt -instance NotMenu 'PointOnMap -instance NotMenu 'Continue -instance TypeError ('Text "Cannot use `prompt` or `prompt_` for menu prompts" - ':$$: 'Text "Use `menu` or `menu_` instead") - => NotMenu ('Menu a) - -prompt - :: forall (pt :: PromptType) (params :: Type). - (ToJSON params, SingPromptType pt, NotMenu pt) - => [Text] -- ^ Message key - -> params -- ^ Message params - -> PromptCancellable - -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler - -> AppM () -prompt msgPath params cancellable cb = do - let pt = singPromptType @pt - msg <- Messages.message msgPath params - p <- case pt of - SPointOnMap -> do - charPos <- use characterPosition - pure $ mkPointOnMapPrompt cancellable charPos cb - SStringPrompt -> pure $ mkPrompt cancellable pt cb - SConfirm -> pure $ mkPrompt cancellable pt cb - SDirectionPrompt -> pure $ mkPrompt cancellable pt cb - SContinue -> pure $ mkPrompt cancellable pt cb - SMenu -> error "unreachable" - promptState .= WaitingPrompt msg p - -prompt_ - :: forall (pt :: PromptType). - (SingPromptType pt, NotMenu pt) - => [Text] -- ^ Message key - -> PromptCancellable - -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler - -> AppM () -prompt_ msg = prompt msg $ object [] - -confirm - :: ToJSON params - => [Text] -- ^ Message key - -> params - -> AppM () - -> AppM () -confirm msgPath params - = prompt @'Confirm msgPath params Cancellable . const - -confirm_ :: [Text] -> AppM () -> AppM () -confirm_ msgPath = confirm msgPath $ object [] - -menu :: forall (a :: Type) (params :: Type). - (ToJSON params) - => [Text] -- ^ Message key - -> params -- ^ Message params - -> PromptCancellable - -> Map Char (MenuOption a) -- ^ Menu items - -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler - -> AppM () -menu msgPath params cancellable items' cb = do - msg <- Messages.message msgPath params - let p = mkMenu cancellable items' cb - promptState .= WaitingPrompt msg p - -menu_ :: forall (a :: Type). - [Text] -- ^ Message key - -> PromptCancellable - -> Map Char (MenuOption a) -- ^ Menu items - -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler - -> AppM () -menu_ msgPath = menu msgPath $ object [] - --------------------------------------------------------------------------------- - -entitiesAtPositionWithType - :: forall a. (Entity a, Typeable a) - => Position - -> EntityMap SomeEntity - -> [(EntityMap.EntityID, a)] -entitiesAtPositionWithType pos em = - let someEnts = EntityMap.atPositionWithIDs pos em - in flip foldMap someEnts $ \(eid, view positioned -> se) -> - case downcastEntity @a se of - Just e -> [(eid, e)] - Nothing -> [] - -describeEntitiesAt :: (MonadState GameState m, MonadRandom m) => Position -> m () -describeEntitiesAt pos = - use ( entities - . EntityMap.atPosition pos - . to (filter (not . entityIs @Character)) - ) >>= \case - Empty -> pure () - ents -> describeEntities ents - -describeEntities - :: ( Entity entity - , MonadRandom m - , MonadState GameState m - , MonoFoldable (f Text) - , Functor f - , Element (f Text) ~ Text - ) - => f entity - -> m () -describeEntities ents = - let descriptions = description <$> ents - in say ["entities", "description"] - $ object ["entityDescriptions" A..= toSentence descriptions] - attackAt :: Position -> AppM () attackAt pos = uses entities (entitiesAtPositionWithType @Creature pos) >>= \case diff --git a/src/Xanthous/App/Autocommands.hs b/src/Xanthous/App/Autocommands.hs new file mode 100644 index 000000000000..e8d94ce741fd --- /dev/null +++ b/src/Xanthous/App/Autocommands.hs @@ -0,0 +1,44 @@ +-------------------------------------------------------------------------------- +module Xanthous.App.Autocommands + ( runAutocommand + , autoStep + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Control.Concurrent (threadDelay) +-------------------------------------------------------------------------------- +import Xanthous.App.Common +import Xanthous.App.Time +import Xanthous.Data +import Xanthous.Data.App +import Xanthous.Entities.Character (speed) +import Xanthous.Game.State +-------------------------------------------------------------------------------- + +autoStep :: Autocommand -> AppM () +autoStep (AutoMove dir) = do + newPos <- uses characterPosition $ move dir + collisionAt newPos >>= \case + Nothing -> do + characterPosition .= newPos + stepGameBy =<< uses (character . speed) (|*| 1) + describeEntitiesAt newPos + Just _ -> cancelAutocommand + +-------------------------------------------------------------------------------- + +autocommandIntervalμs :: Int +autocommandIntervalμs = 1000 * 50 -- 50 ms + +runAutocommand :: Autocommand -> AppM () +runAutocommand ac = do + env <- ask + tid <- liftIO . async $ runReaderT go env + autocommand .= ActiveAutocommand ac tid + where + go = everyμs autocommandIntervalμs $ sendEvent AutoContinue + +-- | Perform 'act' every μs microseconds forever +everyμs :: MonadIO m => Int -> m () -> m () +everyμs μs act = act >> liftIO (threadDelay μs) >> everyμs μs act diff --git a/src/Xanthous/App/Common.hs b/src/Xanthous/App/Common.hs new file mode 100644 index 000000000000..69ba6f0e0596 --- /dev/null +++ b/src/Xanthous/App/Common.hs @@ -0,0 +1,67 @@ +-------------------------------------------------------------------------------- +module Xanthous.App.Common + ( describeEntities + , describeEntitiesAt + , entitiesAtPositionWithType + + -- * Re-exports + , MonadState + , MonadRandom + , EntityMap + , module Xanthous.Game.Lenses + , module Xanthous.Monad + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Data.Aeson (object) +import qualified Data.Aeson as A +import Control.Monad.State (MonadState) +import Control.Monad.Random (MonadRandom) +-------------------------------------------------------------------------------- +import Xanthous.Data (Position, positioned) +import Xanthous.Data.EntityMap (EntityMap) +import qualified Xanthous.Data.EntityMap as EntityMap +import Xanthous.Game +import Xanthous.Game.Lenses +import Xanthous.Game.State +import Xanthous.Monad +import Xanthous.Entities.Character (Character) +import Xanthous.Util.Inflection (toSentence) +-------------------------------------------------------------------------------- + +entitiesAtPositionWithType + :: forall a. (Entity a, Typeable a) + => Position + -> EntityMap SomeEntity + -> [(EntityMap.EntityID, a)] +entitiesAtPositionWithType pos em = + let someEnts = EntityMap.atPositionWithIDs pos em + in flip foldMap someEnts $ \(eid, view positioned -> se) -> + case downcastEntity @a se of + Just e -> [(eid, e)] + Nothing -> [] + +describeEntitiesAt :: (MonadState GameState m, MonadRandom m) => Position -> m () +describeEntitiesAt pos = + use ( entities + . EntityMap.atPosition pos + . to (filter (not . entityIs @Character)) + ) >>= \case + Empty -> pure () + ents -> describeEntities ents + +describeEntities + :: ( Entity entity + , MonadRandom m + , MonadState GameState m + , MonoFoldable (f Text) + , Functor f + , Element (f Text) ~ Text + ) + => f entity + -> m () +describeEntities ents = + let descriptions = description <$> ents + in say ["entities", "description"] + $ object ["entityDescriptions" A..= toSentence descriptions] diff --git a/src/Xanthous/App/Prompt.hs b/src/Xanthous/App/Prompt.hs new file mode 100644 index 000000000000..6704a601da90 --- /dev/null +++ b/src/Xanthous/App/Prompt.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE UndecidableInstances #-} +-------------------------------------------------------------------------------- +module Xanthous.App.Prompt + ( handlePromptEvent + , clearPrompt + , prompt + , prompt_ + , confirm_ + , confirm + , menu + , menu_ + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Brick (BrickEvent(..), Next) +import Brick.Widgets.Edit (handleEditorEvent) +import Data.Aeson (ToJSON, object) +import Graphics.Vty.Input.Events (Event(EvKey), Key(..)) +import GHC.TypeLits (TypeError, ErrorMessage(..)) +-------------------------------------------------------------------------------- +import Xanthous.App.Common +import Xanthous.Data (move) +import Xanthous.Command (directionFromChar) +import Xanthous.Data.App (ResourceName, AppEvent) +import Xanthous.Game.Prompt +import Xanthous.Game.State +import qualified Xanthous.Messages as Messages +-------------------------------------------------------------------------------- + +handlePromptEvent + :: Text -- ^ Prompt message + -> Prompt AppM + -> BrickEvent ResourceName AppEvent + -> AppM (Next GameState) + +handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc [])) + = clearPrompt >> continue +handlePromptEvent _ pr (VtyEvent (EvKey KEnter [])) + = clearPrompt >> submitPrompt pr >> continue + +handlePromptEvent _ pr@(Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'y') [])) + = clearPrompt >> submitPrompt pr >> continue + +handlePromptEvent _ (Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'n') [])) + = clearPrompt >> continue + +handlePromptEvent + msg + (Prompt c SStringPrompt (StringPromptState edit) pri cb) + (VtyEvent ev) + = do + edit' <- lift $ handleEditorEvent ev edit + let prompt' = Prompt c SStringPrompt (StringPromptState edit') pri cb + promptState .= WaitingPrompt msg prompt' + continue + +handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ cb) + (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) [])) + = clearPrompt >> cb (DirectionResult dir) >> continue +handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ _) _ = continue + +handlePromptEvent _ (Prompt _ SMenu _ items' cb) (VtyEvent (EvKey (KChar chr) [])) + | Just (MenuOption _ res) <- items' ^. at chr + = clearPrompt >> cb (MenuResult res) >> continue + | otherwise + = continue + +handlePromptEvent + msg + (Prompt c SPointOnMap (PointOnMapPromptState pos) pri cb) + (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) [])) + = let pos' = move dir pos + prompt' = Prompt c SPointOnMap (PointOnMapPromptState pos') pri cb + in promptState .= WaitingPrompt msg prompt' + >> continue +handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue + +handlePromptEvent + _ + (Prompt Cancellable _ _ _ _) + (VtyEvent (EvKey (KChar 'q') [])) + = clearPrompt >> continue +handlePromptEvent _ _ _ = continue + +clearPrompt :: AppM () +clearPrompt = promptState .= NoPrompt + +class NotMenu (pt :: PromptType) +instance NotMenu 'StringPrompt +instance NotMenu 'Confirm +instance NotMenu 'DirectionPrompt +instance NotMenu 'PointOnMap +instance NotMenu 'Continue +instance TypeError ('Text "Cannot use `prompt` or `prompt_` for menu prompts" + ':$$: 'Text "Use `menu` or `menu_` instead") + => NotMenu ('Menu a) + +prompt + :: forall (pt :: PromptType) (params :: Type). + (ToJSON params, SingPromptType pt, NotMenu pt) + => [Text] -- ^ Message key + -> params -- ^ Message params + -> PromptCancellable + -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler + -> AppM () +prompt msgPath params cancellable cb = do + let pt = singPromptType @pt + msg <- Messages.message msgPath params + p <- case pt of + SPointOnMap -> do + charPos <- use characterPosition + pure $ mkPointOnMapPrompt cancellable charPos cb + SStringPrompt -> pure $ mkPrompt cancellable pt cb + SConfirm -> pure $ mkPrompt cancellable pt cb + SDirectionPrompt -> pure $ mkPrompt cancellable pt cb + SContinue -> pure $ mkPrompt cancellable pt cb + SMenu -> error "unreachable" + promptState .= WaitingPrompt msg p + +prompt_ + :: forall (pt :: PromptType). + (SingPromptType pt, NotMenu pt) + => [Text] -- ^ Message key + -> PromptCancellable + -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler + -> AppM () +prompt_ msg = prompt msg $ object [] + +confirm + :: ToJSON params + => [Text] -- ^ Message key + -> params + -> AppM () + -> AppM () +confirm msgPath params + = prompt @'Confirm msgPath params Cancellable . const + +confirm_ :: [Text] -> AppM () -> AppM () +confirm_ msgPath = confirm msgPath $ object [] + +menu :: forall (a :: Type) (params :: Type). + (ToJSON params) + => [Text] -- ^ Message key + -> params -- ^ Message params + -> PromptCancellable + -> Map Char (MenuOption a) -- ^ Menu items + -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler + -> AppM () +menu msgPath params cancellable items' cb = do + msg <- Messages.message msgPath params + let p = mkMenu cancellable items' cb + promptState .= WaitingPrompt msg p + +menu_ :: forall (a :: Type). + [Text] -- ^ Message key + -> PromptCancellable + -> Map Char (MenuOption a) -- ^ Menu items + -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler + -> AppM () +menu_ msgPath = menu msgPath $ object [] diff --git a/src/Xanthous/App/Time.hs b/src/Xanthous/App/Time.hs new file mode 100644 index 000000000000..b17348f3853e --- /dev/null +++ b/src/Xanthous/App/Time.hs @@ -0,0 +1,40 @@ +-------------------------------------------------------------------------------- +module Xanthous.App.Time + ( stepGame + , stepGameBy + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import System.Exit +-------------------------------------------------------------------------------- +import Xanthous.Data (Ticks) +import Xanthous.App.Prompt +import qualified Xanthous.Data.EntityMap as EntityMap +import Xanthous.Entities.Character (isDead) +import Xanthous.Game.State +import Xanthous.Game.Prompt +import Xanthous.Game.Lenses +import Control.Monad.State (modify) +-------------------------------------------------------------------------------- + + +stepGameBy :: Ticks -> AppM () +stepGameBy ticks = do + ents <- uses entities EntityMap.toEIDsAndPositioned + for_ ents $ \(eid, pEntity) -> do + pEntity' <- step ticks pEntity + entities . ix eid .= pEntity' + + modify updateCharacterVision + + whenM (uses character isDead) + . prompt_ @'Continue ["dead"] Uncancellable + . const . lift . liftIO + $ exitSuccess + +ticksPerTurn :: Ticks +ticksPerTurn = 100 + +stepGame :: AppM () +stepGame = stepGameBy ticksPerTurn diff --git a/src/Xanthous/Command.hs b/src/Xanthous/Command.hs index 2e7e6f1ff566..37025dd37ad2 100644 --- a/src/Xanthous/Command.hs +++ b/src/Xanthous/Command.hs @@ -4,6 +4,7 @@ module Xanthous.Command where import Xanthous.Prelude hiding (Left, Right, Down) -------------------------------------------------------------------------------- import Graphics.Vty.Input (Key(..), Modifier(..)) +import qualified Data.Char as Char -------------------------------------------------------------------------------- import Xanthous.Data (Direction(..)) -------------------------------------------------------------------------------- @@ -11,6 +12,7 @@ import Xanthous.Data (Direction(..)) data Command = Quit | Move Direction + | StartAutoMove Direction | PreviousMessage | PickUp | Drop @@ -33,6 +35,10 @@ commandFromKey :: Key -> [Modifier] -> Maybe Command commandFromKey (KChar 'q') [] = Just Quit commandFromKey (KChar '.') [] = Just Wait commandFromKey (KChar (directionFromChar -> Just dir)) [] = Just $ Move dir +commandFromKey (KChar c) [] + | Char.isUpper c + , Just dir <- directionFromChar $ Char.toLower c + = Just $ StartAutoMove dir commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage commandFromKey (KChar ',') [] = Just PickUp commandFromKey (KChar 'd') [] = Just Drop diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs index ec40b8721122..3cb74bdca9fd 100644 --- a/src/Xanthous/Data.hs +++ b/src/Xanthous/Data.hs @@ -268,7 +268,7 @@ data Direction where DownRight :: Direction Here :: Direction deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (CoArbitrary, Function, NFData) + deriving anyclass (CoArbitrary, Function, NFData, ToJSON, FromJSON, Hashable) deriving Arbitrary via GenericArbitrary Direction instance Opposite Direction where diff --git a/src/Xanthous/Data/App.hs b/src/Xanthous/Data/App.hs new file mode 100644 index 000000000000..0361d2a59ed5 --- /dev/null +++ b/src/Xanthous/Data/App.hs @@ -0,0 +1,39 @@ +-------------------------------------------------------------------------------- +module Xanthous.Data.App + ( Panel(..) + , ResourceName(..) + , AppEvent(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Test.QuickCheck +import Data.Aeson (ToJSON, FromJSON) +-------------------------------------------------------------------------------- +import Xanthous.Util.QuickCheck +-------------------------------------------------------------------------------- + +-- | Enum for "panels" displayed in the game's UI. +data Panel + = InventoryPanel -- ^ A panel displaying the character's inventory + deriving stock (Show, Eq, Ord, Generic, Enum, Bounded) + deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) + deriving Arbitrary via GenericArbitrary Panel + + +data ResourceName + = MapViewport -- ^ The main viewport where we display the game content + | Character -- ^ The character + | MessageBox -- ^ The box where we display messages to the user + | Prompt -- ^ The game's prompt + | Panel Panel -- ^ A panel in the game + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) + deriving Arbitrary via GenericArbitrary ResourceName + +data AppEvent + = AutoContinue -- ^ Continue whatever autocommand has been requested by the + -- user + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) + deriving Arbitrary via GenericArbitrary AppEvent diff --git a/src/Xanthous/Game/Arbitrary.hs b/src/Xanthous/Game/Arbitrary.hs index 886a8c03d786..a1eb789a33c9 100644 --- a/src/Xanthous/Game/Arbitrary.hs +++ b/src/Xanthous/Game/Arbitrary.hs @@ -40,6 +40,7 @@ instance Arbitrary GameState where let _promptState = NoPrompt -- TODO _activePanel <- arbitrary _debugState <- arbitrary + let _autocommand = NoAutocommand pure $ GameState {..} @@ -47,4 +48,3 @@ instance CoArbitrary GameLevel instance Function GameLevel instance CoArbitrary GameState instance Function GameState -deriving newtype instance CoArbitrary (m (a, GameState)) => CoArbitrary (AppT m a) diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs index 659081e5731b..b855ce88e46b 100644 --- a/src/Xanthous/Game/Draw.hs +++ b/src/Xanthous/Game/Draw.hs @@ -10,6 +10,8 @@ import Brick.Widgets.Border.Style import Brick.Widgets.Edit -------------------------------------------------------------------------------- import Xanthous.Data +import Xanthous.Data.App (ResourceName, Panel(..)) +import qualified Xanthous.Data.App as Resource import Xanthous.Data.EntityMap (EntityMap, atPosition) import qualified Xanthous.Data.EntityMap as EntityMap import Xanthous.Game.State @@ -29,12 +31,10 @@ import Xanthous.Game , debugState, allRevealed ) import Xanthous.Game.Prompt -import Xanthous.Resource (Name, Panel(..)) -import qualified Xanthous.Resource as Resource import Xanthous.Orphans () -------------------------------------------------------------------------------- -cursorPosition :: GameState -> Widget Name -> Widget Name +cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName cursorPosition game | WaitingPrompt _ (Prompt _ SPointOnMap (PointOnMapPromptState pos) _ _) <- game ^. promptState @@ -42,10 +42,10 @@ cursorPosition game | otherwise = showCursor Resource.Character (game ^. characterPosition . loc) -drawMessages :: MessageHistory -> Widget Name +drawMessages :: MessageHistory -> Widget ResourceName drawMessages = txtWrap . (<> " ") . unwords . reverse . oextract -drawPromptState :: GamePromptState m -> Widget Name +drawPromptState :: GamePromptState m -> Widget ResourceName drawPromptState NoPrompt = emptyWidget drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) = case (pt, ps, pri) of @@ -67,7 +67,7 @@ drawEntities -> (Position -> Bool) -- ^ Has a given position *ever* been seen by the character? -> EntityMap SomeEntity -- ^ all entities - -> Widget Name + -> Widget ResourceName drawEntities isVisible isRevealed allEnts = vBox rows where @@ -90,7 +90,7 @@ drawEntities isVisible isRevealed allEnts $ maximumBy (compare `on` drawPriority) <$> fromNullable ents -drawMap :: GameState -> Widget Name +drawMap :: GameState -> Widget ResourceName drawMap game = viewport Resource.MapViewport Both . cursorPosition game @@ -106,7 +106,7 @@ drawMap game bullet :: Char bullet = '•' -drawInventoryPanel :: GameState -> Widget Name +drawInventoryPanel :: GameState -> Widget ResourceName drawInventoryPanel game = drawWielded (game ^. character . inventory . wielded) <=> drawBackpack (game ^. character . inventory . backpack) @@ -122,7 +122,7 @@ drawInventoryPanel game ) <=> txt " " - drawBackpack :: Vector Item -> Widget Name + drawBackpack :: Vector Item -> Widget ResourceName drawBackpack Empty = txtWrap "Your backpack is empty right now." drawBackpack backpackItems = txtWrap ( "You are currently carrying the following items in your " @@ -134,7 +134,7 @@ drawInventoryPanel game backpackItems) -drawPanel :: GameState -> Panel -> Widget Name +drawPanel :: GameState -> Panel -> Widget ResourceName drawPanel game panel = border . hLimit 35 @@ -143,7 +143,7 @@ drawPanel game panel InventoryPanel -> drawInventoryPanel $ game -drawCharacterInfo :: Character -> Widget Name +drawCharacterInfo :: Character -> Widget ResourceName drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints where charName | Just n <- ch ^. characterName @@ -154,7 +154,7 @@ drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints = txt "Hitpoints: " <+> txt (tshow $ let Hitpoints hp = characterHitpoints ch in hp) -drawGame :: GameState -> [Widget Name] +drawGame :: GameState -> [Widget ResourceName] drawGame game = pure . withBorderStyle unicode diff --git a/src/Xanthous/Game/Env.hs b/src/Xanthous/Game/Env.hs new file mode 100644 index 000000000000..6e10d0f73581 --- /dev/null +++ b/src/Xanthous/Game/Env.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Game.Env + ( GameEnv(..) + , eventChan + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Brick.BChan (BChan) +import Xanthous.Data.App (AppEvent) +-------------------------------------------------------------------------------- + +data GameEnv = GameEnv + { _eventChan :: BChan AppEvent + } + deriving stock (Generic) +makeLenses ''GameEnv +{-# ANN GameEnv ("HLint: ignore Use newtype instead of data" :: String) #-} diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs index 017d53652c4f..48b7235d2263 100644 --- a/src/Xanthous/Game/Lenses.hs +++ b/src/Xanthous/Game/Lenses.hs @@ -56,6 +56,7 @@ initialStateFromSeed seed = _debugState = DebugState { _allRevealed = False } + _autocommand = NoAutocommand in GameState {..} diff --git a/src/Xanthous/Game/Prompt.hs b/src/Xanthous/Game/Prompt.hs index e89cf5bee3d0..30b5fe7545e0 100644 --- a/src/Xanthous/Game/Prompt.hs +++ b/src/Xanthous/Game/Prompt.hs @@ -30,8 +30,8 @@ import Test.QuickCheck.Arbitrary.Generic -------------------------------------------------------------------------------- import Xanthous.Util (smallestNotIn) import Xanthous.Data (Direction, Position) -import Xanthous.Resource (Name) -import qualified Xanthous.Resource as Resource +import Xanthous.Data.App (ResourceName) +import qualified Xanthous.Data.App as Resource -------------------------------------------------------------------------------- data PromptType where @@ -120,12 +120,13 @@ instance Arbitrary (PromptResult 'Continue) where -------------------------------------------------------------------------------- data PromptState pt where - StringPromptState :: Editor Text Name -> PromptState 'StringPrompt - DirectionPromptState :: PromptState 'DirectionPrompt - ContinuePromptState :: PromptState 'Continue - ConfirmPromptState :: PromptState 'Confirm - MenuPromptState :: forall a. PromptState ('Menu a) - PointOnMapPromptState :: Position -> PromptState 'PointOnMap + 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` () diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs index 80137df7a721..f614cad47339 100644 --- a/src/Xanthous/Game/State.hs +++ b/src/Xanthous/Game/State.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TemplateHaskell #-} @@ -14,6 +15,7 @@ module Xanthous.Game.State , activePanel , promptState , characterEntityID + , autocommand , GamePromptState(..) -- * Game Level @@ -31,9 +33,16 @@ module Xanthous.Game.State , previousMessage , nextTurn + -- * Autocommands + , Autocommand(..) + , AutocommandState(..) + , _NoAutocommand + , _ActiveAutocommand + -- * App monad , AppT(..) , AppM + , runAppT -- * Entities , Draw(..) @@ -73,9 +82,11 @@ import Data.Coerce import System.Random import Test.QuickCheck import Test.QuickCheck.Arbitrary.Generic -import Control.Monad.State.Class -import Control.Monad.State import Control.Monad.Random.Class +import Control.Monad.State +import Control.Monad.Trans.Control (MonadTransControl(..)) +import Control.Monad.Trans.Compose +import Control.Monad.Morph (MFunctor(..)) import Brick (EventM, Widget, raw, str, emptyWidget) import Data.Aeson (ToJSON(..), FromJSON(..), Value(Null)) import qualified Data.Aeson as JSON @@ -87,6 +98,7 @@ import qualified Graphics.Vty.Image as Vty import Xanthous.Util (KnownBool(..)) import Xanthous.Util.QuickCheck (GenericArbitrary(..)) import Xanthous.Data +import Xanthous.Data.App import Xanthous.Data.Levels import Xanthous.Data.EntityMap (EntityMap, EntityID) import Xanthous.Data.EntityChar @@ -94,7 +106,7 @@ import Xanthous.Data.VectorBag import Xanthous.Data.Entities import Xanthous.Orphans () import Xanthous.Game.Prompt -import Xanthous.Resource +import Xanthous.Game.Env -------------------------------------------------------------------------------- data MessageHistory @@ -182,15 +194,21 @@ instance Function (GamePromptState m) where -------------------------------------------------------------------------------- newtype AppT m a - = AppT { unAppT :: StateT GameState m a } + = AppT { unAppT :: ReaderT GameEnv (StateT GameState m) a } deriving ( Functor , Applicative , Monad , MonadState GameState + , MonadReader GameEnv + , MonadIO + ) + via (ReaderT GameEnv (StateT GameState m)) + deriving ( MonadTrans + , MFunctor ) - via (StateT GameState m) + via (ReaderT GameEnv `ComposeT` StateT GameState) -type AppM = AppT (EventM Name) +type AppM = AppT (EventM ResourceName) -------------------------------------------------------------------------------- @@ -414,6 +432,50 @@ data GameLevel = GameLevel -------------------------------------------------------------------------------- +data Autocommand + = AutoMove Direction + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, Hashable, ToJSON, FromJSON, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary Autocommand +{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} + +data AutocommandState + = NoAutocommand + | ActiveAutocommand Autocommand (Async ()) + deriving stock (Eq, Ord, Generic) + deriving anyclass (Hashable) + +instance Show AutocommandState where + show NoAutocommand = "NoAutocommand" + show (ActiveAutocommand ac _) = + "(ActiveAutocommand " <> show ac <> " )" + +instance ToJSON AutocommandState where + toJSON = const Null + +instance FromJSON AutocommandState where + parseJSON Null = pure NoAutocommand + parseJSON _ = fail "Invalid AutocommandState; expected null" + +instance NFData AutocommandState where + rnf NoAutocommand = () + rnf (ActiveAutocommand ac t) = ac `deepseq` t `seq` () + +instance CoArbitrary AutocommandState where + coarbitrary NoAutocommand = variant @Int 1 + coarbitrary (ActiveAutocommand ac t) + = variant @Int 2 + . coarbitrary ac + . coarbitrary (hash t) + +instance Function AutocommandState where + function = functionMap onlyNoAC (const NoAutocommand) + where + onlyNoAC NoAutocommand = () + onlyNoAC _ = error "Can't handle autocommands in Function" + +-------------------------------------------------------------------------------- + data DebugState = DebugState { _allRevealed :: !Bool @@ -439,6 +501,7 @@ data GameState = GameState , _promptState :: !(GamePromptState AppM) , _debugState :: !DebugState + , _autocommand :: !AutocommandState } deriving stock (Show, Generic) deriving anyclass (NFData) @@ -467,8 +530,12 @@ instance Eq GameState where -------------------------------------------------------------------------------- -instance MonadTrans AppT where - lift = AppT . lift +runAppT :: Monad m => AppT m a -> GameEnv -> GameState -> m (a, GameState) +runAppT appt env initialState + = flip runStateT initialState + . flip runReaderT env + . unAppT + $ appt instance (Monad m) => MonadRandom (AppT m) where getRandomR rng = randomGen %%= randomR rng @@ -476,9 +543,16 @@ instance (Monad m) => MonadRandom (AppT m) where getRandomRs rng = uses randomGen $ randomRs rng getRandoms = uses randomGen randoms -instance (MonadIO m) => MonadIO (AppT m) where - liftIO = lift . liftIO +instance MonadTransControl AppT where + type StT AppT a = (a, GameState) + liftWith f + = AppT + . ReaderT $ \e + -> StateT $ \s + -> (,s) <$> f (\action -> runAppT action e s) + restoreT = AppT . ReaderT . const . StateT . const -------------------------------------------------------------------------------- makeLenses ''DebugState +makePrisms ''AutocommandState diff --git a/src/Xanthous/Monad.hs b/src/Xanthous/Monad.hs index 1138a7a5a09b..db602de56f3a 100644 --- a/src/Xanthous/Monad.hs +++ b/src/Xanthous/Monad.hs @@ -5,12 +5,19 @@ module Xanthous.Monad , runAppT , continue , halt + -- * Messages , say , say_ , message , message_ , writeMessage + + -- * Autocommands + , cancelAutocommand + + -- * Events + , sendEvent ) where -------------------------------------------------------------------------------- import Xanthous.Prelude @@ -18,16 +25,16 @@ import Control.Monad.Random import Control.Monad.State import qualified Brick import Brick (EventM, Next) -import Data.Aeson +import Brick.BChan (writeBChan) +import Data.Aeson (ToJSON, object) -------------------------------------------------------------------------------- +import Xanthous.Data.App (AppEvent) import Xanthous.Game.State +import Xanthous.Game.Env import Xanthous.Messages (Message) import qualified Xanthous.Messages as Messages -------------------------------------------------------------------------------- -runAppT :: Monad m => AppT m a -> GameState -> m (a, GameState) -runAppT appt initialState = flip runStateT initialState . unAppT $ appt - halt :: AppT (EventM n) (Next GameState) halt = lift . Brick.halt =<< get @@ -53,3 +60,17 @@ message_ msg = message msg $ object [] writeMessage :: MonadState GameState m => Text -> m () writeMessage m = messageHistory %= pushMessage m + +-- | Cancel the currently active autocommand, if any +cancelAutocommand :: (MonadState GameState m, MonadIO m) => m () +cancelAutocommand = do + traverse_ (liftIO . cancel . snd) =<< preuse (autocommand . _ActiveAutocommand) + autocommand .= NoAutocommand + +-------------------------------------------------------------------------------- + +-- | Send an event to the app in an environment where the game env is available +sendEvent :: (MonadReader GameEnv m, MonadIO m) => AppEvent -> m () +sendEvent evt = do + ec <- view eventChan + liftIO $ writeBChan ec evt diff --git a/src/Xanthous/Resource.hs b/src/Xanthous/Resource.hs deleted file mode 100644 index cc2fc97a1464..000000000000 --- a/src/Xanthous/Resource.hs +++ /dev/null @@ -1,31 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Resource - ( Panel(..) - , Name(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Test.QuickCheck -import Data.Aeson (ToJSON, FromJSON) --------------------------------------------------------------------------------- -import Xanthous.Util.QuickCheck --------------------------------------------------------------------------------- - --- | Enum for "panels" displayed in the game's UI. -data Panel - = InventoryPanel -- ^ A panel displaying the character's inventory - deriving stock (Show, Eq, Ord, Generic, Enum, Bounded) - deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) - deriving Arbitrary via GenericArbitrary Panel - - -data Name - = MapViewport -- ^ The main viewport where we display the game content - | Character -- ^ The character - | MessageBox -- ^ The box where we display messages to the user - | Prompt -- ^ The game's prompt - | Panel Panel -- ^ A panel in the game - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) - deriving Arbitrary via GenericArbitrary Name -- cgit 1.4.1