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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
|
-- ------------------------------------------------------------
{- |
Module : XPathShell
Copyright : Copyright (C) 2008 Uwe Schmidt
License : MIT
Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
Stability : experimental
Portability: portable
XPath example program for testing xpath evaluation
with both evaluation stategies, the full XPath functionality
and the limited but faster one for simple XPath queries
-}
-- ------------------------------------------------------------
module Main
where
import qualified Control.Monad as M
import Data.Maybe
import Text.XML.HXT.Core
import Text.XML.HXT.XPath
import Text.XML.HXT.Curl
import Text.XML.HXT.Parser.XmlCharParser( withNormNewline )
import System.Console.Haskeline
import System.Console.Haskeline.IO
import System.Environment
import Text.ParserCombinators.Parsec ( runParser )
type NsEnv' = AssocList String String
main :: IO()
main
= do
args <- getArgs
(path, env, doc) <- evalArgs args
if not (null path) && not (null doc)
then evalXPath path env (head doc)
else startEvalLoop env doc
evalArgs :: [String] -> IO (String, NsEnv', XmlTrees)
evalArgs [] = evalArgs ("" : "[]" : "" : [])
evalArgs [doc] = evalArgs ("" : "[]" : doc : [])
evalArgs [path, doc] = evalArgs (path : "[]" : doc : [])
evalArgs [path, env, ""] = return (path, buildEnv env, [])
evalArgs [path, env, doc] = do
(d, ne) <- loadDoc doc
return (path, addEntries ne . buildEnv $ env, d)
evalArgs al = evalArgs (take 3 al)
buildEnv :: String -> NsEnv'
buildEnv env = (addEntries . read $ env) $ defaultEnv
loadDoc :: String -> IO ([XmlTree], NsEnv')
loadDoc doc
= do
d <- runX ( readDocument [ withParseByMimeType yes
, withCheckNamespaces yes
, withRemoveWS yes
, withValidate no
, withCanonicalize yes
, withCurl []
] doc
>>>
(documentStatusOk `guards` this)
)
let env = runLA (unlistA >>> collectNamespaceDecl) d
return (d, env)
showDoc :: XmlTree -> IO ()
showDoc doc
= runX ( constA doc
>>>
writeDocument [ withIndent yes
, withXmlPi no
] ""
)
>> return ()
showTree :: XmlTree -> IO ()
showTree doc
= runX ( constA doc
>>>
writeDocument [ withShowTree yes
, withXmlPi no
] ""
)
>> return ()
evalXPath :: String -> NsEnv' -> XmlTree -> IO()
evalXPath path env doc
= putStrLn . unlines $
[ "start xpath evaluation: " ++ pathS
, " parsed xpath: " ++ pathString
, " parsed xpath as tree:"
, pathTree
, "xpath result:"
] ++ xr ++
[ "end xpath evaluation: " ++ pathS
]
where
pathS = show $ path
pathEx = runParser parseXPath (withNormNewline (toNsEnv env)) "" $ path
pathString = either show show $ pathEx
pathTree = either show formatXPathTree $ pathEx
xr = runLA ( xshow $ getXPathTreesWithNsEnv env path) doc
startEvalLoop :: NsEnv' -> XmlTrees -> IO ()
startEvalLoop env doc
= do is0 <- initializeInput defaultSettings
evalLoop0 (readCmdLine is0 "xpath> ") env doc
closeInput is0
return ()
readCmdLine :: InputState -> String -> IO String
readCmdLine is0 prompt
= do
line <- queryInput is0 (getInputLine prompt)
let line' = stringTrim . fromMaybe "" $ line
if null line'
then readCmdLine is0 prompt
else return line'
evalLoop0 :: IO String -> NsEnv' -> XmlTrees -> IO ()
evalLoop0 readCmdLine' env doc
= do
line <- readCmdLine'
case line of
"" -> return () -- EOF / control-d
":q" -> return ()
_ -> do
let ws = words line
if null ws
then evalLoop env doc
else do
evalCmd (words line)
where
evalLoop = evalLoop0 readCmdLine'
evalCmd [] = evalLoop env doc
evalCmd [":ns",uri] = evalCmd [":ns", "", uri]
evalCmd [":ns", ns, uri]
= evalLoop (addEntry ns uri env) doc
evalCmd (":?":_) = do
putStrLn . unlines $
[ "XPath Tester"
, "Commands:"
, ":l <document>\tload a document"
, ":ns <uri>\tset default namespace"
, ":ns <px> <uri>\tset namespace"
, ":q\t\tquit"
, ":s\t\tshow current document"
, ":t\t\tshow current document in tree format"
, ":x\t\tshow current namespace environment"
, ":?\t\tthis message"
, "<xpath-expr>\tevaluate XPath expression"
]
evalLoop env doc
evalCmd [":x"] = do
putStrLn . unlines . map show $ env
evalLoop env doc
evalCmd [":s"] = do
M.when (not . null $ doc) (showDoc . head $ doc)
evalLoop env doc
evalCmd [":t"] = do
M.when (not . null $ doc) (showTree . head $ doc)
evalLoop env doc
evalCmd [":l",n] = do
(nd, nv) <- loadDoc n
if null nd
then do
putStrLn ("error when loading " ++ show n)
evalLoop env doc
else evalLoop (addEntries nv env) nd
evalCmd ws@((':':_):_)
= do
putStrLn ("unknown command (:? for help): " ++ (show . unwords $ ws))
evalLoop env doc
evalCmd ws = do
let path = unwords ws
if null doc
then putStrLn "no document loaded"
else evalXPath path env (head doc)
evalLoop env doc
defaultEnv :: NsEnv'
defaultEnv = [ ("xml",xmlNamespace)
, ("xmlns",xmlnsNamespace)
]
-- ----------------------------------------
|
