如何处理嵌套记录和列表箭头

Question

我有以下情况。我从探针获取周数据。数据收集在几个xml文件中（内联在下面的代码中）。我需要在一个文件中连接这些。虽然我把它们集中在一个可以进一步翻译成单个文件的记录中。

结果记录我试图抓住如下：

[YS {ser = "MSG" 
     , ori =[YO {site = "Bordeaux" , perfM = ["0","0"] } 
       ,YO {site = "Paris" , perfM = ["1","1"]}]} 
    ,YS {ser = "OTP" 
     , ori =[YO {site = "Marseilles" , perfM = ["20","20"]} 
       ,YO {site = "Lyon"  , perfM = ["21","21"]}]} 
    ] 

，你可以看到perfM收集所有提交的数据。

但下面的代码给了我。

[YS {ser = "MSG" 
     , ori = [YO {site = "Bordeaux", perfM = ["0"]} 
       ,YO {site = "Paris", perfM =["1"]} 
       ,YO {site = "Bordeaux", perfM = ["0","0"]} 
       ,YO {site = "Paris", perfM = ["1","1"]}]} 
    ,YS {ser = "OTP" 
     , ori = [YO {site = "Marseilles" 
       , perfM = ["20"]} 
       ,YO {site = "Lyon", perfM =["21"]} 
       ,YO {site = "Marseilles", perfM = ["20","20"]} 
       ,YO {site = "Lyon", perfM = ["21","21"]}]} 
    ] 

这真的不清楚我这里发生了什么，我应该在哪里看看。我认为它在getYearOri和addOri函数中，但到目前为止，我所有的尝试都可能失败。

如果任何人都可以给我一个线索，要改变的代码。

{-# LANGUAGE Arrows, NoMonomorphismRestriction #-} 

    import Text.XML.HXT.Core 

    type Site = String 
    type Service = String 
    data YScen = YS 
     { ser :: Service 
     , ori :: [YOri] 
     } 
     deriving (Show,Eq) 

    data YOri = YO 
     { site     :: Site 
     ,perfM    :: [String] 
     } 
     deriving (Show,Eq) 



    xml= "<DATAS LANG='en'>\ 
     \ <SCENARIO ID='MSG'>\ 
     \ <ORIGIN ID='Bordeaux'>\ 
     \  <SCENARIO_M PERF_MOY='0'></SCENARIO_M>\ 
     \ </ORIGIN>\ 
     \ <ORIGIN ID='Paris'>\ 
     \  <SCENARIO_M PERF_MOY='1'></SCENARIO_M>\ 
     \ </ORIGIN>\ 
     \ </SCENARIO>\ 
     \ <SCENARIO ID='OTP'>\ 
     \ <ORIGIN ID='Marseilles'>\ 
     \  <SCENARIO_M PERF_MOY='20'></SCENARIO_M>\ 
     \ </ORIGIN>\ 
     \ <ORIGIN ID='Lyon'>\ 
     \  <SCENARIO_M PERF_MOY='21'></SCENARIO_M>\ 
     \ </ORIGIN>\ 
     \ </SCENARIO>\ 
     \</DATAS>" 


    parseXML :: String -> IOStateArrow s b XmlTree 
    parseXML s = readString [ withValidate no 
          , withRemoveWS yes 
          ] s 

    atTag :: ArrowXml a => String -> a XmlTree XmlTree 
    atTag tag = deep (isElem >>> hasName tag) 


    getYearOri :: ArrowXml cat => [YOri] -> cat XmlTree YOri 
    getYearOri yo = atTag "ORIGIN" >>> 
     proc tagSite -> do 
     siteName1 <- getAttrValue "ID"  -< tagSite 

     tagScen_M <- atTag "SCENARIO_M"   -< tagSite 
     perfM1  <- getAttrValue "PERF_MOY" -< tagScen_M 

     returnA -< addOri (YO siteName1 [perfM1]) yo 
     where 
      addOri::YOri -> [YOri]-> YOri 
      addOri o [] = o 

      addOri o (x:xs) 
        | site o == site x 
           = YO {site  = site o 
             ,perfM = (perfM x) ++ (perfM o)} 

        | otherwise = addOri o xs 


    getYearScen :: ArrowXml cat => [YScen] -> cat XmlTree YScen 
    getYearScen ys = atTag "SCENARIO" >>> 
     proc l -> do 
     scenName <- getAttrValue "ID"  -< l 
     orig  <- listA (getYearOri (concat (map ori ys))) -< l 
     returnA -< addScen (YS scenName orig) ys 
     where 
      addScen :: YScen -> [YScen] -> YScen 
      addScen sc [] = sc 
      addScen sc (x:xs) 
         | ser sc == ser x 
            = YS {ser=ser x 
             ,ori=(ori x) ++ (ori sc)} 
         | otherwise = addScen sc xs 

    parse :: [YScen]-> IO [YScen] 
    parse ys = do 
     res <- runX (parseXML xml >>> getYearScen ys) 
     return res 

    ysc1 = [YS "" []] 

    test = do 
     ysc2 <- parse ysc1 
     ysc3 <- parse ysc2 
     return ysc3 

Answer 1

我想我找到了我的错误。该addScen功能是不正确的，应该改为

 addScen :: YScen -> [YScen] -> YScen 
     addScen sc [] = sc 
     addScen sc (x:xs) 
        | ser sc == ser x 
           = YS {ser=ser sc 
            ,ori=(ori sc) } 
            -- ,ori=(ori x) ++ (ori sc) <--- Error 
        | otherwise = addScen sc xs 

要了解这一点，我不得不阅读文档中关于debbuging Haskell和最有用的评论，其中“写的小功能，并对其进行测试。然后撰写。”

我把我的代码分解成小部分并测试它的每个部分。但与debbugger比ghc更友好的其他语言相比，这是乏味的。

对不起，烦恼。我发布我的解决方案，以防有些人可能感兴趣。