blob: 3d2811865a77feea91259b5fc3c5123a612de66b (
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
|
{-# LANGUAGE QuasiQuotes #-}
module Main where
import Data.ByteString.Internal qualified as Bytes
import Data.Error.Tree
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import Label
import PossehlAnalyticsPrelude
import Text.XML (def)
import Text.XML qualified as Xml
main :: IO ()
main = do
f <- file
f.documentRoot
& filterElementsRec noUsers
& downTo (T2 (label @"maxdepth" 5) (label @"maxlistitems" 20))
& toTree
& prettyErrorTree
& Text.putStrLn
file :: IO Xml.Document
file = Xml.readFile def "./jbovlaste-en.xml"
-- | Filter XML elements recursively based on the given predicate
filterElementsRec :: (Xml.Element -> Bool) -> Xml.Element -> Xml.Element
filterElementsRec f el =
el
{ Xml.elementNodes =
mapMaybe
( \case
Xml.NodeElement el' ->
if f el'
then Just $ Xml.NodeElement $ filterElementsRec f el'
else Nothing
other -> Just other
)
el.elementNodes
}
-- | no <user> allowed
noUsers :: Xml.Element -> Bool
noUsers el = el.elementName.nameLocalName /= "user"
downTo :: (T2 "maxdepth" Int "maxlistitems" Int) -> Xml.Element -> Xml.Element
downTo n el =
if n.maxdepth > 0
then
el
{ Xml.elementNodes =
( do
let eleven = take (n.maxlistitems + 1) $ map down el.elementNodes
if List.length eleven == (n.maxlistitems + 1)
then eleven <> [Xml.NodeComment "snip!"]
else eleven
)
}
else el {Xml.elementNodes = [Xml.NodeComment "snip!"]}
where
down =
\case
Xml.NodeElement el' ->
Xml.NodeElement $
downTo
( T2
(label @"maxdepth" $ n.maxdepth - 1)
(label @"maxlistitems" n.maxlistitems)
)
el'
more -> more
toTree :: Xml.Element -> ErrorTree
toTree el = do
let outer =
if not $ null el.elementAttributes
then [fmt|<{name el.elementName}: {attrs el.elementAttributes}>|]
else [fmt|<{name el.elementName}>|]
case el.elementNodes & filter (not . isEmptyContent) & nonEmpty of
Nothing -> singleError (newError outer)
Just (n :| []) | not $ isElementNode n -> singleError $ errorContext outer (nodeErrorNoElement n)
Just nodes -> nestedMultiError (newError outer) (nodes <&> node)
where
isEmptyContent = \case
Xml.NodeContent c -> c & Text.all Bytes.isSpaceChar8
_ -> False
isElementNode = \case
Xml.NodeElement _ -> True
_ -> False
node :: Xml.Node -> ErrorTree
node = \case
Xml.NodeElement el' -> toTree el'
other -> singleError $ nodeErrorNoElement other
nodeErrorNoElement :: Xml.Node -> Error
nodeErrorNoElement = \case
Xml.NodeInstruction i -> [fmt|Instruction: {i & show}|]
Xml.NodeContent c -> [fmt|"{c & Text.replace "\"" "\\\""}"|]
Xml.NodeComment c -> [fmt|<!-- {c} -->|]
Xml.NodeElement _ -> error "NodeElement not allowed here"
name :: Xml.Name -> Text
name n = [fmt|{n.namePrefix & fromMaybe ""}{n.nameLocalName}|]
attrs :: Map Xml.Name Text -> Text
attrs a = a & Map.toList <&> (\(k, v) -> [fmt|{name k}={v}|]) & Text.intercalate ", " & \s -> [fmt|({s})|]
|
