如何處理嵌套記錄和列表箭頭

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更友好的其他語言相比，這是乏味的。

對不起，煩惱。我發佈我的解決方案，以防有些人可能感興趣。