1b003db725
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>
113 lines
2.5 KiB
Haskell
113 lines
2.5 KiB
Haskell
{-# 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
|