Skip to content

Commit 55fde27

Browse files
Geometer1729Geometer1729
committedApr 16, 2023
format
1 parent 3314b49 commit 55fde27

8 files changed

+186
-167
lines changed
 

‎bench/Bench.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,10 @@
11
import Criterion.Main
22

3+
import Control.Monad (liftM2)
34
import Data.Maybe (fromJust)
45
import Dist (Dist, expected, range, times)
56
import Parser (parseRoll)
67
import Stats (getExpected)
7-
import Control.Monad (liftM2)
88

99
benchExp :: Text -> Benchmark
1010
benchExp w = bench (toString w) $ nf (fmap getExpected) (parseRoll w)

‎dice-bot-0.1.0.0.tar.gz

+1
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
/nix/store/1sdymwc5spw978awcl5rlcx58ng1w5sa-dice-bot-0.1.0.0.tar.gz

‎dice-bot.cabal

+2-2
Original file line numberDiff line numberDiff line change
@@ -38,12 +38,12 @@ common shared
3838
relude
3939

4040
default-extensions:
41-
DeriveAnyClass
4241
NoStarIsType
4342
BangPatterns
4443
ConstraintKinds
4544
DataKinds
4645
DeriveAnyClass
46+
DeriveAnyClass
4747
DeriveDataTypeable
4848
DeriveFoldable
4949
DeriveFunctor
@@ -107,8 +107,8 @@ common shared
107107
other-modules:
108108
Dist
109109
Parser
110-
Response
111110
RefTable
111+
Response
112112
RollM
113113
Sample
114114
Stats

‎src/Dist.hs

+2-1
Original file line numberDiff line numberDiff line change
@@ -47,7 +47,8 @@ instance Applicative Dist where
4747

4848
instance Monad Dist where
4949
{-# INLINE (>>=) #-}
50-
x >>= f = msimple $ Dist $ do
50+
x >>= f = msimple $
51+
Dist $ do
5152
(x', p1) <- unDist x
5253
(y, p2) <- unDist $ f x'
5354
pure (y, p1 * p2)

‎src/Main.hs

+133-120
Original file line numberDiff line numberDiff line change
@@ -1,19 +1,17 @@
11
module Main where
22

3+
import Control.Arrow (right)
4+
import Data.Text qualified as T
35
import Discord
46
import Discord.Interactions
57
import Discord.Internal.Rest.ApplicationCommands
68
import Discord.Types
7-
8-
import Data.Text qualified as T
9-
10-
import Control.Arrow (right)
119
import Flow ((.>))
1210
import Parser (parseRoll)
1311
import RefTable (RefTable, maybeMakeRef, maybeUnRef, newRefTable)
12+
import Response (Response, followUp, mkInteractionHandler, rc, rc_, respond)
1413
import Sample (rollIO)
1514
import Stats (genReport)
16-
import Response (Response, respond, followUp, mkInteractionHandler, rc, rc_)
1715

1816
main :: IO ()
1917
main = do
@@ -34,35 +32,36 @@ main = do
3432

3533
coms :: [CreateApplicationCommand]
3634
coms =
37-
[ simpleCommand "r" "roll some dice" $ Just $
38-
OptionsValues
39-
[ exprOption
40-
, OptionValueInteger
41-
{ optionValueName = "times"
42-
, optionValueLocalizedName = Nothing
43-
, optionValueDescription = "time number of times to roll it"
44-
, optionValueLocalizedDescription = Nothing
45-
, optionValueRequired = False
46-
, optionValueIntegerChoices = Left False
47-
, optionValueIntegerMinVal = Just 1
48-
, optionValueIntegerMaxVal = Nothing
49-
}
50-
]
35+
[ simpleCommand "r" "roll some dice" $
36+
Just $
37+
OptionsValues
38+
[ exprOption
39+
, OptionValueInteger
40+
{ optionValueName = "times"
41+
, optionValueLocalizedName = Nothing
42+
, optionValueDescription = "time number of times to roll it"
43+
, optionValueLocalizedDescription = Nothing
44+
, optionValueRequired = False
45+
, optionValueIntegerChoices = Left False
46+
, optionValueIntegerMinVal = Just 1
47+
, optionValueIntegerMaxVal = Nothing
48+
}
49+
]
5150
, simpleCommand "stats" "get stats info" $
52-
Just $
53-
OptionsValues
54-
[ exprOption
55-
, OptionValueInteger
56-
{ optionValueName = "result"
57-
, optionValueLocalizedName = Nothing
58-
, optionValueDescription = "the result"
59-
, optionValueLocalizedDescription = Nothing
60-
, optionValueRequired = True
61-
, optionValueIntegerChoices = Left False
62-
, optionValueIntegerMinVal = Nothing
63-
, optionValueIntegerMaxVal = Nothing
64-
}
65-
]
51+
Just $
52+
OptionsValues
53+
[ exprOption
54+
, OptionValueInteger
55+
{ optionValueName = "result"
56+
, optionValueLocalizedName = Nothing
57+
, optionValueDescription = "the result"
58+
, optionValueLocalizedDescription = Nothing
59+
, optionValueRequired = True
60+
, optionValueIntegerChoices = Left False
61+
, optionValueIntegerMinVal = Nothing
62+
, optionValueIntegerMaxVal = Nothing
63+
}
64+
]
6665
, simpleCommand "help" "send help text" Nothing
6766
]
6867

@@ -71,73 +70,80 @@ handler rt = \case
7170
Ready _ _ _ _ _ _ (PartialApplication i _) -> do
7271
putStrLn "ready"
7372
oldComs <- rc $ GetGlobalApplicationCommands i
74-
let removedComs
75-
= Prelude.filter
76-
(\c -> applicationCommandName c `notElem` (createName <$> coms))
77-
oldComs
73+
let removedComs =
74+
Prelude.filter
75+
(\c -> applicationCommandName c `notElem` (createName <$> coms))
76+
oldComs
7877
forM_ removedComs $ rc_ . DeleteGlobalApplicationCommand i . applicationCommandId
7978
forM_ coms $ rc . CreateGlobalApplicationCommand i
8079
putStrLn "commands registered"
8180
InteractionCreate interaction ->
8281
mkInteractionHandler interaction $
8382
case interaction of
8483
( InteractionApplicationCommand
85-
{ applicationCommandData =
86-
ApplicationCommandDataChatInput
87-
{ applicationCommandDataName = name
88-
, optionsData = options
89-
}
90-
}
84+
{ applicationCommandData =
85+
ApplicationCommandDataChatInput
86+
{ applicationCommandDataName = name
87+
, optionsData = options
88+
}
89+
}
9190
) ->
9291
case name of
93-
"help" ->
94-
respond
95-
$ interactionResponseBasic
96-
$ "/help prints this\n"
97-
<> "/r rolls an expression\n"
98-
<> helpText
99-
"stats" ->
100-
case options of
101-
(Just (OptionsDataValues
102-
[ OptionDataValueString _ (Right expr)
103-
, OptionDataValueInteger _ (Right result)
104-
]
105-
)) -> stats (fromInteger result) expr
106-
_ -> putStrLn $ "Bad options for stats:" <> show options
107-
"r" ->
108-
case options of
109-
(Just (OptionsDataValues
110-
[ OptionDataValueString _ (Right expr)]
111-
)) -> rollExpr rt Nothing expr
112-
(Just (OptionsDataValues
113-
[ OptionDataValueString _ (Right expr)
114-
, OptionDataValueInteger _ (Right times)
115-
]
116-
)) -> rollExpr rt (Just $ fromInteger times) expr
117-
_ -> putStrLn $ "Bad options for r: " <> show options
118-
com -> putStrLn $ "bad command: " <> show com
119-
( InteractionComponent{componentData = ButtonData button }
120-
) -> maybeUnRef rt button >>= \case
121-
(T.stripPrefix "roll:" -> Just expr) -> do
122-
rollExpr rt Nothing expr
123-
(T.stripPrefix "rollt:" -> Just rest) -> do
124-
let (times', T.tail -> expr) = T.breakOn ":" rest
125-
case readMaybe $ toString times' of
126-
Just times -> do
127-
rollExpr rt (Just times) expr
128-
Nothing -> die "failed to parse times in rollt"
129-
(T.stripPrefix "logs:" -> Just logs) -> do
130-
respond $ interactionResponseBasic logs
131-
(T.stripPrefix "stats:" -> Just rest) -> do
132-
let (res', T.tail -> expr) = T.breakOn "," rest
133-
res <- case readMaybe $ toString res' of
134-
Nothing -> die "failed to read res in stats"
135-
Just res -> pure res
136-
stats res expr
137-
(T.stripPrefix "err:" -> Just msg) ->
138-
respond $ interactionResponseBasic
139-
msg
140-
_ -> die $ toString $ "unexpected button data:" <> button
92+
"help" ->
93+
respond $
94+
interactionResponseBasic $
95+
"/help prints this\n"
96+
<> "/r rolls an expression\n"
97+
<> helpText
98+
"stats" ->
99+
case options of
100+
( Just
101+
( OptionsDataValues
102+
[ OptionDataValueString _ (Right expr)
103+
, OptionDataValueInteger _ (Right result)
104+
]
105+
)
106+
) -> stats (fromInteger result) expr
107+
_ -> putStrLn $ "Bad options for stats:" <> show options
108+
"r" ->
109+
case options of
110+
( Just
111+
( OptionsDataValues
112+
[OptionDataValueString _ (Right expr)]
113+
)
114+
) -> rollExpr rt Nothing expr
115+
( Just
116+
( OptionsDataValues
117+
[ OptionDataValueString _ (Right expr)
118+
, OptionDataValueInteger _ (Right times)
119+
]
120+
)
121+
) -> rollExpr rt (Just $ fromInteger times) expr
122+
_ -> putStrLn $ "Bad options for r: " <> show options
123+
com -> putStrLn $ "bad command: " <> show com
124+
(InteractionComponent {componentData = ButtonData button}) ->
125+
maybeUnRef rt button >>= \case
126+
(T.stripPrefix "roll:" -> Just expr) -> do
127+
rollExpr rt Nothing expr
128+
(T.stripPrefix "rollt:" -> Just rest) -> do
129+
let (times', T.tail -> expr) = T.breakOn ":" rest
130+
case readMaybe $ toString times' of
131+
Just times -> do
132+
rollExpr rt (Just times) expr
133+
Nothing -> die "failed to parse times in rollt"
134+
(T.stripPrefix "logs:" -> Just logs) -> do
135+
respond $ interactionResponseBasic logs
136+
(T.stripPrefix "stats:" -> Just rest) -> do
137+
let (res', T.tail -> expr) = T.breakOn "," rest
138+
res <- case readMaybe $ toString res' of
139+
Nothing -> die "failed to read res in stats"
140+
Just res -> pure res
141+
stats res expr
142+
(T.stripPrefix "err:" -> Just msg) ->
143+
respond $
144+
interactionResponseBasic
145+
msg
146+
_ -> die $ toString $ "unexpected button data:" <> button
141147
i -> do
142148
putStrLn "unhandled interaction"
143149
print i
@@ -167,8 +173,9 @@ rollExpr :: RefTable -> Maybe Int -> Text -> Response ()
167173
rollExpr rt times expr =
168174
case parseRoll expr of
169175
Left _ ->
170-
respond $ interactionResponseBasic
171-
$ "Failed to parse: " <> expr <> "\n\n" <> helpText
176+
respond $
177+
interactionResponseBasic $
178+
"Failed to parse: " <> expr <> "\n\n" <> helpText
172179
Right roll -> do
173180
(res' :: Either Text (Text, Text)) <- case times of
174181
Nothing -> rollIO roll <&> right (first (show @Text))
@@ -181,24 +188,30 @@ rollExpr rt times expr =
181188
case times of
182189
Nothing -> "roll:"
183190
Just t -> "rollt:" <> show t <> ":"
184-
buttons <- mapM (uncurry $ genButton rt)
185-
[("Reroll",rollPrefix <> expr)
186-
,("How?","logs:" <> (if logs == "" then "It was a constant." else logs))
187-
,("Stats","stats:" <> res <> "," <> expr)
188-
]
189-
respond
190-
$ InteractionResponseChannelMessage
191-
$ InteractionResponseMessage
192-
{ interactionResponseMessageTTS = Nothing
193-
, interactionResponseMessageContent =
194-
Just $ expr <> "= **" <> res <> "**"
195-
, interactionResponseMessageEmbeds = Nothing
196-
, interactionResponseMessageAllowedMentions = Nothing
197-
, interactionResponseMessageFlags = Nothing
198-
, interactionResponseMessageComponents =
199-
Just [ ActionRowButtons buttons ]
200-
, interactionResponseMessageAttachments = Nothing
201-
}
191+
buttons <-
192+
mapM
193+
(uncurry $ genButton rt)
194+
[ ("Reroll", rollPrefix <> expr)
195+
,
196+
( "How?"
197+
, "logs:"
198+
<> (if logs == "" then "It was a constant." else logs)
199+
)
200+
, ("Stats", "stats:" <> res <> "," <> expr)
201+
]
202+
respond $
203+
InteractionResponseChannelMessage $
204+
InteractionResponseMessage
205+
{ interactionResponseMessageTTS = Nothing
206+
, interactionResponseMessageContent =
207+
Just $ expr <> "= **" <> res <> "**"
208+
, interactionResponseMessageEmbeds = Nothing
209+
, interactionResponseMessageAllowedMentions = Nothing
210+
, interactionResponseMessageFlags = Nothing
211+
, interactionResponseMessageComponents =
212+
Just [ActionRowButtons buttons]
213+
, interactionResponseMessageAttachments = Nothing
214+
}
202215

203216
stats :: Int -> Text -> Response ()
204217
stats res expr = do
@@ -232,16 +245,16 @@ genButton rt label msg = do
232245
pure $ simpleButton msg' label
233246

234247
simpleCommand :: Text -> Text -> Maybe Options -> CreateApplicationCommand
235-
simpleCommand name desc opts=
248+
simpleCommand name desc opts =
236249
CreateApplicationCommandChatInput
237-
{ createName = name
238-
, createLocalizedName = Nothing
239-
, createDescription = desc
240-
, createLocalizedDescription = Nothing
241-
, createOptions = opts
242-
, createDefaultMemberPermissions = Nothing
243-
, createDMPermission = Nothing
244-
}
250+
{ createName = name
251+
, createLocalizedName = Nothing
252+
, createDescription = desc
253+
, createLocalizedDescription = Nothing
254+
, createOptions = opts
255+
, createDefaultMemberPermissions = Nothing
256+
, createDMPermission = Nothing
257+
}
245258

246259
exprOption :: OptionValue
247260
exprOption =

0 commit comments

Comments
 (0)
Please sign in to comment.