如何向HXT箭头传递参数以及如何使用-<<

Question

我的问题如下。 我有这个 xml 文件要解析：

<DATAS LANG="en">
<SCENARIO ID="19864">
    <ORIGIN ID="329">
        <SCENARIO_S ERR="0"></SCENARIO_S>
        <SCENARIO_S ERR="2"></SCENARIO_S>
    </ORIGIN>
</SCENARIO>
<ERRORS>
    <ERROR ID="0" LABEL="Aggregated Major Errors" />
    <ERROR ID="2" LABEL="Banner error" />
</ERRORS>
</DATAS>

我想要以下输出：

[("19864","329",[0,2], ["Aggregated Major Errors", "Banner error"])]
that is 
[(Scenario ID, Origin ID, [ERR],[Errors label])]

但是下面的代码给了我：

[("19864","329",[0,2],["","*** Exception: Maybe.fromJust: Nothing

我只想解析一次 XML 以检索“错误标签”和错误。

我认为我的问题出在函数 errToLab 中，但我没有找到明显的解决方案。

感谢您的帮助。

这是代码

{-# LANGUAGE Arrows, NoMonomorphismRestriction #-}
import Text.XML.HXT.Core
import Data.Maybe

dataURL = "test.xml"

parseXML file = readDocument [ withValidate no
                         , withRemoveWS yes  -- throw away formating WS
                         ] file

atTag tag = deep (isElem >>> hasName tag)

getErrLab2 = atTag "ERRORS" >>>
  proc l -> do
     error <- atTag "ERROR"          -< l
     errID <- getAttrValue "ID"     -< error
     desc <- getAttrValue "LABEL"     -< error
     returnA -< (errID,desc)

getErr = atTag "SCENARIO_S" >>>
     proc p -> do
     err    <- getAttrValue "ERR" -< p
     returnA -< read err::Int 

getScenar2' errlab = atTag "SCENARIO" >>>
     proc l -> do
     scenarTag <- atTag "SCENARIO"     -< l
     scenName <- getAttrValue "ID"     -< l
     site     <- atTag "ORIGIN"          -< l
     siteName <- getAttrValue "ID"     -< site
     errs     <- listA getErr           -< site
     errlab   <- listA (errToLab errlab) -< site
     returnA -< (scenName,siteName,errs,errlab)

getData= atTag "DATAS" >>>
     proc p -> do 
          errlab <- getErrLab2  -< p
          datascen <- getScenar2' [errlab] -<< p
          returnA -< datascen

errToLab errlab = atTag "SCENARIO_S" >>>
     proc p -> do
          err    <- getAttrValue "ERR" -< p
          returnA -<  chercheErr err  errlab 

    where
          chercheErr "0" _  = ""
          chercheErr err taberr = fromJust.lookup err $ taberr

main = do
    site <- runX (parseXML dataURL >>> getData)
    print site

Answer 1

只需将错误列表提供给箭头输入即可。

这是一个稍微编辑过的版本：

{-# LANGUAGE Arrows #-}
import Text.XML.HXT.Core
import Data.Maybe

dataURL = "test.xml"

parseXML file = readDocument [ withValidate no
                             , withRemoveWS yes  -- throw away formating WS
                             ] file

atTag tag = deep (isElem >>> hasName tag)

getErrLab2 = atTag "ERRORS" >>>
    proc l -> do
    error <- atTag "ERROR"        -< l
    errID <- getAttrValue "ID"    -< error
    desc  <- getAttrValue "LABEL" -< error
    returnA -< (errID,desc)

getErr = atTag "SCENARIO_S" >>>
    proc p -> do
    err    <- getAttrValue "ERR" -< p
    returnA -< read err::Int 

getScenar2' = proc (p,errlab) -> do
    l <- atTag "SCENARIO" -< p
    scenarTag <- atTag "SCENARIO"  -< l
    scenName  <- getAttrValue "ID" -< l
    site      <- atTag "ORIGIN"    -< l
    siteName  <- getAttrValue "ID" -< site
    errs      <- listA getErr      -< site
    elab      <- listA errToLab    -< (site,errlab)
    returnA -< (scenName,siteName,errs,elab)

getData= atTag "DATAS" >>>
  proc p -> do 
      errlab <- listA getErrLab2  -< p
      getScenar2' -< (p, errlab)

errToLab = proc (s,errlab) -> do
   p    <- atTag "SCENARIO_S" -< s
   err  <- getAttrValue "ERR" -< p
   returnA -<  chercheErr err  errlab 

  where
      -- chercheErr "0" _  = ""
      chercheErr err taberr = fromJust.lookup err $ taberr

main = do
  site <- runX (parseXML dataURL >>> getData)
  print site