{-# LANGUAGE OverloadedStrings #-}
module Streaming.Osm.Internal.Parser where
import Control.Applicative (optional, (<|>))
import Control.Monad (void)
import qualified Data.Attoparsec.ByteString as A
import qualified Data.Attoparsec.Internal.Types as T
import Data.Bits
import qualified Data.ByteString as B
import Data.List (zipWith4, zipWith7)
import qualified Data.Map.Strict as M
import qualified Data.Vector as V
import Streaming.Osm.Internal.Util
import Streaming.Osm.Types
header :: A.Parser ()
header = do
void $ A.take 4
void $ A.word8 0x0a
void $ A.anyWord8
void $ A.string "OSMHeader" <|> A.string "OSMData"
void $ optional (A.word8 0x12 *> varint >>= advance)
void (A.word8 0x18 *> varint)
advance :: Int -> A.Parser ()
advance n = T.Parser $ \t pos more _lose suc -> suc t (pos + T.Pos n) more ()
{-# INLINE advance #-}
blob :: A.Parser Blob
blob = Blob <$> A.eitherP dcmp comp
where dcmp = A.word8 0x0a *> varint >>= A.take
comp = (,) <$> (A.word8 0x10 *> varint) <*> (A.word8 0x1a *> varint >>= A.take)
block :: A.Parser Block
block = do
st <- A.word8 0x0a *> varint *> stringTable
ns <- (A.word8 0x12 *> varint *> A.many1' (node st)) <|> pure []
dn <- (A.word8 0x12 *> varint *> dense st) <|> pure []
ws <- (A.word8 0x12 *> varint *> A.many1' (way st)) <|> pure []
rs <- (A.word8 0x12 *> varint *> A.many1' (relation st)) <|> pure []
void $ optional (A.word8 0x88 *> A.word8 0x01 *> varint)
void $ optional (A.word8 0x90 *> A.word8 0x01 *> varint)
void $ optional (A.word8 0x98 *> A.word8 0x01 *> varint)
void $ optional (A.word8 0xa0 *> A.word8 0x01 *> varint)
pure $ Block (ns ++ dn) ws rs
stringTable :: A.Parser (V.Vector B.ByteString)
stringTable = V.fromList <$> A.many1' (A.word8 0x0a *> varint >>= A.take)
node :: V.Vector B.ByteString -> A.Parser Node
node st = do
void $ A.word8 0x0a *> varint
i <- unzig <$> (A.word8 0x08 *> varint)
ks <- packed <$> (A.word8 0x12 *> varint >>= A.take) <|> pure []
vs <- packed <$> (A.word8 0x1a *> varint >>= A.take) <|> pure []
oi <- optional (A.word8 0x22 *> varint *> info i st)
lat <- unzig <$> (A.word8 0x40 *> varint)
lon <- unzig <$> (A.word8 0x48 *> varint)
let ts = M.fromList $ zip (map (V.unsafeIndex st) ks) (map (V.unsafeIndex st) vs)
pure $ Node (offset lat) (offset lon) oi ts
dense :: V.Vector B.ByteString -> A.Parser [Node]
dense st = do
void $ A.word8 0x12 *> varint
ids <- ints <$> (A.word8 0x0a *> varint >>= A.take)
ifs <- (A.word8 0x2a *> varint *> denseInfo ids st) <|> pure (repeat Nothing)
lts <- ints <$> (A.word8 0x42 *> varint >>= A.take)
lns <- ints <$> (A.word8 0x4a *> varint >>= A.take)
kvs <- (packed <$> (A.word8 0x52 *> varint >>= A.take)) <|> pure []
pure $ zipWith4 f lts lns ifs (denseTags st kvs)
where f lat lon inf ts = Node (offset lat) (offset lon) inf ts
denseTags :: V.Vector B.ByteString -> [Int] -> [M.Map B.ByteString B.ByteString]
denseTags _ [] = repeat M.empty
denseTags st kvs = map (M.fromList . map (both (V.unsafeIndex st)) . pairs) $ breakOn0 kvs
way :: V.Vector B.ByteString -> A.Parser Way
way st = do
void $ A.word8 0x1a *> varint
i <- A.word8 0x08 *> varint
ks <- packed <$> (A.word8 0x12 *> varint >>= A.take) <|> pure []
vs <- packed <$> (A.word8 0x1a *> varint >>= A.take) <|> pure []
oi <- optional (A.word8 0x22 *> varint *> info i st)
ns <- ints <$> (A.word8 0x42 *> varint >>= A.take)
let ts = M.fromList $ zip (map (V.unsafeIndex st) ks) (map (V.unsafeIndex st) vs)
pure $ Way ns oi ts
relation :: V.Vector B.ByteString -> A.Parser Relation
relation st = do
void $ A.word8 0x22 *> varint
i <- A.word8 0x08 *> varint
ks <- packed <$> (A.word8 0x12 *> varint >>= A.take) <|> pure []
vs <- packed <$> (A.word8 0x1a *> varint >>= A.take) <|> pure []
oi <- optional (A.word8 0x22 *> varint *> info i st)
rs <- packed <$> (A.word8 0x42 *> varint >>= A.take) <|> pure []
ms <- map unzig . packed <$> (A.word8 0x4a *> varint >>= A.take) <|> pure []
ts <- map memtype . packed <$> (A.word8 0x52 *> varint >>= A.take) <|> pure []
let tags = M.fromList $ zip (map (V.unsafeIndex st) ks) (map (V.unsafeIndex st) vs)
mems = zipWith3 Member ms ts $ map (V.unsafeIndex st) rs
pure $ Relation mems oi tags
info :: Int -> V.Vector B.ByteString -> A.Parser Info
info i st = do
vn <- (A.word8 0x08 *> varint) <|> pure (-1)
ts <- optional (A.word8 0x10 *> varint)
cs <- optional (A.word8 0x18 *> varint)
ui <- optional (A.word8 0x20 *> varint)
us <- optional (V.unsafeIndex st <$> (A.word8 0x28 *> varint))
vi <- (>>= booly) <$> optional (A.word8 0x30 *> varint)
pure $ Info (fromIntegral i) vn (toffset <$> ts) cs ui us vi
denseInfo :: [Int] -> V.Vector B.ByteString -> A.Parser [Maybe Info]
denseInfo nis st = do
ver <- packed <$> (A.word8 0x0a *> varint >>= A.take)
tms <- map Just . ints <$> (A.word8 0x12 *> varint >>= A.take)
chs <- map Just . ints <$> (A.word8 0x1a *> varint >>= A.take)
uid <- map Just . ints <$> (A.word8 0x22 *> varint >>= A.take)
uss <- map (st V.!?) . ints <$> (A.word8 0x2a *> varint >>= A.take)
vis <- (map booly . packed <$> (A.word8 0x32 *> varint >>= A.take)) <|> pure (repeat $ Just True)
pure $ zipWith7 f nis ver tms chs uid uss vis
where f ni vs tm ch ui us vi = Just $ Info ni vs (toffset <$> tm) ch ui us vi
varint :: A.Parser Int
varint = foldBytes <$> A.takeWhile (`testBit` 7) <*> A.anyWord8
{-# INLINE varint #-}
packed :: B.ByteString -> [Int]
packed bs = either (const []) id $ A.parseOnly (A.many1' varint) bs
ints :: B.ByteString -> [Int]
ints = undelta . map unzig . packed
offset :: Int -> Double
offset coord = 0.000000001 * fromIntegral (100 * coord)
toffset :: Int -> Int
toffset time = 1000 * time
booly :: Int -> Maybe Bool
booly 0 = Just False
booly 1 = Just True
booly _ = Nothing