From 55fde272852790886e0d37035355cd8c01a05480 Mon Sep 17 00:00:00 2001 From: Geometer1729 <16kuhnb@gmail.com> Date: Sun, 16 Apr 2023 16:50:49 -0400 Subject: [PATCH] format --- bench/Bench.hs | 2 +- dice-bot-0.1.0.0.tar.gz | 1 + dice-bot.cabal | 4 +- src/Dist.hs | 3 +- src/Main.hs | 253 +++++++++++++++++++++------------------- src/Response.hs | 70 +++++------ src/RollM.hs | 2 +- src/Stats.hs | 18 +-- 8 files changed, 186 insertions(+), 167 deletions(-) create mode 120000 dice-bot-0.1.0.0.tar.gz diff --git a/bench/Bench.hs b/bench/Bench.hs index fb7f674..2f60845 100644 --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -1,10 +1,10 @@ import Criterion.Main +import Control.Monad (liftM2) import Data.Maybe (fromJust) import Dist (Dist, expected, range, times) import Parser (parseRoll) import Stats (getExpected) -import Control.Monad (liftM2) benchExp :: Text -> Benchmark benchExp w = bench (toString w) $ nf (fmap getExpected) (parseRoll w) diff --git a/dice-bot-0.1.0.0.tar.gz b/dice-bot-0.1.0.0.tar.gz new file mode 120000 index 0000000..3b884e3 --- /dev/null +++ b/dice-bot-0.1.0.0.tar.gz @@ -0,0 +1 @@ +/nix/store/1sdymwc5spw978awcl5rlcx58ng1w5sa-dice-bot-0.1.0.0.tar.gz \ No newline at end of file diff --git a/dice-bot.cabal b/dice-bot.cabal index c3042df..1f13c3d 100644 --- a/dice-bot.cabal +++ b/dice-bot.cabal @@ -38,12 +38,12 @@ common shared relude default-extensions: - DeriveAnyClass NoStarIsType BangPatterns ConstraintKinds DataKinds DeriveAnyClass + DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor @@ -107,8 +107,8 @@ common shared other-modules: Dist Parser - Response RefTable + Response RollM Sample Stats diff --git a/src/Dist.hs b/src/Dist.hs index 43c8b1d..41ffe42 100644 --- a/src/Dist.hs +++ b/src/Dist.hs @@ -47,7 +47,8 @@ instance Applicative Dist where instance Monad Dist where {-# INLINE (>>=) #-} - x >>= f = msimple $ Dist $ do + x >>= f = msimple $ + Dist $ do (x', p1) <- unDist x (y, p2) <- unDist $ f x' pure (y, p1 * p2) diff --git a/src/Main.hs b/src/Main.hs index 25d1b87..d1f9555 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,19 +1,17 @@ module Main where +import Control.Arrow (right) +import Data.Text qualified as T import Discord import Discord.Interactions import Discord.Internal.Rest.ApplicationCommands import Discord.Types - -import Data.Text qualified as T - -import Control.Arrow (right) import Flow ((.>)) import Parser (parseRoll) import RefTable (RefTable, maybeMakeRef, maybeUnRef, newRefTable) +import Response (Response, followUp, mkInteractionHandler, rc, rc_, respond) import Sample (rollIO) import Stats (genReport) -import Response (Response, respond, followUp, mkInteractionHandler, rc, rc_) main :: IO () main = do @@ -34,35 +32,36 @@ main = do coms :: [CreateApplicationCommand] coms = - [ simpleCommand "r" "roll some dice" $ Just $ - OptionsValues - [ exprOption - , OptionValueInteger - { optionValueName = "times" - , optionValueLocalizedName = Nothing - , optionValueDescription = "time number of times to roll it" - , optionValueLocalizedDescription = Nothing - , optionValueRequired = False - , optionValueIntegerChoices = Left False - , optionValueIntegerMinVal = Just 1 - , optionValueIntegerMaxVal = Nothing - } - ] + [ simpleCommand "r" "roll some dice" $ + Just $ + OptionsValues + [ exprOption + , OptionValueInteger + { optionValueName = "times" + , optionValueLocalizedName = Nothing + , optionValueDescription = "time number of times to roll it" + , optionValueLocalizedDescription = Nothing + , optionValueRequired = False + , optionValueIntegerChoices = Left False + , optionValueIntegerMinVal = Just 1 + , optionValueIntegerMaxVal = Nothing + } + ] , simpleCommand "stats" "get stats info" $ - Just $ - OptionsValues - [ exprOption - , OptionValueInteger - { optionValueName = "result" - , optionValueLocalizedName = Nothing - , optionValueDescription = "the result" - , optionValueLocalizedDescription = Nothing - , optionValueRequired = True - , optionValueIntegerChoices = Left False - , optionValueIntegerMinVal = Nothing - , optionValueIntegerMaxVal = Nothing - } - ] + Just $ + OptionsValues + [ exprOption + , OptionValueInteger + { optionValueName = "result" + , optionValueLocalizedName = Nothing + , optionValueDescription = "the result" + , optionValueLocalizedDescription = Nothing + , optionValueRequired = True + , optionValueIntegerChoices = Left False + , optionValueIntegerMinVal = Nothing + , optionValueIntegerMaxVal = Nothing + } + ] , simpleCommand "help" "send help text" Nothing ] @@ -71,10 +70,10 @@ handler rt = \case Ready _ _ _ _ _ _ (PartialApplication i _) -> do putStrLn "ready" oldComs <- rc $ GetGlobalApplicationCommands i - let removedComs - = Prelude.filter - (\c -> applicationCommandName c `notElem` (createName <$> coms)) - oldComs + let removedComs = + Prelude.filter + (\c -> applicationCommandName c `notElem` (createName <$> coms)) + oldComs forM_ removedComs $ rc_ . DeleteGlobalApplicationCommand i . applicationCommandId forM_ coms $ rc . CreateGlobalApplicationCommand i putStrLn "commands registered" @@ -82,62 +81,69 @@ handler rt = \case mkInteractionHandler interaction $ case interaction of ( InteractionApplicationCommand - { applicationCommandData = - ApplicationCommandDataChatInput - { applicationCommandDataName = name - , optionsData = options - } - } + { applicationCommandData = + ApplicationCommandDataChatInput + { applicationCommandDataName = name + , optionsData = options + } + } ) -> case name of - "help" -> - respond - $ interactionResponseBasic - $ "/help prints this\n" - <> "/r rolls an expression\n" - <> helpText - "stats" -> - case options of - (Just (OptionsDataValues - [ OptionDataValueString _ (Right expr) - , OptionDataValueInteger _ (Right result) - ] - )) -> stats (fromInteger result) expr - _ -> putStrLn $ "Bad options for stats:" <> show options - "r" -> - case options of - (Just (OptionsDataValues - [ OptionDataValueString _ (Right expr)] - )) -> rollExpr rt Nothing expr - (Just (OptionsDataValues - [ OptionDataValueString _ (Right expr) - , OptionDataValueInteger _ (Right times) - ] - )) -> rollExpr rt (Just $ fromInteger times) expr - _ -> putStrLn $ "Bad options for r: " <> show options - com -> putStrLn $ "bad command: " <> show com - ( InteractionComponent{componentData = ButtonData button } - ) -> maybeUnRef rt button >>= \case - (T.stripPrefix "roll:" -> Just expr) -> do - rollExpr rt Nothing expr - (T.stripPrefix "rollt:" -> Just rest) -> do - let (times', T.tail -> expr) = T.breakOn ":" rest - case readMaybe $ toString times' of - Just times -> do - rollExpr rt (Just times) expr - Nothing -> die "failed to parse times in rollt" - (T.stripPrefix "logs:" -> Just logs) -> do - respond $ interactionResponseBasic logs - (T.stripPrefix "stats:" -> Just rest) -> do - let (res', T.tail -> expr) = T.breakOn "," rest - res <- case readMaybe $ toString res' of - Nothing -> die "failed to read res in stats" - Just res -> pure res - stats res expr - (T.stripPrefix "err:" -> Just msg) -> - respond $ interactionResponseBasic - msg - _ -> die $ toString $ "unexpected button data:" <> button + "help" -> + respond $ + interactionResponseBasic $ + "/help prints this\n" + <> "/r rolls an expression\n" + <> helpText + "stats" -> + case options of + ( Just + ( OptionsDataValues + [ OptionDataValueString _ (Right expr) + , OptionDataValueInteger _ (Right result) + ] + ) + ) -> stats (fromInteger result) expr + _ -> putStrLn $ "Bad options for stats:" <> show options + "r" -> + case options of + ( Just + ( OptionsDataValues + [OptionDataValueString _ (Right expr)] + ) + ) -> rollExpr rt Nothing expr + ( Just + ( OptionsDataValues + [ OptionDataValueString _ (Right expr) + , OptionDataValueInteger _ (Right times) + ] + ) + ) -> rollExpr rt (Just $ fromInteger times) expr + _ -> putStrLn $ "Bad options for r: " <> show options + com -> putStrLn $ "bad command: " <> show com + (InteractionComponent {componentData = ButtonData button}) -> + maybeUnRef rt button >>= \case + (T.stripPrefix "roll:" -> Just expr) -> do + rollExpr rt Nothing expr + (T.stripPrefix "rollt:" -> Just rest) -> do + let (times', T.tail -> expr) = T.breakOn ":" rest + case readMaybe $ toString times' of + Just times -> do + rollExpr rt (Just times) expr + Nothing -> die "failed to parse times in rollt" + (T.stripPrefix "logs:" -> Just logs) -> do + respond $ interactionResponseBasic logs + (T.stripPrefix "stats:" -> Just rest) -> do + let (res', T.tail -> expr) = T.breakOn "," rest + res <- case readMaybe $ toString res' of + Nothing -> die "failed to read res in stats" + Just res -> pure res + stats res expr + (T.stripPrefix "err:" -> Just msg) -> + respond $ + interactionResponseBasic + msg + _ -> die $ toString $ "unexpected button data:" <> button i -> do putStrLn "unhandled interaction" print i @@ -167,8 +173,9 @@ rollExpr :: RefTable -> Maybe Int -> Text -> Response () rollExpr rt times expr = case parseRoll expr of Left _ -> - respond $ interactionResponseBasic - $ "Failed to parse: " <> expr <> "\n\n" <> helpText + respond $ + interactionResponseBasic $ + "Failed to parse: " <> expr <> "\n\n" <> helpText Right roll -> do (res' :: Either Text (Text, Text)) <- case times of Nothing -> rollIO roll <&> right (first (show @Text)) @@ -181,24 +188,30 @@ rollExpr rt times expr = case times of Nothing -> "roll:" Just t -> "rollt:" <> show t <> ":" - buttons <- mapM (uncurry $ genButton rt) - [("Reroll",rollPrefix <> expr) - ,("How?","logs:" <> (if logs == "" then "It was a constant." else logs)) - ,("Stats","stats:" <> res <> "," <> expr) - ] - respond - $ InteractionResponseChannelMessage - $ InteractionResponseMessage - { interactionResponseMessageTTS = Nothing - , interactionResponseMessageContent = - Just $ expr <> "= **" <> res <> "**" - , interactionResponseMessageEmbeds = Nothing - , interactionResponseMessageAllowedMentions = Nothing - , interactionResponseMessageFlags = Nothing - , interactionResponseMessageComponents = - Just [ ActionRowButtons buttons ] - , interactionResponseMessageAttachments = Nothing - } + buttons <- + mapM + (uncurry $ genButton rt) + [ ("Reroll", rollPrefix <> expr) + , + ( "How?" + , "logs:" + <> (if logs == "" then "It was a constant." else logs) + ) + , ("Stats", "stats:" <> res <> "," <> expr) + ] + respond $ + InteractionResponseChannelMessage $ + InteractionResponseMessage + { interactionResponseMessageTTS = Nothing + , interactionResponseMessageContent = + Just $ expr <> "= **" <> res <> "**" + , interactionResponseMessageEmbeds = Nothing + , interactionResponseMessageAllowedMentions = Nothing + , interactionResponseMessageFlags = Nothing + , interactionResponseMessageComponents = + Just [ActionRowButtons buttons] + , interactionResponseMessageAttachments = Nothing + } stats :: Int -> Text -> Response () stats res expr = do @@ -232,16 +245,16 @@ genButton rt label msg = do pure $ simpleButton msg' label simpleCommand :: Text -> Text -> Maybe Options -> CreateApplicationCommand -simpleCommand name desc opts= +simpleCommand name desc opts = CreateApplicationCommandChatInput - { createName = name - , createLocalizedName = Nothing - , createDescription = desc - , createLocalizedDescription = Nothing - , createOptions = opts - , createDefaultMemberPermissions = Nothing - , createDMPermission = Nothing - } + { createName = name + , createLocalizedName = Nothing + , createDescription = desc + , createLocalizedDescription = Nothing + , createOptions = opts + , createDefaultMemberPermissions = Nothing + , createDMPermission = Nothing + } exprOption :: OptionValue exprOption = diff --git a/src/Response.hs b/src/Response.hs index de03d34..2496f2f 100644 --- a/src/Response.hs +++ b/src/Response.hs @@ -1,25 +1,25 @@ -module Response - (Response - ,respond - ,followUp - ,mkInteractionHandler - ,rc - ,rc_ - ) where +module Response ( + Response, + respond, + followUp, + mkInteractionHandler, + rc, + rc_, +) where -import Discord (DiscordHandler, Request, FromJSON, restCall) -import Discord.Types (InteractionId, InteractionToken, ApplicationId) -import Discord.Interactions (InteractionResponse, InteractionResponseMessage, Interaction (..)) -import Discord.Requests (InteractionResponseRequest(..)) +import Discord (DiscordHandler, FromJSON, Request, restCall) +import Discord.Interactions (Interaction (..), InteractionResponse, InteractionResponseMessage) +import Discord.Requests (InteractionResponseRequest (..)) +import Discord.Types (ApplicationId, InteractionId, InteractionToken) - -newtype Response a = Response - (ReaderT Info DiscordHandler a) +newtype Response a + = Response + (ReaderT Info DiscordHandler a) deriving newtype - (Functor - ,Applicative - ,Monad - ,MonadIO + ( Functor + , Applicative + , Monad + , MonadIO ) data Info = Info @@ -29,8 +29,9 @@ data Info = Info } mkInteractionHandler :: Interaction -> Response () -> DiscordHandler () -mkInteractionHandler interaction (Response r) - = runReaderT r +mkInteractionHandler interaction (Response r) = + runReaderT + r Info { infoInteractionId = interactionId interaction , infoInteractionToken = interactionToken interaction @@ -39,21 +40,23 @@ mkInteractionHandler interaction (Response r) respond :: InteractionResponse -> Response () respond ir = Response $ do - Info{..} <- ask - lift $ rc_ $ - CreateInteractionResponse - infoInteractionId - infoInteractionToken - ir + Info {..} <- ask + lift $ + rc_ $ + CreateInteractionResponse + infoInteractionId + infoInteractionToken + ir followUp :: InteractionResponseMessage -> Response () followUp irm = Response $ do - Info{..} <- ask - lift $ rc_ $ - CreateFollowupInteractionMessage - infoInteractionApplicationId - infoInteractionToken - irm + Info {..} <- ask + lift $ + rc_ $ + CreateFollowupInteractionMessage + infoInteractionApplicationId + infoInteractionToken + irm rc_ :: (Request (r a), FromJSON a) => r a -> DiscordHandler () rc_ = void . rc @@ -63,4 +66,3 @@ rc a = restCall a >>= \case Right r -> pure r Left err -> die $ show err - diff --git a/src/RollM.hs b/src/RollM.hs index 5bb8c4e..367d8dc 100644 --- a/src/RollM.hs +++ b/src/RollM.hs @@ -29,7 +29,7 @@ rollDice = cataM $ \case SubF a b -> pure $ a - b SOSF a b -> do log $ show a <> "d10" <> "= " - a `times'` (\r -> if r >= b then 1 else 0) $ rollSmpl 10 RerollOpts{best=Nothing,under=Nothing} + a `times'` (\r -> if r >= b then 1 else 0) $ rollSmpl 10 RerollOpts {best = Nothing, under = Nothing} DF o a b -> do log $ case a of 1 -> "d" <> show b <> show o <> "= " diff --git a/src/Stats.hs b/src/Stats.hs index f86c959..c34fc47 100644 --- a/src/Stats.hs +++ b/src/Stats.hs @@ -45,14 +45,16 @@ genReport ro res = liftIO $ do threadDelay 60_000_000 putMVar reportVar Nothing takeMVar reportVar >>= \case - Nothing -> pure $ Left $ - takeMVar reportVar >>= \case - Just r -> do - killThread waitPid - pure $ Just r - Nothing -> do - killThread computePid - pure Nothing + Nothing -> + pure $ + Left $ + takeMVar reportVar >>= \case + Just r -> do + killThread waitPid + pure $ Just r + Nothing -> do + killThread computePid + pure Nothing Just r -> do killThread waitPid pure $ Right r