feat(users/Profpatsch/mailbox-org): list & update filters r/5562

One step closer towards a declarative description of filters.
In the end, the filters should be updated by their `rulename` field.

This implements a simple scheme where we list all filters, parse some
of their fields, use those fields to determine whether we want to
change the filters, and then only update the filters where we changed
something.

Unfortunately, we can only update the filters one-by-one (a common
mistake in APIs).

Pulls in some modules for Json parsing that I like to use, and an
`ErrorTree` abstraction over `Error` and `Data.Tree`.

Change-Id: Iea45d5aa0a3fee7ec570f06d3e77009769091274
Reviewed-on: https://cl.tvl.fyi/c/depot/+/7720
Autosubmit: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI
Reviewed-by: Profpatsch <mail@profpatsch.de>

1 files changed, 113 insertions, 0 deletions

diff --git a/users/Profpatsch/my-prelude/Data/Error/Tree.hs b/users/Profpatsch/my-prelude/Data/Error/Tree.hs
new file mode 100644
index 0000000000..e8e45e7048
--- /dev/null
+++ b/users/Profpatsch/my-prelude/Data/Error/Tree.hs
@@ -0,0 +1,113 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Data.Error.Tree where
+
+import Data.String (IsString (..))
+import Data.Tree qualified as Tree
+import MyPrelude
+
+-- | A tree of 'Error's, with a single root 'Error' and 0..n nested 'ErrorTree's.
+--
+-- @@
+-- top error
+-- |
+-- |-- error 1
+-- | |
+-- |  -- error 1.1
+-- |
+-- |-- error 2
+-- @@
+newtype ErrorTree = ErrorTree {unErrorTree :: (Tree.Tree Error)}
+  deriving stock (Show)
+
+instance IsString ErrorTree where
+  fromString = singleError . fromString
+
+-- deriving newtype (Ord) -- TODO: Add this instance with containers-0.6.5
+
+-- | Turn a single 'Error' into an 'ErrorTree', a leaf.
+singleError :: Error -> ErrorTree
+singleError e = ErrorTree $ Tree.Node e []
+
+-- | Take a list of errors & create a new 'ErrorTree' with the given 'Error' as the root.
+errorTree :: Error -> NonEmpty Error -> ErrorTree
+errorTree topLevelErr nestedErrs =
+  ErrorTree
+    ( Tree.Node
+        topLevelErr
+        (nestedErrs <&> (\e -> Tree.Node e []) & toList)
+    )
+
+-- | Attach more context to the root 'Error' of the 'ErrorTree', via 'errorContext'.
+errorTreeContext :: Text -> ErrorTree -> ErrorTree
+errorTreeContext context (ErrorTree tree) =
+  ErrorTree $
+    tree
+      { Tree.rootLabel = tree.rootLabel & errorContext context
+      }
+
+-- | Nest the given 'Error' around the ErrorTree
+--
+-- @@
+-- top level error
+-- |
+-- -- nestedError
+--   |
+--   -- error 1
+--   |
+--   -- error 2
+-- @@
+nestedError ::
+  Error -> -- top level
+  ErrorTree -> -- nested
+  ErrorTree
+nestedError topLevelErr nestedErr =
+  ErrorTree $
+    Tree.Node
+      { Tree.rootLabel = topLevelErr,
+        Tree.subForest = [nestedErr.unErrorTree]
+      }
+
+-- | Nest the given 'Error' around the list of 'ErrorTree's.
+--
+-- @@
+-- top level error
+-- |
+-- |- nestedError1
+-- | |
+-- | -- error 1
+-- | |
+-- | -- error 2
+-- |
+-- |- nestedError 2
+-- @@
+nestedMultiError ::
+  Error -> -- top level
+  NonEmpty ErrorTree -> -- nested
+  ErrorTree
+nestedMultiError topLevelErr nestedErrs =
+  ErrorTree $
+    Tree.Node
+      { Tree.rootLabel = topLevelErr,
+        Tree.subForest = nestedErrs & toList <&> (.unErrorTree)
+      }
+
+prettyErrorTree :: ErrorTree -> Text
+prettyErrorTree (ErrorTree tree) =
+  tree
+    <&> prettyError
+    <&> textToString
+    & Tree.drawTree
+    & stringToText
+
+prettyErrorTrees :: NonEmpty ErrorTree -> Text
+prettyErrorTrees forest =
+  forest
+    <&> (.unErrorTree)
+    <&> fmap prettyError
+    <&> fmap textToString
+    & toList
+    & Tree.drawForest
+    & stringToText