From 376837c4514dd83be97274b21f03699991a02178 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Wed, 17 Sep 2025 00:06:49 +0100 Subject: [PATCH 01/13] you should commit lock files and auto-generated files --- .gitignore | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitignore b/.gitignore index 57468f6..21e4f10 100644 --- a/.gitignore +++ b/.gitignore @@ -3,7 +3,7 @@ .env db.* database* -*.cabal -stack.yaml.lock .gitattributes .vscode +dist-newstyle/ +cabal.project.local From 55843cd9cf8893267c3ba17aa77d2a4d60c1fa4d Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Wed, 17 Sep 2025 00:08:34 +0100 Subject: [PATCH 02/13] bump lts, remove unneeded deps, use more l0negamer deps, and commit lock and cabal file (+ cabal.project) --- cabal.project | 11 ++ stack.yaml | 34 ++---- stack.yaml.lock | 69 +++++++++++ tablebot.cabal | 307 ++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 397 insertions(+), 24 deletions(-) create mode 100644 cabal.project create mode 100644 stack.yaml.lock create mode 100644 tablebot.cabal diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..8221172 --- /dev/null +++ b/cabal.project @@ -0,0 +1,11 @@ +packages: . + +source-repository-package + type: git + location: git@github.com:L0neGamer/haskell-distribution.git + tag: 569d6452e4bffedb2c0d3795885fccdb22a4d29d + +source-repository-package + type: git + location: git@github.com:L0neGamer/duckling.git + tag: f22e3cdd7b77977fe3e9ec75fccd9a0f79c47f97 diff --git a/stack.yaml b/stack.yaml index 619f14b..02c0628 100644 --- a/stack.yaml +++ b/stack.yaml @@ -16,8 +16,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/18.yaml +resolver: lts-24.10 # User packages to be built. # Various formats can be used as shown in the example below. @@ -39,35 +38,22 @@ packages: # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # -# allow-newer: true +allow-newer: true extra-deps: -- discord-haskell-1.14.0 +- discord-haskell-1.18.0 - emoji-0.1.0.2 - load-env-0.2.1.0 -- megaparsec-9.0.1 -- persistent-2.11.0.4 -- persistent-sqlite-2.11.1.0 -- persistent-template-2.9.1.0@rev:2 -- esqueleto-3.4.1.1 -- duckling-0.2.0.0 -- dependent-sum-0.7.1.0 -- constraints-extras-0.3.1.0 -- Chart-diagrams-1.9.3 -- SVGFonts-1.7.0.1 -- diagrams-core-1.5.0 -- diagrams-lib-1.4.5.1 -- diagrams-postscript-1.5.1 -- diagrams-svg-1.4.3.1 +- persistent-2.17.1.0 - svg-builder-0.1.1 -- active-0.2.0.15 -- dual-tree-0.2.3.0 -- monoid-extras-0.6.1 -- statestack-0.3 -- diagrams-rasterific-1.4.2.2 -# - distribution-1.1.1.1 - git: https://github.com/L0neGamer/haskell-distribution.git commit: 569d6452e4bffedb2c0d3795885fccdb22a4d29d +- git: git@github.com:L0neGamer/duckling.git + commit: f22e3cdd7b77977fe3e9ec75fccd9a0f79c47f97 + +allow-newer-deps: + - duckling + - distribution # Override default flag values for local packages and extra-deps # flags: {} diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..e3fb79f --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,69 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/topics/lock_files + +packages: +- completed: + hackage: discord-haskell-1.18.0@sha256:0b88b1c391542b36243647f3533261867a1bd59cb2194519bc4b0e45b9a73797,7032 + pantry-tree: + sha256: 08c931796e4cdab60dd889f6a7f2c8cbcb72f9cdedfeee683c3a0593294073f8 + size: 3916 + original: + hackage: discord-haskell-1.18.0 +- completed: + hackage: emoji-0.1.0.2@sha256:d995572a5c7dcd28f98eb15c6e387a7b3bda1ac2477ab0d9dba8580d5d7b161f,1273 + pantry-tree: + sha256: dd9ea90a631342e5db0fc21331ade4d563a685e9125d5a3989eefa8e1b96c6c6 + size: 437 + original: + hackage: emoji-0.1.0.2 +- completed: + hackage: load-env-0.2.1.0@sha256:17628d397cf7ba6af9bf103c2c3592bb246e2ad58bd019cc5071c654887b1083,1866 + pantry-tree: + sha256: 12947042909a99d32d10cb72865db781867f34c0bd28c430091c2b80db1f1109 + size: 601 + original: + hackage: load-env-0.2.1.0 +- completed: + hackage: persistent-2.17.1.0@sha256:7750cd6e4215241a1391fceb6432eab7f21f99272ed9da2274d89696f03dc577,7096 + pantry-tree: + sha256: 1711bdf4d648fd308242fe1f525ac03d2ca0221e67539778ad95d1dd149cd0fe + size: 7182 + original: + hackage: persistent-2.17.1.0 +- completed: + hackage: svg-builder-0.1.1@sha256:1a7b9deb38cbf4be5b5271daa6cb41ece26825d14994fd77d57e9a960894bd05,1627 + pantry-tree: + sha256: 81aa683eb07ab3914088d336125f06910c42e9c7f86393191db32e5fbf40528a + size: 535 + original: + hackage: svg-builder-0.1.1 +- completed: + commit: 569d6452e4bffedb2c0d3795885fccdb22a4d29d + git: https://github.com/L0neGamer/haskell-distribution.git + name: distribution + pantry-tree: + sha256: df46a8ef68d35f55bdcf3d6c6e5578cad5680306a7bef4e52da8631cc171c1fc + size: 808 + version: 1.1.1.1 + original: + commit: 569d6452e4bffedb2c0d3795885fccdb22a4d29d + git: https://github.com/L0neGamer/haskell-distribution.git +- completed: + commit: f22e3cdd7b77977fe3e9ec75fccd9a0f79c47f97 + git: git@github.com:L0neGamer/duckling.git + name: duckling + pantry-tree: + sha256: 126902871d2ae27e2ac4a88a07f04a4c3b7bff3f0fdf067d8d9226136002ff51 + size: 77724 + version: 0.2.0.1 + original: + commit: f22e3cdd7b77977fe3e9ec75fccd9a0f79c47f97 + git: git@github.com:L0neGamer/duckling.git +snapshots: +- completed: + sha256: 057c5a66404132b661211de21bb4490f6df89c162752a17f0df5a0959381b869 + size: 726309 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/10.yaml + original: lts-24.10 diff --git a/tablebot.cabal b/tablebot.cabal new file mode 100644 index 0000000..be18c7b --- /dev/null +++ b/tablebot.cabal @@ -0,0 +1,307 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: tablebot +version: 0.3.3 +description: Please see the README on GitHub at +homepage: https://github.com/WarwickTabletop/tablebot#readme +bug-reports: https://github.com/WarwickTabletop/tablebot/issues +author: Warwick Tabletop +maintainer: tagarople@gmail.com +copyright: 2021 Warwick Tabletop +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/WarwickTabletop/tablebot + +library + exposed-modules: + Tablebot + Tablebot.Handler + Tablebot.Internal.Administration + Tablebot.Internal.Alias + Tablebot.Internal.Cache + Tablebot.Internal.Embed + Tablebot.Internal.Handler.Command + Tablebot.Internal.Handler.Event + Tablebot.Internal.Permission + Tablebot.Internal.Plugins + Tablebot.Internal.Types + Tablebot.Plugins + Tablebot.Plugins.Administration + Tablebot.Plugins.Alias + Tablebot.Plugins.Basic + Tablebot.Plugins.Cats + Tablebot.Plugins.Dogs + Tablebot.Plugins.Flip + Tablebot.Plugins.Fox + Tablebot.Plugins.Netrunner + Tablebot.Plugins.Netrunner.Command.BanList + Tablebot.Plugins.Netrunner.Command.Custom + Tablebot.Plugins.Netrunner.Command.Find + Tablebot.Plugins.Netrunner.Command.Help + Tablebot.Plugins.Netrunner.Command.Rules + Tablebot.Plugins.Netrunner.Command.Search + Tablebot.Plugins.Netrunner.Plugin + Tablebot.Plugins.Netrunner.Type.BanList + Tablebot.Plugins.Netrunner.Type.Card + Tablebot.Plugins.Netrunner.Type.Cycle + Tablebot.Plugins.Netrunner.Type.Faction + Tablebot.Plugins.Netrunner.Type.NrApi + Tablebot.Plugins.Netrunner.Type.Pack + Tablebot.Plugins.Netrunner.Type.Type + Tablebot.Plugins.Netrunner.Utility.BanList + Tablebot.Plugins.Netrunner.Utility.Card + Tablebot.Plugins.Netrunner.Utility.Cycle + Tablebot.Plugins.Netrunner.Utility.Embed + Tablebot.Plugins.Netrunner.Utility.Faction + Tablebot.Plugins.Netrunner.Utility.Misc + Tablebot.Plugins.Netrunner.Utility.NrApi + Tablebot.Plugins.Netrunner.Utility.Pack + Tablebot.Plugins.Ping + Tablebot.Plugins.Quote + Tablebot.Plugins.Reminder + Tablebot.Plugins.Roll + Tablebot.Plugins.Roll.Dice + Tablebot.Plugins.Roll.Dice.DiceData + Tablebot.Plugins.Roll.Dice.DiceEval + Tablebot.Plugins.Roll.Dice.DiceFunctions + Tablebot.Plugins.Roll.Dice.DiceParsing + Tablebot.Plugins.Roll.Dice.DiceStats + Tablebot.Plugins.Roll.Dice.DiceStatsBase + Tablebot.Plugins.Roll.Plugin + Tablebot.Plugins.Say + Tablebot.Plugins.Shibe + Tablebot.Plugins.Suggest + Tablebot.Plugins.Welcome + Tablebot.Utility + Tablebot.Utility.Discord + Tablebot.Utility.Embed + Tablebot.Utility.Exception + Tablebot.Utility.Font + Tablebot.Utility.Help + Tablebot.Utility.Parser + Tablebot.Utility.Permission + Tablebot.Utility.Random + Tablebot.Utility.Search + Tablebot.Utility.SmartParser + Tablebot.Utility.SmartParser.Interactions + Tablebot.Utility.SmartParser.SmartParser + Tablebot.Utility.SmartParser.Types + Tablebot.Utility.Types + Tablebot.Utility.Utils + other-modules: + Paths_tablebot + hs-source-dirs: + src + default-extensions: + OverloadedStrings + LambdaCase + EmptyDataDecls + FlexibleContexts + GADTs + GeneralizedNewtypeDeriving + MultiParamTypeClasses + QuasiQuotes + TemplateHaskell + TypeFamilies + DerivingStrategies + StandaloneDeriving + UndecidableInstances + DataKinds + FlexibleInstances + DeriveGeneric + TypeApplications + MultiWayIf + TupleSections + ConstraintKinds + RecordWildCards + ScopedTypeVariables + TypeOperators + RankNTypes + BangPatterns + ghc-options: -Wall + build-depends: + Chart + , Chart-diagrams + , JuicyPixels + , SVGFonts + , aeson + , base >=4.7 && <5 + , bytestring + , containers + , data-default + , diagrams-core + , diagrams-lib + , diagrams-rasterific + , discord-haskell + , distribution + , duckling + , edit-distance + , emoji + , esqueleto + , exception-transformers + , extra + , filepath + , http-client + , http-conduit + , load-env + , megaparsec + , monad-logger + , mtl + , persistent + , persistent-sqlite + , persistent-template + , process + , random + , raw-strings-qq + , regex-pcre + , req + , resource-pool + , resourcet + , safe + , scientific + , split + , template-haskell + , text + , text-icu + , th-printf + , time + , timezone-olson + , transformers + , unliftio + , unordered-containers + , yaml + default-language: Haskell2010 + +executable tablebot-exe + main-is: Main.hs + other-modules: + Paths_tablebot + hs-source-dirs: + app + ghc-options: -threaded -rtsopts "-with-rtsopts=-Iw10 -N" + build-depends: + Chart + , Chart-diagrams + , JuicyPixels + , SVGFonts + , aeson + , base >=4.7 && <5 + , bytestring + , containers + , data-default + , diagrams-core + , diagrams-lib + , diagrams-rasterific + , discord-haskell + , distribution + , duckling + , edit-distance + , emoji + , esqueleto + , exception-transformers + , extra + , filepath + , http-client + , http-conduit + , load-env + , megaparsec + , monad-logger + , mtl + , persistent + , persistent-sqlite + , persistent-template + , process + , random + , raw-strings-qq + , regex-pcre + , req + , resource-pool + , resourcet + , safe + , scientific + , split + , tablebot + , template-haskell + , text + , text-icu + , th-printf + , time + , timezone-olson + , transformers + , unliftio + , unordered-containers + , yaml + default-language: Haskell2010 + +test-suite tablebot-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_tablebot + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + Chart + , Chart-diagrams + , JuicyPixels + , SVGFonts + , aeson + , base >=4.7 && <5 + , bytestring + , containers + , data-default + , diagrams-core + , diagrams-lib + , diagrams-rasterific + , discord-haskell + , distribution + , duckling + , edit-distance + , emoji + , esqueleto + , exception-transformers + , extra + , filepath + , http-client + , http-conduit + , load-env + , megaparsec + , monad-logger + , mtl + , persistent + , persistent-sqlite + , persistent-template + , process + , random + , raw-strings-qq + , regex-pcre + , req + , resource-pool + , resourcet + , safe + , scientific + , split + , tablebot + , template-haskell + , text + , text-icu + , th-printf + , time + , timezone-olson + , transformers + , unliftio + , unordered-containers + , yaml + default-language: Haskell2010 From 2393ce8230e4185d80a0c043a6f7d4f429cc92c5 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Wed, 17 Sep 2025 00:18:19 +0100 Subject: [PATCH 03/13] import fixes and discord-haskell upstream updates some structures got more fields for localisation, the Num instance of DiscordId was removed. some other small fixes --- src/Tablebot.hs | 9 +-- src/Tablebot/Handler.hs | 2 +- src/Tablebot/Internal/Administration.hs | 3 +- src/Tablebot/Internal/Alias.hs | 6 +- src/Tablebot/Internal/Types.hs | 2 +- src/Tablebot/Plugins/Administration.hs | 2 +- src/Tablebot/Plugins/Quote.hs | 60 ++++++++++++------- src/Tablebot/Plugins/Reminder.hs | 2 +- src/Tablebot/Plugins/Roll/Dice/DiceEval.hs | 3 +- .../Plugins/Roll/Dice/DiceStatsBase.hs | 2 +- src/Tablebot/Plugins/Roll/Plugin.hs | 3 +- src/Tablebot/Utility/Discord.hs | 12 +++- .../Utility/SmartParser/Interactions.hs | 10 ++-- src/Tablebot/Utility/Types.hs | 2 +- 14 files changed, 70 insertions(+), 48 deletions(-) diff --git a/src/Tablebot.hs b/src/Tablebot.hs index 09fe4a6..f534650 100644 --- a/src/Tablebot.hs +++ b/src/Tablebot.hs @@ -144,13 +144,8 @@ runTablebot vinfo dToken prefix dbpath plugins config = activityStatus = UpdateStatusOpts { updateStatusOptsSince = Nothing, - updateStatusOptsGame = - Just - ( def - { activityName = gamePlaying config prefix, - activityType = ActivityTypeGame - } - ), + updateStatusOptsActivities = + [mkActivity (gamePlaying config prefix) ActivityTypeGame], updateStatusOptsNewStatus = UpdateStatusOnline, updateStatusOptsAFK = False } diff --git a/src/Tablebot/Handler.hs b/src/Tablebot/Handler.hs index d484857..8e8a41e 100644 --- a/src/Tablebot/Handler.hs +++ b/src/Tablebot/Handler.hs @@ -127,7 +127,7 @@ submitApplicationCommands compiledAppComms cacheMVar = Nothing -> pure () Just serverIdStr -> do serverId <- readServerStr serverIdStr - aid <- partialApplicationID . cacheApplication <$> readCache + aid <- fullApplicationID . cacheApplication <$> readCache applicationCommands <- mapM ( \(CApplicationCommand cac action) -> do diff --git a/src/Tablebot/Internal/Administration.hs b/src/Tablebot/Internal/Administration.hs index 8c05139..dbaac6d 100644 --- a/src/Tablebot/Internal/Administration.hs +++ b/src/Tablebot/Internal/Administration.hs @@ -14,7 +14,8 @@ module Tablebot.Internal.Administration ) where -import Control.Monad.Cont (MonadIO, void, when) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad (void, when) import Data.List.Extra (isInfixOf, lower, trim) import Data.Text (Text, pack) import Database.Persist diff --git a/src/Tablebot/Internal/Alias.hs b/src/Tablebot/Internal/Alias.hs index 7782c70..76851fa 100644 --- a/src/Tablebot/Internal/Alias.hs +++ b/src/Tablebot/Internal/Alias.hs @@ -10,7 +10,7 @@ module Tablebot.Internal.Alias where import Control.Monad.Exception (MonadException (catch), SomeException) -import Data.Text +import qualified Data.Text as T import Database.Persist.Sqlite (BackendKey (SqlBackendKey)) import qualified Database.Persist.Sqlite as Sql import Database.Persist.TH @@ -24,8 +24,8 @@ share [mkPersist sqlSettings, mkMigrate "aliasMigration"] [persistLowerCase| Alias - alias Text - command Text + alias T.Text + command T.Text type AliasType UniqueAlias alias type deriving Show diff --git a/src/Tablebot/Internal/Types.hs b/src/Tablebot/Internal/Types.hs index 7a430e1..899401e 100644 --- a/src/Tablebot/Internal/Types.hs +++ b/src/Tablebot/Internal/Types.hs @@ -127,7 +127,7 @@ instance PersistField AliasType where toPersistValue AliasPublic = PersistInt64 (-1) fromPersistValue = \case PersistInt64 (-1) -> Right AliasPublic - PersistInt64 i -> Right $ AliasPrivate (fromIntegral i) + PersistInt64 i -> Right $ AliasPrivate (DiscordId (Snowflake (fromIntegral i))) _ -> Left "AliasType: fromPersistValue: Invalid value" instance PersistFieldSql AliasType where diff --git a/src/Tablebot/Plugins/Administration.hs b/src/Tablebot/Plugins/Administration.hs index 6de41e6..4bc36c9 100644 --- a/src/Tablebot/Plugins/Administration.hs +++ b/src/Tablebot/Plugins/Administration.hs @@ -13,7 +13,7 @@ module Tablebot.Plugins.Administration (administrationPlugin) where import Control.Concurrent.MVar (MVar, swapMVar) import Control.Monad (when) -import Control.Monad.Cont (liftIO) +import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Reader (ask) import Data.Text (Text, pack) import qualified Data.Text as T diff --git a/src/Tablebot/Plugins/Quote.hs b/src/Tablebot/Plugins/Quote.hs index 33d53b6..1809e8a 100644 --- a/src/Tablebot/Plugins/Quote.hs +++ b/src/Tablebot/Plugins/Quote.hs @@ -14,10 +14,11 @@ module Tablebot.Plugins.Quote (quotes) where import Control.Monad.IO.Class (liftIO) +import Control.Monad (join) import Data.Aeson import Data.Default (Default (def)) import Data.Functor ((<&>)) -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import Data.Text (Text, append, pack, unpack) import Data.Time.Clock.System (SystemTime (systemSeconds), getSystemTime, systemToUTCTime) import Database.Persist.Sqlite (Entity (entityKey), Filter, SelectOpt (LimitTo, OffsetBy), entityVal, (==.)) @@ -42,6 +43,8 @@ import Tablebot.Utility.Discord sendMessage, toMention, toMention', + idToWord, + wordToId, ) import Tablebot.Utility.Embed import Tablebot.Utility.Exception (BotException (GenericException, InteractionException), catchBot, throwBot) @@ -49,6 +52,7 @@ import Tablebot.Utility.Permission (requirePermission) import Tablebot.Utility.Search import Tablebot.Utility.SmartParser import Text.RawString.QQ (r) +import Data.Word -- Our Quote table in the database. This is fairly standard for Persistent, -- however you should note the name of the migration made. @@ -59,8 +63,8 @@ Quote quote Text author Text submitter Text - msgId Int - cnlId Int + msgId Word64 + cnlId Word64 time UTCTime deriving Show |] @@ -233,7 +237,7 @@ addQ qu author m = fst <$> addQ' qu author (toMention $ messageAuthor m) (messag addQ' :: (Context m) => Text -> Text -> Text -> MessageId -> ChannelId -> m -> DatabaseDiscord (MessageDetails, Int64) addQ' qu author requestor sourceMsg sourceChannel m = do now <- liftIO $ systemToUTCTime <$> getSystemTime - let new = Quote qu author requestor (fromIntegral sourceMsg) (fromIntegral sourceChannel) now + let new = Quote qu author requestor (idToWord sourceMsg) (idToWord sourceChannel) now added <- insert new let res = pack $ show $ fromSqlKey added renderCustomQuoteMessage ("Quote added as #" `append` res) new (fromSqlKey added) Nothing m <&> (,fromSqlKey added) @@ -266,8 +270,8 @@ addMessageQuote submitter q' m = do (messageContent q') (toMention $ messageAuthor q') (toMention' submitter) - (fromIntegral $ messageId q') - (fromIntegral $ messageChannelId q') + (idToWord $ messageId q') + (idToWord $ messageChannelId q') now added <- insert new let res = pack $ show $ fromSqlKey added @@ -279,7 +283,7 @@ addMessageQuote submitter q' m = do -- @!quote edit n "quoted text" - author@, and then updates quote with id n in the -- database, to match the provided quote. editQ :: Int64 -> Text -> Text -> Message -> DatabaseDiscord () -editQ qId qu author m = editQ' qId (Just qu) (Just author) (toMention $ messageAuthor m) (fromIntegral $ messageId m) (fromIntegral $ messageChannelId m) m >>= sendCustomMessage m +editQ qId qu author m = editQ' qId (Just qu) (Just author) (toMention $ messageAuthor m) (messageId m) (messageChannelId m) m >>= sendCustomMessage m editQ' :: (Context m) => Int64 -> Maybe Text -> Maybe Text -> Text -> MessageId -> ChannelId -> m -> DatabaseDiscord MessageDetails editQ' qId qu author requestor mid cid m = @@ -290,7 +294,7 @@ editQ' qId qu author requestor mid cid m = case oQu of Just (Quote qu' author' _ _ _ _) -> do now <- liftIO $ systemToUTCTime <$> getSystemTime - let new = Quote (fromMaybe qu' qu) (fromMaybe author' author) requestor (fromIntegral mid) (fromIntegral cid) now + let new = Quote (fromMaybe qu' qu) (fromMaybe author' author) requestor (idToWord mid) (idToWord cid) now replace k new renderCustomQuoteMessage "Quote updated" new qId Nothing m Nothing -> return $ messageDetailsBasic "Couldn't update that quote!" @@ -330,13 +334,13 @@ renderCustomQuoteMessage t (Quote txt author submitter msgId cnlId dtm) qId mb m ) where getLink :: Maybe GuildId -> Maybe Text - getLink = fmap (\x -> getMessageLink x (fromIntegral cnlId) (fromIntegral msgId)) + getLink = fmap (\x -> getMessageLink x (wordToId cnlId) (wordToId msgId)) maybeAddFooter :: Maybe Text -> Text maybeAddFooter (Just l) = "\n[source](" <> l <> ") - added by " <> submitter maybeAddFooter Nothing = "" quoteApplicationCommand :: CreateApplicationCommand -quoteApplicationCommand = CreateApplicationCommandChatInput "quote" "store and retrieve quotes" (Just opts) Nothing True +quoteApplicationCommand = CreateApplicationCommandChatInput "quote" Nothing "store and retrieve quotes" Nothing (Just opts) Nothing (Just True) where opts = OptionsSubcommands $ @@ -350,33 +354,43 @@ quoteApplicationCommand = CreateApplicationCommandChatInput "quote" "store and r addQuoteAppComm = OptionSubcommand "add" + Nothing "add a new quote" - [ OptionValueString "quote" "what the actual quote is" True (Left False), - OptionValueString "author" "who authored this quote" True (Left False) + Nothing + [ OptionValueString "quote" Nothing "what the actual quote is" Nothing True (Left False) Nothing Nothing, + OptionValueString "author" Nothing "who authored this quote" Nothing True (Left False) Nothing Nothing ] showQuoteAppComm = OptionSubcommand "show" + Nothing "show a quote by number" - [ OptionValueInteger "id" "the quote's number" True (Left True) (Just 1) Nothing + Nothing + [ OptionValueInteger "id" Nothing "the quote's number" Nothing True (Left True) (Just 1) Nothing ] randomQuoteAppComm = OptionSubcommand "random" + Nothing "show a random quote" + Nothing [] authorQuoteAppComm = OptionSubcommand "author" + Nothing "show a random quote by an author" - [OptionValueString "author" "whose quotes do you want to see" True (Left False)] + Nothing + [OptionValueString "author" Nothing "whose quotes do you want to see" Nothing True (Left False) Nothing Nothing] editQuoteAppComm = OptionSubcommand "edit" + Nothing "edit a quote" - [ OptionValueInteger "quoteid" "the id of the quote to edit" True (Left False) Nothing Nothing, - OptionValueString "quote" "what the actual quote is" False (Left False), - OptionValueString "author" "who authored this quote" False (Left False) + Nothing + [ OptionValueInteger "quoteid" Nothing "the id of the quote to edit" Nothing True (Left False) Nothing Nothing, + OptionValueString "quote" Nothing "what the actual quote is" Nothing False (Left False) Nothing Nothing, + OptionValueString "author" Nothing "who authored this quote" Nothing False (Left False) Nothing Nothing ] quoteApplicationCommandRecv :: Interaction -> DatabaseDiscord () @@ -406,7 +420,7 @@ quoteApplicationCommandRecv ((getValue "quote" vals >>= stringFromOptionValue) >>= \q -> (getValue "author" vals >>= stringFromOptionValue) <&> (q,)) ( \(qt, author) -> do let requestor = toMention' $ contextUserId i - (msg, qid) <- addQ' qt author requestor 0 0 i + (msg, qid) <- addQ' qt author requestor (wordToId 0) (wordToId 0) i interactionResponseCustomMessage i msg -- to get the message to display as wanted, we have to do some trickery -- we have already sent off the message above with the broken message id @@ -418,7 +432,7 @@ quoteApplicationCommandRecv Left _ -> return () Right m -> do now <- liftIO $ systemToUTCTime <$> getSystemTime - let new = Quote qt author requestor (fromIntegral $ messageId m) (fromIntegral $ messageChannelId m) now + let new = Quote qt author requestor (idToWord $ messageId m) (idToWord $ messageChannelId m) now replace (toSqlKey qid) new newMsg <- renderCustomQuoteMessage (messageContent m) new qid Nothing i _ <- liftDiscord $ restCall $ R.EditOriginalInteractionResponse (interactionApplicationId i) (interactionToken i) (convertMessageFormatInteraction newMsg) @@ -434,13 +448,13 @@ quoteApplicationCommandRecv case (qt, author) of (Nothing, Nothing) -> interactionResponseCustomMessage i (makeEphermeral (messageDetailsBasic "No edits made to quote.")) _ -> do - msg <- editQ' qid qt author (toMention' $ contextUserId i) 0 0 i + msg <- editQ' qid qt author (toMention' $ contextUserId i) (wordToId 0) (wordToId 0) i interactionResponseCustomMessage i msg v <- liftDiscord $ restCall $ R.GetOriginalInteractionResponse (interactionApplicationId i) (interactionToken i) case v of Left _ -> return () Right m -> do - msg' <- editQ' qid qt author (toMention' $ contextUserId i) (fromIntegral $ messageId m) (fromIntegral $ messageChannelId m) i + msg' <- editQ' qid qt author (toMention' $ contextUserId i) (messageId m) (messageChannelId m) i _ <- liftDiscord $ restCall $ R.EditOriginalInteractionResponse (interactionApplicationId i) (interactionToken i) (convertMessageFormatInteraction msg') return () ) @@ -466,12 +480,12 @@ quoteApplicationCommandRecv handleNothing (getValue "id" vals) ( \case - OptionDataValueInteger _ (Right showid') -> interactionResponseAutocomplete i $ InteractionResponseAutocompleteInteger [Choice (pack $ show showid') showid'] + OptionDataValueInteger _ (Right showid') -> interactionResponseAutocomplete i $ InteractionResponseAutocompleteInteger [Choice (pack $ show showid') Nothing showid'] OptionDataValueInteger _ (Left showid') -> do allQ <- allQuotes () let allQ' = (\qe -> (show (fromSqlKey $ entityKey qe), (fromSqlKey $ entityKey qe, (\(Quote q _ _ _ _ _) -> q) (entityVal qe)))) <$> allQ options = take 25 $ closestPairsWithCosts (def {deletion = 100, substitution = 100, transposition = 5}) allQ' (unpack showid') - interactionResponseAutocomplete i $ InteractionResponseAutocompleteInteger ((\(qids, (qid, _)) -> Choice (pack qids) (toInteger qid)) <$> options) + interactionResponseAutocomplete i $ InteractionResponseAutocompleteInteger ((\(qids, (qid, _)) -> Choice (pack qids) Nothing (toInteger qid)) <$> options) _ -> return () ) _ -> return () diff --git a/src/Tablebot/Plugins/Reminder.hs b/src/Tablebot/Plugins/Reminder.hs index 528b8df..e7a9c4d 100644 --- a/src/Tablebot/Plugins/Reminder.hs +++ b/src/Tablebot/Plugins/Reminder.hs @@ -134,7 +134,7 @@ reminderCron = do res <- getMessage (DiscordId $ Snowflake cid) (DiscordId $ Snowflake mid) case res of Left _ -> do - sendChannelMessage (fromIntegral cid) (pack $ "Reminder to <@" ++ show uid ++ ">! " ++ content) + sendChannelMessage (DiscordId (Snowflake cid)) (pack $ "Reminder to <@" ++ show uid ++ ">! " ++ content) delete (entityKey re) Right mess -> do sendCustomReplyMessage mess (DiscordId $ Snowflake mid) True $ diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs b/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs index 1e7faea..370a873 100644 --- a/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs +++ b/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs @@ -11,7 +11,8 @@ module Tablebot.Plugins.Roll.Dice.DiceEval (ParseShow (parseShow), evalProgram, evalList, evalInteger, evaluationException, propagateException, maximumRNG, maximumListLength) where import Control.Monad.Exception (MonadException) -import Control.Monad.State (MonadIO (liftIO), StateT, evalStateT, gets, modify, when) +import Control.Monad.State (MonadIO (liftIO), StateT, evalStateT, gets, modify) +import Control.Monad (when) import Data.List (foldl', genericDrop, genericReplicate, genericTake, sortBy) import Data.List.NonEmpty as NE (NonEmpty ((:|)), head, tail, (<|)) import Data.Map (Map, empty) diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceStatsBase.hs b/src/Tablebot/Plugins/Roll/Dice/DiceStatsBase.hs index c8d031e..bfbda8f 100644 --- a/src/Tablebot/Plugins/Roll/Dice/DiceStatsBase.hs +++ b/src/Tablebot/Plugins/Roll/Dice/DiceStatsBase.hs @@ -68,7 +68,7 @@ distributionRenderable d = toRenderable $ do layout_y_axis . laxis_override .= \ad@AxisData {_axis_labels = axisLabels} -> ad {_axis_labels = (second (\s -> if '.' `elem` s then s else s ++ ".0") <$>) <$> axisLabels} layout_all_font_styles .= defFontStyle pb <- (bars @Integer @Double) (barNames d) pts - let pb' = pb {_plot_bars_spacing = BarsFixGap 10 5} + let pb' = set plot_bars_spacing (BarsFixGap 10 5) pb plot $ return $ plotBars pb' where removeNullMap m diff --git a/src/Tablebot/Plugins/Roll/Plugin.hs b/src/Tablebot/Plugins/Roll/Plugin.hs index 54b023d..cef900f 100644 --- a/src/Tablebot/Plugins/Roll/Plugin.hs +++ b/src/Tablebot/Plugins/Roll/Plugin.hs @@ -9,7 +9,8 @@ -- A command that outputs the result of rolling the input dice. module Tablebot.Plugins.Roll.Plugin (rollPlugin) where -import Control.Monad.Writer (MonadIO (liftIO), void) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad (void) import Data.ByteString.Lazy (toStrict) import Data.Default (Default (def)) import Data.Distribution (isValid) diff --git a/src/Tablebot/Utility/Discord.hs b/src/Tablebot/Utility/Discord.hs index 883c899..43b0a8e 100644 --- a/src/Tablebot/Utility/Discord.hs +++ b/src/Tablebot/Utility/Discord.hs @@ -48,10 +48,12 @@ module Tablebot.Utility.Discord interactionResponseCustomMessage, interactionResponseComponentsUpdateMessage, interactionResponseAutocomplete, + idToWord, + wordToId ) where -import Control.Monad.Cont (liftIO) +import Control.Monad.IO.Class (liftIO) import Control.Monad.Exception (MonadException (throw)) import Data.Char (isDigit) import Data.Default (Default (def)) @@ -73,6 +75,7 @@ import Tablebot.Internal.Cache (fillEmojiCache, lookupEmojiCache) import Tablebot.Internal.Embed (Embeddable (..)) import Tablebot.Utility (EnvDatabaseDiscord, MessageDetails, convertMessageFormatBasic, convertMessageFormatInteraction, liftDiscord, messageDetailsBasic) import Tablebot.Utility.Exception (BotException (..)) +import Data.Coerce ( coerce ) -- | @sendMessage@ sends the input message @t@ in the same channel as message -- @m@. @@ -449,3 +452,10 @@ interactionResponseAutocomplete i ac = do case res of Left _ -> throw $ InteractionException "Failed to respond to interaction with autocomplete response." Right _ -> return () + +-- | Not guaranteed to be a valid ID! +wordToId :: Word64 -> DiscordId a +wordToId = coerce + +idToWord :: DiscordId a -> Word64 +idToWord = coerce diff --git a/src/Tablebot/Utility/SmartParser/Interactions.hs b/src/Tablebot/Utility/SmartParser/Interactions.hs index 7925ca5..078e973 100644 --- a/src/Tablebot/Utility/SmartParser/Interactions.hs +++ b/src/Tablebot/Utility/SmartParser/Interactions.hs @@ -78,21 +78,21 @@ class MakeAppCommArg commandty where -- | Create a labelled text argument. By default it is required and does not -- have autocompeletion. instance (KnownSymbol name, KnownSymbol desc) => MakeAppCommArg (Labelled name desc Text) where - makeAppCommArg l = OptionValueString n d True (Left False) + makeAppCommArg l = OptionValueString n Nothing d Nothing True (Left False) Nothing Nothing where (n, d) = getLabelValues l -- | Create a labelled integer argument. By default it is required and does not -- have autocompeletion, and does not have bounds. instance (KnownSymbol name, KnownSymbol desc) => MakeAppCommArg (Labelled name desc Integer) where - makeAppCommArg l = OptionValueInteger n d True (Left False) Nothing Nothing + makeAppCommArg l = OptionValueInteger n Nothing d Nothing True (Left False) Nothing Nothing where (n, d) = getLabelValues l -- | Create a labelled scientific argument. By default it is required and does not -- have autocompeletion, and does not have bounds. instance (KnownSymbol name, KnownSymbol desc) => MakeAppCommArg (Labelled name desc Scientific) where - makeAppCommArg l = OptionValueNumber n d True (Left False) Nothing Nothing + makeAppCommArg l = OptionValueNumber n Nothing d Nothing True (Left False) Nothing Nothing where (n, d) = getLabelValues l @@ -274,8 +274,8 @@ onlyAllowRequestor' msg f = do ) <* eof where - prefunc :: UserId -> SenderUserId -> Interaction -> DatabaseDiscord (Maybe MessageDetails) - prefunc uid (SenderUserId u) i = + prefunc :: Snowflake -> SenderUserId -> Interaction -> DatabaseDiscord (Maybe MessageDetails) + prefunc uid (SenderUserId (DiscordId u)) i = if uid == u then return Nothing else diff --git a/src/Tablebot/Utility/Types.hs b/src/Tablebot/Utility/Types.hs index 097dfe8..e916a9a 100644 --- a/src/Tablebot/Utility/Types.hs +++ b/src/Tablebot/Utility/Types.hs @@ -359,7 +359,7 @@ instance Context Message where instance Context Interaction where -- this is safe to do because we are guaranteed to get either a user or a member - contextUserId i = maybe 0 userId (either memberUser Just mor) + contextUserId i = maybe (DiscordId (Snowflake 0)) userId (either memberUser Just mor) where (MemberOrUser mor) = interactionUser i contextGuildId i = return $ interactionGuildId i From 35e325c414293516ef27c8f1af9b5fb65c0cafb7 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Wed, 17 Sep 2025 00:19:20 +0100 Subject: [PATCH 04/13] adjust the integral parser to have a concrete type this massively helps type inference --- src/Tablebot/Utility/SmartParser/SmartParser.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Tablebot/Utility/SmartParser/SmartParser.hs b/src/Tablebot/Utility/SmartParser/SmartParser.hs index a623854..1b6e534 100644 --- a/src/Tablebot/Utility/SmartParser/SmartParser.hs +++ b/src/Tablebot/Utility/SmartParser/SmartParser.hs @@ -189,10 +189,11 @@ instance (KnownSymbol s) => CanParse (Exactly s) where instance (KnownSymbol err, CanParse x) => CanParse (WithError err x) where pars = (WErr <$> try (pars @x)) symbolVal (Proxy :: Proxy err) +newtype IntegralData a = MkIntegralData a + -- | Parsing implementation for all integral types --- Overlappable due to the really flexible head state -instance {-# OVERLAPPABLE #-} (Integral a, Read a) => CanParse a where - pars = integer +instance (Integral a, Read a) => CanParse (IntegralData a) where + pars = MkIntegralData <$> integer instance CanParse Double where pars = double From 2f1f49653af37c357cba1ceec8e89b57ae474c64 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Wed, 17 Sep 2025 00:20:55 +0100 Subject: [PATCH 05/13] use the new IntegralData --- src/Tablebot/Plugins/Quote.hs | 16 ++++++++-------- src/Tablebot/Plugins/Reminder.hs | 6 +++--- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Tablebot/Plugins/Quote.hs b/src/Tablebot/Plugins/Quote.hs index 1809e8a..eb040eb 100644 --- a/src/Tablebot/Plugins/Quote.hs +++ b/src/Tablebot/Plugins/Quote.hs @@ -93,11 +93,11 @@ quoteCommand = quoteComm :: WithError "Unknown quote functionality." - (Either () (Either Int64 (RestOfInput Text))) -> + (Either () (Either (IntegralData Int64) (RestOfInput Text))) -> Message -> DatabaseDiscord () quoteComm (WErr (Left ())) m = randomQ m >>= sendCustomMessage m - quoteComm (WErr (Right (Left t))) m = showQ t m >>= sendCustomMessage m + quoteComm (WErr (Right (Left (MkIntegralData t)))) m = showQ t m >>= sendCustomMessage m quoteComm (WErr (Right (Right (ROI t)))) m = authorQ t m >>= sendCustomMessage m addQuote :: Command @@ -115,10 +115,10 @@ editQuote = Command "edit" (parseComm editComm) [] editComm :: WithError "Edit format incorrect!\nFormat is: .quote edit quoteId \"new quote\" - author" - (Int64, Quoted Text, Exactly "-", RestOfInput Text) -> + ((IntegralData Int64), Quoted Text, Exactly "-", RestOfInput Text) -> Message -> DatabaseDiscord () - editComm (WErr (qId, Qu qu, _, ROI author)) = editQ qId qu author + editComm (WErr (MkIntegralData qId, Qu qu, _, ROI author)) = editQ qId qu author thisQuote :: Command thisQuote = Command "this" (parseComm thisComm) [] @@ -154,19 +154,19 @@ showQuote :: Command showQuote = Command "show" (parseComm showComm) [] where showComm :: - WithError "Quote format incorrect!\nExpected quote number to show, e.g. .quote show 420" Int64 -> + WithError "Quote format incorrect!\nExpected quote number to show, e.g. .quote show 420" (IntegralData Int64) -> Message -> DatabaseDiscord () - showComm (WErr qId) m = showQ qId m >>= sendCustomMessage m + showComm (WErr (MkIntegralData qId)) m = showQ qId m >>= sendCustomMessage m deleteQuote :: Command deleteQuote = Command "delete" (parseComm deleteComm) [] where deleteComm :: - WithError "Quote format incorrect!\nExpected quote number to delete, e.g. .quote delete 420" Int64 -> + WithError "Quote format incorrect!\nExpected quote number to delete, e.g. .quote delete 420" (IntegralData Int64) -> Message -> DatabaseDiscord () - deleteComm (WErr qId) = deleteQ qId + deleteComm (WErr (MkIntegralData qId)) = deleteQ qId randomQuote :: Command randomQuote = Command "random" (parseComm randomComm) [] diff --git a/src/Tablebot/Plugins/Reminder.hs b/src/Tablebot/Plugins/Reminder.hs index e7a9c4d..d158e85 100644 --- a/src/Tablebot/Plugins/Reminder.hs +++ b/src/Tablebot/Plugins/Reminder.hs @@ -31,7 +31,7 @@ import Tablebot.Utility import Tablebot.Utility.Database import Tablebot.Utility.Discord (getMessage, sendChannelMessage, sendCustomReplyMessage, sendMessage, toTimestamp) import Tablebot.Utility.Permission (requirePermission) -import Tablebot.Utility.SmartParser (PComm (parseComm), Quoted (Qu), RestOfInput (ROI), WithError (..)) +import Tablebot.Utility.SmartParser (PComm (parseComm), Quoted (Qu), RestOfInput (ROI), WithError (..), IntegralData(..)) import Text.RawString.QQ (r) -- Our Reminder table in the database. This is fairly standard for Persistent, @@ -98,8 +98,8 @@ addReminder time content m = do sendMessage m ("Reminder " <> res <> " set for " <> toTimestamp time <> " with message `" <> pack content <> "`") -- @deleteReminder@ takes a reminder Id and deletes it from the list of awating reminders. -deleteReminder :: WithError "Missing required argument" (Int) -> Message -> DatabaseDiscord () -deleteReminder (WErr rid) m = requirePermission Any m $ do +deleteReminder :: WithError "Missing required argument" (IntegralData Int) -> Message -> DatabaseDiscord () +deleteReminder (WErr (MkIntegralData rid)) m = requirePermission Any m $ do delete k sendMessage m ("Reminder " <> pack (show rid) <> " deleted.") where From d7e163e1bd2853372465d577b19a075ef9bfbdc5 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Wed, 17 Sep 2025 00:21:59 +0100 Subject: [PATCH 06/13] remove Tablebot.Utility.Database in favour of lifting sql functions when we need This is what we were doing anyway effectively; let's not waste thinking overhead by keeping this around. --- src/Tablebot/Internal/Alias.hs | 5 +- src/Tablebot/Plugins/Administration.hs | 12 +-- src/Tablebot/Plugins/Alias.hs | 5 +- src/Tablebot/Plugins/Quote.hs | 46 +++++----- src/Tablebot/Plugins/Reminder.hs | 13 ++- src/Tablebot/Utility/Database.hs | 121 ------------------------- 6 files changed, 39 insertions(+), 163 deletions(-) delete mode 100644 src/Tablebot/Utility/Database.hs diff --git a/src/Tablebot/Internal/Alias.hs b/src/Tablebot/Internal/Alias.hs index 76851fa..f16a18f 100644 --- a/src/Tablebot/Internal/Alias.hs +++ b/src/Tablebot/Internal/Alias.hs @@ -17,8 +17,7 @@ import Database.Persist.TH import Discord.Types import Tablebot.Internal.Administration (currentBlacklist) import Tablebot.Internal.Types -import Tablebot.Utility.Database (liftSql, selectList) -import Tablebot.Utility.Types (EnvDatabaseDiscord) +import Tablebot.Utility.Types (EnvDatabaseDiscord, liftSql) share [mkPersist sqlSettings, mkMigrate "aliasMigration"] @@ -38,5 +37,5 @@ getAliases uid = do if "alias" `elem` blacklist then return Nothing else - (Just . fmap Sql.entityVal <$> selectList [AliasType Sql.<-. [AliasPublic, AliasPrivate uid]] []) + liftSql (Just . fmap Sql.entityVal <$> Sql.selectList [AliasType Sql.<-. [AliasPublic, AliasPrivate uid]] []) `catch` (\(_ :: SomeException) -> return Nothing) diff --git a/src/Tablebot/Plugins/Administration.hs b/src/Tablebot/Plugins/Administration.hs index 4bc36c9..33cd94d 100644 --- a/src/Tablebot/Plugins/Administration.hs +++ b/src/Tablebot/Plugins/Administration.hs @@ -26,11 +26,11 @@ import Tablebot.Internal.Administration import Tablebot.Internal.Cache (getVersionInfo) import Tablebot.Internal.Types (CompiledPlugin (compiledName)) import Tablebot.Utility -import Tablebot.Utility.Database import Tablebot.Utility.Discord (sendMessage) import Tablebot.Utility.Permission (requirePermission) import Tablebot.Utility.SmartParser import Text.RawString.QQ +import qualified Database.Persist.Sqlite as Sql -- | @SS@ denotes the type returned by the command setup. Here its unused. type SS = [Text] @@ -60,19 +60,19 @@ addBlacklist pLabel m = requirePermission Superuser m $ do -- It's not an error to add an unknown plugin (so that you can pre-disable a plugin you know you're about to add), -- but emmit a warning so people know if it wasn't deliberate when (pack pLabel `notElem` known) $ sendMessage m "Warning, unknown plugin" - extant <- exists [PluginBlacklistLabel ==. pLabel] + extant <- liftSql $ Sql.exists [PluginBlacklistLabel ==. pLabel] if not extant then do - _ <- insert $ PluginBlacklist pLabel + _ <- liftSql $ Sql.insert $ PluginBlacklist pLabel sendMessage m "Plugin added to blacklist. Please reload for it to take effect" else sendMessage m "Plugin already in blacklist" removeBlacklist :: String -> Message -> EnvDatabaseDiscord SS () removeBlacklist pLabel m = requirePermission Superuser m $ do - extant <- selectKeysList [PluginBlacklistLabel ==. pLabel] [] + extant <- liftSql $ Sql.selectKeysList [PluginBlacklistLabel ==. pLabel] [] if not $ null extant then do - _ <- delete (head extant) + _ <- liftSql $ Sql.delete (head extant) sendMessage m "Plugin removed from blacklist. Please reload for it to take effect" else sendMessage m "Plugin not in blacklist" @@ -80,7 +80,7 @@ removeBlacklist pLabel m = requirePermission Superuser m $ do -- along with their current status. listBlacklist :: Message -> EnvDatabaseDiscord SS () listBlacklist m = requirePermission Superuser m $ do - bl <- selectList allBlacklisted [] + bl <- liftSql $ Sql.selectList allBlacklisted [] pl <- ask sendMessage m (format pl (blacklisted bl)) where diff --git a/src/Tablebot/Plugins/Alias.hs b/src/Tablebot/Plugins/Alias.hs index c7cef93..88ef25f 100644 --- a/src/Tablebot/Plugins/Alias.hs +++ b/src/Tablebot/Plugins/Alias.hs @@ -18,7 +18,6 @@ import Discord.Types import Tablebot.Internal.Alias import Tablebot.Internal.Types (AliasType (..)) import Tablebot.Utility -import Tablebot.Utility.Database (deleteBy, exists) import Tablebot.Utility.Discord (sendMessage) import Tablebot.Utility.Permission (requirePermission) import Tablebot.Utility.SmartParser (PComm (parseComm), Quoted (..), WithError (..)) @@ -157,9 +156,9 @@ aliasDeleteCommand = aliasDelete :: Text -> AliasType -> Message -> DatabaseDiscord () aliasDelete a at m = do let toDelete = UniqueAlias a at - itemExists <- exists [AliasAlias Sql.==. a, AliasType Sql.==. at] + itemExists <- liftSql $ Sql.exists [AliasAlias Sql.==. a, AliasType Sql.==. at] if itemExists - then deleteBy toDelete >> sendMessage m ("Deleted alias `" <> a <> "`") + then liftSql (Sql.deleteBy toDelete) >> sendMessage m ("Deleted alias `" <> a <> "`") else sendMessage m ("No such alias `" <> a <> "`") aliasDeleteHelp :: HelpPage diff --git a/src/Tablebot/Plugins/Quote.hs b/src/Tablebot/Plugins/Quote.hs index eb040eb..24ccd05 100644 --- a/src/Tablebot/Plugins/Quote.hs +++ b/src/Tablebot/Plugins/Quote.hs @@ -21,7 +21,7 @@ import Data.Functor ((<&>)) import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import Data.Text (Text, append, pack, unpack) import Data.Time.Clock.System (SystemTime (systemSeconds), getSystemTime, systemToUTCTime) -import Database.Persist.Sqlite (Entity (entityKey), Filter, SelectOpt (LimitTo, OffsetBy), entityVal, (==.)) +import Database.Persist.Sqlite (Entity (entityKey), Filter, SelectOpt (LimitTo, OffsetBy), entityVal, (==.), toSqlKey, fromSqlKey) import Database.Persist.TH import Discord (restCall) import Discord.Interactions @@ -31,7 +31,6 @@ import GHC.Generics (Generic) import GHC.Int (Int64) import System.Random (randomRIO) import Tablebot.Utility -import Tablebot.Utility.Database import Tablebot.Utility.Discord ( getMessage, getMessageLink, @@ -52,6 +51,7 @@ import Tablebot.Utility.Permission (requirePermission) import Tablebot.Utility.Search import Tablebot.Utility.SmartParser import Text.RawString.QQ (r) +import qualified Database.Persist.Sqlite as Sql import Data.Word -- Our Quote table in the database. This is fairly standard for Persistent, @@ -178,7 +178,7 @@ randomQuote = Command "random" (parseComm randomComm) [] -- that quote up in the database and responds with that quote. showQ :: (Context m) => Int64 -> m -> DatabaseDiscord MessageDetails showQ qId m = do - qu <- get $ toSqlKey qId + qu <- liftSql $ Sql.get $ toSqlKey qId case qu of Just q -> renderQuoteMessage q qId Nothing m Nothing -> return $ messageDetailsBasic "Couldn't get that quote!" @@ -217,14 +217,14 @@ filteredRandomQuote quoteFilter errorMessage mb m = catchBot (filteredRandomQuot -- goes wrong. filteredRandomQuote' :: (Context m) => [Filter Quote] -> Text -> Maybe Button -> m -> DatabaseDiscord MessageDetails filteredRandomQuote' quoteFilter errorMessage mb m = do - num <- count quoteFilter + num <- liftSql $ Sql.count quoteFilter if num == 0 -- we can't find any quotes meeting the filter then throwBot (GenericException "quote exception" (unpack errorMessage)) else do rindex <- liftIO $ randomRIO (0, num - 1) - key <- selectKeysList quoteFilter [OffsetBy rindex, LimitTo 1] - qu <- get $ head key - case qu of + key <- liftSql $ Sql.selectKeysList quoteFilter [OffsetBy rindex, LimitTo 1] + qu <- traverse (liftSql . Sql.get) $ listToMaybe key + case join qu of Just q -> renderQuoteMessage q (fromSqlKey $ head key) mb m Nothing -> throwBot (GenericException "quote exception" (unpack errorMessage)) @@ -238,7 +238,7 @@ addQ' :: (Context m) => Text -> Text -> Text -> MessageId -> ChannelId -> m -> D addQ' qu author requestor sourceMsg sourceChannel m = do now <- liftIO $ systemToUTCTime <$> getSystemTime let new = Quote qu author requestor (idToWord sourceMsg) (idToWord sourceChannel) now - added <- insert new + added <- liftSql $ Sql.insert new let res = pack $ show $ fromSqlKey added renderCustomQuoteMessage ("Quote added as #" `append` res) new (fromSqlKey added) Nothing m <&> (,fromSqlKey added) @@ -259,7 +259,7 @@ thisQ m = do -- | @addMessageQuote@, adds a message as a quote to the database, checking that it passes the relevant tests addMessageQuote :: (Context m) => UserId -> Message -> m -> DatabaseDiscord MessageDetails addMessageQuote submitter q' m = do - num <- count [QuoteMsgId ==. fromIntegral (messageId q')] + num <- liftSql $ Sql.count [QuoteMsgId ==. idToWord (messageId q')] if num == 0 then if not $ userIsBot (messageAuthor q') @@ -273,7 +273,7 @@ addMessageQuote submitter q' m = do (idToWord $ messageId q') (idToWord $ messageChannelId q') now - added <- insert new + added <- liftSql $ Sql.insert new let res = pack $ show $ fromSqlKey added renderCustomQuoteMessage ("Quote added as #" `append` res) new (fromSqlKey added) Nothing m else return $ makeEphermeral (messageDetailsBasic "Can't quote a bot") @@ -288,14 +288,14 @@ editQ qId qu author m = editQ' qId (Just qu) (Just author) (toMention $ messageA editQ' :: (Context m) => Int64 -> Maybe Text -> Maybe Text -> Text -> MessageId -> ChannelId -> m -> DatabaseDiscord MessageDetails editQ' qId qu author requestor mid cid m = requirePermission Any m $ - let k = toSqlKey qId + let k = Sql.toSqlKey qId in do - (oQu :: Maybe Quote) <- get k + (oQu :: Maybe Quote) <- liftSql $ Sql.get k case oQu of Just (Quote qu' author' _ _ _ _) -> do now <- liftIO $ systemToUTCTime <$> getSystemTime let new = Quote (fromMaybe qu' qu) (fromMaybe author' author) requestor (idToWord mid) (idToWord cid) now - replace k new + liftSql $ Sql.replace k new renderCustomQuoteMessage "Quote updated" new qId Nothing m Nothing -> return $ messageDetailsBasic "Couldn't update that quote!" @@ -304,12 +304,12 @@ editQ' qId qu author requestor mid cid m = deleteQ :: Int64 -> Message -> DatabaseDiscord () deleteQ qId m = requirePermission Any m $ - let k = toSqlKey qId + let k = Sql.toSqlKey qId in do - qu <- get k + qu <- liftSql $ Sql.get k case qu of Just Quote {} -> do - delete k + liftSql $ Sql.delete k sendMessage m "Quote deleted" Nothing -> sendMessage m "Couldn't delete that quote!" @@ -433,7 +433,7 @@ quoteApplicationCommandRecv Right m -> do now <- liftIO $ systemToUTCTime <$> getSystemTime let new = Quote qt author requestor (idToWord $ messageId m) (idToWord $ messageChannelId m) now - replace (toSqlKey qid) new + liftSql $ Sql.replace (toSqlKey qid) new newMsg <- renderCustomQuoteMessage (messageContent m) new qid Nothing i _ <- liftDiscord $ restCall $ R.EditOriginalInteractionResponse (interactionApplicationId i) (interactionToken i) (convertMessageFormatInteraction newMsg) return () @@ -482,7 +482,7 @@ quoteApplicationCommandRecv ( \case OptionDataValueInteger _ (Right showid') -> interactionResponseAutocomplete i $ InteractionResponseAutocompleteInteger [Choice (pack $ show showid') Nothing showid'] OptionDataValueInteger _ (Left showid') -> do - allQ <- allQuotes () + allQ <- allQuotes let allQ' = (\qe -> (show (fromSqlKey $ entityKey qe), (fromSqlKey $ entityKey qe, (\(Quote q _ _ _ _ _) -> q) (entityVal qe)))) <$> allQ options = take 25 $ closestPairsWithCosts (def {deletion = 100, substitution = 100, transposition = 5}) allQ' (unpack showid') interactionResponseAutocomplete i $ InteractionResponseAutocompleteInteger ((\(qids, (qid, _)) -> Choice (pack qids) Nothing (toInteger qid)) <$> options) @@ -607,8 +607,8 @@ instance FromJSON Quote instance ToJSON Quote -- | Get all the quotes in the database. -allQuotes :: () -> DatabaseDiscord [Entity Quote] -allQuotes _ = selectList [] [] +allQuotes :: DatabaseDiscord [Entity Quote] +allQuotes = liftSql $ Sql.selectList [] [] -- | Export all the quotes in the database to either a default quotes file or to a given -- file name that is quoted in the command. Superuser only. @@ -619,7 +619,7 @@ exportQ :: Maybe (Quoted FilePath) -> Message -> DatabaseDiscord () exportQ qfp m = requirePermission Superuser m $ do let defFileName = getSystemTime >>= \now -> return $ "quotes_" <> show (systemSeconds now) <> ".json" (Qu fp) <- liftIO $ maybe (Qu <$> defFileName) return qfp - aq <- fmap entityVal <$> allQuotes () + aq <- fmap entityVal <$> allQuotes _ <- liftIO $ encodeFile fp aq sendMessage m ("Succesfully exported all " <> (pack . show . length) aq <> " quotes to `" <> pack fp <> "`") @@ -630,7 +630,7 @@ importQuotes = Command "import" (parseComm importQ) [] importQ :: Quoted FilePath -> Message -> DatabaseDiscord () importQ (Qu fp) m = requirePermission Superuser m $ do mqs <- liftIO $ decodeFileStrict fp - qs <- maybe (throwBot $ GenericException "error getting file" "there was an error obtaining or decoding the quotes json") (insertMany @Quote) mqs + qs :: [Sql.Key Quote] <- maybe (throwBot $ GenericException "error getting file" "there was an error obtaining or decoding the quotes json") (liftSql . Sql.insertMany) mqs sendMessage m ("Succesfully imported " <> (pack . show . length) qs <> " quotes") -- | Clear all the quotes from the database. Superuser only. @@ -640,6 +640,6 @@ clearQuotes = Command "clear" (parseComm clearQ) [] clearQ :: Maybe (Quoted Text) -> Message -> DatabaseDiscord () clearQ (Just (Qu "clear the quotes")) m = requirePermission Superuser m $ do exportQ Nothing m - i <- deleteWhereCount @Quote [] + i <- liftSql $ Sql.deleteWhereCount @Quote [] sendMessage m ("Cleared " <> pack (show i) <> " quotes from the database.") clearQ _ m = sendMessage m "To _really do this_, call this command like so: `quote clear \"clear the quotes\"`" diff --git a/src/Tablebot/Plugins/Reminder.hs b/src/Tablebot/Plugins/Reminder.hs index d158e85..bb33584 100644 --- a/src/Tablebot/Plugins/Reminder.hs +++ b/src/Tablebot/Plugins/Reminder.hs @@ -21,14 +21,14 @@ import Data.Time.Clock.System (getSystemTime, systemToUTCTime) import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC) import Data.Time.LocalTime.TimeZone.Olson.Parse (getTimeZoneSeriesFromOlsonFile) import Data.Word (Word64) -import Database.Esqueleto hiding (delete, insert) +import Database.Esqueleto.Legacy +import qualified Database.Persist.Sqlite as Sql import Database.Persist.TH import Discord.Types import Duckling.Core (Dimension (Time), Entity (value), Lang (EN), Region (GB), ResolvedVal (RVal), Seal (Seal), currentReftime, makeLocale, parse) import Duckling.Resolve (Context (..), DucklingTime, Options (..)) import Duckling.Time.Types (InstantValue (InstantValue), SingleTimeValue (SimpleValue), TimeValue (TimeValue)) import Tablebot.Utility -import Tablebot.Utility.Database import Tablebot.Utility.Discord (getMessage, sendChannelMessage, sendCustomReplyMessage, sendMessage, toTimestamp) import Tablebot.Utility.Permission (requirePermission) import Tablebot.Utility.SmartParser (PComm (parseComm), Quoted (Qu), RestOfInput (ROI), WithError (..), IntegralData(..)) @@ -93,14 +93,14 @@ addReminder time content m = do let (Snowflake cid) = unId $ messageChannelId m (Snowflake mid) = unId $ messageId m (Snowflake uid) = unId $ userId $ messageAuthor m - added <- insert $ Reminder cid mid uid time content + added <- liftSql $ Sql.insert $ Reminder cid mid uid time content let res = pack $ show $ fromSqlKey added sendMessage m ("Reminder " <> res <> " set for " <> toTimestamp time <> " with message `" <> pack content <> "`") -- @deleteReminder@ takes a reminder Id and deletes it from the list of awating reminders. deleteReminder :: WithError "Missing required argument" (IntegralData Int) -> Message -> DatabaseDiscord () deleteReminder (WErr (MkIntegralData rid)) m = requirePermission Any m $ do - delete k + liftSql $ Sql.delete k sendMessage m ("Reminder " <> pack (show rid) <> " deleted.") where k :: Key Reminder @@ -130,17 +130,16 @@ reminderCron = do forM_ entitydue $ \re -> let (Reminder cid mid uid _time content) = entityVal re in do - liftIO . print $ entityVal re res <- getMessage (DiscordId $ Snowflake cid) (DiscordId $ Snowflake mid) case res of Left _ -> do sendChannelMessage (DiscordId (Snowflake cid)) (pack $ "Reminder to <@" ++ show uid ++ ">! " ++ content) - delete (entityKey re) + liftSql $ Sql.delete (entityKey re) Right mess -> do sendCustomReplyMessage mess (DiscordId $ Snowflake mid) True $ pack $ "Reminder to <@" ++ show uid ++ ">! " ++ content - delete (entityKey re) + liftSql $ Sql.delete (entityKey re) reminderHelp :: HelpPage reminderHelp = diff --git a/src/Tablebot/Utility/Database.hs b/src/Tablebot/Utility/Database.hs deleted file mode 100644 index 2c3c5b3..0000000 --- a/src/Tablebot/Utility/Database.hs +++ /dev/null @@ -1,121 +0,0 @@ --- | --- Module : Tablebot.Utility.Database --- Description : Wrappers to database functionality to match our main monad. --- License : MIT --- Maintainer : tagarople@gmail.com --- Stability : experimental --- Portability : POSIX --- --- Wrappers to database functionality to match our main monad. -module Tablebot.Utility.Database - ( module Tablebot.Utility.Database, - Sql.fromSqlKey, - Sql.toSqlKey, - liftSql, - ) -where - -import Data.Int (Int64) -import Data.Map (Map) -import Data.Text (Text) -import qualified Database.Persist.Sqlite as Sql -import Tablebot.Utility (EnvDatabaseDiscord, liftSql) - -insert :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => record -> EnvDatabaseDiscord d (Sql.Key record) -insert r = liftSql $ Sql.insert r - -insert_ :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => record -> EnvDatabaseDiscord d () -insert_ r = liftSql $ Sql.insert_ r - -insertMany :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => [record] -> EnvDatabaseDiscord d [Sql.Key record] -insertMany r = liftSql $ Sql.insertMany r - -insertMany_ :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => [record] -> EnvDatabaseDiscord d () -insertMany_ r = liftSql $ Sql.insertMany_ r - -insertEntityMany :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => [Sql.Entity record] -> EnvDatabaseDiscord d () -insertEntityMany r = liftSql $ Sql.insertEntityMany r - -insertEntity :: (Sql.PersistEntity e, Sql.PersistEntityBackend e ~ Sql.SqlBackend) => e -> EnvDatabaseDiscord d (Sql.Entity e) -insertEntity r = liftSql $ Sql.insertEntity r - -insertEntityUnique :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => record -> EnvDatabaseDiscord d (Maybe (Sql.Entity record)) -insertEntityUnique r = liftSql $ Sql.insertUniqueEntity r - -insertUnique :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => record -> EnvDatabaseDiscord d (Maybe (Sql.Key record)) -insertUnique r = liftSql $ Sql.insertUnique r - -delete :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => Sql.Key record -> EnvDatabaseDiscord d () -delete r = liftSql $ Sql.delete r - -deleteBy :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => Sql.Unique record -> EnvDatabaseDiscord d () -deleteBy r = liftSql $ Sql.deleteBy r - -deleteCascade :: (Sql.DeleteCascade record Sql.SqlBackend) => Sql.Key record -> EnvDatabaseDiscord d () -deleteCascade r = liftSql $ Sql.deleteCascade r - -deleteCascadeWhere :: (Sql.DeleteCascade record Sql.SqlBackend) => [Sql.Filter record] -> EnvDatabaseDiscord d () -deleteCascadeWhere r = liftSql $ Sql.deleteCascadeWhere r - -deleteWhereCount :: (Sql.PersistEntity val, Sql.PersistEntityBackend val ~ Sql.SqlBackend) => [Sql.Filter val] -> EnvDatabaseDiscord d Int64 -deleteWhereCount r = liftSql $ Sql.deleteWhereCount r - -update :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => Sql.Key record -> [Sql.Update record] -> EnvDatabaseDiscord d () -update r v = liftSql $ Sql.update r v - -updateWhere :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => [Sql.Filter record] -> [Sql.Update record] -> EnvDatabaseDiscord d () -updateWhere r v = liftSql $ Sql.updateWhere r v - -updateWhereCount :: (Sql.PersistEntity val, Sql.PersistEntityBackend val ~ Sql.SqlBackend) => [Sql.Filter val] -> [Sql.Update val] -> EnvDatabaseDiscord d Int64 -updateWhereCount r v = liftSql $ Sql.updateWhereCount r v - -updateGet :: (Sql.PersistEntity a, Sql.PersistEntityBackend a ~ Sql.SqlBackend) => Sql.Key a -> [Sql.Update a] -> EnvDatabaseDiscord d a -updateGet r v = liftSql $ Sql.updateGet r v - -upsert :: (Sql.OnlyOneUniqueKey record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => record -> [Sql.Update record] -> EnvDatabaseDiscord d (Sql.Entity record) -upsert r v = liftSql $ Sql.upsert r v - -replace :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => Sql.Key record -> record -> EnvDatabaseDiscord d () -replace r v = liftSql $ Sql.replace r v - -replaceUnique :: (Sql.PersistEntity record, Eq (Sql.Unique record), Sql.PersistEntityBackend record ~ Sql.SqlBackend) => Sql.Key record -> record -> EnvDatabaseDiscord d (Maybe (Sql.Unique record)) -replaceUnique r v = liftSql $ Sql.replaceUnique r v - -count :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => [Sql.Filter record] -> EnvDatabaseDiscord d Int -count r = liftSql $ Sql.count r - -exists :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => [Sql.Filter record] -> EnvDatabaseDiscord d Bool -exists r = liftSql $ Sql.exists r - -selectFirst :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => [Sql.Filter record] -> [Sql.SelectOpt record] -> EnvDatabaseDiscord d (Maybe (Sql.Entity record)) -selectFirst r v = liftSql $ Sql.selectFirst r v - -selectKeysList :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => [Sql.Filter record] -> [Sql.SelectOpt record] -> EnvDatabaseDiscord d [Sql.Key record] -selectKeysList r v = liftSql $ Sql.selectKeysList r v - -selectList :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => [Sql.Filter record] -> [Sql.SelectOpt record] -> EnvDatabaseDiscord d [Sql.Entity record] -selectList r v = liftSql $ Sql.selectList r v - -get :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => Sql.Key record -> EnvDatabaseDiscord d (Maybe record) -get v = liftSql $ Sql.get v - -getBy :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => Sql.Unique record -> EnvDatabaseDiscord d (Maybe (Sql.Entity record)) -getBy v = liftSql $ Sql.getBy v - -getByValue :: (Sql.AtLeastOneUniqueKey record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => record -> EnvDatabaseDiscord d (Maybe (Sql.Entity record)) -getByValue v = liftSql $ Sql.getByValue v - -getEntity :: (Sql.PersistEntity e, Sql.PersistEntityBackend e ~ Sql.SqlBackend) => Sql.Key e -> EnvDatabaseDiscord d (Maybe (Sql.Entity e)) -getEntity v = liftSql $ Sql.getEntity v - -getFieldName :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => Sql.EntityField record typ -> EnvDatabaseDiscord d Text -getFieldName v = liftSql $ Sql.getFieldName v - -getJust :: (Sql.PersistEntity a, Sql.PersistEntityBackend a ~ Sql.SqlBackend) => Sql.Key a -> EnvDatabaseDiscord d a -getJust v = liftSql $ Sql.getJust v - -getJustEntity :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => Sql.Key record -> EnvDatabaseDiscord d (Sql.Entity record) -getJustEntity v = liftSql $ Sql.getJustEntity v - -getMany :: (Sql.PersistEntity record, Sql.PersistEntityBackend record ~ Sql.SqlBackend) => [Sql.Key record] -> EnvDatabaseDiscord d (Map (Sql.Key record) record) -getMany v = liftSql $ Sql.getMany v From d4f30462a4fce38a7f1cb714aeeec8891b24b76a Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Wed, 17 Sep 2025 00:28:11 +0100 Subject: [PATCH 07/13] ormolu formatting --- src/Tablebot/Internal/Administration.hs | 2 +- src/Tablebot/Plugins/Administration.hs | 2 +- src/Tablebot/Plugins/Quote.hs | 10 +++++----- src/Tablebot/Plugins/Reminder.hs | 2 +- src/Tablebot/Plugins/Roll/Dice/DiceEval.hs | 2 +- src/Tablebot/Plugins/Roll/Plugin.hs | 2 +- src/Tablebot/Utility/Discord.hs | 6 +++--- 7 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Tablebot/Internal/Administration.hs b/src/Tablebot/Internal/Administration.hs index dbaac6d..bf76580 100644 --- a/src/Tablebot/Internal/Administration.hs +++ b/src/Tablebot/Internal/Administration.hs @@ -14,8 +14,8 @@ module Tablebot.Internal.Administration ) where -import Control.Monad.IO.Class (MonadIO) import Control.Monad (void, when) +import Control.Monad.IO.Class (MonadIO) import Data.List.Extra (isInfixOf, lower, trim) import Data.Text (Text, pack) import Database.Persist diff --git a/src/Tablebot/Plugins/Administration.hs b/src/Tablebot/Plugins/Administration.hs index 33cd94d..fb84677 100644 --- a/src/Tablebot/Plugins/Administration.hs +++ b/src/Tablebot/Plugins/Administration.hs @@ -19,6 +19,7 @@ import Data.Text (Text, pack) import qualified Data.Text as T import Data.Version (showVersion) import Database.Persist (Entity, Filter, entityVal, (==.)) +import qualified Database.Persist.Sqlite as Sql import Discord (stopDiscord) import Discord.Types import Language.Haskell.Printf (s) @@ -30,7 +31,6 @@ import Tablebot.Utility.Discord (sendMessage) import Tablebot.Utility.Permission (requirePermission) import Tablebot.Utility.SmartParser import Text.RawString.QQ -import qualified Database.Persist.Sqlite as Sql -- | @SS@ denotes the type returned by the command setup. Here its unused. type SS = [Text] diff --git a/src/Tablebot/Plugins/Quote.hs b/src/Tablebot/Plugins/Quote.hs index 24ccd05..402edb5 100644 --- a/src/Tablebot/Plugins/Quote.hs +++ b/src/Tablebot/Plugins/Quote.hs @@ -13,15 +13,17 @@ -- quotes and then @!quote show n@ a particular quote. module Tablebot.Plugins.Quote (quotes) where -import Control.Monad.IO.Class (liftIO) import Control.Monad (join) +import Control.Monad.IO.Class (liftIO) import Data.Aeson import Data.Default (Default (def)) import Data.Functor ((<&>)) import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import Data.Text (Text, append, pack, unpack) import Data.Time.Clock.System (SystemTime (systemSeconds), getSystemTime, systemToUTCTime) -import Database.Persist.Sqlite (Entity (entityKey), Filter, SelectOpt (LimitTo, OffsetBy), entityVal, (==.), toSqlKey, fromSqlKey) +import Data.Word +import Database.Persist.Sqlite (Entity (entityKey), Filter, SelectOpt (LimitTo, OffsetBy), entityVal, fromSqlKey, toSqlKey, (==.)) +import qualified Database.Persist.Sqlite as Sql import Database.Persist.TH import Discord (restCall) import Discord.Interactions @@ -36,13 +38,13 @@ import Tablebot.Utility.Discord getMessageLink, getPrecedingMessage, getReplyMessage, + idToWord, interactionResponseAutocomplete, interactionResponseCustomMessage, sendCustomMessage, sendMessage, toMention, toMention', - idToWord, wordToId, ) import Tablebot.Utility.Embed @@ -51,8 +53,6 @@ import Tablebot.Utility.Permission (requirePermission) import Tablebot.Utility.Search import Tablebot.Utility.SmartParser import Text.RawString.QQ (r) -import qualified Database.Persist.Sqlite as Sql -import Data.Word -- Our Quote table in the database. This is fairly standard for Persistent, -- however you should note the name of the migration made. diff --git a/src/Tablebot/Plugins/Reminder.hs b/src/Tablebot/Plugins/Reminder.hs index bb33584..0a50f84 100644 --- a/src/Tablebot/Plugins/Reminder.hs +++ b/src/Tablebot/Plugins/Reminder.hs @@ -31,7 +31,7 @@ import Duckling.Time.Types (InstantValue (InstantValue), SingleTimeValue (Simple import Tablebot.Utility import Tablebot.Utility.Discord (getMessage, sendChannelMessage, sendCustomReplyMessage, sendMessage, toTimestamp) import Tablebot.Utility.Permission (requirePermission) -import Tablebot.Utility.SmartParser (PComm (parseComm), Quoted (Qu), RestOfInput (ROI), WithError (..), IntegralData(..)) +import Tablebot.Utility.SmartParser (IntegralData (..), PComm (parseComm), Quoted (Qu), RestOfInput (ROI), WithError (..)) import Text.RawString.QQ (r) -- Our Reminder table in the database. This is fairly standard for Persistent, diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs b/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs index 370a873..5ca0f67 100644 --- a/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs +++ b/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs @@ -10,9 +10,9 @@ -- expressions. module Tablebot.Plugins.Roll.Dice.DiceEval (ParseShow (parseShow), evalProgram, evalList, evalInteger, evaluationException, propagateException, maximumRNG, maximumListLength) where +import Control.Monad (when) import Control.Monad.Exception (MonadException) import Control.Monad.State (MonadIO (liftIO), StateT, evalStateT, gets, modify) -import Control.Monad (when) import Data.List (foldl', genericDrop, genericReplicate, genericTake, sortBy) import Data.List.NonEmpty as NE (NonEmpty ((:|)), head, tail, (<|)) import Data.Map (Map, empty) diff --git a/src/Tablebot/Plugins/Roll/Plugin.hs b/src/Tablebot/Plugins/Roll/Plugin.hs index cef900f..7abb5f5 100644 --- a/src/Tablebot/Plugins/Roll/Plugin.hs +++ b/src/Tablebot/Plugins/Roll/Plugin.hs @@ -9,8 +9,8 @@ -- A command that outputs the result of rolling the input dice. module Tablebot.Plugins.Roll.Plugin (rollPlugin) where -import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.ByteString.Lazy (toStrict) import Data.Default (Default (def)) import Data.Distribution (isValid) diff --git a/src/Tablebot/Utility/Discord.hs b/src/Tablebot/Utility/Discord.hs index 43b0a8e..b81cbfe 100644 --- a/src/Tablebot/Utility/Discord.hs +++ b/src/Tablebot/Utility/Discord.hs @@ -49,13 +49,14 @@ module Tablebot.Utility.Discord interactionResponseComponentsUpdateMessage, interactionResponseAutocomplete, idToWord, - wordToId + wordToId, ) where -import Control.Monad.IO.Class (liftIO) import Control.Monad.Exception (MonadException (throw)) +import Control.Monad.IO.Class (liftIO) import Data.Char (isDigit) +import Data.Coerce (coerce) import Data.Default (Default (def)) import Data.Foldable (msum) import Data.List ((\\)) @@ -75,7 +76,6 @@ import Tablebot.Internal.Cache (fillEmojiCache, lookupEmojiCache) import Tablebot.Internal.Embed (Embeddable (..)) import Tablebot.Utility (EnvDatabaseDiscord, MessageDetails, convertMessageFormatBasic, convertMessageFormatInteraction, liftDiscord, messageDetailsBasic) import Tablebot.Utility.Exception (BotException (..)) -import Data.Coerce ( coerce ) -- | @sendMessage@ sends the input message @t@ in the same channel as message -- @m@. From 7cbf2e416efd6ac9855caf09d102b40ae7e8c79b Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Wed, 17 Sep 2025 18:19:45 +0100 Subject: [PATCH 08/13] add view patterns --- package.yaml | 1 + tablebot.cabal | 1 + 2 files changed, 2 insertions(+) diff --git a/package.yaml b/package.yaml index 0896e71..2993826 100644 --- a/package.yaml +++ b/package.yaml @@ -100,6 +100,7 @@ library: - TypeOperators - RankNTypes - BangPatterns + - ViewPatterns ghc-options: - -Wall diff --git a/tablebot.cabal b/tablebot.cabal index be18c7b..15c12c9 100644 --- a/tablebot.cabal +++ b/tablebot.cabal @@ -129,6 +129,7 @@ library TypeOperators RankNTypes BangPatterns + ViewPatterns ghc-options: -Wall build-depends: Chart From 9466cb86dc6a1e04a4b70e6c7d5fa93974284dd8 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Wed, 17 Sep 2025 18:21:14 +0100 Subject: [PATCH 09/13] basic warning fixes --- src/Tablebot.hs | 2 -- src/Tablebot/Plugins/Administration.hs | 8 ++++---- src/Tablebot/Plugins/Flip.hs | 6 +++--- src/Tablebot/Plugins/Netrunner/Command/BanList.hs | 6 ++---- src/Tablebot/Plugins/Netrunner/Command/Search.hs | 2 +- src/Tablebot/Plugins/Quote.hs | 6 +++--- src/Tablebot/Plugins/Roll/Dice/DiceEval.hs | 6 ++++-- src/Tablebot/Plugins/Roll/Dice/DiceStats.hs | 2 +- src/Tablebot/Utility/SmartParser/Interactions.hs | 12 +++++++----- src/Tablebot/Utility/Utils.hs | 2 +- 10 files changed, 26 insertions(+), 26 deletions(-) diff --git a/src/Tablebot.hs b/src/Tablebot.hs index f534650..9813c88 100644 --- a/src/Tablebot.hs +++ b/src/Tablebot.hs @@ -27,7 +27,6 @@ import Data.Map as M (empty) import Data.Maybe (fromMaybe) import Data.Text (Text, pack) import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) import Database.Persist.Sqlite ( runMigration, runSqlPool, @@ -38,7 +37,6 @@ import Discord.Internal.Rest import LoadEnv (loadEnv) import Paths_tablebot (version) import System.Environment (getEnv, lookupEnv) -import System.Exit (die) import Tablebot.Handler (eventHandler, killCron, runCron, submitApplicationCommands) import Tablebot.Internal.Administration ( ShutdownReason (Reload), diff --git a/src/Tablebot/Plugins/Administration.hs b/src/Tablebot/Plugins/Administration.hs index fb84677..263a286 100644 --- a/src/Tablebot/Plugins/Administration.hs +++ b/src/Tablebot/Plugins/Administration.hs @@ -70,11 +70,11 @@ addBlacklist pLabel m = requirePermission Superuser m $ do removeBlacklist :: String -> Message -> EnvDatabaseDiscord SS () removeBlacklist pLabel m = requirePermission Superuser m $ do extant <- liftSql $ Sql.selectKeysList [PluginBlacklistLabel ==. pLabel] [] - if not $ null extant - then do - _ <- liftSql $ Sql.delete (head extant) + case extant of + x : _ -> do + _ <- liftSql $ Sql.delete x sendMessage m "Plugin removed from blacklist. Please reload for it to take effect" - else sendMessage m "Plugin not in blacklist" + _ -> sendMessage m "Plugin not in blacklist" -- | @listBlacklist@ shows a list of the plugins eligible for disablement (those not starting with _), -- along with their current status. diff --git a/src/Tablebot/Plugins/Flip.hs b/src/Tablebot/Plugins/Flip.hs index 66a2d0d..93be3c5 100644 --- a/src/Tablebot/Plugins/Flip.hs +++ b/src/Tablebot/Plugins/Flip.hs @@ -28,9 +28,9 @@ flip = Command "flip" flipcomm [] flipcomm = do args <- (try quoted <|> nonSpaceWord) `sepBy` some space return $ \m -> do - c <- case length args of - 0 -> liftIO $ chooseOneWithDefault "" ["Heads", "Tails"] - _ -> liftIO $ chooseOneWithDefault (head args) args + c <- case args of + [] -> liftIO $ chooseOneWithDefault "" ["Heads", "Tails"] + a : _ -> liftIO $ chooseOneWithDefault a args sendMessage m $ pack c flipHelp :: HelpPage diff --git a/src/Tablebot/Plugins/Netrunner/Command/BanList.hs b/src/Tablebot/Plugins/Netrunner/Command/BanList.hs index d303376..7a5e28a 100644 --- a/src/Tablebot/Plugins/Netrunner/Command/BanList.hs +++ b/src/Tablebot/Plugins/Netrunner/Command/BanList.hs @@ -19,7 +19,7 @@ where import Data.List (nubBy) import Data.Map (keys) -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.Text (Text, intercalate, isInfixOf, toLower, unpack) import qualified Data.Text as T (length, take) import Tablebot.Plugins.Netrunner.Type.BanList (BanList (active, affectedCards, listId, name), CardBan (..)) @@ -81,9 +81,7 @@ listAffectedCards api b = in (pre, map format cCards, map format rCards) where find :: Text -> Maybe Card - find cCode = case filter ((Just cCode ==) . code) $ cards api of - [] -> Nothing - xs -> Just $ head xs + find cCode = listToMaybe $ filter ((Just cCode ==) . code) $ cards api format :: Card -> Text format card = symbol (toMwlStatus api b card) <> " " <> condense (fromMaybe "?" $ title card) condense :: Text -> Text diff --git a/src/Tablebot/Plugins/Netrunner/Command/Search.hs b/src/Tablebot/Plugins/Netrunner/Command/Search.hs index 33c8ccc..34e99d7 100644 --- a/src/Tablebot/Plugins/Netrunner/Command/Search.hs +++ b/src/Tablebot/Plugins/Netrunner/Command/Search.hs @@ -126,7 +126,7 @@ fixSearch api = mapMaybe fix -- format ("r", sep, v) = format ("u", sep, v) = Just $ QBool "u" sep uniqueness v format ("b", _, []) = Nothing - format ("b", sep, v) = Just $ QBan "b" sep $ fixBan $ head v + format ("b", sep, v : _) = Just $ QBan "b" sep $ fixBan v -- format ("z", sep, v) = format _ = Nothing cycleIndex :: Card -> Maybe Int diff --git a/src/Tablebot/Plugins/Quote.hs b/src/Tablebot/Plugins/Quote.hs index 402edb5..a84da78 100644 --- a/src/Tablebot/Plugins/Quote.hs +++ b/src/Tablebot/Plugins/Quote.hs @@ -222,10 +222,10 @@ filteredRandomQuote' quoteFilter errorMessage mb m = do then throwBot (GenericException "quote exception" (unpack errorMessage)) else do rindex <- liftIO $ randomRIO (0, num - 1) - key <- liftSql $ Sql.selectKeysList quoteFilter [OffsetBy rindex, LimitTo 1] - qu <- traverse (liftSql . Sql.get) $ listToMaybe key + keys <- liftSql $ Sql.selectKeysList quoteFilter [OffsetBy rindex, LimitTo 1] + qu <- traverse (\key -> fmap (,key) <$> liftSql (Sql.get key)) $ listToMaybe keys case join qu of - Just q -> renderQuoteMessage q (fromSqlKey $ head key) mb m + Just (q, key) -> renderQuoteMessage q (fromSqlKey key) mb m Nothing -> throwBot (GenericException "quote exception" (unpack errorMessage)) -- | @addQuote@, which looks for a message of the form diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs b/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs index 5ca0f67..ab98561 100644 --- a/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs +++ b/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs @@ -13,7 +13,7 @@ module Tablebot.Plugins.Roll.Dice.DiceEval (ParseShow (parseShow), evalProgram, import Control.Monad (when) import Control.Monad.Exception (MonadException) import Control.Monad.State (MonadIO (liftIO), StateT, evalStateT, gets, modify) -import Data.List (foldl', genericDrop, genericReplicate, genericTake, sortBy) +import Data.List (genericDrop, genericReplicate, genericTake, sortBy) import Data.List.NonEmpty as NE (NonEmpty ((:|)), head, tail, (<|)) import Data.Map (Map, empty) import qualified Data.Map as M @@ -161,7 +161,9 @@ propagateException t a = catchBot a handleException handleException (EvaluationException msg' locs) = throwBot (EvaluationException msg' (addIfNotIn locs)) handleException e = throwBot e pa = unpack t - addIfNotIn locs = if null locs || pa /= Prelude.head locs then pa : locs else locs + addIfNotIn locs = case locs of + x : _ | pa == x -> locs + _ -> pa : locs -- | This type class evaluates an item and returns a list of integers (with -- their representations if valid). diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceStats.hs b/src/Tablebot/Plugins/Roll/Dice/DiceStats.hs index b1f60aa..9e3bb20 100644 --- a/src/Tablebot/Plugins/Roll/Dice/DiceStats.hs +++ b/src/Tablebot/Plugins/Roll/Dice/DiceStats.hs @@ -59,7 +59,7 @@ rangeListValues lv = do head' [] = [] head' (x : _) = [x] getHeads xs = (\(xs', p) -> (,p) <$> head' xs') =<< xs - getTails xs = first tail <$> xs + getTails xs = first (drop 1) <$> xs zip' xs = getHeads xs : zip' (getTails xs) -- | Type class to get the overall range of a value. diff --git a/src/Tablebot/Utility/SmartParser/Interactions.hs b/src/Tablebot/Utility/SmartParser/Interactions.hs index 078e973..50d2963 100644 --- a/src/Tablebot/Utility/SmartParser/Interactions.hs +++ b/src/Tablebot/Utility/SmartParser/Interactions.hs @@ -46,11 +46,13 @@ makeApplicationCommandPair name desc f = do -- a function's type. makeSlashCommand :: (MakeAppComm t) => Text -> Text -> Proxy t -> Maybe CreateApplicationCommand makeSlashCommand name desc p = - createChatInput name desc >>= \cac -> - return $ - cac - { createOptions = Just $ OptionsValues $ makeAppComm p - } + createChatInput name desc >>= \case + cac@CreateApplicationCommandChatInput {} -> + return $ + cac + { createOptions = Just $ OptionsValues $ makeAppComm p + } + _ -> Nothing -- | Create a series of command option values from the given types. -- diff --git a/src/Tablebot/Utility/Utils.hs b/src/Tablebot/Utility/Utils.hs index f42bce3..c1c5701 100644 --- a/src/Tablebot/Utility/Utils.hs +++ b/src/Tablebot/Utility/Utils.hs @@ -13,7 +13,7 @@ import Control.Monad (when) import Data.Proxy (Proxy (Proxy)) import Data.Text (Text, filter, toLower) import Data.Text.ICU.Char (Bool_ (Diacritic), property) -import Data.Text.ICU.Normalize (NormalizationMode (NFD), normalize) +import Data.Text.ICU.Normalize2 (NormalizationMode (NFD), normalize) import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Builder.Int (decimal) From 4ecf53334d41b6f3a1fe8531fffeeadb9227e6cb Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Wed, 17 Sep 2025 18:21:36 +0100 Subject: [PATCH 10/13] use nonempty here to avoid `head` --- src/Tablebot/Internal/Handler/Command.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Tablebot/Internal/Handler/Command.hs b/src/Tablebot/Internal/Handler/Command.hs index 2adc979..eb5878d 100644 --- a/src/Tablebot/Internal/Handler/Command.hs +++ b/src/Tablebot/Internal/Handler/Command.hs @@ -17,6 +17,7 @@ module Tablebot.Internal.Handler.Command ) where +import qualified Data.Functor as Functor import Data.List (find) import qualified Data.List.NonEmpty as NE import Data.Maybe (catMaybes) @@ -125,7 +126,7 @@ instance ShowErrorComponent ReadableError where makeBundleReadable :: ParseErrorBundle Text Void -> (ParseErrorBundle Text ReadableError, String) makeBundleReadable (ParseErrorBundle errs state) = - let (errors, title) = NE.unzip $ NE.map makeReadable errs + let (errors, title) = Functor.unzip $ NE.map makeReadable errs in (ParseErrorBundle errors state, getTitle $ NE.toList title) where getTitle :: [Maybe String] -> String @@ -133,10 +134,9 @@ makeBundleReadable (ParseErrorBundle errs state) = getTitle titles = case filter (not . null) $ catMaybes titles of -- therefore, `x` is nonempty, so `lines x` is nonempty, meaning that `head (lines x)` is fine, -- since `lines x` is nonempty for nonempty input. - (x : xs) -> - let title = head (lines x) - in if null xs then title else title ++ " (and " ++ show (length xs) ++ " more)" - [] -> "Parser Error!" + ((NE.nonEmpty . lines -> Just (title NE.:| _)) : xs) -> + if null xs then title else title ++ " (and " ++ show (length xs) ++ " more)" + _ -> "Parser Error!" -- | Transform our errors into more useful ones. -- This uses the Label hidden within each error to build an error message, From d294d964bc505d1b55565e737591a15c68301ba7 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Wed, 17 Sep 2025 18:24:10 +0100 Subject: [PATCH 11/13] use parser for fromMention, invert module dep and move inlineCommandHelper --- src/Tablebot/Plugins/Netrunner/Plugin.hs | 4 +-- src/Tablebot/Plugins/Roll/Plugin.hs | 2 +- src/Tablebot/Utility/Discord.hs | 39 +++++++++++++++--------- src/Tablebot/Utility/Parser.hs | 38 +++++++++++------------ 4 files changed, 44 insertions(+), 39 deletions(-) diff --git a/src/Tablebot/Plugins/Netrunner/Plugin.hs b/src/Tablebot/Plugins/Netrunner/Plugin.hs index 3c2d297..3dd6e42 100644 --- a/src/Tablebot/Plugins/Netrunner/Plugin.hs +++ b/src/Tablebot/Plugins/Netrunner/Plugin.hs @@ -29,9 +29,9 @@ import Tablebot.Plugins.Netrunner.Utility.Card (toText) import Tablebot.Plugins.Netrunner.Utility.Embed import Tablebot.Plugins.Netrunner.Utility.NrApi (getNrApi) import Tablebot.Utility -import Tablebot.Utility.Discord (formatFromEmojiName, sendEmbedMessage, sendMessage) +import Tablebot.Utility.Discord (formatFromEmojiName, inlineCommandHelper, sendEmbedMessage, sendMessage) import Tablebot.Utility.Embed (addColour) -import Tablebot.Utility.Parser (inlineCommandHelper, keyValue, keyValuesSepOn) +import Tablebot.Utility.Parser (keyValue, keyValuesSepOn) import Tablebot.Utility.SmartParser (PComm (parseComm), Quoted (Qu), RestOfInput (ROI), RestOfInput1 (ROI1), WithError (WErr)) import Tablebot.Utility.Types () import Text.Megaparsec (anySingleBut, some) diff --git a/src/Tablebot/Plugins/Roll/Plugin.hs b/src/Tablebot/Plugins/Roll/Plugin.hs index 7abb5f5..5de537f 100644 --- a/src/Tablebot/Plugins/Roll/Plugin.hs +++ b/src/Tablebot/Plugins/Roll/Plugin.hs @@ -31,7 +31,7 @@ import Tablebot.Plugins.Roll.Dice.DiceData import Tablebot.Plugins.Roll.Dice.DiceStats (getStats, rangeExpr) import Tablebot.Plugins.Roll.Dice.DiceStatsBase (distributionByteString) import Tablebot.Utility -import Tablebot.Utility.Discord (Format (Code), formatText, sendCustomMessage, sendMessage, toMention') +import Tablebot.Utility.Discord (Format (Code), formatText, inlineCommandHelper, sendCustomMessage, sendMessage, toMention') import Tablebot.Utility.Exception (BotException (EvaluationException), throwBot) import Tablebot.Utility.Parser import Tablebot.Utility.SmartParser diff --git a/src/Tablebot/Utility/Discord.hs b/src/Tablebot/Utility/Discord.hs index b81cbfe..62a1617 100644 --- a/src/Tablebot/Utility/Discord.hs +++ b/src/Tablebot/Utility/Discord.hs @@ -27,7 +27,6 @@ module Tablebot.Utility.Discord toMention, toMention', fromMention, - fromMentionStr, toTimestamp, toTimestamp', formatEmoji, @@ -48,22 +47,23 @@ module Tablebot.Utility.Discord interactionResponseCustomMessage, interactionResponseComponentsUpdateMessage, interactionResponseAutocomplete, + inlineCommandHelper, idToWord, wordToId, ) where +import Control.Monad import Control.Monad.Exception (MonadException (throw)) import Control.Monad.IO.Class (liftIO) -import Data.Char (isDigit) import Data.Coerce (coerce) import Data.Default (Default (def)) -import Data.Foldable (msum) import Data.List ((\\)) import Data.Map.Strict (keys) import Data.Maybe (listToMaybe) import Data.String (IsString (fromString)) -import Data.Text (Text, pack, unpack) +import Data.Text (Text, pack) +import qualified Data.Text as T import Data.Time.Clock (nominalDiffTimeToSeconds) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Discord (Cache (cacheGuilds), DiscordHandler, RestCallErrorCode, readCache, restCall) @@ -74,8 +74,11 @@ import GHC.Word (Word64) import System.Environment (lookupEnv) import Tablebot.Internal.Cache (fillEmojiCache, lookupEmojiCache) import Tablebot.Internal.Embed (Embeddable (..)) -import Tablebot.Utility (EnvDatabaseDiscord, MessageDetails, convertMessageFormatBasic, convertMessageFormatInteraction, liftDiscord, messageDetailsBasic) +import Tablebot.Utility import Tablebot.Utility.Exception (BotException (..)) +import Tablebot.Utility.Parser +import Text.Megaparsec +import Text.Megaparsec.Char (string) -- | @sendMessage@ sends the input message @t@ in the same channel as message -- @m@. @@ -308,16 +311,7 @@ toMention' u = "<@!" <> pack (show u) <> ">" -- | @fromMention@ converts some text into what could be a userid (which isn't checked -- for correctness above getting rid of triangle brackets, '@', and the optional '!') fromMention :: Text -> Maybe UserId -fromMention = fromMentionStr . unpack - --- | Try to get the userid from a given string. -fromMentionStr :: String -> Maybe UserId -fromMentionStr user - | length user < 4 || head user /= '<' || last user /= '>' || (head . tail) user /= '@' || (head stripToNum /= '!' && (not . isDigit) (head stripToNum)) = Nothing - | all isDigit (tail stripToNum) = Just $ if head stripToNum == '!' then read (tail stripToNum) else read stripToNum - | otherwise = Nothing - where - stripToNum = (init . tail . tail) user +fromMention = parseMaybe parseMentionUserId -- | Data types for different time formats. data TimeFormat = Default | ShortTime | LongTime | ShortDate | LongDate | ShortDateTime | LongDateTime | Relative deriving (Show, Enum, Eq) @@ -459,3 +453,18 @@ wordToId = coerce idToWord :: DiscordId a -> Word64 idToWord = coerce + +-- | For helping to create inline commands. Takes the opening characters, closing +-- characters, a parser to get a value `e`, and an action that takes that `e` and a +-- message and produces a DatabaseDiscord effect. +inlineCommandHelper :: Text -> Text -> Parser e -> (e -> Message -> EnvDatabaseDiscord d ()) -> EnvInlineCommand d +inlineCommandHelper open close p action = + InlineCommand + ( do + getExprs <- some (try $ skipManyTill anySingle (string open *> skipSpace *> (((Right <$> try p) <* skipSpace <* string close) <|> (Left . T.pack <$> manyTill anySingle (string close))))) + return $ \m -> mapM_ (`action'` m) (take maxInlineCommands getExprs) + ) + where + maxInlineCommands = 3 + action' (Right p') m = action p' m + action' (Left _) m = void $ reactToMessage m "x" diff --git a/src/Tablebot/Utility/Parser.hs b/src/Tablebot/Utility/Parser.hs index f50b327..c2053d2 100644 --- a/src/Tablebot/Utility/Parser.hs +++ b/src/Tablebot/Utility/Parser.hs @@ -11,14 +11,17 @@ module Tablebot.Utility.Parser where import Data.Char (isDigit, isLetter, isSpace) -import Data.Functor (void, ($>)) +import Data.Functor (($>)) import Data.Text (Text) -import qualified Data.Text as T -import Discord.Internal.Rest (Message) -import Tablebot.Utility -import Tablebot.Utility.Discord (reactToMessage) +import Discord.Types + ( DiscordId (..), + Snowflake (..), + UserId, + ) +import Tablebot.Utility.Types (Parser) import Text.Megaparsec -import Text.Megaparsec.Char (char, string) +import Text.Megaparsec.Char (char) +import Text.Read (readMaybe) space :: Parser () space = satisfy isSpace $> () @@ -171,21 +174,6 @@ double = do <|> return "" return (read (minus : digits ++ decimal)) --- | For helping to create inline commands. Takes the opening characters, closing --- characters, a parser to get a value `e`, and an action that takes that `e` and a --- message and produces a DatabaseDiscord effect. -inlineCommandHelper :: Text -> Text -> Parser e -> (e -> Message -> EnvDatabaseDiscord d ()) -> EnvInlineCommand d -inlineCommandHelper open close p action = - InlineCommand - ( do - getExprs <- some (try $ skipManyTill anySingle (string open *> skipSpace *> (((Right <$> try p) <* skipSpace <* string close) <|> (Left . T.pack <$> manyTill anySingle (string close))))) - return $ \m -> mapM_ (`action'` m) (take maxInlineCommands getExprs) - ) - where - maxInlineCommands = 3 - action' (Right p') m = action p' m - action' (Left _) m = void $ reactToMessage m "x" - -- | Parse 0 or more comma separated values. parseCommaSeparated :: Parser a -> Parser [a] parseCommaSeparated p = do @@ -214,3 +202,11 @@ instance (ParseShow a, ParseShow b) => ParseShow (Either a b) where instance ParseShow Text where parseShow t = t + +-- | Try to get the userid from a given string. +parseMentionUserId :: Parser UserId +parseMentionUserId = do + digits <- between (chunk "<@" <* optional (single '!')) (single '>') (some digit) -- single '<' *> single '@' *> single '!' *> some (satisy ) <* single '>' + case readMaybe digits of + Just i -> pure $ DiscordId $ Snowflake $ i + Nothing -> fail $ "could not read user id: " <> show digits From b05099fac11ffcd018c08877eb983c15731ae736 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Wed, 17 Sep 2025 18:24:39 +0100 Subject: [PATCH 12/13] guarantee nonemptiness to avoid head --- src/Tablebot/Plugins/Roll/Plugin.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Tablebot/Plugins/Roll/Plugin.hs b/src/Tablebot/Plugins/Roll/Plugin.hs index 5de537f..7f35879 100644 --- a/src/Tablebot/Plugins/Roll/Plugin.hs +++ b/src/Tablebot/Plugins/Roll/Plugin.hs @@ -14,6 +14,7 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.ByteString.Lazy (toStrict) import Data.Default (Default (def)) import Data.Distribution (isValid) +import qualified Data.List.NonEmpty as NE import Data.Maybe (catMaybes, fromMaybe) import Data.Text (Text, intercalate, pack, replicate, unpack) import qualified Data.Text as T @@ -195,18 +196,17 @@ To see a full list of uses, options and limitations, please go to rpgSystems') +genchar = Command "genchar" (snd $ NE.head rpgSystems') (toCommand <$> NE.toList rpgSystems') where doDiceRoll (nm, lv) = (nm, parseComm $ rollDice' (Just (Program [] (Left lv))) (Just (Qu ("genchar for " <> nm)))) rpgSystems' = doDiceRoll <$> rpgSystems toCommand (nm, ps) = Command nm ps [] -- | List of supported genchar systems and the dice used to roll for them -rpgSystems :: [(Text, ListValues)] +rpgSystems :: NE.NonEmpty (Text, ListValues) rpgSystems = - [ ("dnd", MultipleValues (Value 6) (DiceBase (Dice (NBase (Value 4)) (Die (Value 6)) (Just (DieOpRecur (DieOpOptionKD Drop (Low (Value 1))) Nothing))))), - ("wfrp", MultipleValues (Value 8) (NBase (NBParen (Paren (Expr (BinOp (promote (Value 20)) [(Add, promote (Die (Value 10)))])))))) - ] + ("dnd", MultipleValues (Value 6) (DiceBase (Dice (NBase (Value 4)) (Die (Value 6)) (Just (DieOpRecur (DieOpOptionKD Drop (Low (Value 1))) Nothing))))) + NE.:| [("wfrp", MultipleValues (Value 8) (NBase (NBParen (Paren (Expr (BinOp (promote (Value 20)) [(Add, promote (Die (Value 10)))]))))))] -- | Small help page for gen char. gencharHelp :: HelpPage @@ -215,7 +215,7 @@ gencharHelp = "genchar" [] "generate stat arrays for some systems" - ("**Genchar**\nCan be used to generate stat arrays for certain systems.\n\nCurrently supported systems: " <> intercalate ", " (fst <$> rpgSystems) <> ".\n\n*Usage:* `genchar`, `genchar dnd`") + ("**Genchar**\nCan be used to generate stat arrays for certain systems.\n\nCurrently supported systems: " <> intercalate ", " (fst <$> NE.toList rpgSystems) <> ".\n\n*Usage:* `genchar`, `genchar dnd`") [] None From d01404f83fce7e23789eb10a50bd3d5c1a4aa5be Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Thu, 18 Sep 2025 19:29:19 +0100 Subject: [PATCH 13/13] treat infinite stream like an infinite stream --- .../Plugins/Roll/Dice/DiceStatsBase.hs | 27 ++++++++++++++----- 1 file changed, 20 insertions(+), 7 deletions(-) diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceStatsBase.hs b/src/Tablebot/Plugins/Roll/Dice/DiceStatsBase.hs index bfbda8f..09c5f52 100644 --- a/src/Tablebot/Plugins/Roll/Dice/DiceStatsBase.hs +++ b/src/Tablebot/Plugins/Roll/Dice/DiceStatsBase.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveFunctor #-} + -- | -- Module : Tablebot.Plugins.Roll.Dice.DiceStatsBase -- Description : The basics for dice stats @@ -106,31 +108,42 @@ scaledIntAxis' r@(minI, maxI) _ = makeAxis (_la_labelf lap) ((minI - 1) : (maxI ) gridvs = labelvs +data Stream a = a :|< Stream a + deriving (Functor) + +prependList :: [a] -> Stream a -> Stream a +prependList [] stream = stream +prependList (a : as) stream = a :|< prependList as stream + +spanStream :: (a -> Bool) -> Stream a -> ([a], Stream a) +spanStream f stream@(a :|< as) + | f a = first (a :) $ spanStream f as + | otherwise = ([], stream) + -- | Taken and modified from -- https://hackage.haskell.org/package/Chart-1.9.3/docs/src/Graphics.Rendering.Chart.Axis.Int.html#stepsInt stepsInt' :: Integer -> (Integer, Integer) -> [Integer] stepsInt' nSteps range = bestSize (goodness alt0) alt0 alts where - bestSize n a (a' : as) = + bestSize n a (a' :|< as) = let n' = goodness a' in if n' < n then bestSize n' a' as else a - bestSize _ _ [] = [] goodness vs = abs (genericLength vs - nSteps) - (alt0 : alts) = map (`steps` range) sampleSteps' + (alt0 :|< alts) = fmap (`steps` range) sampleSteps' -- throw away sampleSteps that are definitely too small as -- they takes a long time to process sampleSteps' = let rangeMag = (snd range - fst range) - (s1, s2) = span (< (rangeMag `div` nSteps)) sampleSteps - in (reverse . take 5 . reverse) s1 ++ s2 + (s1, s2) = spanStream (< (rangeMag `div` nSteps)) sampleSteps + in (reverse . take 5 . reverse) s1 `prependList` s2 -- generate all possible step sizes - sampleSteps = [1, 2, 5] ++ sampleSteps1 - sampleSteps1 = [10, 20, 25, 50] ++ map (* 10) sampleSteps1 + sampleSteps = [1, 2, 5] `prependList` sampleSteps1 + sampleSteps1 = [10, 20, 25, 50] `prependList` fmap (* 10) sampleSteps1 steps :: Integer -> (Integer, Integer) -> [Integer] steps size' (minV, maxV) = takeWhile (< b) [a, a + size' ..] ++ [b]