module Data.Conduit.OSM
(
sourceFileOSM
, conduitNWR
, conduitNodes
, conduitWays
, conduitRelations
, conduitOSM
)
where
import Data.Conduit (Consumer, Conduit, Source, ConduitM, (=$))
import Data.Text (Text, unpack, toLower)
import Data.XML.Types (Event, Name)
import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.Trans.Resource (MonadResource)
import Control.Exception (ErrorCall(..))
import Text.Read (readMaybe)
import Text.XML.Stream.Parse (AttrParser, tagName, requireAttr, attr
, ignoreAttrs, many, many', manyYield, manyYield'
, parseFile, def, choose, tagIgnoreAttrs)
import Data.Conduit.OSM.Types
sourceFileOSM :: MonadResource m => FilePath -> Source m OSM
sourceFileOSM path = parseFile def path =$ conduitOSM
conduitOSM :: MonadThrow m => Conduit Event m OSM
conduitOSM = manyYield parseOSM
conduitNodes :: MonadThrow m => Conduit Event m Node
conduitNodes = loopConduit $ tagIgnoreAttrs "osm" $ manyYield' parseNode
conduitWays :: MonadThrow m => Conduit Event m Way
conduitWays = loopConduit $ tagIgnoreAttrs "osm" $ manyYield' parseWay
conduitRelations :: MonadThrow m => Conduit Event m Relation
conduitRelations = loopConduit $ tagIgnoreAttrs "osm" $ manyYield' parseRelation
conduitNWR :: MonadThrow m => Conduit Event m NWRWrap
conduitNWR = loopConduit $ tagIgnoreAttrs "osm" $ manyYield' parseNWR
loopConduit :: Monad m => ConduitM i o m (Maybe ()) -> Conduit i m o
loopConduit cond = loop
where
loop = cond >>= maybe (return ()) (const loop)
parseOSM :: MonadThrow m => Consumer Event m (Maybe OSM)
parseOSM = tagName "osm" tagParser $ \cont -> cont <$> parseBounds <*> many parseNode <*> many parseWay <*> many' parseRelation
where
tagParser = OSM <$> requireAttrRead "version" <*> attr "generator" <* ignoreAttrs
parseNWR :: MonadThrow m => Consumer Event m (Maybe NWRWrap)
parseNWR = choose [ fmap N <$> parseNode
, fmap W <$> parseWay
, fmap R <$> parseRelation ]
parseNode :: MonadThrow m => Consumer Event m (Maybe Node)
parseNode = tagName "node" tagParser $ \cont -> cont <$> many' parseTag
where
tagParser = (\f latitude longitude tagz -> Node latitude longitude (f tagz))
<$> nwrCommonParser
<*> requireAttrRead "lat"
<*> requireAttrRead "lon"
<* ignoreAttrs
parseWay :: MonadThrow m => Consumer Event m (Maybe Way)
parseWay = tagName "way" (nwrCommonParser <* ignoreAttrs)
$ \cont -> Way <$> many parseNd <*> (cont <$> many' parseTag)
parseRelation :: MonadThrow m => Consumer Event m (Maybe Relation)
parseRelation = tagName "relation" (nwrCommonParser <* ignoreAttrs)
$ \cont -> Relation <$> many parseMember <*> (cont <$> many' parseTag)
parseMember :: MonadThrow m => Consumer Event m (Maybe Member)
parseMember = tagName "member" tagParser return
where
tagParser = Member <$> (requireAttr "type" >>= readNWRType)
<*> requireAttr "ref"
<*> attr "role"
<* ignoreAttrs
parseNd :: MonadThrow m => Consumer Event m (Maybe Nd)
parseNd = tagName "nd" (Nd <$> requireAttr "ref" <* ignoreAttrs) return
parseTag :: MonadThrow m => Consumer Event m (Maybe Tag)
parseTag = tagName "tag" tagParser (return . Tag)
where
tagParser = (,) <$> requireAttr "k" <*> requireAttr "v" <* ignoreAttrs
parseBounds :: MonadThrow m => Consumer Event m (Maybe Bounds)
parseBounds = tagName "bounds" tagParser return
where
tagParser = Bounds <$> requireAttrRead "minlat"
<*> requireAttrRead "minlon"
<*> requireAttrRead "maxlat"
<*> requireAttrRead "maxlon"
nwrCommonParser :: AttrParser ([Tag] -> NWRCommon)
nwrCommonParser = NWRCommon <$> requireAttr "id"
<*> fmap (>>= readBool) (attr "visible")
<*> attr "chageset"
<*> attr "timestamp"
<*> attr "user"
readNWRType :: Text -> AttrParser NWR
readNWRType a =
case toLower a of
"node" -> return NWRn
"relation" -> return NWRr
"way" -> return NWRw
_ -> throwM $ ErrorCall "unknown type in <member>"
fromStr :: Read a => Text -> Maybe a
fromStr = readMaybe . unpack
requireAttrRead :: Read a => Name -> AttrParser a
requireAttrRead str = requireAttr str
>>= maybe (throwM $ ErrorCall "Could not parse attribute value") return . fromStr
readBool :: Text -> Maybe Bool
readBool a
| toLower a == "true" = Just True
| toLower a == "false" = Just False
| otherwise = Nothing