Upstream Mercury Slack blocks code

flake.nix

@@ -79,6 +79,13 @@
             # and the fourmolu/ormolu bug:
             # https://github.com/tweag/ormolu/issues/927
             mutable-containers = hlib.dontCheck hprev.mutable-containers;
+
+            # it's not yet in hackage2nix
+            string-variants = hfinal.callHackageDirect {
+              pkg = "string-variants";
+              ver = "0.1.0.1";
+              sha256 = "sha256-7oNYwPP8xRNYxKNdNH+21zBHdeUeiWBtKOK5G43xtSQ=";
+            } {};
           });
       };
     };

fourmolu.yaml

@@ -0,0 +1,13 @@
+indentation: 2
+comma-style: leading # 'leading' or 'trailing'
+record-brace-space: true # rec {x = 1} vs. rec{x = 1}
+indent-wheres: true # 'false' means save space by only half-indenting the 'where' keyword
+diff-friendly-import-export: false # 'false' uses Ormolu-style lists
+respectful: false # don't be too opinionated about newlines etc.
+haddock-style: single-line # 'signle-line' or 'multi-line', i.e., '--' vs. '{-'
+newlines-between-decls: 1 # number of newlines between top-level declarations
+
+fixities:
+  - 'infixl 9 .:'
+  - 'infixl 9 .:?'
+  - 'infixr 8 .='

slack-web.cabal

@@ -107,32 +107,38 @@ library
       Web.Slack.Pager
       Web.Slack.Types
       Web.Slack.User
+      Web.Slack.Experimental.Blocks
+      Web.Slack.Experimental.Blocks.Types
   other-modules:
       Web.Slack.Util
       Web.Slack.Prelude
+      Web.Slack.AesonUtils
   build-depends:
       aeson >= 2.0 && < 2.2
     , base >= 4.11 && < 4.18
-    , scientific
+    , classy-prelude
     , containers
     , deepseq
-    , unordered-containers
-    , mono-traversable
-    , classy-prelude
+    , errors
     , hashable
-    , string-conversions
     , http-api-data >= 0.3 && < 0.6
     , http-client >= 0.5 && < 0.8
     , http-client-tls >= 0.3 && < 0.4
+    , megaparsec >= 5.0 && < 10
+    , mono-traversable
+    , mtl
+    , refined
+    , scientific
     , servant >= 0.16 && < 0.20
     , servant-client >= 0.16 && < 0.20
     , servant-client-core >= 0.16 && < 0.20
+    , string-conversions
+    , string-variants >= 0.1.0.1
     , text (>= 1.2 && < 1.3) || (>= 2.0 && < 2.1)
-    , transformers
-    , mtl
     , time
-    , errors
-    , megaparsec >= 5.0 && < 10
+    , transformers
+    , unordered-containers
+    , vector
   default-language:
       Haskell2010
   ghc-options:

src/Web/Slack/AesonUtils.hs

@@ -0,0 +1,100 @@
+module Web.Slack.AesonUtils where
+
+import Data.Aeson
+import Data.Char qualified as Char
+import Data.Text qualified as T
+import Web.Slack.Prelude
+import Data.Aeson.Types (Pair)
+import qualified Data.Aeson as J
+
+-- | Checks that a record's field labels each start with the given 'prefix',
+-- then uses a given 'drop (length prefix)' derivingStrategy to drop that prefix from generated JSON.
+--
+-- If used in a Template Haskell splice, gives a compile-time error if the prefixes don't match up.
+-- Warning: This function should not be used outside of a Template Haskell splice, as it calls `error` in the case that the prefixes don't match up!
+--
+-- Example usage:
+--
+-- data PrefixedRecord = PrefixedRecord { prefixedRecordOne :: Int, prefixedRecordTwo :: Char }
+
+-- $(deriveFromJSON (jsonDeriveWithAffix "prefixedRecord" jsonDeriveOptionsSnakeCase) ''PrefixedRecord)
+
+jsonDeriveWithAffix :: Text -> (Int -> Options) -> Options
+jsonDeriveWithAffix prefix derivingStrategy =
+  originalOptions
+    { fieldLabelModifier = \fieldLabel ->
+        if prefix `isPrefixOf` T.pack fieldLabel
+          then originalModifier fieldLabel
+          else error $ "Prefixes don't match: `" <> T.unpack prefix <> "` isn't a prefix of `" <> fieldLabel <> "`. Search for jsonDeriveWithAffix to learn more."
+    }
+  where
+    originalOptions = derivingStrategy $ T.length prefix
+    originalModifier = fieldLabelModifier originalOptions
+
+camelToSnake :: String -> String
+camelToSnake = camelTo2 '_'
+
+lowerFirst :: String -> String
+lowerFirst [] = []
+lowerFirst (c : chars) = Char.toLower c : chars
+
+jsonDeriveOptionsSnakeCase :: Int -> Options
+jsonDeriveOptionsSnakeCase n =
+  defaultOptions
+    { fieldLabelModifier = camelToSnake . lowerFirst . drop n
+    , omitNothingFields = True
+    , constructorTagModifier = camelToSnake . lowerFirst . drop n
+    }
+
+-- | Create a 'Value' from a list of name\/value @Maybe Pair@'s.
+-- For 'Nothing', instead of outputting @null@, that field will not be output at all.
+-- If duplicate keys arise, later keys and their associated values win.
+--
+-- Example:
+--
+-- @
+-- objectOptional
+--   [ "always" .=! 1
+--   , "just" .=? Just 2
+--   , "nothing" .=? Nothing
+--   ]
+-- @
+--
+-- will result in the JSON
+--
+-- @
+-- {
+--   "always": 1,
+--   "just": 2
+-- }
+-- @
+--
+-- The field @nothing@ is ommited because it was 'Nothing'.
+objectOptional :: [Maybe Pair] -> Value
+objectOptional = J.object . catMaybes
+
+-- | Encode a value for 'objectOptional'
+(.=!) :: ToJSON v => Key -> v -> Maybe Pair
+key .=! val = Just (key .= val)
+
+infixr 8 .=!
+
+-- | Encode a Maybe value for 'objectOptional'
+(.=?) :: ToJSON v => Key -> Maybe v -> Maybe Pair
+key .=? mVal = fmap (key .=) mVal
+
+infixr 8 .=?
+
+-- | Conditionally encode a value for 'objectOptional'
+(?.>) :: Bool -> Pair -> Maybe Pair
+True ?.> pair = Just pair
+False ?.> _ = Nothing
+
+infixr 7 ?.>
+
+-- | Conditionally express a pair in a JSON series
+thenPair :: Bool -> J.Series -> J.Series
+thenPair True s = s
+thenPair False _ = mempty
+
+infixr 7 `thenPair`

src/Web/Slack/Experimental/Blocks.hs

@@ -0,0 +1,193 @@
+module Web.Slack.Experimental.Blocks
+  ( -- * General Slack Messages
+    SlackText,
+    (<+>),
+    parens,
+    brackets,
+    angleBrackets,
+    ticks,
+    codeBlock,
+    bold,
+    newline,
+    unorderedList,
+    link,
+    monospaced,
+    mentionUser,
+    isSubStringOf,
+    SlackImage (..),
+    SlackMessage,
+    Markdown (..),
+    Image (..),
+    context,
+    textToMessage,
+    prefixFirstSlackMessage,
+    mentionUserGroupById,
+    textToContext,
+    slackMessage,
+    SlackBlock (..),
+
+    -- * Rendered messages
+    RenderedSlackMessage (..),
+    render,
+
+    -- * Introduction to Slack Interactive Messages
+    -- $interactive
+
+    -- * Creating Slack Interactive Messages
+    actions,
+    actionsWithBlockId,
+    SlackActionId (..),
+    SlackBlockId,
+    setting,
+    emptySetting,
+    SlackStyle (..),
+    plaintext,
+    plaintextonly,
+    mrkdwn,
+    button,
+    buttonSettings,
+    ButtonSettings
+      ( buttonUrl,
+        buttonValue,
+        buttonStyle,
+        buttonConfirm
+      ),
+    confirm,
+    confirmAreYouSure,
+    ConfirmSettings
+      ( confirmTitle,
+        confirmText,
+        confirmConfirm,
+        confirmDeny,
+        confirmStyle
+      ),
+
+    -- * Responding to Slack Interactive Messages
+    SlackInteractiveResponse (..),
+  )
+where
+
+import Data.Aeson.Text (encodeToLazyText)
+import Data.Text qualified as T
+import Web.Slack.Experimental.Blocks.Types
+import Web.Slack.Prelude
+import Web.Slack.Types
+
+(<+>) :: SlackText -> SlackText -> SlackText
+x <+> y = x <> " " <> y
+
+parens :: SlackText -> SlackText
+parens x = "(" <> x <> ")"
+
+brackets :: SlackText -> SlackText
+brackets x = "[" <> x <> "]"
+
+angleBrackets :: SlackText -> SlackText
+angleBrackets x = "<" <> x <> ">"
+
+ticks :: SlackText -> SlackText
+ticks x = "`" <> x <> "`"
+
+-- | Render a 'Slack' renderable value with ticks around it. Alias for @ticks . message@
+monospaced :: Slack a => a -> SlackText
+monospaced = ticks . message
+
+codeBlock :: SlackText -> SlackText
+codeBlock x = "```\n" <> x <> "\n```"
+
+bold :: SlackText -> SlackText
+bold x = "*" <> x <> "*"
+
+newline :: SlackText -> SlackText
+newline x = "\n" <> x
+
+-- | Render an unordered (bulleted) list
+unorderedList :: [SlackText] -> SlackText
+unorderedList = mconcat . fmap (\t -> newline (message @Text "- " <> t))
+
+-- | https://api.slack.com/reference/surfaces/formatting#mentioning-users
+mentionUser :: UserId -> SlackText
+mentionUser slackUserId = message $ "<@" <> unUserId slackUserId <> ">"
+
+-- | https://api.slack.com/reference/surfaces/formatting#mentioning-groups
+mentionUserGroupById :: SlackText -> SlackText
+mentionUserGroupById userGroupId = angleBrackets $ "!subteam^" <> userGroupId
+
+isSubStringOf :: Text -> SlackText -> Bool
+needle `isSubStringOf` (SlackText haystack) = needle `isInfixOf` concat haystack
+
+-- | RenderedSlackMessage contains the original SlackMessage, the rendered version, and a
+--   boolean indicating whether truncation was done.
+--
+--   Usage:
+--
+--   @
+--      let
+--        msg =
+--        (mkPostMsgReq channel "")
+--          { postMsgReqBlocks = Just blocks
+--          , postMsgReqThreadTs = mThreadTs
+--          }
+--    chatPostMessage msg
+--   @
+data RenderedSlackMessage = RenderedSlackMessage
+  { _originalMessage :: SlackMessage
+  , _renderedMessage :: Text
+  , _truncated :: Bool
+  }
+
+render :: SlackMessage -> RenderedSlackMessage
+render sm =
+  let (truncatedSm, isTruncated) = truncateSlackMessage sm
+   in RenderedSlackMessage sm (cs . encodeToLazyText . toJSON $ truncatedSm) isTruncated
+
+-- | Slack will fail if any text block is over 3000 chars.
+--   truncateSlackMessage will truncate all text blocks and also return an bool
+--   indicating whether any truncation was done.
+truncateSlackMessage :: SlackMessage -> (SlackMessage, Bool)
+truncateSlackMessage (SlackMessage blocks) =
+  let (truncatedBlocks, isTruncateds) = unzip $ map truncateSlackBlock blocks
+   in (SlackMessage truncatedBlocks, or isTruncateds)
+
+truncateSlackBlock :: SlackBlock -> (SlackBlock, Bool)
+truncateSlackBlock sb@(SlackBlockSection (SlackText texts)) =
+  let messageLength = sum $ map T.length texts
+      lengthLimit = 3000
+      truncationMessage = "\n...Rest of message truncated for slack\n"
+      truncationMessageLength = T.length truncationMessage
+      truncateTexts ts = take (lengthLimit - truncationMessageLength) (concat ts)
+   in if messageLength > lengthLimit
+        then (SlackBlockSection (SlackText [truncateTexts texts <> "\n...Rest of message truncated for slack\n"]), True)
+        else (sb, False)
+-- possible to also truncate SlackContexts, but we never put long strings in there.
+truncateSlackBlock x = (x, False)
+
+prefixFirstSlackBlockSection :: Text -> [SlackBlock] -> ([SlackBlock], Bool)
+prefixFirstSlackBlockSection prefix (SlackBlockSection slackBlockSection : sbs) = (SlackBlockSection (message prefix <> slackBlockSection) : sbs, True)
+prefixFirstSlackBlockSection prefix (sb : sbs) = let (prefixedSbs, match) = prefixFirstSlackBlockSection prefix sbs in (sb : prefixedSbs, match)
+prefixFirstSlackBlockSection _ [] = ([], False)
+
+prefixFirstSlackMessage :: Text -> [SlackMessage] -> [SlackMessage]
+prefixFirstSlackMessage prefix (sm : sms) =
+  let SlackMessage slackBlocks = sm
+      (prefixedSlackBlocks, match) = prefixFirstSlackBlockSection prefix slackBlocks
+   in if match
+        then SlackMessage prefixedSlackBlocks : sms
+        else sm : prefixFirstSlackMessage prefix sms
+prefixFirstSlackMessage _ [] = []
+
+-- | Concatenate a list of 'SlackText' into a single block, and wrap it up as a full message
+slackMessage :: [SlackText] -> SlackMessage
+slackMessage = SlackMessage . pure . SlackBlockSection . mconcat
+
+-- $interactive
+--
+-- = Slack Interactive Messages
+--
+-- First, familiarize yourself with [Slack's Interactivity documentation](https://api.slack.com/interactivity).
+-- Currently we only support [Block Kit interactive components](https://api.slack.com/interactivity/components),
+-- i.e. components like buttons attached to messages.
+--
+-- To make an Slack message interactive, you need to include an \"Actions\" block that has one or more interactive components.
+-- These should generally only be created using the builder functions such as 'actions' and 'button'. Consumers of this module
+-- should avoid directly importing "Web.Slack.Experimental.Blocks.Types".