From 1b003db7250949e2589336220ce162bf0b7b6fe3 Mon Sep 17 00:00:00 2001
From: Profpatsch <mail@profpatsch.de>
Date: Mon, 2 Jan 2023 03:02:48 +0100
Subject: feat(users/Profpatsch/mailbox-org): list & update filters

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>
---
 users/Profpatsch/my-prelude/Data/Error/Tree.hs | 113 +++++++++++++++++++++++++
 1 file changed, 113 insertions(+)
 create mode 100644 users/Profpatsch/my-prelude/Data/Error/Tree.hs

(limited to 'users/Profpatsch/my-prelude/Data/Error/Tree.hs')

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
-- 
cgit 1.4.1