Some XML parsing exercise for my dad

stupid-payment-system.hs

{-# LANGUAGE OverloadedStrings #-}
module Main where
import Prelude hiding (readFile)
import Text.XML
import Text.XML.Cursor
import Text.XML.Cursor (node)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO

import Data.Map ((!))
import qualified Data.Map as Map

import qualified Data.Set as Set

data Entry = Entry {
    imie :: T.Text,
    nazwisko :: T.Text,
    dataUrodzenia :: T.Text,
    pesel :: T.Text,
    kwoty :: Map.Map T.Text T.Text
}

nsName :: String -> Name
nsName s = Name (T.pack s) (Just "http://www.insert.com.pl/GTSchemas/ListaPlac.xsd") Nothing

gttnsName :: String -> Name
gttnsName s = Name (T.pack s) (Just "http://www.insert.com.pl/GTSchemas/Typy.xsd") (Just "gttns")

getCursorSubElementContent :: Name -> Cursor -> T.Text
getCursorSubElementContent n c = T.concat $ c $/ element n &/ content

processKwoty :: Cursor -> Map.Map T.Text T.Text
processKwoty cursor = Map.unions 
    $ cursor 
    $/ element (nsName "Kwota") 
    &| processKwota

processKwota :: Cursor -> Map.Map T.Text T.Text
processKwota cursor = let
        wartosc = getCursorSubElementContent (nsName "Wartosc") cursor
        key = extractKey 
                $ head
                $ cursor 
                $/ checkElement ((/= "Wartosc") . nameLocalName . elementName)
                &| node
    in 
        Map.singleton key wartosc
    where
        extractKey :: Node -> T.Text
        extractKey (NodeElement e) = (nameLocalName . elementName) e 
        extractKey _ = T.empty 
    
processWyplata :: Cursor -> Entry
processWyplata cursor = 
    let 
        pracownikC = head $ cursor $/ element (nsName "Pracownik")
        kwotyC = head $ cursor $/ element (nsName "Kwoty")
    in
        Entry { 
            imie = getCursorSubElementContent (gttnsName "Imie") pracownikC,
            nazwisko = getCursorSubElementContent (gttnsName "Nazwisko") pracownikC, 
            dataUrodzenia = getCursorSubElementContent (gttnsName "DataUrodzenia") pracownikC, 
            pesel = getCursorSubElementContent (gttnsName "PESEL") pracownikC,
            kwoty = processKwoty kwotyC }

printEntry :: [T.Text] -> Entry -> IO ()
printEntry keysOrder e = TIO.putStrLn $ 
    let 
        m = kwoty e
        valuesInOrder = fmap (m !) keysOrder
    in
        T.intercalate ";" ([imie e, nazwisko e, dataUrodzenia e, pesel e] ++ valuesInOrder)

main :: IO ()
main = do 
    doc <- readFile def "test.xml"
    let cursor = fromDocument doc
        wyplataC = cursor 
                    $/ element (nsName "ListaPlac") 
                    &/ element (nsName "Wyplaty") 
                    &/ element (nsName "Wyplata")
        entries = fmap processWyplata wyplataC
        keysInOrder = Set.toList $ Set.unions $ fmap (Set.fromList . Map.keys . kwoty) entries
    TIO.putStrLn $ T.intercalate ";" (["Imie", "Nazwisko", "DataUrodzenia", "PESEL"] ++ keysInOrder)
    mapM_ (printEntry keysInOrder) entries