blob: e8e45e7048823eeffed02e8127bde63e7ed91848 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
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
|
