osm-xml-dvb.hs

{-# LANGUAGE OverloadedStrings, RankNTypes #-}
module Main where

import Data.Conduit
import Data.Conduit.Binary
import qualified Data.Conduit.List as CL
import Data.XML.Types
import Text.XML.Stream.Parse
import System.IO
import qualified Data.Text as T
import qualified Data.HashMap.Strict as HM
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as LBC


type OSMNode = Object

main :: IO ()
main =
  sourceHandle stdin $=
  parseBytes def $$
  processDocument =$=
  CL.filter (not . HM.null) =$=
  (do yield "["
      CL.concatMap (LBC.toChunks . (`LBC.append` ",\n") . encode)
      yield "null]\n"
  ) =$=
  sinkHandle stdout
  
processDocument :: Monad m => Conduit Event m OSMNode
processDocument =
  do mEv <- await
     case mEv of
       Nothing ->
         -- EOF
         return ()
       Just (EventBeginElement "osm" _) ->
         CL.sequence processNodes
       Just _ ->
         -- Ignore
         processDocument
  
  
processNodes :: Monad m => Consumer Event m OSMNode
processNodes =
  do mEv <- await
     case mEv of
       Nothing ->
         -- EOF
         return HM.empty
       Just (EventBeginElement name attrs) ->
         do let getKey m ev =
                  case ev of
                    EventBeginElement "tag" attrs' ->
                      let getAttr name' =
                            maybe T.empty contentsToText $
                            name' `lookup` attrs'
                      in HM.insert (getAttr "k") (String $ getAttr "v") m
                    _ ->
                      m
                ev' = EventEndElement name
            evs <- sinkUntil (== ev')
            let m = HM.fromList $
                    ("kind", String $ nameLocalName name) :
                    map (\(name, cs) ->
                          (nameLocalName name,
                           String $ contentsToText cs
                          )
                        ) attrs
                m' = foldl getKey m evs
            return m'
       Just _ ->
         -- Ignore
         processNodes

contentsToText :: [Content] -> T.Text
contentsToText = 
  T.concat . 
  map (\c ->
        case c of
          ContentText t -> t
          _ -> T.empty
      )
                            
sinkUntil :: Monad m => (a -> Bool) -> Consumer a m [a]
sinkUntil cond =
  do mA <- await
     case mA of
       Just a | not (cond a) ->
          fmap (a :) $ sinkUntil cond
       _ ->
         return []