diff --git a/.env.example b/.env.example index 2d641d2f..b5fb462b 100644 --- a/.env.example +++ b/.env.example @@ -9,4 +9,5 @@ SUPERUSER_GROUP=147258369147258369 SERVER_ID=314159265358979323 ALLOW_GIT_UPDATE=False EMOJI_SERVERS=[121213131414151516] +STATS_TIMEOUT=20 # NOTE: YOU MUST HAVE A NEWLINE AT THE END OF THE FILE diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index f5723b20..f883b801 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -6,7 +6,7 @@ name: CI on: # Triggers the workflow on push or pull request events but only for the main branch push: - branches: [ main ] + branches: [main] pull_request: # Allows you to run this workflow manually from the Actions tab @@ -17,26 +17,46 @@ jobs: ormolu: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v2 - - uses: mrkkrp/ormolu-action@v4 + - uses: actions/checkout@v4 + - uses: haskell-actions/run-ormolu@v17 + build: - name: Build - runs-on: ubuntu-latest # or macOS-latest, or windows-latest - needs: ormolu + name: Build Docker Image + runs-on: ubuntu-latest + permissions: + packages: write + needs: + - ormolu + if: success() steps: - - uses: actions/checkout@v2 - - uses: haskell/actions/setup@v1 + - uses: actions/checkout@v3 + + - name: Log in to the Container registry + uses: docker/login-action@v2 + if: github.event_name != 'pull_request' # don't need to login if we're not pushing with: - ghc-version: 'latest' - enable-stack: true - stack-version: 'latest' - - name: Cache .stack - id: cache-stack - uses: actions/cache@v2 + registry: ghcr.io + username: ${{ github.repository_owner }} + password: ${{ secrets.GITHUB_TOKEN }} + + - name: Get Docker Metadata + id: meta + uses: docker/metadata-action@v4 + with: + images: ghcr.io/${{ github.repository }} + tags: | # tag with commit hash and with 'latest' + type=sha + type=raw,value=latest,enable={{is_default_branch}} + + - name: Set up Docker Buildx + uses: docker/setup-buildx-action@v2 + + - name: Build and Push Docker image + uses: docker/build-push-action@v3 with: - path: ~/.stack - key: ${{ runner.os }}-stack-${{ hashFiles('stack.yaml') }} - restore-keys: | - ${{ runner.os }}-stack - ${{ runner.os }} - - run: stack build + context: . + push: ${{ github.event_name != 'pull_request' }} # dont push on a pull request + tags: ${{ steps.meta.outputs.tags }} + labels: ${{ steps.meta.outputs.labels }} + cache-from: type=gha + cache-to: type=gha,mode=max diff --git a/.gitignore b/.gitignore index 57468f69..21e4f10d 100644 --- a/.gitignore +++ b/.gitignore @@ -3,7 +3,7 @@ .env db.* database* -*.cabal -stack.yaml.lock .gitattributes .vscode +dist-newstyle/ +cabal.project.local diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 00000000..a6507bec --- /dev/null +++ b/Dockerfile @@ -0,0 +1,37 @@ +# stack resolver 24.10 uses ghc 9.10.2 - when upgrading LTS version in stack.yaml, check Haskell version on https://www.stackage.org/ and check which Debian release is available on https://hub.docker.com/_/haskell/ +FROM haskell:9.10.2-bullseye as build +RUN mkdir -p /tablebot/build +WORKDIR /tablebot/build + +# system lib dependencies +RUN apt-get update -qq && \ + apt-get install -qq -y libpcre3-dev build-essential pkg-config libicu-dev --fix-missing --no-install-recommends && \ + apt-get clean && \ + rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/* + +COPY . . + +RUN stack build --system-ghc + +RUN mv "$(stack path --local-install-root --system-ghc)/bin" /tablebot/build/bin + +# ensure this matches first FROM +FROM haskell:9.10.2-slim-bullseye as app + +# system runtime deps - if this command fails, check libicu version (https://packages.debian.org/index) and upgrade if necessary +RUN apt-get update -qq && \ + apt-get install -qq -y libpcre3 libicu67 --fix-missing --no-install-recommends && \ + apt-get clean && \ + rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/* + +RUN mkdir -p /tablebot +WORKDIR /tablebot + +COPY --from=build /tablebot/build/bin . +# apparently we need the .git folder +COPY .git .git +# we need fonts for the roll stats +COPY fonts fonts +# resources folder +COPY resources resources +CMD /tablebot/tablebot-exe diff --git a/README.md b/README.md index e8ee3b9a..55a5a238 100644 --- a/README.md +++ b/README.md @@ -26,6 +26,7 @@ Create a `.env` file containing the following keys. Consult `.env.example` if yo * `SERVER_ID` (optional) - either `global` or the id of the server the bot will mainly be deployed in. Application commands will be registered here. If absent, application commands won't be registered. * `EMOJI_SERVERS` (optional) - a list of server IDs that the bot will search for emoji within. +* `STATS_TIMEOUT` (optional) - an integer value that determines the maximum number of seconds that the bot will perform dice stats calculations for before timing out. * `ALLOW_GIT_UPDATE` (optional) - a `true` or `false` value that determines whether the bot can automatically load data from the repository. **Warning!** Be very careful with setting this to true; if you haven't set up permissions properly on your repo and your discord servers then things can go wrong! diff --git a/cabal.project b/cabal.project new file mode 100644 index 00000000..82211722 --- /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/fonts/LICENSE b/fonts/LICENSE new file mode 100644 index 00000000..7bfa350f --- /dev/null +++ b/fonts/LICENSE @@ -0,0 +1,96 @@ +Source Code © 2023 Adobe (http://www.adobe.com/), with Reserved Font Name 'Source'. All Rights Reserved. Source is a trademark of Adobe in the United States and/or other countries. +Source Sans Copyright 2010-2020 Adobe (http://www.adobe.com/), with Reserved Font Name 'Source'. All Rights Reserved. Source is a trademark of Adobe in the United States and/or other countries. +Libertine Copyright (c) 2003–2012, Philipp H. Poll (www.linuxlibertine.org | gillian at linuxlibertine.org), +with Reserved Font Name "Linux Libertine" and "Biolinum". + +All three Font Softwares are licensed under the SIL Open Font License, Version 1.1. +This license is copied below, and is also available with a FAQ at: +http://scripts.sil.org/OFL + + +----------------------------------------------------------- +SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007 +----------------------------------------------------------- + +PREAMBLE +The goals of the Open Font License (OFL) are to stimulate worldwide +development of collaborative font projects, to support the font creation +efforts of academic and linguistic communities, and to provide a free and +open framework in which fonts may be shared and improved in partnership +with others. + +The OFL allows the licensed fonts to be used, studied, modified and +redistributed freely as long as they are not sold by themselves. The +fonts, including any derivative works, can be bundled, embedded, +redistributed and/or sold with any software provided that any reserved +names are not used by derivative works. The fonts and derivatives, +however, cannot be released under any other type of license. The +requirement for fonts to remain under this license does not apply +to any document created using the fonts or their derivatives. + +DEFINITIONS +"Font Software" refers to the set of files released by the Copyright +Holder(s) under this license and clearly marked as such. This may +include source files, build scripts and documentation. + +"Reserved Font Name" refers to any names specified as such after the +copyright statement(s). + +"Original Version" refers to the collection of Font Software components as +distributed by the Copyright Holder(s). + +"Modified Version" refers to any derivative made by adding to, deleting, +or substituting -- in part or in whole -- any of the components of the +Original Version, by changing formats or by porting the Font Software to a +new environment. + +"Author" refers to any designer, engineer, programmer, technical +writer or other person who contributed to the Font Software. + +PERMISSION & CONDITIONS +Permission is hereby granted, free of charge, to any person obtaining +a copy of the Font Software, to use, study, copy, merge, embed, modify, +redistribute, and sell modified and unmodified copies of the Font +Software, subject to the following conditions: + +1) Neither the Font Software nor any of its individual components, +in Original or Modified Versions, may be sold by itself. + +2) Original or Modified Versions of the Font Software may be bundled, +redistributed and/or sold with any software, provided that each copy +contains the above copyright notice and this license. These can be +included either as stand-alone text files, human-readable headers or +in the appropriate machine-readable metadata fields within text or +binary files as long as those fields can be easily viewed by the user. + +3) No Modified Version of the Font Software may use the Reserved Font +Name(s) unless explicit written permission is granted by the corresponding +Copyright Holder. This restriction only applies to the primary font name as +presented to the users. + +4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font +Software shall not be used to promote, endorse or advertise any +Modified Version, except to acknowledge the contribution(s) of the +Copyright Holder(s) and the Author(s) or with their explicit written +permission. + +5) The Font Software, modified or unmodified, in part or in whole, +must be distributed entirely under this license, and must not be +distributed under any other license. The requirement for fonts to +remain under this license does not apply to any document created +using the Font Software. + +TERMINATION +This license becomes null and void if any of the above conditions are +not met. + +DISCLAIMER +THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT +OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE +COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL +DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM +OTHER DEALINGS IN THE FONT SOFTWARE. \ No newline at end of file diff --git a/fonts/LinLibertine_R.svg b/fonts/LinLibertine_R.svg new file mode 100644 index 00000000..3f167837 --- /dev/null +++ b/fonts/LinLibertine_R.svg @@ -0,0 +1,10319 @@ + + + + + +Created by FontForge 20120601 at Mon Jul 2 00:09:39 2012 + By Gillian Tiefenlicht +Linux Libertine by Philipp H. Poll, +Open Font under Terms of following Free Software Licenses: +GPL (General Public License) with font-exception and OFL (Open Font License). +Created with FontForge (http://fontforge.sf.net) +Sept 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011,2012 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/fonts/LinLibertine_RB.svg b/fonts/LinLibertine_RB.svg new file mode 100644 index 00000000..215c3056 --- /dev/null +++ b/fonts/LinLibertine_RB.svg @@ -0,0 +1,9167 @@ + + + + + +Created by FontForge 20120601 at Mon Jul 2 00:09:41 2012 + By Gillian Tiefenlicht +Linux Libertine by Philipp H. Poll, +Open Font under Terms of following Free Software Licenses: +GPL (General Public License) with font-exception and OFL (Open Font License). +Created with FontForge (http://fontforge.sf.net) +Sept 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011,2012 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/fonts/LinLibertine_RBI.svg b/fonts/LinLibertine_RBI.svg new file mode 100644 index 00000000..9300b15f --- /dev/null +++ b/fonts/LinLibertine_RBI.svg @@ -0,0 +1,6768 @@ + + + + + +Created by FontForge 20120601 at Mon Jul 2 00:09:41 2012 + By Gillian Tiefenlicht +Linux Libertine by Philipp H. Poll, +Open Font under Terms of following Free Software Licenses: +GPL (General Public License) with font-exception and OFL (Open Font License). +Created with FontForge (http://fontforge.sf.net) +Sept 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011,2012 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/fonts/LinLibertine_RI.svg b/fonts/LinLibertine_RI.svg new file mode 100644 index 00000000..63f18e94 --- /dev/null +++ b/fonts/LinLibertine_RI.svg @@ -0,0 +1,9071 @@ + + + + + +Created by FontForge 20120601 at Mon Jul 2 00:09:38 2012 + By Gillian Tiefenlicht +Linux Libertine by Philipp H. Poll, +Open Font under Terms of following Free Software Licenses: +GPL (General Public License) with font-exception and OFL (Open Font License). +Created with FontForge (http://fontforge.sf.net) +Sept 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011,2012 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/fonts/SourceCodePro_R.svg b/fonts/SourceCodePro_R.svg new file mode 100644 index 00000000..12849b96 --- /dev/null +++ b/fonts/SourceCodePro_R.svg @@ -0,0 +1,2421 @@ + + + + +Created by FontForge 20110222 at Mon Jul 29 16:17:38 2013 + By Jan Bracker,,, +Copyright 2010, 2012 Adobe Systems Incorporated. All Rights Reserved. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/fonts/SourceCodePro_RB.svg b/fonts/SourceCodePro_RB.svg new file mode 100644 index 00000000..b227e44f --- /dev/null +++ b/fonts/SourceCodePro_RB.svg @@ -0,0 +1,2401 @@ + + + + +Created by FontForge 20110222 at Mon Jul 29 16:16:54 2013 + By Jan Bracker,,, +Copyright 2010, 2012 Adobe Systems Incorporated. All Rights Reserved. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/fonts/SourceSansPro_R.svg b/fonts/SourceSansPro_R.svg new file mode 100644 index 00000000..22d44481 --- /dev/null +++ b/fonts/SourceSansPro_R.svg @@ -0,0 +1,6374 @@ + + + + +Created by FontForge 20110222 at Mon Jul 29 16:19:42 2013 + By Jan Bracker,,, +Copyright 2010, 2012 Adobe Systems Incorporated. All Rights Reserved. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/fonts/SourceSansPro_RB.svg b/fonts/SourceSansPro_RB.svg new file mode 100644 index 00000000..856f8ecd --- /dev/null +++ b/fonts/SourceSansPro_RB.svg @@ -0,0 +1,6048 @@ + + + + +Created by FontForge 20110222 at Mon Jul 29 16:18:11 2013 + By Jan Bracker,,, +Copyright 2010, 2012 Adobe Systems Incorporated. All Rights Reserved. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/fonts/SourceSansPro_RBI.svg b/fonts/SourceSansPro_RBI.svg new file mode 100644 index 00000000..85ff48f9 --- /dev/null +++ b/fonts/SourceSansPro_RBI.svg @@ -0,0 +1,4316 @@ + + + + +Created by FontForge 20110222 at Mon Jul 29 16:18:52 2013 + By Jan Bracker,,, +Copyright 2010, 2012 Adobe Systems Incorporated. All Rights Reserved. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/fonts/SourceSansPro_RI.svg b/fonts/SourceSansPro_RI.svg new file mode 100644 index 00000000..81112d86 --- /dev/null +++ b/fonts/SourceSansPro_RI.svg @@ -0,0 +1,4357 @@ + + + + +Created by FontForge 20110222 at Mon Jul 29 16:19:17 2013 + By Jan Bracker,,, +Copyright 2010, 2012 Adobe Systems Incorporated. All Rights Reserved. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/package.yaml b/package.yaml index c641120c..2993826d 100644 --- a/package.yaml +++ b/package.yaml @@ -69,6 +69,8 @@ dependencies: - distribution - extra - process +- filepath +- SVGFonts library: source-dirs: src @@ -98,6 +100,7 @@ library: - TypeOperators - RankNTypes - BangPatterns + - ViewPatterns ghc-options: - -Wall @@ -109,7 +112,7 @@ executables: ghc-options: - -threaded - -rtsopts - - -with-rtsopts=-N + - "\"-with-rtsopts=-Iw10 -N\"" dependencies: - tablebot diff --git a/src/Tablebot.hs b/src/Tablebot.hs index 0aea8a8a..9813c88e 100644 --- a/src/Tablebot.hs +++ b/src/Tablebot.hs @@ -18,28 +18,25 @@ module Tablebot ) where -import Control.Concurrent import Control.Monad.Extra import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Logger (NoLoggingT (runNoLoggingT)) +import Control.Monad.Logger (NoLoggingT (..)) import Control.Monad.Reader (runReaderT) import Control.Monad.Trans.Resource (runResourceT) import Data.Map as M (empty) import Data.Maybe (fromMaybe) import Data.Text (Text, pack) -import Data.Text.Encoding (encodeUtf8) -import qualified Data.Text.IO as TIO (putStrLn) +import qualified Data.Text as T import Database.Persist.Sqlite - ( createSqlitePool, - runMigration, + ( runMigration, runSqlPool, + withSqlitePool, ) import Discord 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), @@ -54,8 +51,9 @@ import Tablebot.Internal.Plugins import Tablebot.Internal.Types import Tablebot.Plugins (addAdministrationPlugin) import Tablebot.Utility +import Tablebot.Utility.Font (makeFontMap) import Tablebot.Utility.Help (generateHelp) -import Text.Regex.PCRE ((=~)) +import UnliftIO.Concurrent -- | runTablebotWithEnv @plugins@ runs the bot using data found in the .env -- file with the @[CompiledPlugin]@ given. If you're looking to run the bot as @@ -71,8 +69,6 @@ runTablebotWithEnv plugins config = do _ <- swapMVar rFlag Reload loadEnv dToken <- pack <$> getEnv "DISCORD_TOKEN" - unless (encodeUtf8 dToken =~ ("^[A-Za-z0-9_-]{24}[.][A-Za-z0-9_-]{6}[.][A-Za-z0-9_-]{38}$" :: String)) $ - die "Invalid token format. Please check it is a bot token" prefix <- pack . fromMaybe "!" <$> lookupEnv "PREFIX" dbpath <- getEnv "SQLITE_FILENAME" runTablebot vInfo dToken prefix dbpath (addAdministrationPlugin rFlag plugins) config @@ -101,57 +97,53 @@ runTablebot vinfo dToken prefix dbpath plugins config = do debugPrint ("DEBUG enabled. This is strongly not recommended in production!" :: String) -- Create multiple database threads. - pool <- runNoLoggingT $ createSqlitePool (pack dbpath) 8 + runNoLoggingT . withSqlitePool (pack dbpath) 8 $ \pool -> do + -- Setup and then apply plugin blacklist from the database + runSqlPool (runMigration adminMigration) pool + blacklist <- runResourceT $ runNoLoggingT $ runSqlPool currentBlacklist pool + let filteredPlugins = removeBlacklisted blacklist plugins + -- Combine the list of plugins into both a combined plugin + let !plugin = generateHelp (rootHelpText config) $ combinePlugins filteredPlugins + -- Run the setup actions of each plugin and collect the plugin actions into a single @PluginActions@ instance + allActions <- NoLoggingT $ mapM (runResourceT . runNoLoggingT . flip runSqlPool pool) (combinedSetupAction plugin) + let !actions = combineActions allActions - -- Setup and then apply plugin blacklist from the database - runSqlPool (runMigration adminMigration) pool - blacklist <- runResourceT $ runNoLoggingT $ runSqlPool currentBlacklist pool - let filteredPlugins = removeBlacklisted blacklist plugins - -- Combine the list of plugins into both a combined plugin - let !plugin = generateHelp (rootHelpText config) $ combinePlugins filteredPlugins - -- Run the setup actions of each plugin and collect the plugin actions into a single @PluginActions@ instance - allActions <- mapM (runResourceT . runNoLoggingT . flip runSqlPool pool) (combinedSetupAction plugin) - let !actions = combineActions allActions + -- TODO: this might have issues with duplicates? + -- TODO: in production, this should probably run once and then never again. + mapM_ (\migration -> runSqlPool (runMigration migration) pool) $ combinedMigrations plugin + -- Create a var to kill any ongoing tasks. + mvar <- newEmptyMVar + fm <- NoLoggingT makeFontMap + cacheMVar <- newMVar (TCache M.empty M.empty vinfo fm) + userFacingError <- + NoLoggingT $ + runDiscord $ + def + { discordToken = dToken, + discordOnEvent = + flip runSqlPool pool . flip runReaderT cacheMVar . eventHandler actions prefix, + discordOnStart = do + -- Build list of cron jobs, saving them to the mvar. + -- Note that we cannot just use @runSqlPool@ here - this creates + -- a single transaction which is reverted in case of exception + -- (which can just happen due to databases being unavailable + -- sometimes). + runReaderT (mapM (runCron pool) (compiledCronJobs actions) >>= liftIO . putMVar mvar) cacheMVar - -- TODO: this might have issues with duplicates? - -- TODO: in production, this should probably run once and then never again. - mapM_ (\migration -> runSqlPool (runMigration migration) pool) $ combinedMigrations plugin - -- Create a var to kill any ongoing tasks. - mvar <- newEmptyMVar :: IO (MVar [ThreadId]) - cacheMVar <- newMVar (TCache M.empty M.empty vinfo) :: IO (MVar TablebotCache) - userFacingError <- - runDiscord $ - def - { discordToken = dToken, - discordOnEvent = - flip runSqlPool pool . flip runReaderT cacheMVar . eventHandler actions prefix, - discordOnStart = do - -- Build list of cron jobs, saving them to the mvar. - -- Note that we cannot just use @runSqlPool@ here - this creates - -- a single transaction which is reverted in case of exception - -- (which can just happen due to databases being unavailable - -- sometimes). - runReaderT (mapM (runCron pool) (compiledCronJobs actions) >>= liftIO . putMVar mvar) cacheMVar + submitApplicationCommands (compiledApplicationCommands actions) cacheMVar - submitApplicationCommands (compiledApplicationCommands actions) cacheMVar - - liftIO $ putStrLn "The bot lives!" - sendCommand (UpdateStatus activityStatus), - -- Kill every cron job in the mvar. - discordOnEnd = takeMVar mvar >>= killCron - } - TIO.putStrLn userFacingError + liftIO $ putStrLn "The bot lives!" + sendCommand (UpdateStatus activityStatus), + -- Kill every cron job in the mvar. + discordOnEnd = takeMVar mvar >>= killCron + } + liftIO $ putStrLn $ T.unpack userFacingError where 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 d4848578..8e8a41e1 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 7d5ba552..bf765801 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 (void, when) +import Control.Monad.IO.Class (MonadIO) import Data.List.Extra (isInfixOf, lower, trim) import Data.Text (Text, pack) import Database.Persist @@ -32,7 +33,7 @@ PluginBlacklist deriving Show |] -currentBlacklist :: MonadIO m => SqlPersistT m [Text] +currentBlacklist :: (MonadIO m) => SqlPersistT m [Text] currentBlacklist = do bl <- selectList allBlacklisted [] return $ fmap (pack . pluginBlacklistLabel . entityVal) bl diff --git a/src/Tablebot/Internal/Alias.hs b/src/Tablebot/Internal/Alias.hs index 7782c701..f16a18fc 100644 --- a/src/Tablebot/Internal/Alias.hs +++ b/src/Tablebot/Internal/Alias.hs @@ -10,22 +10,21 @@ 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 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"] [persistLowerCase| Alias - alias Text - command Text + alias T.Text + command T.Text type AliasType UniqueAlias alias type deriving Show @@ -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/Internal/Cache.hs b/src/Tablebot/Internal/Cache.hs index 707a6e3d..1087b0bc 100644 --- a/src/Tablebot/Internal/Cache.hs +++ b/src/Tablebot/Internal/Cache.hs @@ -16,6 +16,7 @@ import Control.Monad.Trans.Reader (ask) import qualified Data.Map as M import Data.Text (Text) import Discord.Types +import Tablebot.Utility.Font (FontMap) import Tablebot.Utility.Types lookupEmojiCache :: Text -> EnvDatabaseDiscord s (Maybe Emoji) @@ -49,3 +50,9 @@ getVersionInfo = do mcache <- liftCache ask cache <- liftIO $ readMVar mcache pure $ cacheVersionInfo cache + +getFontMap :: EnvDatabaseDiscord s (FontMap Double) +getFontMap = do + mcache <- liftCache ask + cache <- liftIO $ readMVar mcache + pure $ cacheFonts cache diff --git a/src/Tablebot/Internal/Handler/Command.hs b/src/Tablebot/Internal/Handler/Command.hs index 2adc979a..eb5878df 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, diff --git a/src/Tablebot/Internal/Permission.hs b/src/Tablebot/Internal/Permission.hs index 0bc498ca..2be6df62 100644 --- a/src/Tablebot/Internal/Permission.hs +++ b/src/Tablebot/Internal/Permission.hs @@ -63,7 +63,7 @@ permsFromGroups debug krls gps = -- debug <- liftIO isDebug -- return $ permsFromGroups debug knownroles $ getMemberGroups member -getSenderPermission :: Context m => m -> EnvDatabaseDiscord s UserPermission +getSenderPermission :: (Context m) => m -> EnvDatabaseDiscord s UserPermission getSenderPermission m = do let member = contextMember m knownroles <- liftIO getKnownRoles diff --git a/src/Tablebot/Internal/Types.hs b/src/Tablebot/Internal/Types.hs index 7a430e13..899401e9 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 6de41e6c..263a2866 100644 --- a/src/Tablebot/Plugins/Administration.hs +++ b/src/Tablebot/Plugins/Administration.hs @@ -13,12 +13,13 @@ 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 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) @@ -26,7 +27,6 @@ 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 @@ -60,27 +60,27 @@ 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] [] - if not $ null extant - then do - _ <- delete (head extant) + extant <- liftSql $ Sql.selectKeysList [PluginBlacklistLabel ==. pLabel] [] + 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. 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 d0cee7bd..88ef25f8 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 (..)) @@ -119,7 +118,8 @@ aliasList :: AliasType -> Message -> DatabaseDiscord () aliasList at m = do aliases <- fmap Sql.entityVal <$> liftSql (Sql.selectList [AliasType Sql.==. at] []) let msg = - aliasTypeToText at <> " aliases:\n" + aliasTypeToText at + <> " aliases:\n" <> T.unlines (map (\(Alias a b _) -> "\t`" <> a <> "` -> `" <> b <> "`") aliases) sendMessage m msg @@ -156,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/Flip.hs b/src/Tablebot/Plugins/Flip.hs index 66a2d0d3..93be3c55 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 d303376a..7a5e28af 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 33c8ccc3..34e99d7f 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/Netrunner/Plugin.hs b/src/Tablebot/Plugins/Netrunner/Plugin.hs index cf18c490..3dd6e426 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) @@ -262,7 +262,9 @@ beginnerText = do agenda <- formatFromEmojiName "agenda" rezCost <- formatFromEmojiName "rez_cost" return $ - agenda <> " **NETRUNNER** " <> rezCost + agenda + <> " **NETRUNNER** " + <> rezCost <> [r| Netrunner is an asymmetric collectable card game about hackers hacking corporations. It's run as a *free* community endeavour by NISEI: |] diff --git a/src/Tablebot/Plugins/Netrunner/Type/BanList.hs b/src/Tablebot/Plugins/Netrunner/Type/BanList.hs index 65e60a3d..0c19f730 100644 --- a/src/Tablebot/Plugins/Netrunner/Type/BanList.hs +++ b/src/Tablebot/Plugins/Netrunner/Type/BanList.hs @@ -30,7 +30,8 @@ data BanList = BanList instance FromJSON BanList where parseJSON = withObject "BanList" $ \o -> - BanList <$> o .: "id" + BanList + <$> o .: "id" <*> o .: "date_creation" <*> o .: "date_update" <*> o .: "code" @@ -66,11 +67,11 @@ instance FromJSON CardBan where return $ maybe False (== 0) limit return $ if - | banned -> Banned - | restricted -> Restricted - | universalInfluence > 0 -> UniversalInfluence universalInfluence - | globalPenalty > 0 -> GlobalPenalty globalPenalty - | otherwise -> GlobalPenalty universalInfluence + | banned -> Banned + | restricted -> Restricted + | universalInfluence > 0 -> UniversalInfluence universalInfluence + | globalPenalty > 0 -> GlobalPenalty globalPenalty + | otherwise -> GlobalPenalty universalInfluence defaultBanList :: BanList defaultBanList = diff --git a/src/Tablebot/Plugins/Netrunner/Type/Card.hs b/src/Tablebot/Plugins/Netrunner/Type/Card.hs index 0c3345ff..f2423900 100644 --- a/src/Tablebot/Plugins/Netrunner/Type/Card.hs +++ b/src/Tablebot/Plugins/Netrunner/Type/Card.hs @@ -46,7 +46,8 @@ data Card = Card instance FromJSON Card where parseJSON = withObject "Card" $ \o -> - Card <$> o .:? "advancement_cost" + Card + <$> o .:? "advancement_cost" <*> o .:? "agenda_points" <*> o .:? "base_link" <*> o .:? "code" diff --git a/src/Tablebot/Plugins/Netrunner/Type/Cycle.hs b/src/Tablebot/Plugins/Netrunner/Type/Cycle.hs index c57eaf9e..6c06fdfd 100644 --- a/src/Tablebot/Plugins/Netrunner/Type/Cycle.hs +++ b/src/Tablebot/Plugins/Netrunner/Type/Cycle.hs @@ -25,7 +25,8 @@ data Cycle = Cycle instance FromJSON Cycle where parseJSON = withObject "Cycle" $ \o -> - Cycle <$> o .: "code" + Cycle + <$> o .: "code" <*> o .: "name" <*> o .: "position" <*> o .: "size" diff --git a/src/Tablebot/Plugins/Netrunner/Type/Faction.hs b/src/Tablebot/Plugins/Netrunner/Type/Faction.hs index 16f3187c..330b38f1 100644 --- a/src/Tablebot/Plugins/Netrunner/Type/Faction.hs +++ b/src/Tablebot/Plugins/Netrunner/Type/Faction.hs @@ -25,7 +25,8 @@ data Faction = Faction instance FromJSON Faction where parseJSON = withObject "Faction" $ \o -> - Faction <$> o .: "code" + Faction + <$> o .: "code" <*> o .: "color" <*> o .: "is_mini" <*> o .: "name" diff --git a/src/Tablebot/Plugins/Netrunner/Type/Pack.hs b/src/Tablebot/Plugins/Netrunner/Type/Pack.hs index 54c36925..e8b2ab9a 100644 --- a/src/Tablebot/Plugins/Netrunner/Type/Pack.hs +++ b/src/Tablebot/Plugins/Netrunner/Type/Pack.hs @@ -24,7 +24,8 @@ data Pack = Pack instance FromJSON Pack where parseJSON = withObject "Pack" $ \o -> - Pack <$> o .: "code" + Pack + <$> o .: "code" <*> o .: "cycle_code" <*> o .: "name" <*> o .: "position" diff --git a/src/Tablebot/Plugins/Netrunner/Type/Type.hs b/src/Tablebot/Plugins/Netrunner/Type/Type.hs index 29d1bb4f..a8c45311 100644 --- a/src/Tablebot/Plugins/Netrunner/Type/Type.hs +++ b/src/Tablebot/Plugins/Netrunner/Type/Type.hs @@ -25,7 +25,8 @@ data Type = Type instance FromJSON Type where parseJSON = withObject "Type" $ \o -> - Type <$> o .: "code" + Type + <$> o .: "code" <*> o .: "name" <*> o .: "position" <*> o .: "is_subtype" diff --git a/src/Tablebot/Plugins/Netrunner/Utility/Card.hs b/src/Tablebot/Plugins/Netrunner/Utility/Card.hs index 9d19ac4c..cde351a9 100644 --- a/src/Tablebot/Plugins/Netrunner/Utility/Card.hs +++ b/src/Tablebot/Plugins/Netrunner/Utility/Card.hs @@ -165,7 +165,8 @@ toReleaseData api card = fromMaybe "" helper x -> " (universal influence: " <> pack (show x) <> ")" legality = rotation <> banStatus <> restriction <> globalPenalty <> universalInf expansion = - Cycle.name c <> legality + Cycle.name c + <> legality <> if Pack.name p /= Cycle.name c then " • " <> Pack.name p else "" diff --git a/src/Tablebot/Plugins/Ping.hs b/src/Tablebot/Plugins/Ping.hs index 247ff4a3..3c430a09 100644 --- a/src/Tablebot/Plugins/Ping.hs +++ b/src/Tablebot/Plugins/Ping.hs @@ -25,8 +25,7 @@ ping :: Command ping = Command "ping" - ( parseComm $ echo "pong" - ) + (parseComm $ echo "pong") [] pingHelp :: HelpPage diff --git a/src/Tablebot/Plugins/Quote.hs b/src/Tablebot/Plugins/Quote.hs index 01a4f2cb..a84da786 100644 --- a/src/Tablebot/Plugins/Quote.hs +++ b/src/Tablebot/Plugins/Quote.hs @@ -13,14 +13,17 @@ -- quotes and then @!quote show n@ a particular quote. module Tablebot.Plugins.Quote (quotes) where +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) +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 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 @@ -30,18 +33,19 @@ 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, getPrecedingMessage, getReplyMessage, + idToWord, interactionResponseAutocomplete, interactionResponseCustomMessage, sendCustomMessage, sendMessage, toMention, toMention', + wordToId, ) import Tablebot.Utility.Embed import Tablebot.Utility.Exception (BotException (GenericException, InteractionException), catchBot, throwBot) @@ -59,8 +63,8 @@ Quote quote Text author Text submitter Text - msgId Int - cnlId Int + msgId Word64 + cnlId Word64 time UTCTime deriving Show |] @@ -72,10 +76,10 @@ quoteReactionAdd = ReactionAdd quoteReaction where quoteReaction ri | emojiName (reactionEmoji ri) == "\x1F4AC" = do - m <- getMessage (reactionChannelId ri) (reactionMessageId ri) - case m of - Left _ -> pure () - Right mes -> addMessageQuote (reactionUserId ri) mes mes >>= sendCustomMessage mes + m <- getMessage (reactionChannelId ri) (reactionMessageId ri) + case m of + Left _ -> pure () + Right mes -> addMessageQuote (reactionUserId ri) mes mes >>= sendCustomMessage mes | otherwise = return () -- | Our quote command, which combines various functions to create, display and update quotes. @@ -89,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 @@ -111,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) [] @@ -150,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) [] @@ -172,16 +176,16 @@ randomQuote = Command "random" (parseComm randomComm) [] -- | @showQuote@, which looks for a message of the form @!quote show n@, looks -- that quote up in the database and responds with that quote. -showQ :: Context m => Int64 -> m -> DatabaseDiscord MessageDetails +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!" -- | @randomQuote@, which looks for a message of the form @!quote random@, -- selects a random quote from the database and responds with that quote. -randomQ :: Context m => m -> DatabaseDiscord MessageDetails +randomQ :: (Context m) => m -> DatabaseDiscord MessageDetails randomQ = filteredRandomQuote [] "Couldn't find any quotes!" (Just randomButton) where randomButton = mkButton "Random quote" "quote random" @@ -191,7 +195,7 @@ randomQuoteComponentRecv = ComponentRecv "random" (processComponentInteraction ( -- | @authorQuote@, which looks for a message of the form @!quote author u@, -- selects a random quote from the database attributed to u and responds with that quote. -authorQ :: Context m => Text -> m -> DatabaseDiscord MessageDetails +authorQ :: (Context m) => Text -> m -> DatabaseDiscord MessageDetails authorQ t = filteredRandomQuote [QuoteAuthor ==. t] "Couldn't find any quotes with that author!" (Just authorButton) where authorButton = mkButton "Random author quote" ("quote author " <> t) @@ -202,7 +206,7 @@ authorQuoteComponentRecv = ComponentRecv "author" (processComponentInteraction ( -- | @filteredRandomQuote@ selects a random quote that meets a -- given criteria, and returns that as the response, sending the user a message if the -- quote cannot be found. -filteredRandomQuote :: Context m => [Filter Quote] -> Text -> Maybe Button -> m -> DatabaseDiscord MessageDetails +filteredRandomQuote :: (Context m) => [Filter Quote] -> Text -> Maybe Button -> m -> DatabaseDiscord MessageDetails filteredRandomQuote quoteFilter errorMessage mb m = catchBot (filteredRandomQuote' quoteFilter errorMessage mb m) catchBot' where catchBot' (GenericException "quote exception" _) = return $ (messageDetailsBasic errorMessage) {messageDetailsEmbeds = Just [], messageDetailsComponents = Just []} @@ -211,17 +215,17 @@ filteredRandomQuote quoteFilter errorMessage mb m = catchBot (filteredRandomQuot -- | @filteredRandomQuote'@ selects a random quote that meets a -- given criteria, and returns that as the response, throwing an exception if something -- goes wrong. -filteredRandomQuote' :: Context m => [Filter Quote] -> Text -> Maybe Button -> m -> DatabaseDiscord MessageDetails +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 - Just q -> renderQuoteMessage q (fromSqlKey $ head key) mb m + 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, key) -> renderQuoteMessage q (fromSqlKey key) mb m Nothing -> throwBot (GenericException "quote exception" (unpack errorMessage)) -- | @addQuote@, which looks for a message of the form @@ -230,11 +234,11 @@ filteredRandomQuote' quoteFilter errorMessage mb m = do addQ :: Text -> Text -> Message -> DatabaseDiscord MessageDetails addQ qu author m = fst <$> addQ' qu author (toMention $ messageAuthor m) (messageId m) (messageChannelId m) m -addQ' :: Context m => Text -> Text -> Text -> MessageId -> ChannelId -> m -> DatabaseDiscord (MessageDetails, Int64) +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 - added <- insert new + let new = Quote qu author requestor (idToWord sourceMsg) (idToWord sourceChannel) now + added <- liftSql $ Sql.insert new let res = pack $ show $ fromSqlKey added renderCustomQuoteMessage ("Quote added as #" `append` res) new (fromSqlKey added) Nothing m <&> (,fromSqlKey added) @@ -253,9 +257,9 @@ thisQ m = do Nothing -> sendMessage m "Unable to add quote" -- | @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 :: (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') @@ -266,10 +270,10 @@ 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 + 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") @@ -279,19 +283,19 @@ 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' :: (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 (fromIntegral mid) (fromIntegral cid) now - replace k new + let new = Quote (fromMaybe qu' qu) (fromMaybe author' author) requestor (idToWord mid) (idToWord cid) now + liftSql $ Sql.replace k new renderCustomQuoteMessage "Quote updated" new qId Nothing m Nothing -> return $ messageDetailsBasic "Couldn't update that quote!" @@ -300,19 +304,19 @@ 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!" -renderQuoteMessage :: Context m => Quote -> Int64 -> Maybe Button -> m -> DatabaseDiscord MessageDetails +renderQuoteMessage :: (Context m) => Quote -> Int64 -> Maybe Button -> m -> DatabaseDiscord MessageDetails renderQuoteMessage = renderCustomQuoteMessage "" -renderCustomQuoteMessage :: Context m => Text -> Quote -> Int64 -> Maybe Button -> m -> DatabaseDiscord MessageDetails +renderCustomQuoteMessage :: (Context m) => Text -> Quote -> Int64 -> Maybe Button -> m -> DatabaseDiscord MessageDetails renderCustomQuoteMessage t (Quote txt author submitter msgId cnlId dtm) qId mb m = do guild <- contextGuildId m let link = getLink guild @@ -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 () @@ -396,19 +410,17 @@ quoteApplicationCommandRecv "author" -> handleNothing (getValue "author" vals >>= stringFromOptionValue) - ( \author -> authorQ author i >>= interactionResponseCustomMessage i - ) + (\author -> authorQ author i >>= interactionResponseCustomMessage i) "show" -> handleNothing (getValue "id" vals >>= integerFromOptionValue) - ( \showid -> showQ (fromIntegral showid) i >>= interactionResponseCustomMessage i - ) + (\showid -> showQ (fromIntegral showid) i >>= interactionResponseCustomMessage i) "add" -> handleNothing ((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 @@ -420,8 +432,8 @@ quoteApplicationCommandRecv Left _ -> return () Right m -> do now <- liftIO $ systemToUTCTime <$> getSystemTime - let new = Quote qt author requestor (fromIntegral $ messageId m) (fromIntegral $ messageChannelId m) now - replace (toSqlKey qid) new + let new = Quote qt author requestor (idToWord $ messageId m) (idToWord $ messageChannelId m) now + 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 () @@ -436,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 () ) @@ -468,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 () + 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 () @@ -595,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. @@ -607,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 <> "`") @@ -618,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. @@ -628,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 528b8dfa..0a50f84a 100644 --- a/src/Tablebot/Plugins/Reminder.hs +++ b/src/Tablebot/Plugins/Reminder.hs @@ -21,17 +21,17 @@ 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 (..)) +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, @@ -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" (Int) -> Message -> DatabaseDiscord () -deleteReminder (WErr rid) m = requirePermission Any m $ do - delete k +deleteReminder :: WithError "Missing required argument" (IntegralData Int) -> Message -> DatabaseDiscord () +deleteReminder (WErr (MkIntegralData rid)) m = requirePermission Any m $ do + 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 (fromIntegral cid) (pack $ "Reminder to <@" ++ show uid ++ ">! " ++ content) - delete (entityKey re) + sendChannelMessage (DiscordId (Snowflake cid)) (pack $ "Reminder to <@" ++ show uid ++ ">! " ++ content) + 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/Plugins/Roll/Dice.hs b/src/Tablebot/Plugins/Roll/Dice.hs index 365e44d2..c70d1e7c 100644 --- a/src/Tablebot/Plugins/Roll/Dice.hs +++ b/src/Tablebot/Plugins/Roll/Dice.hs @@ -40,10 +40,10 @@ -- vars - "var" spc1 "!"? ("l_" name spcs "=" spcs lstv | name spcs "=" spcs expr) -- lstv - nbse "#" base | funcBasics | lstb | name | misc -- lstb - "{" expr ("," expr)* "}" | "(" lstv ")" --- expr - term ([+-] expr)? | misc --- term - nega ([*/] term)? +-- expr - term ([+-] term)* | misc +-- term - nega ([*/] nega)* -- nega - "-" expo | expo --- expo - func "^" expo | func +-- expo - func ("^" func)* -- func - funcBasics | base -- base - dice | nbse | name -- nbse - "(" expr ")" | [0-9]+ diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceData.hs b/src/Tablebot/Plugins/Roll/Dice/DiceData.hs index bb9d2e94..c232f28f 100644 --- a/src/Tablebot/Plugins/Roll/Dice/DiceData.hs +++ b/src/Tablebot/Plugins/Roll/Dice/DiceData.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + -- | -- Module : Tablebot.Plugins.Roll.Dice.DiceData -- Description : Data structures for dice and other expressions. @@ -45,9 +47,6 @@ data Program = Program [Statement] (Either ListValues Expr) deriving (Show) data ArgValue = AVExpr Expr | AVListValues ListValues deriving (Show) --- | Alias for `MiscData` that returns a `ListValues`. -type ListValuesMisc = MiscData ListValues - -- | The type for list values. data ListValues = -- | Represents `N#B`, where N is a NumBase (numbers, parentheses) and B is a Base (numbase or dice value) @@ -59,7 +58,7 @@ data ListValues | -- | A variable that has been defined elsewhere. LVVar Text | -- | A misc list values expression. - ListValuesMisc ListValuesMisc + ListValuesMisc (MiscData ListValues) deriving (Show) -- | The type for basic list values (that can be used as is for custom dice). @@ -71,18 +70,49 @@ data ListValues data ListValuesBase = LVBParen (Paren ListValues) | LVBList [Expr] deriving (Show) --- | Alias for `MiscData` that returns an `Expr`. -type ExprMisc = MiscData Expr +-- | The type for a binary operator between one or more `sub` values +data BinOp sub typ where + BinOp :: (Operation typ) => sub -> [(typ, sub)] -> BinOp sub typ + +deriving instance (Show sub, Show typ) => Show (BinOp sub typ) + +-- | Convenience pattern for the empty list. +pattern SingBinOp :: (Operation typ) => sub -> BinOp sub typ +pattern SingBinOp a <- + BinOp a [] + where + SingBinOp a = BinOp a [] + +-- | The type class that means we can get an operation on integers from a value. +class Operation a where + getOperation :: a -> (forall n. (Integral n) => n -> n -> n) --- | The type of the top level expression. Represents one of addition, --- subtraction, or a single term; or some misc expression statement. -data Expr = ExprMisc ExprMisc | Add Term Expr | Sub Term Expr | NoExpr Term +-- | The type of the top level expression. +-- +-- Represents either a misc expression or additive operations between terms. +data Expr = ExprMisc (MiscData Expr) | Expr (BinOp Term ExprType) deriving (Show) --- | The type representing multiplication, division, or a single negated term. -data Term = Multi Negation Term | Div Negation Term | NoTerm Negation +-- | The type of the additive expression, either addition or subtraction. +data ExprType = Add | Sub + deriving (Show, Eq) + +instance Operation ExprType where + getOperation Sub = (-) + getOperation Add = (+) + +-- | Represents multiplicative operations between (possible) negations. +newtype Term = Term (BinOp Negation TermType) deriving (Show) +-- | The type of the additive expression, either addition or subtraction. +data TermType = Multi | Div + deriving (Show, Eq) + +instance Operation TermType where + getOperation Multi = (*) + getOperation Div = div + -- | The type representing a possibly negated value. data Negation = Neg Expo | NoNeg Expo deriving (Show) @@ -127,7 +157,7 @@ data AdvancedOrdering = Not AdvancedOrdering | OrderingId Ordering | And [Advanc deriving (Show, Eq, Ord) -- | Compare two values according an advanced ordering. -applyCompare :: Ord a => AdvancedOrdering -> a -> a -> Bool +applyCompare :: (Ord a) => AdvancedOrdering -> a -> a -> Bool applyCompare (OrderingId o) a b = o == compare a b applyCompare (And os) a b = all (\o -> applyCompare o a b) os applyCompare (Or os) a b = any (\o -> applyCompare o a b) os @@ -181,11 +211,14 @@ class Converter a b where instance Converter ListValuesBase ListValues where promote = LVBase +instance (Converter a sub, Operation typ) => Converter a (BinOp sub typ) where + promote = SingBinOp . promote + instance (Converter a Term) => Converter a Expr where - promote = NoExpr . promote + promote = Expr . promote instance (Converter a Negation) => Converter a Term where - promote = NoTerm . promote + promote = Term . promote instance (Converter a Expo) => Converter a Negation where promote = NoNeg . promote diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs b/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs index f2769102..ab98561e 100644 --- a/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs +++ b/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs @@ -10,9 +10,10 @@ -- 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, when) -import Data.List (foldl', genericDrop, genericReplicate, genericTake, sortBy) +import Control.Monad.State (MonadIO (liftIO), StateT, evalStateT, gets, modify) +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 @@ -23,7 +24,7 @@ import Tablebot.Plugins.Roll.Dice.DiceData import Tablebot.Plugins.Roll.Dice.DiceFunctions (FuncInfoBase (..), ListInteger (..)) import Tablebot.Plugins.Roll.Dice.DiceParsing () import Tablebot.Utility.Discord (Format (..), formatInput, formatText) -import Tablebot.Utility.Exception (BotException (EvaluationException), catchBot, throwBot) +import Tablebot.Utility.Exception (BotException (EvaluationException), catchBot, evaluationException, throwBot) import Tablebot.Utility.Parser (ParseShow (parseShow)) import Tablebot.Utility.Random (chooseOne) @@ -65,10 +66,6 @@ checkRNGCount = do rngCount <- gets getRNGCount when (rngCount > maximumRNG) $ evaluationException ("Maximum RNG count exceeded (" <> pack (show maximumRNG) <> ")") [] --- | Utility function to throw an `EvaluationException` when using `Text`. -evaluationException :: (MonadException m) => Text -> [Text] -> m a -evaluationException nm locs = throwBot $ EvaluationException (unpack nm) (unpack <$> locs) - --- Evaluating an expression. Uses IO because dice are random -- | Evaluating a full program @@ -164,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). @@ -174,12 +173,12 @@ class IOEvalList a where -- it took. If the `a` value is a dice value, the values of the dice should be -- displayed. This function adds the current location to the exception -- callstack. - evalShowL :: ParseShow a => a -> ProgramStateM ([(Integer, Text)], Maybe Text) + evalShowL :: (ParseShow a) => a -> ProgramStateM ([(Integer, Text)], Maybe Text) evalShowL a = do (is, mt) <- propagateException (parseShow a) (evalShowL' a) return (genericTake maximumListLength is, mt) - evalShowL' :: ParseShow a => a -> ProgramStateM ([(Integer, Text)], Maybe Text) + evalShowL' :: (ParseShow a) => a -> ProgramStateM ([(Integer, Text)], Maybe Text) evalArgValue :: ArgValue -> ProgramStateM ListInteger evalArgValue (AVExpr e) = do @@ -209,21 +208,21 @@ instance IOEvalList ListValuesBase where return (vs, Nothing) evalShowL' (LVBParen (Paren lv)) = evalShowL lv -instance IOEvalList ListValuesMisc where +instance IOEvalList (MiscData ListValues) where evalShowL' (MiscVar l) = evalShowL l evalShowL' (MiscIf l) = evalShowL l -- | This type class gives a function which evaluates the value to an integer -- and a string. -class IOEval a where +class (ParseShow a) => IOEval a where -- | Evaluate the given item to an integer, a string representation of the -- value, and the number of RNG calls it took. If the `a` value is a dice -- value, the values of the dice should be displayed. This function adds -- the current location to the exception callstack. - evalShow :: ParseShow a => a -> ProgramStateM (Integer, Text) + evalShow :: a -> ProgramStateM (Integer, Text) evalShow a = propagateException (parseShow a) (evalShow' a) - evalShow' :: ParseShow a => a -> ProgramStateM (Integer, Text) + evalShow' :: a -> ProgramStateM (Integer, Text) instance IOEval Base where evalShow' (NBase nb) = evalShow nb @@ -388,32 +387,35 @@ evalDieOpHelpKD kd lh is = do --- Pure evaluation functions for non-dice calculations -- Was previously its own type class that wouldn't work for evaluating Base values. --- | Utility function to evaluate a binary operator. -binOpHelp :: (IOEval a, IOEval b, ParseShow a, ParseShow b) => a -> b -> Text -> (Integer -> Integer -> Integer) -> ProgramStateM (Integer, Text) -binOpHelp a b opS op = do - (a', a's) <- evalShow a - (b', b's) <- evalShow b - return (op a' b', a's <> " " <> opS <> " " <> b's) - -instance IOEval ExprMisc where +instance IOEval (MiscData Expr) where evalShow' (MiscVar l) = evalShow l evalShow' (MiscIf l) = evalShow l +instance (IOEval sub, Operation typ, ParseShow typ) => IOEval (BinOp sub typ) where + evalShow' (BinOp a tas) = foldl' foldel (evalShow a) tas + where + foldel at (typ, b) = do + (a', t) <- at + (b', t') <- evalShow b + return (getOperation typ a' b', t <> " " <> parseShow typ <> " " <> t') + instance IOEval Expr where - evalShow' (NoExpr t) = evalShow t evalShow' (ExprMisc e) = evalShow e - evalShow' (Add t e) = binOpHelp t e "+" (+) - evalShow' (Sub t e) = binOpHelp t e "-" (-) + evalShow' (Expr e) = evalShow e instance IOEval Term where - evalShow' (NoTerm f) = evalShow f - evalShow' (Multi f t) = binOpHelp f t "*" (*) - evalShow' (Div f t) = do - (f', f's) <- evalShow f - (t', t's) <- evalShow t - if t' == 0 - then evaluationException "division by zero" [parseShow t] - else return (div f' t', f's <> " / " <> t's) + evalShow' (Term (BinOp a tas)) = foldl' foldel (evalShow a) tas + where + foldel at (Div, b) = do + (a', t) <- at + (b', t') <- evalShow b + if b' == 0 + then evaluationException "division by zero" [parseShow b] + else return (getOperation Div a' b', t <> " " <> parseShow Div <> " " <> t') + foldel at (typ, b) = do + (a', t) <- at + (b', t') <- evalShow b + return (getOperation typ a' b', t <> " " <> parseShow typ <> " " <> t') instance IOEval Func where evalShow' (Func s exprs) = evaluateFunction s exprs diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceFunctions.hs b/src/Tablebot/Plugins/Roll/Dice/DiceFunctions.hs index e85b1b0d..41be9b8e 100644 --- a/src/Tablebot/Plugins/Roll/Dice/DiceFunctions.hs +++ b/src/Tablebot/Plugins/Roll/Dice/DiceFunctions.hs @@ -48,16 +48,16 @@ integerFunctionsList = M.keys integerFunctions -- for each function that returns an integer. integerFunctions' :: [FuncInfo] integerFunctions' = - funcInfoIndex : - constructFuncInfo "length" (genericLength @Integer @Integer) : - constructFuncInfo "sum" (sum @[] @Integer) : - constructFuncInfo "max" (max @Integer) : - constructFuncInfo "min" (min @Integer) : - constructFuncInfo "maximum" (maximum @[] @Integer) : - constructFuncInfo "minimum" (minimum @[] @Integer) : - constructFuncInfo' "mod" (mod @Integer) (Nothing, Nothing, (== 0)) : - constructFuncInfo' "fact" fact (Nothing, Just factorialLimit, const False) : - (uncurry constructFuncInfo <$> [("abs", abs @Integer), ("id", id), ("neg", negate)]) + funcInfoIndex + : constructFuncInfo "length" (genericLength @Integer @Integer) + : constructFuncInfo "sum" (sum @[] @Integer) + : constructFuncInfo "max" (max @Integer) + : constructFuncInfo "min" (min @Integer) + : constructFuncInfo "maximum" (maximum @[] @Integer) + : constructFuncInfo "minimum" (minimum @[] @Integer) + : constructFuncInfo' "mod" (mod @Integer) (Nothing, Nothing, (== 0)) + : constructFuncInfo' "fact" fact (Nothing, Just factorialLimit, const False) + : (uncurry constructFuncInfo <$> [("abs", abs @Integer), ("id", id), ("neg", negate)]) where fact n | n < 0 = 0 @@ -77,15 +77,15 @@ listFunctionsList = M.keys listFunctions -- each function that returns an integer. listFunctions' :: [FuncInfoBase [Integer]] listFunctions' = - funcInfoInsert : - constructFuncInfo "prepend" (:) : - constructFuncInfo "replicate" (genericReplicate @Integer) : - funcInfoSet : - constructFuncInfo "concat" (++) : - constructFuncInfo "between" between : - constructFuncInfo "drop" (genericDrop @Integer) : - constructFuncInfo "take" (genericTake @Integer) : - (uncurry constructFuncInfo <$> [("sort", sort), ("reverse", reverse)]) + funcInfoInsert + : constructFuncInfo "prepend" (:) + : constructFuncInfo "replicate" (genericReplicate @Integer) + : funcInfoSet + : constructFuncInfo "concat" (++) + : constructFuncInfo "between" between + : constructFuncInfo "drop" (genericDrop @Integer) + : constructFuncInfo "take" (genericTake @Integer) + : (uncurry constructFuncInfo <$> [("sort", sort), ("reverse", reverse)]) where between i i' = let (mi, ma, rev) = (min i i', max i i', if i > i' then reverse else id) in rev [mi .. ma] @@ -170,10 +170,10 @@ instance ArgCount Integer where instance ArgCount [Integer] where getTypes _ = [ATIntegerList] -instance ArgCount f => ArgCount (Integer -> f) where +instance (ArgCount f) => ArgCount (Integer -> f) where getTypes _ = ATInteger : getTypes (Proxy :: Proxy f) -instance ArgCount f => ArgCount ([Integer] -> f) where +instance (ArgCount f) => ArgCount ([Integer] -> f) where getTypes _ = ATIntegerList : getTypes (Proxy :: Proxy f) -- | Type class which represents applying a function f to some inputs when given @@ -181,7 +181,7 @@ instance ArgCount f => ArgCount ([Integer] -> f) where -- -- If the number of inputs is incorrect or the value given out of the range, an -- exception is thrown. -class ArgCount f => ApplyFunc f where +class (ArgCount f) => ApplyFunc f where -- | Takes a function, the number of arguments in the function overall, bounds -- on integer values to the function, and a list of `ListInteger`s (which are -- either a list of integers or an integer), and returns a wrapped `j` value, diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceParsing.hs b/src/Tablebot/Plugins/Roll/Dice/DiceParsing.hs index e9462cc0..e4290212 100644 --- a/src/Tablebot/Plugins/Roll/Dice/DiceParsing.hs +++ b/src/Tablebot/Plugins/Roll/Dice/DiceParsing.hs @@ -29,7 +29,7 @@ import Tablebot.Plugins.Roll.Dice.DiceFunctions import Tablebot.Utility.Parser import Tablebot.Utility.SmartParser (CanParse (..), ()) import Tablebot.Utility.Types (Parser) -import Text.Megaparsec (MonadParsec (try), choice, failure, optional, some, (), (<|>)) +import Text.Megaparsec (MonadParsec (try), choice, failure, many, optional, some, (), (<|>)) import Text.Megaparsec.Char (char, string) import Text.Megaparsec.Error (ErrorItem (Tokens)) @@ -40,7 +40,7 @@ failure' s ss = failure (Just $ Tokens $ NE.fromList $ T.unpack s) (S.map (Token variableName :: Parser T.Text variableName = T.pack <$> some (choice $ char <$> '_' : ['a' .. 'z']) -instance CanParse a => CanParse (Var a) where +instance (CanParse a) => CanParse (Var a) where pars = do _ <- try (string "var") <* skipSpace letCon <- try (char '!' $> VarLazy) <|> return Var @@ -87,9 +87,11 @@ instance CanParse ListValues where do functionParser listFunctions LVFunc <|> (LVVar . ("l_" <>) <$> try (string "l_" *> variableName)) - <|> ListValuesMisc <$> (pars >>= checkVar) - <|> (try (pars <* char '#') >>= \nb -> MultipleValues nb <$> pars) - <|> LVBase <$> pars + <|> ListValuesMisc + <$> (pars >>= checkVar) + <|> (try (pars <* char '#') >>= \nb -> MultipleValues nb <$> pars) + <|> LVBase + <$> pars where checkVar (MiscVar l) | T.isPrefixOf "l_" (varName l) = return (MiscVar l) @@ -104,7 +106,8 @@ instance CanParse ListValuesBase where <* skipSpace <* (char '}' "could not find closing brace for list") ) - <|> LVBParen . unnest + <|> LVBParen + . unnest <$> pars where unnest (Paren (LVBase (LVBParen e))) = e @@ -121,21 +124,32 @@ instance (CanParse b) => CanParse (If b) where e <- string "else" *> skipSpace1 *> pars return $ If a t e -instance CanParse a => CanParse (MiscData a) where +instance (CanParse a) => CanParse (MiscData a) where pars = (MiscVar <$> pars) <|> (MiscIf <$> pars) +instance (CanParse sub, CanParse typ, Operation typ) => CanParse (BinOp sub typ) where + pars = do + a <- pars + tas <- many parseTas + return $ BinOp a tas + where + parseTas = try $ do + t <- skipSpace *> pars + a' <- skipSpace *> pars + return (t, a') + +instance CanParse ExprType where + pars = try (char '+' $> Add) <|> try (char '-' $> Sub) + instance CanParse Expr where pars = - (ExprMisc <$> pars) - <|> ( do - t <- pars - binOpParseHelp '+' (Add t) <|> binOpParseHelp '-' (Sub t) <|> (return . NoExpr) t - ) + (ExprMisc <$> pars) <|> (Expr <$> pars) + +instance CanParse TermType where + pars = try (char '*' $> Multi) <|> try (char '/' $> Div) instance CanParse Term where - pars = do - t <- pars - binOpParseHelp '*' (Multi t) <|> binOpParseHelp '/' (Div t) <|> (return . NoTerm) t + pars = Term <$> pars instance CanParse Func where pars = functionParser integerFunctions Func <|> NoFunc <$> pars @@ -156,8 +170,11 @@ functionParser m mainCons = instance CanParse Negation where pars = - try (char '-') *> skipSpace *> (Neg <$> pars) - <|> NoNeg <$> pars + try (char '-') + *> skipSpace + *> (Neg <$> pars) + <|> NoNeg + <$> pars instance CanParse Expo where pars = do @@ -167,9 +184,10 @@ instance CanParse Expo where instance CanParse NumBase where pars = (NBParen . unnest <$> pars) - <|> Value <$> integer "could not parse integer" + <|> Value + <$> integer "could not parse integer" where - unnest (Paren (NoExpr (NoTerm (NoNeg (NoExpo (NoFunc (NBase (NBParen e)))))))) = e + unnest (Paren (Expr (SingBinOp (Term (SingBinOp (NoNeg (NoExpo (NoFunc (NBase (NBParen e)))))))))) = e unnest e = e instance (CanParse a) => CanParse (Paren a) where @@ -182,8 +200,9 @@ instance CanParse Base where (DiceBase <$> parseDice nb) <|> return (NBase nb) ) - <|> DiceBase <$> parseDice (Value 1) - <|> (NumVar <$> try variableName) + <|> DiceBase + <$> parseDice (Value 1) + <|> (NumVar <$> try variableName) instance CanParse Die where pars = do @@ -274,7 +293,7 @@ instance ParseShow ArgValue where instance ParseShow ListValues where parseShow (LVBase e) = parseShow e parseShow (MultipleValues nb b) = parseShow nb <> "#" <> parseShow b - parseShow (LVFunc s n) = funcInfoName s <> "(" <> T.intercalate "," (parseShow <$> n) <> ")" + parseShow (LVFunc s n) = funcInfoName s <> "(" <> T.intercalate ", " (parseShow <$> n) <> ")" parseShow (LVVar t) = t parseShow (ListValuesMisc l) = parseShow l @@ -282,23 +301,30 @@ instance ParseShow ListValuesBase where parseShow (LVBList es) = "{" <> T.intercalate ", " (parseShow <$> es) <> "}" parseShow (LVBParen p) = parseShow p -instance ParseShow a => ParseShow (MiscData a) where +instance (ParseShow a) => ParseShow (MiscData a) where parseShow (MiscVar l) = parseShow l parseShow (MiscIf l) = parseShow l +instance (ParseShow sub, ParseShow typ) => ParseShow (BinOp sub typ) where + parseShow (BinOp a tas) = parseShow a <> T.concat (fmap (\(t, a') -> " " <> parseShow t <> " " <> parseShow a') tas) + +instance ParseShow ExprType where + parseShow Add = "+" + parseShow Sub = "-" + +instance ParseShow TermType where + parseShow Multi = "*" + parseShow Div = "/" + instance ParseShow Expr where - parseShow (Add t e) = parseShow t <> " + " <> parseShow e - parseShow (Sub t e) = parseShow t <> " - " <> parseShow e - parseShow (NoExpr t) = parseShow t + parseShow (Expr e) = parseShow e parseShow (ExprMisc e) = parseShow e instance ParseShow Term where - parseShow (Multi f t) = parseShow f <> " * " <> parseShow t - parseShow (Div f t) = parseShow f <> " / " <> parseShow t - parseShow (NoTerm f) = parseShow f + parseShow (Term f) = parseShow f instance ParseShow Func where - parseShow (Func s n) = funcInfoName s <> "(" <> T.intercalate "," (parseShow <$> n) <> ")" + parseShow (Func s n) = funcInfoName s <> "(" <> T.intercalate ", " (parseShow <$> n) <> ")" parseShow (NoFunc b) = parseShow b instance ParseShow Negation where diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceStats.hs b/src/Tablebot/Plugins/Roll/Dice/DiceStats.hs index 473fdd89..9e3bb206 100644 --- a/src/Tablebot/Plugins/Roll/Dice/DiceStats.hs +++ b/src/Tablebot/Plugins/Roll/Dice/DiceStats.hs @@ -44,14 +44,6 @@ getStats d = (modalOrder, expectation d, standardDeviation d) vals = toList d modalOrder = fst <$> sortBy (\(_, r) (_, r') -> compare r' r) vals --- | Convenience wrapper which gets the range of the given values then applies --- the function to the resultant distributions. -combineRangesBinOp :: (MonadException m, Range a, Range b, ParseShow a, ParseShow b) => (Integer -> Integer -> Integer) -> a -> b -> m Experiment -combineRangesBinOp f a b = do - d <- range a - d' <- range b - return $ f <$> d <*> d' - rangeExpr :: (MonadException m) => Expr -> m Distribution rangeExpr e = do ex <- range e @@ -67,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. @@ -76,7 +68,7 @@ rangeListValues lv = do -- has a variety of functions that operate on them. -- -- An `Data.Distribution.Experiment` is a monadic form of this. -class ParseShow a => Range a where +class (ParseShow a) => Range a where -- | Try and get the `Experiment` of the given value, throwing a -- `MonadException` on failure. range :: (MonadException m, ParseShow a) => a -> m Experiment @@ -114,20 +106,30 @@ instance (RangeList a) => RangeList (Var a) where rangeList' (Var _ a) = rangeList a rangeList' (VarLazy _ a) = rangeList a +instance (ParseShow typ, Range sub) => Range (BinOp sub typ) where + range' (BinOp a tas) = foldl' foldel (range a) tas + where + foldel at (typ, b) = do + a' <- at + b' <- range b + return $ getOperation typ <$> a' <*> b' + instance Range Expr where - range' (NoExpr t) = range t - range' (Add t e) = combineRangesBinOp (+) t e - range' (Sub t e) = combineRangesBinOp (-) t e + range' (Expr e) = range e range' (ExprMisc t) = range t instance Range Term where - range' (NoTerm t) = range t - range' (Multi t e) = combineRangesBinOp (*) t e - range' (Div t e) = do - d <- range t - d' <- range e - -- If 0 is always the denominator, the distribution will be empty. - return $ div <$> d <*> from (assuming (/= 0) (run d')) + range' (Term (BinOp a tas)) = foldl' foldel (range a) tas + where + foldel at (Div, b) = do + a' <- at + b' <- range b + -- If 0 is always the denominator, the distribution will be empty. + return $ getOperation Div <$> a' <*> from (assuming (/= 0) (run b')) + foldel at (typ, b) = do + a' <- at + b' <- range b + return $ getOperation typ <$> a' <*> b' instance Range Negation where range' (Neg t) = fmap negate <$> range t @@ -190,7 +192,7 @@ rangeDiceExperiment die (Just (DieOpRecur doo mdor)) is = rangeDieOpExperiment d -- | Perform one dice operation on the given `Experiment`, possibly returning -- a modified experiment representing the distribution of dice rolls. -rangeDieOpExperiment :: MonadException m => Experiment -> DieOpOption -> ExperimentList -> m ExperimentList +rangeDieOpExperiment :: (MonadException m) => Experiment -> DieOpOption -> ExperimentList -> m ExperimentList rangeDieOpExperiment die (DieOpOptionLazy o) is = rangeDieOpExperiment die o is rangeDieOpExperiment _ (DieOpOptionKD kd lhw) is = rangeDieOpExperimentKD kd lhw is rangeDieOpExperiment die (Reroll rro cond lim) is = do @@ -241,7 +243,7 @@ rangeDieOpExperimentKD kd lhw is = do -- -- Only used within `DiceStats` as I have no interest in producing statistics on -- lists -class ParseShow a => RangeList a where +class (ParseShow a) => RangeList a where -- | Try and get the `DistributionList` of the given value, throwing a -- `MonadException` on failure. rangeList :: (MonadException m, ParseShow a) => a -> m ExperimentList @@ -268,7 +270,7 @@ instance RangeList ListValues where rangeList' (ListValuesMisc m) = rangeList m rangeList' b@(LVVar _) = evaluationException "cannot find range of variable" [parseShow b] -rangeArgValue :: MonadException m => ArgValue -> m (D.Experiment ListInteger) +rangeArgValue :: (MonadException m) => ArgValue -> m (D.Experiment ListInteger) rangeArgValue (AVExpr e) = (LIInteger <$>) <$> range e rangeArgValue (AVListValues lv) = (LIList <$>) <$> rangeList lv diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceStatsBase.hs b/src/Tablebot/Plugins/Roll/Dice/DiceStatsBase.hs index 266458eb..09c5f529 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 @@ -15,6 +17,7 @@ module Tablebot.Plugins.Roll.Dice.DiceStatsBase where import Codec.Picture (PngSavable (encodePng)) +import Control.Monad.Exception (MonadException) import Data.Bifunctor import qualified Data.ByteString.Lazy as B import qualified Data.Distribution as D @@ -25,10 +28,11 @@ import qualified Data.Text as T import Diagrams (Diagram, dims2D, renderDia) import Diagrams.Backend.Rasterific import Graphics.Rendering.Chart.Axis.Int -import Graphics.Rendering.Chart.Backend.Diagrams (defaultEnv, runBackendR) +import Graphics.Rendering.Chart.Backend.Diagrams (runBackendR) import Graphics.Rendering.Chart.Backend.Types import Graphics.Rendering.Chart.Easy import Tablebot.Plugins.Roll.Dice.DiceEval (evaluationException) +import Tablebot.Utility.Font (FontMap, makeSansSerifEnv) -- | A wrapper type for mapping values to their probabilities. type Distribution = D.Distribution Integer @@ -39,22 +43,21 @@ diagramX, diagramY :: Double -- | Get the ByteString representation of the given distribution, setting the -- string as its title. -distributionByteString :: [(Distribution, T.Text)] -> IO B.ByteString -distributionByteString d = encodePng . renderDia Rasterific opts <$> distributionDiagram d +distributionByteString :: (MonadException m) => FontMap Double -> [(Distribution, T.Text)] -> m B.ByteString +distributionByteString fontMap d = encodePng . renderDia Rasterific opts <$> distributionDiagram fontMap d where opts = RasterificOptions (dims2D diagramX diagramY) -- | Get the Diagram representation of the given distribution, setting the -- string as its title. -distributionDiagram :: [(Distribution, T.Text)] -> IO (Diagram B) -distributionDiagram d = do +distributionDiagram :: (MonadException m) => FontMap Double -> [(Distribution, T.Text)] -> m (Diagram B) +distributionDiagram fontMap d = do if null d then evaluationException "empty distribution" [] - else do - defEnv <- defaultEnv (AlignmentFns id id) diagramX diagramY - return . fst $ runBackendR defEnv r + else return . fst $ runBackendR defEnv r where r = distributionRenderable d + defEnv = makeSansSerifEnv diagramX diagramY fontMap -- | Get the Renderable representation of the given distribution, setting the -- string as its title. @@ -67,7 +70,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 @@ -105,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] diff --git a/src/Tablebot/Plugins/Roll/Plugin.hs b/src/Tablebot/Plugins/Roll/Plugin.hs index 60c8efbf..348e0e8e 100644 --- a/src/Tablebot/Plugins/Roll/Plugin.hs +++ b/src/Tablebot/Plugins/Roll/Plugin.hs @@ -9,10 +9,12 @@ -- 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 (void) +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 @@ -22,19 +24,22 @@ import Discord.Interactions ) import Discord.Internal.Rest.Channel (ChannelRequest (..), MessageDetailedOpts (..)) import Discord.Types (ActionRow (..), Button (..), Message (..), User (..), UserId, mkButton, mkEmoji) +import System.Environment (lookupEnv) import System.Timeout (timeout) +import Tablebot.Internal.Cache (getFontMap) import Tablebot.Internal.Handler.Command (parseValue) import Tablebot.Plugins.Roll.Dice 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 import Text.Megaparsec import Text.RawString.QQ (r) +import Text.Read (readMaybe) -- | The basic execution function for rolling dice. Both the expression and message are -- optional. If the expression is not given, then the default roll is used. @@ -193,18 +198,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 (Add (promote (Value 20)) (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 @@ -213,7 +217,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 @@ -222,7 +226,6 @@ gencharHelp = statsCommand :: Command statsCommand = Command "stats" statsCommandParser [] where - oneSecond = 1000000 statsCommandParser :: Parser (Message -> DatabaseDiscord ()) statsCommandParser = do firstE <- pars @@ -230,11 +233,14 @@ statsCommand = Command "stats" statsCommandParser [] return $ statsCommand' (firstE : restEs) statsCommand' :: [Expr] -> Message -> DatabaseDiscord () statsCommand' es m = do - mrange' <- liftIO $ timeout (oneSecond * 5) $ mapM (\e -> rangeExpr e >>= \re -> re `seq` return (re, parseShow e)) es + let oneSecond = 1000000 + timeoutTime <- liftIO $ (oneSecond *) . fromMaybe 10 . readMaybe . fromMaybe "10" <$> lookupEnv "STATS_TIMEOUT" + mrange' <- liftIO $ timeout timeoutTime $ mapM (\e -> rangeExpr e >>= \re -> re `seq` return (re, parseShow e)) es case mrange' of Nothing -> throwBot (EvaluationException "Timed out calculating statistics" []) (Just range') -> do - mimage <- liftIO $ timeout (oneSecond * 5) (distributionByteString range' >>= \res -> res `seq` return res) + fontMap <- getFontMap + mimage <- liftIO $ timeout timeoutTime (distributionByteString fontMap range' >>= \res -> res `seq` return res) case mimage of Nothing -> do sendMessage m (msg range') diff --git a/src/Tablebot/Utility/Database.hs b/src/Tablebot/Utility/Database.hs deleted file mode 100644 index d8d660f0..00000000 --- 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 diff --git a/src/Tablebot/Utility/Discord.hs b/src/Tablebot/Utility/Discord.hs index a5626082..62a16178 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,19 +47,23 @@ module Tablebot.Utility.Discord interactionResponseCustomMessage, interactionResponseComponentsUpdateMessage, interactionResponseAutocomplete, + inlineCommandHelper, + idToWord, + wordToId, ) where -import Control.Monad.Cont (liftIO) +import Control.Monad import Control.Monad.Exception (MonadException (throw)) -import Data.Char (isDigit) +import Control.Monad.IO.Class (liftIO) +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) @@ -71,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@. @@ -152,7 +158,7 @@ sendCustomReplyMessage m mid fail' t = do -- If you suffer from nightmares, don't look in 'Tablebot.Handler.Embed'. Nothing good lives there. -- In the future, I may actually submit a PR to discord-haskell with a fix to allow colours properly. sendEmbedMessage :: - Embeddable e => + (Embeddable e) => Message -> Text -> e -> @@ -160,7 +166,7 @@ sendEmbedMessage :: sendEmbedMessage m = sendChannelEmbedMessage (messageChannelId m) sendChannelEmbedMessage :: - Embeddable e => + (Embeddable e) => ChannelId -> Text -> e -> @@ -305,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) @@ -449,3 +446,25 @@ 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 + +-- | 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/Embed.hs b/src/Tablebot/Utility/Embed.hs index b940baf6..72c792a6 100644 --- a/src/Tablebot/Utility/Embed.hs +++ b/src/Tablebot/Utility/Embed.hs @@ -20,49 +20,49 @@ import Tablebot.Internal.Embed (Embeddable, asEmbed) simpleEmbed :: Text -> CreateEmbed simpleEmbed t = CreateEmbed "" "" Nothing "" "" Nothing t [] Nothing "" Nothing Nothing Nothing -addTitle :: Embeddable e => Text -> e -> CreateEmbed +addTitle :: (Embeddable e) => Text -> e -> CreateEmbed addTitle t e = (asEmbed e) { createEmbedTitle = t } -addFooter :: Embeddable e => Text -> e -> CreateEmbed +addFooter :: (Embeddable e) => Text -> e -> CreateEmbed addFooter t e = (asEmbed e) { createEmbedFooterText = t } -addTimestamp :: Embeddable e => UTCTime -> e -> CreateEmbed +addTimestamp :: (Embeddable e) => UTCTime -> e -> CreateEmbed addTimestamp t e = (asEmbed e) { createEmbedTimestamp = Just t } -addAuthor :: Embeddable e => Text -> e -> CreateEmbed +addAuthor :: (Embeddable e) => Text -> e -> CreateEmbed addAuthor t e = (asEmbed e) { createEmbedAuthorName = t } -addLink :: Embeddable e => Text -> e -> CreateEmbed +addLink :: (Embeddable e) => Text -> e -> CreateEmbed addLink t e = (asEmbed e) { createEmbedUrl = t } -addColour :: Embeddable e => DiscordColor -> e -> CreateEmbed +addColour :: (Embeddable e) => DiscordColor -> e -> CreateEmbed addColour c e = (asEmbed e) { createEmbedColor = Just c } -addImage :: Embeddable e => Text -> e -> CreateEmbed +addImage :: (Embeddable e) => Text -> e -> CreateEmbed addImage url e = (asEmbed e) { createEmbedImage = Just $ CreateEmbedImageUrl url } -addThumbnail :: Embeddable e => Text -> e -> CreateEmbed +addThumbnail :: (Embeddable e) => Text -> e -> CreateEmbed addThumbnail url e = (asEmbed e) { createEmbedThumbnail = Just $ CreateEmbedImageUrl url diff --git a/src/Tablebot/Utility/Exception.hs b/src/Tablebot/Utility/Exception.hs index 3e8231be..d5552bb7 100644 --- a/src/Tablebot/Utility/Exception.hs +++ b/src/Tablebot/Utility/Exception.hs @@ -16,12 +16,14 @@ module Tablebot.Utility.Exception showError, showUserError, embedError, + evaluationException, ) where import Control.Monad.Exception (Exception, MonadException, catch, throw) import Data.List (intercalate) import Data.Text (pack) +import qualified Data.Text as T import Discord.Internal.Types import Tablebot.Utility.Embed @@ -43,20 +45,20 @@ data BotException instance Exception BotException -- | Aliases for throw and catch that enforce the exception type. -throwBot :: MonadException m => BotException -> m a +throwBot :: (MonadException m) => BotException -> m a throwBot = throw -catchBot :: MonadException m => m a -> (BotException -> m a) -> m a +catchBot :: (MonadException m) => m a -> (BotException -> m a) -> m a catchBot = catch -- | @transformException@ takes a computation m that may fail, catches any -- exception it throws, and transforms it into a new one with transformer. -transformException :: MonadException m => m a -> (BotException -> BotException) -> m a +transformException :: (MonadException m) => m a -> (BotException -> BotException) -> m a transformException m transformer = m `catchBot` (throwBot . transformer) -- | @transformExceptionConst@ takes a computation m that may fail and replaces -- any exception it throws with the constant exception e. -transformExceptionConst :: MonadException m => m a -> BotException -> m a +transformExceptionConst :: (MonadException m) => m a -> BotException -> m a transformExceptionConst m e = m `catchBot` \_ -> throwBot e -- | @errorEmoji@ defines a Discord emoji in plaintext for use in error outputs. @@ -67,12 +69,21 @@ errorEmoji = ":warning:" -- Discord. formatUserError :: String -> String -> String formatUserError name' message = - errorEmoji ++ " **" ++ name' ++ "** " ++ errorEmoji ++ "\n" + errorEmoji + ++ " **" + ++ name' + ++ "** " + ++ errorEmoji + ++ "\n" ++ "An error was encountered while resolving your command:\n" ++ "> `" ++ message ++ "`" +-- | Utility function to throw an `EvaluationException` when using `Text`. +evaluationException :: (MonadException m) => T.Text -> [T.Text] -> m a +evaluationException nm locs = throwBot $ EvaluationException (T.unpack nm) (T.unpack <$> locs) + -- | @ErrorInfo@ packs the info for each error into one data type. This allows -- each error type to be defined in one block (as opposed to errorName being -- defined for each error type _then_ errorMsg being defined for each type). diff --git a/src/Tablebot/Utility/Font.hs b/src/Tablebot/Utility/Font.hs new file mode 100644 index 00000000..3cb7f783 --- /dev/null +++ b/src/Tablebot/Utility/Font.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Tablebot.Utility.Font (makeSansSerifEnv, FontMap, makeFontMap) where + +import Control.Monad.Exception (MonadException) +import Control.Monad.IO.Class (MonadIO (..)) +import qualified Data.Map as M +import Graphics.Rendering.Chart.Backend.Diagrams (DEnv (..), createEnv) +import Graphics.Rendering.Chart.Backend.Types +import Graphics.SVGFonts (loadFont) +import qualified Graphics.SVGFonts.ReadFont as F + +-- | A type to map between some basic font characteristics and some loaded fonts. +type FontMap n = M.Map (String, FontSlant, FontWeight) (F.PreparedFont n) + +makeSansSerifEnv :: forall n. (Read n, RealFloat n) => n -> n -> FontMap n -> DEnv n +makeSansSerifEnv diX diY fontMap = createEnv (AlignmentFns id id) diX diY fontSelector + where + alterFontFamily :: String -> F.PreparedFont n -> F.PreparedFont n + alterFontFamily n (fd, om) = (fd {F.fontDataFamily = n}, om) + localSansSerif :: FontMap n = M.filterWithKey (\(k, _, _) _ -> k == "sans-serif") fontMap + localAltered :: FontMap n = M.mapWithKey (\(s, _, _) v -> alterFontFamily s v) localSansSerif + -- we simplify the map so that other font types become sans-serif as well + localKeySimple = M.mapKeys (\(_, fs, fw) -> (fs, fw)) localAltered + -- we use an unsafe lookup method because what do we do if this isn't correct? + fontSelector :: FontStyle -> F.PreparedFont n + fontSelector FontStyle {..} = localKeySimple M.! (_font_slant, _font_weight) + +makeFontMap :: (Read n, RealFloat n, MonadIO m, MonadException m) => m (FontMap n) +makeFontMap = mapM (liftIO . loadFont) localFonts + +-- thanks to https://stackoverflow.com/questions/21549082/how-do-i-deploy-an-executable-using-chart-diagrams-standard-fonts-without-cabal +localFonts :: M.Map (String, FontSlant, FontWeight) FilePath +localFonts = + M.fromList + [ (("serif", FontSlantNormal, FontWeightNormal), "fonts/LinLibertine_R.svg"), + (("serif", FontSlantNormal, FontWeightBold), "fonts/LinLibertine_RB.svg"), + (("serif", FontSlantItalic, FontWeightNormal), "fonts/LinLibertine_RI.svg"), + (("serif", FontSlantOblique, FontWeightNormal), "fonts/LinLibertine_RI.svg"), + (("serif", FontSlantItalic, FontWeightBold), "fonts/LinLibertine_RBI.svg"), + (("serif", FontSlantOblique, FontWeightBold), "fonts/LinLibertine_RBI.svg"), + (("sans-serif", FontSlantNormal, FontWeightNormal), "fonts/SourceSansPro_R.svg"), + (("sans-serif", FontSlantNormal, FontWeightBold), "fonts/SourceSansPro_RB.svg"), + (("sans-serif", FontSlantItalic, FontWeightNormal), "fonts/SourceSansPro_RI.svg"), + (("sans-serif", FontSlantOblique, FontWeightNormal), "fonts/SourceSansPro_RI.svg"), + (("sans-serif", FontSlantItalic, FontWeightBold), "fonts/SourceSansPro_RBI.svg"), + (("sans-serif", FontSlantOblique, FontWeightBold), "fonts/SourceSansPro_RBI.svg"), + (("monospace", FontSlantNormal, FontWeightNormal), "fonts/SourceCodePro_R.svg"), + (("monospace", FontSlantNormal, FontWeightBold), "fonts/SourceCodePro_RB.svg"), + (("monospace", FontSlantItalic, FontWeightNormal), "fonts/SourceCodePro_R.svg"), + (("monospace", FontSlantOblique, FontWeightNormal), "fonts/SourceCodePro_R.svg"), + (("monospace", FontSlantItalic, FontWeightBold), "fonts/SourceCodePro_RB.svg"), + (("monospace", FontSlantOblique, FontWeightBold), "fonts/SourceCodePro_RB.svg") + ] diff --git a/src/Tablebot/Utility/Parser.hs b/src/Tablebot/Utility/Parser.hs index 318beef2..c2053d28 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 $> () @@ -167,25 +170,10 @@ double = do _ <- char '.' num <- some digit return $ '.' : num - ) + ) <|> 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 diff --git a/src/Tablebot/Utility/Permission.hs b/src/Tablebot/Utility/Permission.hs index 37507427..fa959e17 100644 --- a/src/Tablebot/Utility/Permission.hs +++ b/src/Tablebot/Utility/Permission.hs @@ -14,7 +14,7 @@ import Tablebot.Utility.Exception (BotException (PermissionException), throwBot) import Tablebot.Utility.Types -- | @requirePermission@ only runs the inputted effect if permissions are matched. Otherwise it returns an error. -requirePermission :: Context m => RequiredPermission -> m -> EnvDatabaseDiscord s a -> EnvDatabaseDiscord s a +requirePermission :: (Context m) => RequiredPermission -> m -> EnvDatabaseDiscord s a -> EnvDatabaseDiscord s a requirePermission perm m a = do p <- getSenderPermission m if userHasPermission perm p diff --git a/src/Tablebot/Utility/Random.hs b/src/Tablebot/Utility/Random.hs index 68dac0a6..9eee72aa 100644 --- a/src/Tablebot/Utility/Random.hs +++ b/src/Tablebot/Utility/Random.hs @@ -36,7 +36,7 @@ chooseOneWeighted weight xs | any ((< 0) . weight) xs = throw $ RandomException "Probability weightings cannot be negative." | all ((== 0) . weight) xs = throw $ RandomException "At least one weighting must be positive." | otherwise = - fst . fromJust . (\i -> find ((> i) . snd) (zip xs' $ scanl1 (+) $ weight <$> xs')) <$> randomRIO (0, totalWeight - 1) + fst . fromJust . (\i -> find ((> i) . snd) (zip xs' $ scanl1 (+) $ weight <$> xs')) <$> randomRIO (0, totalWeight - 1) where xs' = filter ((> 0) . weight) xs -- removes elements with a weight of zero totalWeight = sum $ weight <$> xs' diff --git a/src/Tablebot/Utility/Search.hs b/src/Tablebot/Utility/Search.hs index 7c6f8640..0bbb1c6a 100644 --- a/src/Tablebot/Utility/Search.hs +++ b/src/Tablebot/Utility/Search.hs @@ -31,7 +31,7 @@ import Data.Text (Text, isInfixOf, length, take) import Text.EditDistance -- | @compareOn@ is a helper function for comparing types that aren't ord. -compareOn :: Ord b => (a -> b) -> a -> a -> Ordering +compareOn :: (Ord b) => (a -> b) -> a -> a -> Ordering compareOn comp a b = compare (comp a) (comp b) -- | @FuzzyCosts@ is a wrapper for Text.EditDistance's EditCosts data type for diff --git a/src/Tablebot/Utility/SmartParser/Interactions.hs b/src/Tablebot/Utility/SmartParser/Interactions.hs index 72ea2b08..50d2963a 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. -- @@ -78,21 +80,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 @@ -252,8 +254,7 @@ processComponentInteraction' _ _ _ = throwBot $ InteractionException "could not onlyAllowRequestor :: forall f. (PComm f () Interaction MessageDetails) => f -> Parser (Interaction -> DatabaseDiscord MessageDetails) onlyAllowRequestor = onlyAllowRequestor' - ( (messageDetailsBasic "You don't have permission to use this component.") {messageDetailsFlags = Just $ InteractionResponseMessageFlags [InteractionResponseMessageFlagEphermeral]} - ) + ((messageDetailsBasic "You don't have permission to use this component.") {messageDetailsFlags = Just $ InteractionResponseMessageFlags [InteractionResponseMessageFlagEphermeral]}) -- | Take a message to send when a user that is not the one that created a -- component, and then parse out a user id, and then get the interaction @@ -275,8 +276,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/SmartParser/SmartParser.hs b/src/Tablebot/Utility/SmartParser/SmartParser.hs index 6a6ad34f..1b6e534f 100644 --- a/src/Tablebot/Utility/SmartParser/SmartParser.hs +++ b/src/Tablebot/Utility/SmartParser/SmartParser.hs @@ -125,7 +125,7 @@ instance CanParse Text where instance {-# OVERLAPPING #-} CanParse String where pars = word -instance IsString a => CanParse (Quoted a) where +instance (IsString a) => CanParse (Quoted a) where pars = Qu . fromString <$> quoted instance (ParseShow a) => ParseShow (Quoted a) where @@ -133,7 +133,7 @@ instance (ParseShow a) => ParseShow (Quoted a) where -- A parser for @Maybe a@ attempts to parse @a@, returning @Just x@ if -- correctly parsed, else @Nothing@. -instance CanParse a => CanParse (Maybe a) where +instance (CanParse a) => CanParse (Maybe a) where pars = optional $ try (pars @a) -- Note: we override @parsThenMoveToNext@: @@ -144,7 +144,7 @@ instance CanParse a => CanParse (Maybe a) where Just val -> Just val <$ (eof <|> skipSpace1) -- A parser for @[a]@ parses any number of @a@s. -instance {-# OVERLAPPABLE #-} CanParse a => CanParse [a] where +instance {-# OVERLAPPABLE #-} (CanParse a) => CanParse [a] where pars = many pars -- A parser for @Either a b@ attempts to parse @a@, and if that fails then @@ -183,16 +183,17 @@ instance (CanParse a, CanParse b, CanParse c, CanParse d, CanParse e) => CanPars v <- pars @e return (x, y, z, w, v) -instance KnownSymbol s => CanParse (Exactly s) where +instance (KnownSymbol s) => CanParse (Exactly s) where pars = chunk (pack $ symbolVal (Proxy :: Proxy s)) >> return Ex 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 @@ -203,10 +204,10 @@ instance CanParse () where instance CanParse Snowflake where pars = Snowflake . fromInteger <$> posInteger -instance IsString a => CanParse (RestOfInput a) where +instance (IsString a) => CanParse (RestOfInput a) where pars = ROI . fromString <$> untilEnd -instance IsString a => CanParse (RestOfInput1 a) where +instance (IsString a) => CanParse (RestOfInput1 a) where pars = ROI1 . fromString <$> untilEnd1 -- | Parse a labelled value, by parsing the base value and adding the label diff --git a/src/Tablebot/Utility/Types.hs b/src/Tablebot/Utility/Types.hs index 34002f27..e916a9a2 100644 --- a/src/Tablebot/Utility/Types.hs +++ b/src/Tablebot/Utility/Types.hs @@ -28,6 +28,7 @@ import Discord.Interactions import Discord.Internal.Rest.Channel (MessageDetailedOpts (MessageDetailedOpts)) import qualified Discord.Requests as R import Discord.Types +import Tablebot.Utility.Font (FontMap) import Text.Megaparsec (Parsec) -- * DatabaseDiscord @@ -48,9 +49,10 @@ type DatabaseDiscord = EnvDatabaseDiscord () type Database d = SqlPersistM d data TablebotCache = TCache - { cacheKnownEmoji :: Map Text Emoji, - cacheApplicationCommands :: Map ApplicationCommandId (Interaction -> EnvDatabaseDiscord () ()), - cacheVersionInfo :: VersionInfo + { cacheKnownEmoji :: !(Map Text Emoji), + cacheApplicationCommands :: !(Map ApplicationCommandId (Interaction -> EnvDatabaseDiscord () ())), + cacheVersionInfo :: !VersionInfo, + cacheFonts :: !(FontMap Double) } data VersionInfo = VInfo @@ -357,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 diff --git a/src/Tablebot/Utility/Utils.hs b/src/Tablebot/Utility/Utils.hs index 54c660ab..c1c57016 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) @@ -30,12 +30,12 @@ isDebug = do justDebug (Just "1") = True justDebug _ = False -debugPrint :: Show a => a -> IO () +debugPrint :: (Show a) => a -> IO () debugPrint a = do d <- isDebug when d $ print a -intToText :: Integral a => a -> Text +intToText :: (Integral a) => a -> Text intToText = toStrict . toLazyText . decimal -- | @standardise@ takes converts text to lowercase and removes diacritics diff --git a/stack.yaml b/stack.yaml index 619f14bd..398de291 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: https://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 00000000..a53e483f --- /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: https://github.com/L0neGamer/duckling.git + name: duckling + pantry-tree: + sha256: 126902871d2ae27e2ac4a88a07f04a4c3b7bff3f0fdf067d8d9226136002ff51 + size: 77724 + version: 0.2.0.1 + original: + commit: f22e3cdd7b77977fe3e9ec75fccd9a0f79c47f97 + git: https://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 00000000..15c12c95 --- /dev/null +++ b/tablebot.cabal @@ -0,0 +1,308 @@ +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 + ViewPatterns + 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