vectortiles 1.0.0 → 1.1.0

raw patch · 8 files changed

+709/−698 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Geography/VectorTile.hs +18/−315
• Geography/VectorTile/Geometry.hs +1/−170
• Geography/VectorTile/Protobuf.hs +473/−0
• Geography/VectorTile/Raw.hs +0/−142
• Geography/VectorTile/VectorTile.hs +145/−0
• bench/Bench.hs +7/−7
• test/Test.hs +60/−60
• vectortiles.cabal +5/−4

@@ -1,7 +1,3 @@-{-# LANGUAGE StrictData #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveGeneric #-}- -- | -- Module    : Geography.VectorTile -- Copyright : (c) Azavea, 2016@@ -18,336 +14,43 @@ -- -- The order in which to explore the modules of this library is as follows: ----- 1. "Geography.VectorTile" (here)+-- 1. "Geography.VectorTile.VectorTile" -- 2. "Geography.VectorTile.Geometry"--- 3. "Geography.VectorTile.Raw"+-- 3. "Geography.VectorTile.Protobuf" -- -- == Usage ----- This library reads and writes strict `ByteString`s. Given some legal+-- This library reads and writes strict `ByteString`s. By importing this module,+-- you use the default protobuf backend. Given some legal -- VectorTile file called @roads.mvt@: -- -- > import qualified Data.ByteString as BS -- > import           Data.Text (Text) -- > import           Geography.VectorTile--- > import qualified Geography.VectorTile.Raw as R -- > -- > -- | Read in raw protobuf data and decode it into a high-level type. -- > roads :: IO (Either Text VectorTile) -- > roads = do -- >   mvt <- BS.readFile "roads.mvt"--- >   pure $ R.decode mvt >>= tile+-- >   pure $ decode mvt >>= tile -- -- Or encode a `VectorTile` back into a `ByteString`: -- -- > roadsBytes :: VectorTile -> BS.ByteString--- > roadsBytes = R.encode . untile+-- > roadsBytes = encode . untile + module Geography.VectorTile-  ( -- * Types-    VectorTile(..)-  , Layer(..)-  , Feature(..)-  , Val(..)-    -- * Protobuf Conversions-    -- ** From Protobuf-    -- | Generally the `tile` function is the only one needed here. Usage:-    ---    -- > import qualified Geography.VectorTile.Raw as R-    -- >-    -- > R.decode someBytes >>= tile-    ---    -- Note that since the "Data.ProtocolBuffers" library does not handle default-    -- values, we handle those specifically defined in /vector_tile.proto/-    -- explicitely here. See:-    ---    -- https://github.com/mapbox/vector-tile-spec/blob/master/2.1/vector_tile.proto-  , tile-  , layer-  , features-  , value-    -- ** To Protobuf-    -- | To convert from high-level data back into a form that can be encoded-    -- into raw protobuf bytes, use:-    ---    -- > import qualified Geography.VectorTile.Raw as R-    -- >-    -- > R.encode $ untile someTile-    ---    -- This is a pure process and will succeed every time.-  , untile-  , unlayer-  , unfeature-  , unval-    -- * Lenses-    -- | This section can be safely ignored if one isn't concerned with lenses.-    -- Otherwise, see the following for a good primer on Haskell lenses:-    -- http://hackage.haskell.org/package/lens-tutorial-1.0.1/docs/Control-Lens-Tutorial.html-    ---    -- These lenses are written in a generic way to avoid taking a dependency-    -- on one of the lens libraries.-  , layers-  , version-  , name-  , points-  , linestrings-  , polygons-  , extent-  , featureId-  , metadata-  , geometries+  ( -- * High-level Types+    module Geography.VectorTile.VectorTile+  , -- * Protobuf Backend+    -- ** Conversions+    PB.tile+  , PB.untile+  -- ** ByteString Encoding / Decoding+  , PB.decode+  , PB.encode   ) where -import           Control.Applicative ((<|>))-import           Control.DeepSeq (NFData)-import           Data.Foldable (foldrM)-import           Data.Int-import           Data.List (nub, elemIndex)-import qualified Data.Map.Lazy as M-import           Data.Maybe (fromJust)-import           Data.Monoid-import           Data.ProtocolBuffers-import qualified Data.Set as S-import           Data.Text (Text,pack)-import qualified Data.Vector as V-import           Data.Word-import           GHC.Generics (Generic)-import           Geography.VectorTile.Geometry-import qualified Geography.VectorTile.Raw as R-import           Geography.VectorTile.Util-------{- Types -}---- | A high-level representation of a Vector Tile. At its simplest, a tile--- is just a list of `Layer`s.------ There is potential to implement `_layers` as a `M.Map`, with its String-based--- `name` as a key.-newtype VectorTile = VectorTile { _layers :: V.Vector Layer } deriving (Eq,Show,Generic)---- | > Lens' VectorTile (Vector Layer)-layers :: Functor f => (V.Vector Layer -> f (V.Vector Layer)) -> VectorTile -> f VectorTile-layers f v = VectorTile <$> f (_layers v)-{-# INLINE layers #-}--instance NFData VectorTile---- | A layer, which could contain any number of `Feature`s of any `Geometry` type.--- This codec only respects the canonical three `Geometry` types, and we split--- them here explicitely to allow for more fine-grained access to each type.-data Layer = Layer { _version :: Int  -- ^ The version of the spec we follow. Should always be 2.-                   , _name :: Text-                   , _points :: V.Vector (Feature Point)-                   , _linestrings :: V.Vector (Feature LineString)-                   , _polygons :: V.Vector (Feature Polygon)-                   , _extent :: Int  -- ^ Default: 4096-                   } deriving (Eq,Show,Generic)---- | > Lens' Layer Int-version :: Functor f => (Layer -> f Int) -> Layer -> f Layer-version f l = fmap (\v -> l { _version = v }) $ f l-{-# INLINE version #-}---- | > Lens' Layer Text-name :: Functor f => (Layer -> f Text) -> Layer -> f Layer-name f l = fmap (\v -> l { _name = v }) $ f l-{-# INLINE name #-}---- | > Lens' Layer (Vector (Feature Point))-points :: Functor f => (Layer -> f (V.Vector (Feature Point))) -> Layer -> f Layer-points f l = fmap (\v -> l { _points = v }) $ f l-{-# INLINE points #-}---- | > Lens' Layer (Vector (Feature LineString)))-linestrings :: Functor f => (Layer -> f (V.Vector (Feature LineString))) -> Layer -> f Layer-linestrings f l = fmap (\v -> l { _linestrings = v }) $ f l-{-# INLINE linestrings #-}---- | > Lens' Layer (Vector (Feature Polygon)))-polygons :: Functor f => (Layer -> f (V.Vector (Feature Polygon))) -> Layer -> f Layer-polygons f l = fmap (\v -> l { _polygons = v }) $ f l-{-# INLINE polygons #-}---- | > Lens' Layer Int-extent :: Functor f => (Layer -> f Int) -> Layer -> f Layer-extent f l = fmap (\v -> l { _extent = v }) $ f l-{-# INLINE extent #-}--instance NFData Layer---- | A geographic feature. Features are a set of geometries that share--- some common theme:------ * Points: schools, gas station locations, etc.--- * LineStrings: Roads, power lines, rivers, etc.--- * Polygons: Buildings, water bodies, etc.------ Where, for instance, all school locations may be stored as a single--- `Feature`, and no `Point` within that `Feature` would represent anything--- else.------ Note: Each `Geometry` type and their /Multi*/ counterpart are considered--- the same thing, as a `V.Vector` of that `Geometry`.-data Feature g = Feature { _featureId :: Int  -- ^ Default: 0-                         , _metadata :: M.Map Text Val-                         , _geometries :: V.Vector g } deriving (Eq,Show,Generic)---- | > Lens' (Feature g) Int-featureId :: Functor f => (Feature g -> f Int) -> Feature g -> f (Feature g)-featureId f l = fmap (\v -> l { _featureId = v }) $ f l-{-# INLINE featureId #-}---- | > Lens' (Feature g) (Map Text Val)-metadata :: Functor f => (Feature g -> f (M.Map Text Val)) -> Feature g -> f (Feature g)-metadata f l = fmap (\v -> l { _metadata = v }) $ f l-{-# INLINE metadata #-}---- | > Lens' (Feature g) (Vector g)-geometries :: Functor f => (Feature g -> f (V.Vector g)) -> Feature g -> f (Feature g)-geometries f l = fmap (\v -> l { _geometries = v }) $ f l-{-# INLINE geometries #-}--instance NFData g => NFData (Feature g)---- | Legal Metadata /Value/ types. Note that `S64` are Z-encoded automatically--- by the underlying "Data.ProtocolBuffers" library.-data Val = St Text | Fl Float | Do Double | I64 Int64 | W64 Word64 | S64 Int64 | B Bool-         deriving (Eq,Show,Generic)--instance NFData Val--{- FROM PROTOBUF -}---- | Convert a `R.RawVectorTile` of parsed protobuf data into a useable--- `VectorTile`.-tile :: R.RawVectorTile -> Either Text VectorTile-tile = fmap (VectorTile . V.fromList) . mapM layer . getField . R.layers---- | Convert a single `R.RawLayer` of parsed protobuf data into a useable--- `Layer`.-layer :: R.RawLayer -> Either Text Layer-layer l = do-  (ps,ls,polys) <- features keys vals . getField $ R.features l-  pure Layer { _version = fromIntegral . getField $ R.version l-             , _name = getField $ R.name l-             , _points = ps-             , _linestrings = ls-             , _polygons = polys-             , _extent = maybe 4096 fromIntegral (getField $ R.extent l) }-  where keys = getField $ R.keys l-        vals = getField $ R.values l---- | Convert a list of `R.RawFeature`s of parsed protobuf data into `V.Vector`s--- of each of the three legal `Geometry` types.------ The long type signature is due to two things:------ 1. `Feature`s are polymorphic at the high level, but not at the parsed--- protobuf mid-level. In a @[RawFeature]@, there are features of points,--- linestrings, and polygons all mixed together.------ 2. `R.RawLayer`s and `R.RawFeature`s--- are strongly coupled at the protobuf level. In order to achieve higher--- compression ratios, `R.RawLayer`s contain all metadata in key/value lists--- to be shared across their `R.RawFeature`s, while those `R.RawFeature`s store only--- indices into those lists. As a result, this function needs to be passed--- those key/value lists from the parent `R.RawLayer`, and a more isomorphic:------ > feature :: Geometry g => RawFeature -> Either Text (Feature g)------ is not possible.-features :: [Text] -> [R.RawVal] -> [R.RawFeature]-  -> Either Text (V.Vector (Feature Point), V.Vector (Feature LineString), V.Vector (Feature Polygon))-features _ _ [] = Left "VectorTile.features: `[R.RawFeature]` empty"-features keys vals fs = (,,) <$> ps <*> ls <*> polys-  where -- (_:ps':ls':polys':_) = groupBy sameGeom $ sortOn geomBias fs  -- ok ok ok-        ps = foldrM f V.empty $ filter (\fe -> getField (R.geom fe) == Just R.Point) fs-        ls = foldrM f V.empty $ filter (\fe -> getField (R.geom fe) == Just R.LineString) fs-        polys = foldrM f V.empty $ filter (\fe -> getField (R.geom fe) == Just R.Polygon) fs--        f :: Geometry g => R.RawFeature -> V.Vector (Feature g) -> Either Text (V.Vector (Feature g))-        f x acc = do-          geos <- commands (getField $ R.geometries x) >>= fromCommands-          meta <- getMeta keys vals . getField $ R.tags x-          pure $ Feature { _featureId = maybe 0 fromIntegral . getField $ R.featureId x-                         , _metadata = meta-                         , _geometries = geos-                         } `V.cons` acc---- | Convert a `R.RawVal` parsed from protobuf data into a useable--- `Val`. The higher-level `Val` type better expresses the mutual exclusivity--- of the /Value/ types.-value :: R.RawVal -> Either Text Val-value v = mtoe "Value decode: No legal Value type offered" $ fmap St (getField $ R.string v)-  <|> fmap Fl  (getField $ R.float v)-  <|> fmap Do  (getField $ R.double v)-  <|> fmap I64 (getField $ R.int64 v)-  <|> fmap W64 (getField $ R.uint64 v)-  <|> fmap (\(Signed n) -> S64 n) (getField $ R.sint v)-  <|> fmap B   (getField $ R.bool v)--getMeta :: [Text] -> [R.RawVal] -> [Word32] -> Either Text (M.Map Text Val)-getMeta keys vals tags = do-  kv <- map (both fromIntegral) <$> pairs tags-  foldrM (\(k,v) acc -> (\v' -> M.insert (keys !! k) v' acc) <$> (value $ vals !! v)) M.empty kv--{- TO PROTOBUF -}---- | Encode a high-level `VectorTile` back into its mid-level--- `R.RawVectorTile` form.-untile :: VectorTile -> R.RawVectorTile-untile vt = R.RawVectorTile { R.layers = putField . V.toList . V.map unlayer $ _layers vt }---- Has to get back all its metadata from its features--- | Encode a high-level `Layer` back into its mid-level `R.RawLayer` form.-unlayer :: Layer -> R.RawLayer-unlayer l = R.RawLayer { R.version = putField . fromIntegral $ _version l-                       , R.name = putField $ _name l-                       , R.features = putField fs-                       , R.keys = putField ks-                       , R.values = putField $ map unval vs-                       , R.extent = putField . Just . fromIntegral $ _extent l }-  where (ks,vs) = totalMeta (_points l) (_linestrings l) (_polygons l)-        fs = V.toList $ V.concat [ V.map (unfeature ks vs) (_points l)-                                 , V.map (unfeature ks vs) (_linestrings l)-                                 , V.map (unfeature ks vs) (_polygons l) ]--totalMeta :: V.Vector (Feature Point) -> V.Vector (Feature LineString) -> V.Vector (Feature Polygon) -> ([Text], [Val])-totalMeta ps ls polys = (keys, vals)-  where keys = S.toList . S.unions $ f ps <> f ls <> f polys-        vals = nub . concat $ g ps <> g ls <> g polys  -- `nub` is O(n^2)-        f = V.foldr (\x acc -> M.keysSet (_metadata x) : acc) []-        g = V.foldr (\x acc -> M.elems (_metadata x) : acc) []---- | Encode a high-level `Feature` back into its mid-level `R.RawFeature` form.-unfeature :: R.Geom g => [Text] -> [Val] -> Feature g -> R.RawFeature-unfeature keys vals fe = R.RawFeature-                         { R.featureId = putField . Just . fromIntegral $ _featureId fe-                         , R.tags = putField $ tags fe-                         , R.geom = putField . Just . R.geomType . V.head $ _geometries fe-                         , R.geometries = putField . uncommands . toCommands $ _geometries fe-                         }-  where tags = unpairs . map f . M.toList . _metadata-        f (k,v) = both (fromIntegral . fromJust) (k `elemIndex` keys, v `elemIndex` vals)---- | Encode a high-level `Val` back into its mid-level `R.RawVal` form.-unval :: Val -> R.RawVal-unval (St v)  = def { R.string = putField $ Just v }-unval (Fl v)  = def { R.float = putField $ Just v }-unval (Do v)  = def { R.double = putField $ Just v }-unval (I64 v) = def { R.int64 = putField $ Just v }-unval (W64 v) = def { R.uint64 = putField $ Just v }-unval (S64 v) = def { R.sint = putField . Just $ Signed v }-unval (B v)   = def { R.bool = putField $ Just v }---- | A `R.RawVal` with every entry set to `Nothing`.-def :: R.RawVal-def = R.RawVal { R.string = putField Nothing-               , R.float  = putField Nothing-               , R.double = putField Nothing-               , R.int64  = putField Nothing-               , R.uint64 = putField Nothing-               , R.sint   = putField Nothing-               , R.bool   = putField Nothing }+import Geography.VectorTile.VectorTile+import qualified Geography.VectorTile.Protobuf as PB

@@ -17,37 +17,19 @@ module Geography.VectorTile.Geometry   ( -- * Geometries     -- ** Types-    Geometry(..)-  , Point(..)+    Point, x, y   , LineString(..)   , Polygon(..)   -- ** Operations   , area   , surveyor   , distance-  -- * Commands-  , Command(..)-  , commands-  , uncommands-   -- * Z-Encoding-  , zig-  , unzig   ) where  import           Control.DeepSeq (NFData)-import           Control.Monad.Trans.State.Lazy-import           Data.Bits-import           Data.Foldable (foldlM)-import           Data.Int-import           Data.Monoid-import           Data.Text (Text)-import qualified Data.Text as T import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U-import           Data.Word import           GHC.Generics (Generic)-import           Geography.VectorTile.Util-import           Text.Printf.TH  --- @@ -102,154 +84,3 @@ distance p1 p2 = sqrt . fromIntegral $ dx ^ 2 + dy ^ 2   where dx = x p1 - x p2         dy = y p1 - y p2---- | Any classical type considered a GIS "geometry". These must be able--- to convert between an encodable list of `Command`s.-class Geometry g where-  fromCommands :: [Command] -> Either Text (V.Vector g)-  toCommands :: V.Vector g -> [Command]---- | A valid `R.Feature` of points must contain a single `MoveTo` command--- with a count greater than 0.-instance Geometry Point where-  fromCommands (MoveTo ps : []) = Right . U.convert $ evalState (U.mapM expand ps) (0,0)-  fromCommands (c:_) = Left $ [st|Invalid command found in Point feature: %s|] (show c)-  fromCommands [] = Left "No points given!"--  -- | A multipoint geometry must reduce to a single `MoveTo` command.-  toCommands ps = [MoveTo $ evalState (U.mapM collapse $ U.convert ps) (0,0)]---- | A valid `R.Feature` of linestrings must contain pairs of:------ A `MoveTo` with a count of 1, followed by one `LineTo` command with--- a count greater than 0.-instance Geometry LineString where-  fromCommands cs = evalState (f cs) (0,0)-    where f (MoveTo p : LineTo ps : rs) = fmap . V.cons <$> ls <*> f rs-            where ls = LineString <$> U.mapM expand (p <> ps)-          f [] = pure $ Right V.empty-          f _  = pure $ Left "LineString decode: Invalid command sequence given."--  toCommands ls = concat $ evalState (mapM f ls) (0,0)-    where f (LineString ps) = do-            curr <- get-            let (h,t) = (U.head ps, U.tail ps)-            put h-            l <- U.mapM collapse t-            pure [MoveTo $ U.singleton (x h - x curr, y h - y curr), LineTo l]---- | A valid `R.Feature` of polygons must contain at least one sequence of:------ An Exterior Ring, followed by 0 or more Interior Rings.------ Any Ring must have a `MoveTo` with a count of 1, a single `LineTo`--- with a count of at least 2, and a single `ClosePath` command.------ Performs no sanity checks for malformed Interior Rings.-instance Geometry Polygon where-  fromCommands cs = do-    ps <- evalState (f cs) (0,0)-    let (h,t) = (V.head ps, V.tail ps)-        (ps',p') = runState (foldlM g V.empty t) h-    pure $ V.snoc ps' p'  -- Include the last Exterior Ring worked on.-    where f (MoveTo p : LineTo ps : ClosePath : rs) = do-            curr <- get-            let h = U.head p-                here = (x h + x curr, y h + y curr)-            po <- flip U.snoc here <$> U.mapM expand (U.cons h ps)-            fmap (V.cons (Polygon po V.empty)) <$> f rs-          f [] = pure $ Right V.empty-          f _  = pure . Left $ [st|Polygon decode: Invalid command sequence given: %s|] (show cs)-          g acc p | area p > 0 = do  -- New external rings.-                      curr <- get-                      put p-                      pure $ V.snoc acc curr-                  | otherwise = do  -- Next internal ring.-                      modify (\s -> s { inner = V.snoc (inner s) p })-                      pure acc--  toCommands ps = concat $ evalState (mapM f ps) (0,0)-    where f (Polygon p i) = do-            curr <- get-            let (h,t) = (U.head p, U.tail $ U.init p)  -- Exclude the final point.-            put h-            l <- U.mapM collapse t-            let cs = [MoveTo $ U.singleton (x h - x curr, y h - y curr), LineTo l, ClosePath]-            concat . V.cons cs <$> mapM f i---- | The possible commands, and the values they hold.-data Command = MoveTo (U.Vector (Int,Int))-             | LineTo (U.Vector (Int,Int))-             | ClosePath deriving (Eq,Show)---- | Z-encode a 64-bit Int.-zig :: Int -> Word32-zig n = fromIntegral $ shift n 1 `xor` shift n (-63)---- | Decode a Z-encoded Word32 into a 64-bit Int.-unzig :: Word32 -> Int-unzig n = fromIntegral (fromIntegral unzigged :: Int32)-  where unzigged = shift n (-1) `xor` negate (n .&. 1)---- | Divide a "Command Integer" into its @(Command,Count)@.-parseCmd :: Word32 -> Either T.Text (Int,Int)-parseCmd n = case (cmd,count) of-  (1,m) -> Right $ both fromIntegral (1,m)-  (2,m) -> Right $ both fromIntegral (2,m)-  (7,1) -> Right (7,1)-  (7,m) -> Left $ "ClosePath was given a parameter count: " <> T.pack (show m)-  (m,_) -> Left $ [st|Invalid command integer %d found in: %X|] m n-  where cmd = n .&. 7-        count = shift n (-3)---- | Recombine a Command ID and parameter count into a Command Integer.-unparseCmd :: (Int,Int) -> Word32-unparseCmd (cmd,count) = fromIntegral $ (cmd .&. 7) .|. shift count 3---- | Attempt to parse a list of Command/Parameter integers, as defined here:------ https://github.com/mapbox/vector-tile-spec/tree/master/2.1#43-geometry-encoding-commands :: [Word32] -> Either T.Text [Command]-commands [] = Right []-commands (n:ns) = parseCmd n >>= f-  where f (1,count) = do-          mts <- MoveTo . U.fromList . map (both unzig) <$> pairs (take (count * 2) ns)-          (mts :) <$> commands (drop (count * 2) ns)-        f (2,count) = do-          mts <- LineTo . U.fromList . map (both unzig) <$> pairs (take (count * 2) ns)-          (mts :) <$> commands (drop (count * 2) ns)-        f (7,_) = (ClosePath :) <$> commands ns-        f _ = Left "Sentinel: You should never see this."---- | Convert a list of parsed `Command`s back into their original Command--- and Z-encoded Parameter integer forms.-uncommands :: [Command] -> [Word32]-uncommands = U.toList . U.concat . map f-  where f (MoveTo ps) = (U.cons $ unparseCmd (1, U.length ps)) $ params ps-        f (LineTo ls) = (U.cons $ unparseCmd (2, U.length ls)) $ params ls-        f ClosePath = U.singleton $ unparseCmd (7,1)  -- ClosePath, Count 1.--{- UTIL -}---- | Transform a `V.Vector` of `Point`s into one of Z-encoded Parameter ints.-params :: U.Vector (Int,Int) -> U.Vector Word32-params = U.foldr (\(a,b) acc -> U.cons (zig a) $ U.cons (zig b) acc) U.empty---- | Expand a pair of diffs from some reference point into that--- of a `Point` value. The reference point is moved to our new `Point`.-expand :: (Int,Int) -> State (Int,Int) Point-expand p = do-  curr <- get-  let here = (x p + x curr, y p + y curr)-  put here-  pure here---- | Collapse a given `Point` into a pair of diffs, relative to--- the previous point in the sequence. The reference point is moved--- to the `Point` given.-collapse :: Point -> State (Int,Int) (Int,Int)-collapse p = do-  curr <- get-  let diff = (x p - x curr, y p - y curr)-  put p-  pure diff

@@ -0,0 +1,473 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module    : Geography.VectorTile.Raw+-- Copyright : (c) Azavea, 2016+-- License   : Apache 2+-- Maintainer: Colin Woodbury <cwoodbury@azavea.com>+--+-- Raw Vector Tile data is stored as binary protobuf data.+-- This module reads and writes raw protobuf ByteStrings between a data type+-- which closely matches the current Mapbox vector tile spec defined here:+-- https://github.com/mapbox/vector-tile-spec/blob/master/2.1/vector_tile.proto+--+-- As this raw version of the data is hard to work with, in practice we convert+-- to a more canonical Haskell type for further processing.+-- See `Geography.VectorTile` for the user-friendly version.+--+-- Please import this module @qualified@ to avoid namespace clashes:+--+-- > import qualified Geography.VectorTile.Protobuf as PB++module Geography.VectorTile.Protobuf+  ( -- * Types+    RawVectorTile(..)+  , RawLayer(..)+  , RawVal(..)+  , RawFeature(..)+  , GeomType(..)+  , ProtobufGeom(..)+    -- * Commands+  , Command(..)+  , commands+  , uncommands+   -- * Z-Encoding+  , zig+  , unzig+    -- * Protobuf Conversions+    -- ** From Protobuf+    -- | Generally the `tile` function is the only one needed here. Usage:+    --+    -- > import qualified Geography.VectorTile.Protobuf as PB+    -- >+    -- > PB.decode someBytes >>= PB.tile+    --+    -- Note that since the "Data.ProtocolBuffers" library does not handle default+    -- values, we handle those specifically defined in /vector_tile.proto/+    -- explicitely here. See:+    --+    -- https://github.com/mapbox/vector-tile-spec/blob/master/2.1/vector_tile.proto+  , tile+  , layer+  , features+  , value+    -- ** To Protobuf+    -- | To convert from high-level data back into a form that can be encoded+    -- into raw protobuf bytes, use:+    --+    -- > import qualified Geography.VectorTile.Protobuf as PB+    -- >+    -- > PB.encode $ PB.untile someTile+    --+    -- This is a pure process and will succeed every time.+  , untile+  , unlayer+  , unfeature+  , unval+    -- * ByteString Encoding / Decoding+  , decode+  , encode+  , decodeIO+  , encodeIO+  ) where++import           Control.Applicative ((<|>))+import           Control.DeepSeq (NFData)+import           Control.Monad.Trans.State.Lazy+import           Data.Bits+import qualified Data.ByteString as BS+import           Data.Foldable (foldrM, foldlM)+import           Data.Int+import           Data.List (nub, elemIndex)+import qualified Data.Map.Lazy as M+import           Data.Maybe (fromJust)+import           Data.Monoid+import           Data.ProtocolBuffers hiding (decode, encode)+import           Data.Serialize.Get+import           Data.Serialize.Put+import qualified Data.Set as S+import           Data.Text (Text, pack)+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import           Data.Word+import           GHC.Generics (Generic)+import qualified Geography.VectorTile.VectorTile as VT+import qualified Geography.VectorTile.Geometry as G+import           Geography.VectorTile.Util+import           Text.Printf.TH++---++-- | A list of `RawLayer`s.+data RawVectorTile = RawVectorTile { _layers :: Repeated 3 (Message RawLayer) }+                   deriving (Generic,Show,Eq)++instance Encode RawVectorTile+instance Decode RawVectorTile+instance NFData RawVectorTile++-- | Contains a pseudo-map of metadata, to be shared across all `RawFeature`s+-- of this `RawLayer`.+data RawLayer = RawLayer { _version :: Required 15 (Value Word32)+                         , _name :: Required 1 (Value Text)+                         , _features :: Repeated 2 (Message RawFeature)+                         , _keys :: Repeated 3 (Value Text)+                         , _values :: Repeated 4 (Message RawVal)+                         , _extent :: Optional 5 (Value Word32)+                         } deriving (Generic,Show,Eq)++instance Encode RawLayer+instance Decode RawLayer+instance NFData RawLayer++-- | The /Value/ types of metadata fields.+data RawVal = RawVal { _string :: Optional 1 (Value Text)+                     , _float :: Optional 2 (Value Float)+                     , _double :: Optional 3 (Value Double)+                     , _int64 :: Optional 4 (Value Int64)+                     , _uint64 :: Optional 5 (Value Word64)+                     , _sint :: Optional 6 (Value (Signed Int64))  -- ^ Z-encoded.+                     , _bool :: Optional 7 (Value Bool)+                     } deriving (Generic,Show,Eq)++instance Encode RawVal+instance Decode RawVal+instance NFData RawVal++-- | A set of geometries unified by some theme.+data RawFeature = RawFeature { _featureId :: Optional 1 (Value Word64)+                             , _tags :: Packed 2 (Value Word32)+                             , _geom :: Optional 3 (Enumeration GeomType)+                             , _geometries :: Packed 4 (Value Word32)+                             } deriving (Generic,Show,Eq)++instance Encode RawFeature+instance Decode RawFeature+instance NFData RawFeature++-- | The four potential Geometry types. The spec allows for encoders to set+-- `Unknown` as the type, but our decoder ignores these.+data GeomType = Unknown | Point | LineString | Polygon+              deriving (Generic,Enum,Show,Eq)++instance Encode GeomType+instance Decode GeomType+instance NFData GeomType++-- | Any classical type considered a GIS "geometry". These must be able+-- to convert between an encodable list of `Command`s.+class ProtobufGeom g where+  fromCommands :: [Command] -> Either Text (V.Vector g)+  toCommands :: V.Vector g -> [Command]+  geomType :: g -> GeomType++-- | A valid `RawFeature` of points must contain a single `MoveTo` command+-- with a count greater than 0.+instance ProtobufGeom G.Point where+  fromCommands (MoveTo ps : []) = Right . U.convert $ evalState (U.mapM expand ps) (0,0)+  fromCommands (c:_) = Left $ [st|Invalid command found in Point feature: %s|] (show c)+  fromCommands [] = Left "No points given!"++  -- | A multipoint geometry must reduce to a single `MoveTo` command.+  toCommands ps = [MoveTo $ evalState (U.mapM collapse $ U.convert ps) (0,0)]++  geomType _ = Point++-- | A valid `RawFeature` of linestrings must contain pairs of:+--+-- A `MoveTo` with a count of 1, followed by one `LineTo` command with+-- a count greater than 0.+instance ProtobufGeom G.LineString where+  fromCommands cs = evalState (f cs) (0,0)+    where f (MoveTo p : LineTo ps : rs) = fmap . V.cons <$> ls <*> f rs+            where ls = G.LineString <$> U.mapM expand (p <> ps)+          f [] = pure $ Right V.empty+          f _  = pure $ Left "LineString decode: Invalid command sequence given."++  toCommands ls = concat $ evalState (mapM f ls) (0,0)+    where f (G.LineString ps) = do+            curr <- get+            let (h,t) = (U.head ps, U.tail ps)+            put h+            l <- U.mapM collapse t+            pure [MoveTo $ U.singleton (G.x h - G.x curr, G.y h - G.y curr), LineTo l]++  geomType _ = LineString++-- | A valid `RawFeature` of polygons must contain at least one sequence of:+--+-- An Exterior Ring, followed by 0 or more Interior Rings.+--+-- Any Ring must have a `MoveTo` with a count of 1, a single `LineTo`+-- with a count of at least 2, and a single `ClosePath` command.+--+-- Performs no sanity checks for malformed Interior Rings.+instance ProtobufGeom G.Polygon where+  fromCommands cs = do+    ps <- evalState (f cs) (0,0)+    let (h,t) = (V.head ps, V.tail ps)+        (ps',p') = runState (foldlM g V.empty t) h+    pure $ V.snoc ps' p'  -- Include the last Exterior Ring worked on.+    where f (MoveTo p : LineTo ps : ClosePath : rs) = do+            curr <- get+            let h = U.head p+                here = (G.x h + G.x curr, G.y h + G.y curr)+            po <- flip U.snoc here <$> U.mapM expand (U.cons h ps)+            fmap (V.cons (G.Polygon po V.empty)) <$> f rs+          f [] = pure $ Right V.empty+          f _  = pure . Left $ [st|Polygon decode: Invalid command sequence given: %s|] (show cs)+          g acc p | G.area p > 0 = do  -- New external rings.+                      curr <- get+                      put p+                      pure $ V.snoc acc curr+                  | otherwise = do  -- Next internal ring.+                      modify (\s -> s { G.inner = V.snoc (G.inner s) p })+                      pure acc++  toCommands ps = concat $ evalState (mapM f ps) (0,0)+    where f (G.Polygon p i) = do+            curr <- get+            let (h,t) = (U.head p, U.tail $ U.init p)  -- Exclude the final point.+            put h+            l <- U.mapM collapse t+            let cs = [MoveTo $ U.singleton (G.x h - G.x curr, G.y h - G.y curr), LineTo l, ClosePath]+            concat . V.cons cs <$> mapM f i++  geomType _ = Polygon++-- | The possible commands, and the values they hold.+data Command = MoveTo (U.Vector (Int,Int))+             | LineTo (U.Vector (Int,Int))+             | ClosePath deriving (Eq,Show)++-- | Z-encode a 64-bit Int.+zig :: Int -> Word32+zig n = fromIntegral $ shift n 1 `xor` shift n (-63)++-- | Decode a Z-encoded Word32 into a 64-bit Int.+unzig :: Word32 -> Int+unzig n = fromIntegral (fromIntegral unzigged :: Int32)+  where unzigged = shift n (-1) `xor` negate (n .&. 1)++-- | Divide a "Command Integer" into its @(Command,Count)@.+parseCmd :: Word32 -> Either Text (Int,Int)+parseCmd n = case (cmd,count) of+  (1,m) -> Right $ both fromIntegral (1,m)+  (2,m) -> Right $ both fromIntegral (2,m)+  (7,1) -> Right (7,1)+  (7,m) -> Left $ "ClosePath was given a parameter count: " <> pack (show m)+  (m,_) -> Left $ [st|Invalid command integer %d found in: %X|] m n+  where cmd = n .&. 7+        count = shift n (-3)++-- | Recombine a Command ID and parameter count into a Command Integer.+unparseCmd :: (Int,Int) -> Word32+unparseCmd (cmd,count) = fromIntegral $ (cmd .&. 7) .|. shift count 3++-- | Attempt to parse a list of Command/Parameter integers, as defined here:+--+-- https://github.com/mapbox/vector-tile-spec/tree/master/2.1#43-geometry-encoding+commands :: [Word32] -> Either Text [Command]+commands [] = Right []+commands (n:ns) = parseCmd n >>= f+  where f (1,count) = do+          mts <- MoveTo . U.fromList . map (both unzig) <$> pairs (take (count * 2) ns)+          (mts :) <$> commands (drop (count * 2) ns)+        f (2,count) = do+          mts <- LineTo . U.fromList . map (both unzig) <$> pairs (take (count * 2) ns)+          (mts :) <$> commands (drop (count * 2) ns)+        f (7,_) = (ClosePath :) <$> commands ns+        f _ = Left "Sentinel: You should never see this."++-- | Convert a list of parsed `Command`s back into their original Command+-- and Z-encoded Parameter integer forms.+uncommands :: [Command] -> [Word32]+uncommands = U.toList . U.concat . map f+  where f (MoveTo ps) = (U.cons $ unparseCmd (1, U.length ps)) $ params ps+        f (LineTo ls) = (U.cons $ unparseCmd (2, U.length ls)) $ params ls+        f ClosePath = U.singleton $ unparseCmd (7,1)  -- ClosePath, Count 1.++-- | Attempt to decode a `BS.ByteString` of raw protobuf data into a mid-level+-- representation of a `RawVectorTile`.+decode :: BS.ByteString -> Either Text RawVectorTile+decode bs = case runGet decodeMessage bs of+  Left e -> Left $ pack e+  Right vt -> Right vt++-- | Encode a mid-level representation of a `RawVectorTile` into raw protobuf data.+encode :: RawVectorTile -> BS.ByteString+encode = runPut . encodeMessage++-- | Given a filename, attempt to decode bytes read from that file.+decodeIO :: FilePath -> IO (Either Text RawVectorTile)+decodeIO = fmap decode . BS.readFile++-- | Write a mid-level representation of a `RawVectorTile` to a file as raw+-- protobuf data.+encodeIO :: RawVectorTile -> FilePath -> IO ()+encodeIO vt fp = BS.writeFile fp $ encode vt++{- FROM PROTOBUF -}++-- | Convert a `RawVectorTile` of parsed protobuf data into a useable+-- `VectorTile`.+tile :: RawVectorTile -> Either Text VT.VectorTile+tile = fmap (VT.VectorTile . V.fromList) . mapM layer . getField . _layers++-- | Convert a single `RawLayer` of parsed protobuf data into a useable+-- `Layer`.+layer :: RawLayer -> Either Text VT.Layer+layer l = do+  (ps,ls,polys) <- features keys vals . getField $ _features l+  pure VT.Layer { VT._version = fromIntegral . getField $ _version l+                , VT._name = getField $ _name l+                , VT._points = ps+                , VT._linestrings = ls+                , VT._polygons = polys+                , VT._extent = maybe 4096 fromIntegral (getField $ _extent l) }+  where keys = getField $ _keys l+        vals = getField $ _values l++-- | Convert a list of `RawFeature`s of parsed protobuf data into `V.Vector`s+-- of each of the three legal `ProtobufGeom` types.+--+-- The long type signature is due to two things:+--+-- 1. `Feature`s are polymorphic at the high level, but not at the parsed+-- protobuf mid-level. In a @[RawFeature]@, there are features of points,+-- linestrings, and polygons all mixed together.+--+-- 2. `RawLayer`s and `RawFeature`s+-- are strongly coupled at the protobuf level. In order to achieve higher+-- compression ratios, `RawLayer`s contain all metadata in key/value lists+-- to be shared across their `RawFeature`s, while those `RawFeature`s store only+-- indices into those lists. As a result, this function needs to be passed+-- those key/value lists from the parent `RawLayer`, and a more isomorphic:+--+-- > feature :: ProtobufGeom g => RawFeature -> Either Text (Feature g)+--+-- is not possible.+features :: [Text] -> [RawVal] -> [RawFeature]+  -> Either Text (V.Vector (VT.Feature G.Point), V.Vector (VT.Feature G.LineString), V.Vector (VT.Feature G.Polygon))+features _ _ [] = Left "VectorTile.features: `[RawFeature]` empty"+features keys vals fs = (,,) <$> ps <*> ls <*> polys+  where -- (_:ps':ls':polys':_) = groupBy sameGeom $ sortOn geomBias fs  -- ok ok ok+        ps = foldrM f V.empty $ filter (\fe -> getField (_geom fe) == Just Point) fs+        ls = foldrM f V.empty $ filter (\fe -> getField (_geom fe) == Just LineString) fs+        polys = foldrM f V.empty $ filter (\fe -> getField (_geom fe) == Just Polygon) fs++        f :: ProtobufGeom g => RawFeature -> V.Vector (VT.Feature g) -> Either Text (V.Vector (VT.Feature g))+        f x acc = do+          geos <- commands (getField $ _geometries x) >>= fromCommands+          meta <- getMeta keys vals . getField $ _tags x+          pure $ VT.Feature { VT._featureId = maybe 0 fromIntegral . getField $ _featureId x+                            , VT._metadata = meta+                            , VT._geometries = geos+                            } `V.cons` acc++-- | Convert a `RawVal` parsed from protobuf data into a useable+-- `Val`. The higher-level `Val` type better expresses the mutual exclusivity+-- of the /Value/ types.+value :: RawVal -> Either Text VT.Val+value v = mtoe "Value decode: No legal Value type offered" $ fmap VT.St (getField $ _string v)+  <|> fmap VT.Fl  (getField $ _float v)+  <|> fmap VT.Do  (getField $ _double v)+  <|> fmap VT.I64 (getField $ _int64 v)+  <|> fmap VT.W64 (getField $ _uint64 v)+  <|> fmap (\(Signed n) -> VT.S64 n) (getField $ _sint v)+  <|> fmap VT.B   (getField $ _bool v)++getMeta :: [Text] -> [RawVal] -> [Word32] -> Either Text (M.Map Text VT.Val)+getMeta keys vals tags = do+  kv <- map (both fromIntegral) <$> pairs tags+  foldrM (\(k,v) acc -> (\v' -> M.insert (keys !! k) v' acc) <$> (value $ vals !! v)) M.empty kv++{- TO PROTOBUF -}++-- | Encode a high-level `VectorTile` back into its mid-level+-- `RawVectorTile` form.+untile :: VT.VectorTile -> RawVectorTile+untile vt = RawVectorTile { _layers = putField . V.toList . V.map unlayer $ VT._layers vt }++-- Has to get back all its metadata from its features+-- | Encode a high-level `Layer` back into its mid-level `RawLayer` form.+unlayer :: VT.Layer -> RawLayer+unlayer l = RawLayer { _version = putField . fromIntegral $ VT._version l+                     , _name = putField $ VT._name l+                     , _features = putField fs+                     , _keys = putField ks+                     , _values = putField $ map unval vs+                     , _extent = putField . Just . fromIntegral $ VT._extent l }+  where (ks,vs) = totalMeta (VT._points l) (VT._linestrings l) (VT._polygons l)+        fs = V.toList $ V.concat [ V.map (unfeature ks vs) (VT._points l)+                                 , V.map (unfeature ks vs) (VT._linestrings l)+                                 , V.map (unfeature ks vs) (VT._polygons l) ]++totalMeta :: V.Vector (VT.Feature G.Point) -> V.Vector (VT.Feature G.LineString) -> V.Vector (VT.Feature G.Polygon) -> ([Text], [VT.Val])+totalMeta ps ls polys = (keys, vals)+  where keys = S.toList . S.unions $ f ps <> f ls <> f polys+        vals = nub . concat $ g ps <> g ls <> g polys  -- `nub` is O(n^2)+        f = V.foldr (\x acc -> M.keysSet (VT._metadata x) : acc) []+        g = V.foldr (\x acc -> M.elems (VT._metadata x) : acc) []++-- | Encode a high-level `Feature` back into its mid-level `RawFeature` form.+unfeature :: ProtobufGeom g => [Text] -> [VT.Val] -> VT.Feature g -> RawFeature+unfeature keys vals fe = RawFeature+                         { _featureId = putField . Just . fromIntegral $ VT._featureId fe+                         , _tags = putField $ tags fe+                         , _geom = putField . Just . geomType . V.head $ VT._geometries fe+                         , _geometries = putField . uncommands . toCommands $ VT._geometries fe+                         }+  where tags = unpairs . map f . M.toList . VT._metadata+        f (k,v) = both (fromIntegral . fromJust) (k `elemIndex` keys, v `elemIndex` vals)++-- | Encode a high-level `Val` back into its mid-level `RawVal` form.+unval :: VT.Val -> RawVal+unval (VT.St v)  = def { _string = putField $ Just v }+unval (VT.Fl v)  = def { _float = putField $ Just v }+unval (VT.Do v)  = def { _double = putField $ Just v }+unval (VT.I64 v) = def { _int64 = putField $ Just v }+unval (VT.W64 v) = def { _uint64 = putField $ Just v }+unval (VT.S64 v) = def { _sint = putField . Just $ Signed v }+unval (VT.B v)   = def { _bool = putField $ Just v }++{- UTIL -}++-- | A `RawVal` with every entry set to `Nothing`.+def :: RawVal+def = RawVal { _string = putField Nothing+             , _float  = putField Nothing+             , _double = putField Nothing+             , _int64  = putField Nothing+             , _uint64 = putField Nothing+             , _sint   = putField Nothing+             , _bool   = putField Nothing }++-- | Transform a `V.Vector` of `Point`s into one of Z-encoded Parameter ints.+params :: U.Vector (Int,Int) -> U.Vector Word32+params = U.foldr (\(a,b) acc -> U.cons (zig a) $ U.cons (zig b) acc) U.empty++-- | Expand a pair of diffs from some reference point into that+-- of a `Point` value. The reference point is moved to our new `Point`.+expand :: (Int,Int) -> State (Int,Int) G.Point+expand p = do+  curr <- get+  let here = (G.x p + G.x curr, G.y p + G.y curr)+  put here+  pure here++-- | Collapse a given `Point` into a pair of diffs, relative to+-- the previous point in the sequence. The reference point is moved+-- to the `Point` given.+collapse :: G.Point -> State (Int,Int) (Int,Int)+collapse p = do+  curr <- get+  let diff = (G.x p - G.x curr, G.y p - G.y curr)+  put p+  pure diff

@@ -1,142 +0,0 @@-{-# LANGUAGE StrictData #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}---- |--- Module    : Geography.VectorTile.Raw--- Copyright : (c) Azavea, 2016--- License   : Apache 2--- Maintainer: Colin Woodbury <cwoodbury@azavea.com>------ Raw Vector Tile data is stored as binary protobuf data.--- This module reads and writes raw protobuf ByteStrings between a data type--- which closely matches the current Mapbox vector tile spec defined here:--- https://github.com/mapbox/vector-tile-spec/blob/master/2.1/vector_tile.proto------ As this raw version of the data is hard to work with, in practice we convert--- to a more canonical Haskell type for further processing.--- See `Geography.VectorTile` for the user-friendly version.------ Please import this module @qualified@ to avoid namespace clashes:------ > import qualified Geography.VectorTile.Raw as R--module Geography.VectorTile.Raw-  ( -- * Types-    RawVectorTile(..)-  , RawLayer(..)-  , RawVal(..)-  , RawFeature(..)-  , GeomType(..)-  , Geom(..)-    -- * Encoding / Decoding-  , decode-  , encode-  , decodeIO-  , encodeIO-  ) where--import           Control.DeepSeq (NFData)-import qualified Data.ByteString as BS-import           Data.Int-import           Data.ProtocolBuffers hiding (decode, encode)-import           Data.Serialize.Get-import           Data.Serialize.Put-import           Data.Text (Text, pack)-import           Data.Word-import           GHC.Generics (Generic)-import qualified Geography.VectorTile.Geometry as G--------- | A list of `RawLayer`s.-data RawVectorTile = RawVectorTile { layers :: Repeated 3 (Message RawLayer) }-                   deriving (Generic,Show,Eq)--instance Encode RawVectorTile-instance Decode RawVectorTile-instance NFData RawVectorTile---- | Contains a pseudo-map of metadata, to be shared across all `RawFeature`s--- of this `RawLayer`.-data RawLayer = RawLayer { version :: Required 15 (Value Word32)-                         , name :: Required 1 (Value Text)-                         , features :: Repeated 2 (Message RawFeature)-                         , keys :: Repeated 3 (Value Text)-                         , values :: Repeated 4 (Message RawVal)-                         , extent :: Optional 5 (Value Word32)-                         } deriving (Generic,Show,Eq)--instance Encode RawLayer-instance Decode RawLayer-instance NFData RawLayer---- | The /Value/ types of metadata fields.-data RawVal = RawVal { string :: Optional 1 (Value Text)-                     , float :: Optional 2 (Value Float)-                     , double :: Optional 3 (Value Double)-                     , int64 :: Optional 4 (Value Int64)-                     , uint64 :: Optional 5 (Value Word64)-                     , sint :: Optional 6 (Value (Signed Int64))  -- ^ Z-encoded.-                     , bool :: Optional 7 (Value Bool)-                     } deriving (Generic,Show,Eq)--instance Encode RawVal-instance Decode RawVal-instance NFData RawVal---- | A set of geometries unified by some theme.-data RawFeature = RawFeature { featureId :: Optional 1 (Value Word64)-                             , tags :: Packed 2 (Value Word32)-                             , geom :: Optional 3 (Enumeration GeomType)-                             , geometries :: Packed 4 (Value Word32)-                             } deriving (Generic,Show,Eq)--instance Encode RawFeature-instance Decode RawFeature-instance NFData RawFeature---- | The four potential Geometry types. The spec allows for encoders to set--- `Unknown` as the type, but our decoder ignores these.-data GeomType = Unknown | Point | LineString | Polygon-              deriving (Generic,Enum,Show,Eq)--instance Encode GeomType-instance Decode GeomType-instance NFData GeomType---- | A `Geom` can recover its `GeomType` from its `G.Geometry` instance.-class G.Geometry g => Geom g where-  -- | The @g@ here is a proxy argument to discern the type.-  geomType :: g -> GeomType--instance Geom G.Point where-  geomType _ = Point--instance Geom G.LineString where-  geomType _ = LineString--instance Geom G.Polygon where-  geomType _ = Polygon---- | Attempt to decode a `BS.ByteString` of raw protobuf data into a mid-level--- representation of a `RawVectorTile`.-decode :: BS.ByteString -> Either Text RawVectorTile-decode bs = case runGet decodeMessage bs of-  Left e -> Left $ pack e-  Right vt -> Right vt---- | Encode a mid-level representation of a `RawVectorTile` into raw protobuf data.-encode :: RawVectorTile -> BS.ByteString-encode = runPut . encodeMessage---- | Given a filename, attempt to decode bytes read from that file.-decodeIO :: FilePath -> IO (Either Text RawVectorTile)-decodeIO = fmap decode . BS.readFile---- | Write a mid-level representation of a `RawVectorTile` to a file as raw--- protobuf data.-encodeIO :: RawVectorTile -> FilePath -> IO ()-encodeIO vt fp = BS.writeFile fp $ encode vt

@@ -0,0 +1,145 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}++-- |+-- Module    : Geography.VectorTile.VectorTile+-- Copyright : (c) Azavea, 2016+-- License   : Apache 2+-- Maintainer: Colin Woodbury <cwoodbury@azavea.com>+--+-- High-level types for representing Vector Tiles.++module Geography.VectorTile.VectorTile+  ( -- * Types+    VectorTile(..)+  , Layer(..)+  , Feature(..)+  , Val(..)+    -- * Lenses+    -- | This section can be safely ignored if one isn't concerned with lenses.+    -- Otherwise, see the following for a good primer on Haskell lenses:+    -- http://hackage.haskell.org/package/lens-tutorial-1.0.1/docs/Control-Lens-Tutorial.html+    --+    -- These lenses are written in a generic way to avoid taking a dependency+    -- on one of the lens libraries.+  , layers+  , version+  , name+  , points+  , linestrings+  , polygons+  , extent+  , featureId+  , metadata+  , geometries+  ) where++import           Control.DeepSeq (NFData)+import           Data.Int+import qualified Data.Map.Lazy as M+import           Data.Text (Text)+import qualified Data.Vector as V+import           Data.Word+import           GHC.Generics (Generic)+import           Geography.VectorTile.Geometry++---++-- | A high-level representation of a Vector Tile. At its simplest, a tile+-- is just a list of `Layer`s.+--+-- There is potential to implement `_layers` as a `M.Map`, with its String-based+-- `name` as a key.+newtype VectorTile = VectorTile { _layers :: V.Vector Layer } deriving (Eq,Show,Generic)++-- | > Lens' VectorTile (Vector Layer)+layers :: Functor f => (V.Vector Layer -> f (V.Vector Layer)) -> VectorTile -> f VectorTile+layers f v = VectorTile <$> f (_layers v)+{-# INLINE layers #-}++instance NFData VectorTile++-- | A layer, which could contain any number of `Feature`s of any `Geometry` type.+-- This codec only respects the canonical three `Geometry` types, and we split+-- them here explicitely to allow for more fine-grained access to each type.+data Layer = Layer { _version :: Int  -- ^ The version of the spec we follow. Should always be 2.+                   , _name :: Text+                   , _points :: V.Vector (Feature Point)+                   , _linestrings :: V.Vector (Feature LineString)+                   , _polygons :: V.Vector (Feature Polygon)+                   , _extent :: Int  -- ^ Default: 4096+                   } deriving (Eq,Show,Generic)++-- | > Lens' Layer Int+version :: Functor f => (Int -> f Int) -> Layer -> f Layer+version f l = fmap (\v -> l { _version = v }) $ f (_version l)+{-# INLINE version #-}++-- | > Lens' Layer Text+name :: Functor f => (Text -> f Text) -> Layer -> f Layer+name f l = fmap (\v -> l { _name = v }) $ f (_name l)+{-# INLINE name #-}++-- | > Lens' Layer (Vector (Feature Point))+points :: Functor f => (V.Vector (Feature Point) -> f (V.Vector (Feature Point))) -> Layer -> f Layer+points f l = fmap (\v -> l { _points = v }) $ f (_points l)+{-# INLINE points #-}++-- | > Lens' Layer (Vector (Feature LineString)))+linestrings :: Functor f => (V.Vector (Feature LineString) -> f (V.Vector (Feature LineString))) -> Layer -> f Layer+linestrings f l = fmap (\v -> l { _linestrings = v }) $ f (_linestrings l)+{-# INLINE linestrings #-}++-- | > Lens' Layer (Vector (Feature Polygon)))+polygons :: Functor f => (V.Vector (Feature Polygon) -> f (V.Vector (Feature Polygon))) -> Layer -> f Layer+polygons f l = fmap (\v -> l { _polygons = v }) $ f (_polygons l)+{-# INLINE polygons #-}++-- | > Lens' Layer Int+extent :: Functor f => (Int -> f Int) -> Layer -> f Layer+extent f l = fmap (\v -> l { _extent = v }) $ f (_extent l)+{-# INLINE extent #-}++instance NFData Layer++-- | A geographic feature. Features are a set of geometries that share+-- some common theme:+--+-- * Points: schools, gas station locations, etc.+-- * LineStrings: Roads, power lines, rivers, etc.+-- * Polygons: Buildings, water bodies, etc.+--+-- Where, for instance, all school locations may be stored as a single+-- `Feature`, and no `Point` within that `Feature` would represent anything+-- else.+--+-- Note: Each `Geometry` type and their /Multi*/ counterpart are considered+-- the same thing, as a `V.Vector` of that `Geometry`.+data Feature g = Feature { _featureId :: Int  -- ^ Default: 0+                         , _metadata :: M.Map Text Val+                         , _geometries :: V.Vector g } deriving (Eq,Show,Generic)++-- | > Lens' (Feature g) Int+featureId :: Functor f => (Int -> f Int) -> Feature g -> f (Feature g)+featureId f l = fmap (\v -> l { _featureId = v }) $ f (_featureId l)+{-# INLINE featureId #-}++-- | > Lens' (Feature g) (Map Text Val)+metadata :: Functor f => (M.Map Text Val -> f (M.Map Text Val)) -> Feature g -> f (Feature g)+metadata f l = fmap (\v -> l { _metadata = v }) $ f (_metadata l)+{-# INLINE metadata #-}++-- | > Lens' (Feature g) (Vector g)+geometries :: Functor f => (V.Vector g -> f (V.Vector g)) -> Feature g -> f (Feature g)+geometries f l = fmap (\v -> l { _geometries = v }) $ f (_geometries l)+{-# INLINE geometries #-}++instance NFData g => NFData (Feature g)++-- | Legal Metadata /Value/ types. Note that `S64` are Z-encoded automatically+-- by the underlying "Data.ProtocolBuffers" library.+data Val = St Text | Fl Float | Do Double | I64 Int64 | W64 Word64 | S64 Int64 | B Bool+         deriving (Eq,Show,Generic)++instance NFData Val

@@ -4,7 +4,7 @@ import           Criterion.Main import qualified Data.ByteString as BS import           Geography.VectorTile-import qualified Geography.VectorTile.Raw as R+import qualified Geography.VectorTile.Protobuf as R  --- @@ -13,9 +13,9 @@   op <- BS.readFile "test/onepoint.mvt"   ls <- BS.readFile "test/linestring.mvt"   rd <- BS.readFile "test/roads.mvt"-  let op' = fromRight $ R.decode op >>= tile-      ls' = fromRight $ R.decode ls >>= tile-      rd' = fromRight $ R.decode rd >>= tile+  let op' = fromRight $ R.decode op >>= R.tile+      ls' = fromRight $ R.decode ls >>= R.tile+      rd' = fromRight $ R.decode rd >>= R.tile   defaultMain [ bgroup "Decoding"                 [ bgroup "onepoint.mvt" $ decodes op                 , bgroup "linestring.mvt" $ decodes ls@@ -30,12 +30,12 @@  decodes :: BS.ByteString -> [Benchmark] decodes bs = [ bench "Raw.VectorTile" $ nf R.decode bs-             , bench "VectorTile" $ nf (R.decode >=> tile) bs+             , bench "VectorTile" $ nf (R.decode >=> R.tile) bs              ]  encodes :: VectorTile -> [Benchmark]-encodes vt = [ bench "Raw.VectorTile" $ nf untile vt-             , bench "ByteString" $ nf (R.encode . untile) vt+encodes vt = [ bench "Raw.VectorTile" $ nf R.untile vt+             , bench "ByteString" $ nf (R.encode . R.untile) vt              ]  fromRight :: Either a b -> b

@@ -9,7 +9,7 @@ import           Data.ProtocolBuffers import           Data.Serialize.Get import           Data.Serialize.Put-import qualified Geography.VectorTile.Raw as R+import qualified Geography.VectorTile.Protobuf as R import           Test.Tasty import           Test.Tasty.HUnit import           Geography.VectorTile@@ -90,7 +90,7 @@ tileDecode :: BS.ByteString -> Assertion tileDecode bs = case decodeIt bs of   Left e -> assertFailure e-  Right t -> assert . isRight $ tile t+  Right t -> assert . isRight $ R.tile t  fromRaw :: BS.ByteString -> Assertion fromRaw vt = case decodeIt vt of@@ -124,116 +124,116 @@ rawTest = decodeIt <$> BS.readFile "onepoint.mvt"  encodeIso :: R.RawVectorTile -> Assertion-encodeIso vt = assert . isRight . fmap untile $ tile vt+encodeIso vt = assert . isRight . fmap R.untile $ R.tile vt  testTile :: R.RawVectorTile testTile = R.RawVectorTile $ putField [l]-  where l = R.RawLayer { R.version = putField 2-                       , R.name = putField "testlayer"-                       , R.features = putField [f]-                       , R.keys = putField ["somekey"]-                       , R.values = putField [v]-                       , R.extent = putField $ Just 4096+  where l = R.RawLayer { R._version = putField 2+                       , R._name = putField "testlayer"+                       , R._features = putField [f]+                       , R._keys = putField ["somekey"]+                       , R._values = putField [v]+                       , R._extent = putField $ Just 4096                        }-        f = R.RawFeature { R.featureId = putField $ Just 0-                         , R.tags = putField [0,0]-                         , R.geom = putField $ Just R.Point-                         , R.geometries = putField [9, 50, 34]  -- MoveTo(+25,+17)+        f = R.RawFeature { R._featureId = putField $ Just 0+                         , R._tags = putField [0,0]+                         , R._geom = putField $ Just R.Point+                         , R._geometries = putField [9, 50, 34]  -- MoveTo(+25,+17)                          }-        v = R.RawVal { R.string = putField $ Just "Some Value"-                     , R.float = putField Nothing-                     , R.double = putField Nothing-                     , R.int64 = putField Nothing-                     , R.uint64 = putField Nothing-                     , R.sint = putField Nothing-                     , R.bool = putField Nothing+        v = R.RawVal { R._string = putField $ Just "Some Value"+                     , R._float = putField Nothing+                     , R._double = putField Nothing+                     , R._int64 = putField Nothing+                     , R._uint64 = putField Nothing+                     , R._sint = putField Nothing+                     , R._bool = putField Nothing                      }  -- | Correct decoding of `onepoint.mvt` onePoint :: R.RawVectorTile onePoint = R.RawVectorTile $ putField [l]-  where l = R.RawLayer { R.version = putField 1-                       , R.name = putField "OnePoint"-                       , R.features = putField [f]-                       , R.keys = putField []-                       , R.values = putField []-                       , R.extent = putField $ Just 4096+  where l = R.RawLayer { R._version = putField 1+                       , R._name = putField "OnePoint"+                       , R._features = putField [f]+                       , R._keys = putField []+                       , R._values = putField []+                       , R._extent = putField $ Just 4096                        }-        f = R.RawFeature { R.featureId = putField Nothing-                         , R.tags = putField []-                         , R.geom = putField $ Just R.Point-                         , R.geometries = putField [9, 10, 10]  -- MoveTo(+5,+5)+        f = R.RawFeature { R._featureId = putField Nothing+                         , R._tags = putField []+                         , R._geom = putField $ Just R.Point+                         , R._geometries = putField [9, 10, 10]  -- MoveTo(+5,+5)                          }  -- | Correct decoding of `linestring.mvt` oneLineString :: R.RawVectorTile oneLineString = R.RawVectorTile $ putField [l]-  where l = R.RawLayer { R.version = putField 1-                       , R.name = putField "OneLineString"-                       , R.features = putField [f]-                       , R.keys = putField []-                       , R.values = putField []-                       , R.extent = putField $ Just 4096+  where l = R.RawLayer { R._version = putField 1+                       , R._name = putField "OneLineString"+                       , R._features = putField [f]+                       , R._keys = putField []+                       , R._values = putField []+                       , R._extent = putField $ Just 4096                        }-        f = R.RawFeature { R.featureId = putField Nothing-                         , R.tags = putField []-                         , R.geom = putField $ Just R.LineString+        f = R.RawFeature { R._featureId = putField Nothing+                         , R._tags = putField []+                         , R._geom = putField $ Just R.LineString                          -- MoveTo(+5,+5), LineTo(+1195,+1195)-                         , R.geometries = putField [9, 10, 10, 10, 2390, 2390]+                         , R._geometries = putField [9, 10, 10, 10, 2390, 2390]                          }  -- | Correct decoding of `polygon.mvt` onePolygon :: R.RawVectorTile onePolygon = R.RawVectorTile $ putField [l]-  where l = R.RawLayer { R.version = putField 1-                       , R.name = putField "OnePolygon"-                       , R.features = putField [f]-                       , R.keys = putField []-                       , R.values = putField []-                       , R.extent = putField $ Just 4096+  where l = R.RawLayer { R._version = putField 1+                       , R._name = putField "OnePolygon"+                       , R._features = putField [f]+                       , R._keys = putField []+                       , R._values = putField []+                       , R._extent = putField $ Just 4096                        }-        f = R.RawFeature { R.featureId = putField Nothing-                         , R.tags = putField []-                         , R.geom = putField $ Just R.Polygon+        f = R.RawFeature { R._featureId = putField Nothing+                         , R._tags = putField []+                         , R._geom = putField $ Just R.Polygon                          -- MoveTo(+2,+2), LineTo(+3,+2), LineTo(-3,+2), ClosePath-                         , R.geometries = putField [9, 4, 4, 18, 6, 4, 5, 4, 15]+                         , R._geometries = putField [9, 4, 4, 18, 6, 4, 5, 4, 15]                          }  zencoding :: Assertion-zencoding = assert $ map (unzig . zig) vs @?= vs+zencoding = assert $ map (R.unzig . R.zig) vs @?= vs   where vs = [0,(-1),1,(-2),2,(-3),3]  commandTest :: Assertion-commandTest = assert $ commands [9,4,4,18,6,4,5,4,15] @?= Right-  [ MoveTo $ U.singleton (2,2)-  , LineTo $ U.fromList [(3,2),(-3,2)]-  , ClosePath ]+commandTest = assert $ R.commands [9,4,4,18,6,4,5,4,15] @?= Right+  [ R.MoveTo $ U.singleton (2,2)+  , R.LineTo $ U.fromList [(3,2),(-3,2)]+  , R.ClosePath ]  commandIso :: Assertion-commandIso = assert $ (uncommands . fromRight $ commands cs) @?= cs+commandIso = assert $ (R.uncommands . fromRight $ R.commands cs) @?= cs   where cs = [9,4,4,18,6,4,5,4,15]  pointIso :: Assertion pointIso = cs' @?= cs   where cs = [17,4,4,6,6]-        cs' = fromRight $ uncommands . toCommands <$> (commands cs >>= fromCommands @Point)+        cs' = fromRight $ R.uncommands . R.toCommands <$> (R.commands cs >>= R.fromCommands @Point)  linestringIso :: Assertion linestringIso = cs' @?= cs   where cs = [9,4,4,18,6,4,5,4,9,4,4,18,6,4,5,4]-        cs' = fromRight $ uncommands . toCommands <$> (commands cs >>= fromCommands @LineString)+        cs' = fromRight $ R.uncommands . R.toCommands <$> (R.commands cs >>= R.fromCommands @LineString)  -- | Two external rings polygonIso :: Assertion polygonIso = cs' @?= cs   where cs = [9,4,4,18,6,4,5,4,15,9,4,4,18,6,4,5,4,15]-        cs' = fromRight $ uncommands . toCommands <$> (commands cs >>= fromCommands @Polygon)+        cs' = fromRight $ R.uncommands . R.toCommands <$> (R.commands cs >>= R.fromCommands @Polygon)  -- | One external, one internal polygonIso2 :: Assertion polygonIso2 = cs' @?= cs   where cs = [9,4,4,26,6,0,0,6,5,0,15,9,2,3,26,0,2,2,0,0,1,15]-        cs' = fromRight $ uncommands . toCommands <$> (commands cs >>= fromCommands @Polygon)+        cs' = fromRight $ R.uncommands . R.toCommands <$> (R.commands cs >>= R.fromCommands @Polygon)  {-} foo :: FilePath -> IO (Either Text VectorTile)

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                vectortiles-version:             1.0.0+version:             1.1.0 synopsis:            GIS Vector Tiles, as defined by Mapbox. description:         GIS Vector Tiles, as defined by Mapbox.                      .@@ -14,9 +14,9 @@                      .                      The order in which to explore the modules of this library is as follows:                      .-                     1. "Geography.VectorTile" (high-level types and conversion functions)+                     1. "Geography.VectorTile.VectorTile" (high-level types)                      2. "Geography.VectorTile.Geometry" (typical GIS geometry types)-                     3. "Geography.VectorTile.Raw" (mid-level representation of parsed protobuf data)+                     3. "Geography.VectorTile.Protobuf" (mid-level representation of parsed protobuf data with conversion functions)  homepage:            https://github.com/fosskers/vectortiles license:             Apache-2.0@@ -36,7 +36,8 @@  library   exposed-modules:     Geography.VectorTile-                     , Geography.VectorTile.Raw+                     , Geography.VectorTile.VectorTile+                     , Geography.VectorTile.Protobuf                      , Geography.VectorTile.Geometry                      , Geography.VectorTile.Util