How to deal with nested records and listA arrows

Question

i have the following situation. I get week datas from probes. Datas are collected in several xml files (inline in the code below). I need to concat these in one file. Though i aggregate them in one record that can further be translated into a single file.

The result record i try to catch is the following :

    [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"]}]}
    ]

as you can see perfM collects all datas.

But the following code give me that.

    [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"]}]}
    ]

This is really unclear to me what's going on here and where should i need to look at. I think it's in the getYearOri and the addOri functions but so far all my attemps lamentably failed.

if anyone could give me a clue on the code to be changed.

    {-# 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

I think i have found my error. The addScen function is not correct and should be change to

        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

To find this i had to read documentation about debbuging haskell and the most usefull comment where " write small functions and test them. then compose. "

I broke my code into small parts and test every part of it. But this is tedious compared to other languages where debbugger are friendlier than ghc's one.

Sorry for the annoyance. i post my solution in case some may be interested in.