xml-scores.hs

{-# LANGUAGE OverloadedStrings #-}
import           Control.Monad.Trans.Class
import           Data.Conduit
import qualified Data.Conduit.Combinators  as CC
import qualified Data.Conduit.List         as CL
import           Data.Monoid               (Monoid (..))
import           Data.Text                 (Text, unpack)
import           Data.XML.Types
import           Safe                      (readMay)
import           Text.XML.Stream.Parse

main :: IO ()
main = runResourceT
     $ parseFile def "scores.xml"
    $$ toScores
    =$ getAverages
    =$ CL.mapM_ (lift . print)

data Score = Score
    { scoreName  :: Text
    , scoreValue :: Double
    }
    deriving Show

toScores :: Monad m => Conduit Event m Score
toScores =
    CL.mapMaybe go
  where
    go (EventBeginElement "result" attrs) = do
        [ContentText name] <- lookup "name" attrs
        [ContentText scoreT] <- lookup "score" attrs
        score <- readMay $ unpack scoreT
        Just $ Score name score
    go _ = Nothing

getAverages :: Monad m => Conduit Score m Score
getAverages =
    start
  where
    start = CL.peek >>= maybe (return ()) (loop . scoreName)

    loop name = do
        avg <- CC.takeWhile (\s -> scoreName s == name)
           =$= CL.map scoreValue
           =$= computeAverage
        yield $ Score name avg
        start

data Average n = Average
    { averageTotal :: !n
    , averageCount :: !n
    }
instance Num n => Monoid (Average n) where
    mempty = Average 0 0
    mappend (Average a x) (Average b y) = Average (a + b) (x + y)

toAverage :: Num n => n -> Average n
toAverage = flip Average 1

computeAverage :: (Monad m, Fractional n) => Consumer n m n
computeAverage = do
    Average total count <- CL.foldMap toAverage
    return $ total / count