vectortiles 1.3.0 → 1.4.0

raw patch · 10 files changed

+293/−240 lines, 10 filesdep +mtldep ~criterionsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl

Dependency ranges changed: criterion

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−1
• Setup.hs +0/−2
• bench/Bench.hs +40/−28
• lib/Geography/VectorTile.hs +1/−1
• lib/Geography/VectorTile/Geometry.hs +34/−19
• lib/Geography/VectorTile/Internal.hs +123/−110
• lib/Geography/VectorTile/Util.hs +18/−11
• lib/Geography/VectorTile/VectorTile.hs +17/−16
• test/Test.hs +27/−27
• vectortiles.cabal +28/−25

@@ -1,9 +1,13 @@ Changelog ========= +1.4.0+------+- **Breaking:** `Feature` is now explicit about what `Vector` type it holds+- Performance improvements+ 1.2.0.3 -------- - Performance improvements during metadata encoding.  1.2.0.2

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -1,5 +1,3 @@--- -*- dante-target: "vectortiles-bench"; -*-- {-# LANGUAGE OverloadedStrings #-}  module Main where@@ -7,7 +5,9 @@ import           Criterion.Main import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL-import qualified Data.HashMap.Lazy as M+import qualified Data.HashMap.Strict as M+import           Data.Monoid ((<>))+import qualified Data.Vector.Storable as VS import           Geography.VectorTile import           Lens.Micro import           Lens.Micro.Platform ()  -- Instances only.@@ -24,31 +24,36 @@       ls' = fromRight $ tile ls       pl' = fromRight $ tile pl       rd' = fromRight $ tile rd-  defaultMain [ bgroup "Decoding"-                [ bgroup "onepoint.mvt" $ decodes op-                , bgroup "linestring.mvt" $ decodes ls-                , bgroup "polygon.mvt" $ decodes pl-                , bgroup "roads.mvt" $ decodes rd-                ]-              , bgroup "Encoding"-                [ bgroup "Point" $ encodes op'-                , bgroup "LineString" $ encodes ls'-                , bgroup "Polygon" $ encodes pl'-                , bgroup "Roads" $ encodes rd'-                ]-              , bgroup "Data Access"-                [ bgroup "All Layer Names"-                  [ bench "One Point" $ nf layerNames op-                  , bench "One LineString" $ nf layerNames ls-                  , bench "One Polygon" $ nf layerNames pl-                  , bench "roads.mvt" $ nf layerNames rd-                  ]-                , bgroup "First Polygon"-                  [ bench "One Polygon" $ nf (firstPoly "OnePolygon") op-                  , bench "roads.mvt - water layer" $ nf (firstPoly "water") rd-                  ]-                ]-              ]+  defaultMain+    [ bgroup "Decoding"+      [ bgroup "onepoint.mvt"   $ decodes op+      , bgroup "linestring.mvt" $ decodes ls+      , bgroup "polygon.mvt"    $ decodes pl+      , bgroup "roads.mvt"      $ decodes rd+      ]+    , bgroup "Encoding"+      [ bgroup "Point"      $ encodes op'+      , bgroup "LineString" $ encodes ls'+      , bgroup "Polygon"    $ encodes pl'+      , bgroup "Roads"      $ encodes rd'+      ]+    , bgroup "Data Access"+      [ bgroup "All Layer Names"+        [ bench "One Point"      $ nf layerNames op+        , bench "One LineString" $ nf layerNames ls+        , bench "One Polygon"    $ nf layerNames pl+        , bench "roads.mvt"      $ nf layerNames rd+        ]+      , bgroup "First Polygon"+        [ bench "One Polygon" $ nf (firstPoly "OnePolygon") op+        , bench "roads.mvt - water layer" $ nf (firstPoly "water") rd+        ]+      ]+    , bgroup "Other Functions"+      [ bench "Surveyor - Tiny" $ nf surveyor tinyvec+      , bench "Surveyor - Big"  $ nf surveyor bigvec+      ]+    ]  decodes :: BS.ByteString -> [Benchmark] decodes bs = [ bench "VectorTile" $ nf tile bs ]@@ -65,3 +70,10 @@ fromRight :: Either a b -> b fromRight (Right b) = b fromRight _ = error "`Left` given to fromRight!"++tinyvec :: VS.Vector Point+tinyvec = VS.fromList [ Point 1 1, Point 2 1, Point 2 2, Point 1 2, Point 1 1 ]++bigvec :: VS.Vector Point+bigvec = ps <> VS.fromList [ Point 500 1000, Point 1 1 ]+  where ps = VS.fromList $ map (\n -> Point n 1) [ 1 .. 1000 ]

@@ -47,7 +47,7 @@   , geometries   , Val(..)   -- * Geometries-  , Point, x, y+  , Point(..)   , LineString(..)   , Polygon(..)   , area

@@ -10,7 +10,7 @@ module Geography.VectorTile.Geometry   ( -- * Geometries     -- ** Types-    Point, pattern Point, x, y+    Point(..)   , LineString(..)   , Polygon(..)   -- ** Operations@@ -21,22 +21,37 @@  import           Control.DeepSeq (NFData) import           Data.Foldable (foldl')-import qualified Data.Sequence as Seq-import qualified Data.Vector.Unboxed as U+import           Data.Semigroup+import qualified Data.Vector as V+import qualified Data.Vector.Storable as VS+import           Foreign.Storable import           GHC.Generics (Generic)  --- --- | Points in space. Using "Record Pattern Synonyms" here allows us to treat--- `Point` like a normal ADT, while its implementation remains an unboxed--- @(Int,Int)@.-type Point = (Int,Int)-pattern Point :: Int -> Int -> (Int, Int)-pattern Point{x, y} = (x, y)+-- | A strict pair of integers indicating some location on a discrete grid.+-- @Point 0 0@ is the top-left.+data Point = Point { x :: !Int, y :: !Int } deriving (Eq, Show, Generic) +instance Semigroup Point where+  Point x0 y0 <> Point x1 y1 = Point (x0 + x1) (y0 + y1)+  {-# INLINE (<>) #-}++instance Monoid Point where+  mempty = Point 0 0+  mappend = (<>)++instance Storable Point where+  sizeOf _ = 16+  alignment _ = 8+  peek p = Point <$> peekByteOff p 0 <*> peekByteOff p 8+  poke p (Point a b) = pokeByteOff p 0 a *> pokeByteOff p 8 b++instance NFData Point+ -- | /newtype/ compiles away to expose only the `U.Vector` of unboxed `Point`s -- at runtime.-newtype LineString = LineString { lsPoints :: U.Vector Point } deriving (Eq,Show,Generic)+newtype LineString = LineString { lsPoints :: VS.Vector Point } deriving (Eq, Show, Generic)  instance NFData LineString @@ -45,8 +60,8 @@ -- VectorTiles require that Polygon exteriors have clockwise winding order, -- and that interior holes have counter-clockwise winding order. -- These assume that the origin (0,0) is in the *top-left* corner.-data Polygon = Polygon { polyPoints :: U.Vector Point-                       , inner :: Seq.Seq Polygon } deriving (Eq,Show,Generic)+data Polygon = Polygon { polyPoints :: VS.Vector Point+                       , inner      :: V.Vector Polygon } deriving (Eq, Show, Generic)  instance NFData Polygon @@ -59,13 +74,13 @@ -- If the value reported here is negative, then the `Polygon` should be -- considered an Interior Ring. ----- Assumption: The `U.Vector` given has at least 4 `Point`s.-surveyor :: U.Vector Point -> Double-surveyor v = (/ 2) . fromIntegral . U.sum $ U.zipWith3 (\xn yn yp -> xn * (yn - yp)) xs yns yps-  where v' = U.init v-        xs = U.map x v'-        yns = U.map y . U.tail $ U.snoc v' (U.head v')-        yps = U.map y . U.init $ U.cons (U.last v') v'+-- Assumption: The `V.Vector` given has at least 4 `Point`s.+surveyor :: VS.Vector Point -> Double+surveyor v = (/ 2) . fromIntegral . VS.foldl' (+) 0 $ VS.zipWith3 (\xn yn yp -> xn * (yn - yp)) xs yns yps+  where v' = VS.init v+        xs = VS.map x v'+        yns = VS.map y . VS.tail $ VS.snoc v' (VS.head v')+        yps = VS.map y . VS.init $ VS.cons (VS.last v') v'  -- | Euclidean distance. distance :: Point -> Point -> Double

@@ -1,11 +1,7 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE LambdaCase #-}  -- | -- Module    : Geography.VectorTile.Internal@@ -50,20 +46,23 @@   ) where  import           Control.Applicative ((<|>))-import           Control.Monad (void)-import           Control.Monad.Trans.State.Strict+import           Control.Monad (void, (>=>))+import           Control.Monad.Except+import           Control.Monad.State.Strict import           Data.Bits import qualified Data.ByteString.Lazy as BL-import           Data.Foldable (fold, foldl', foldlM, toList)-import           Data.Int-import qualified Data.HashMap.Lazy as M+import           Data.Foldable (fold, foldlM, toList)+import qualified Data.HashMap.Strict as M import qualified Data.HashSet as HS+import           Data.Int+import           Data.List (unfoldr) import           Data.Maybe (fromJust)-import           Data.Monoid+import           Data.Semigroup hiding (diff)+import           Data.Sequence (Seq, (<|), (|>), Seq()) import qualified Data.Sequence as Seq-import           Data.Sequence (Seq, (<|), (|>), Seq((:<|))) import           Data.Text (Text, pack)-import qualified Data.Vector.Unboxed as U+import qualified Data.Vector as V+import qualified Data.Vector.Storable as VS import           Data.Word import qualified Geography.VectorTile.Geometry as G import qualified Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile as Tile@@ -85,6 +84,11 @@ type instance Protobuf VT.Layer = Layer.Layer type instance Protobuf VT.Val = Value.Value +type family GeomVec g = v | v -> g+type instance GeomVec G.Point      = VS.Vector G.Point+type instance GeomVec G.LineString = V.Vector G.LineString+type instance GeomVec G.Polygon    = V.Vector G.Polygon+ -- | A type which can be converted to and from an underlying Protobuf type, -- according to the `Protobuf` type family. class Protobuffable a where@@ -101,17 +105,17 @@  instance Protobuffable VT.Layer where   fromProtobuf l = do-    (ps,ls,polys) <- feats (utf8 <$> Layer.keys l) (Layer.values l) $ Layer.features l-    pure VT.Layer { VT._version = fromIntegral $ Layer.version l-                  , VT._name = utf8 $ Layer.name l-                  , VT._points = ps-                  , VT._linestrings = ls-                  , VT._polygons = polys-                  , VT._extent = maybe 4096 fromIntegral (Layer.extent l) }+    Feats ps ls polys <- feats (utf8 <$> Layer.keys l) (Layer.values l) $ Layer.features l+    pure VT.Layer { VT._version     = fromIntegral $ Layer.version l+                  , VT._name        = utf8 $ Layer.name l+                  , VT._points      = V.fromList $ toList ps+                  , VT._linestrings = V.fromList $ toList ls+                  , VT._polygons    = V.fromList $ toList polys+                  , VT._extent      = maybe 4096 fromIntegral (Layer.extent l) }    toProtobuf l = Layer.Layer { Layer.version   = fromIntegral $ VT._version l                              , Layer.name      = Utf8 $ VT._name l-                             , Layer.features  = fs+                             , Layer.features  = Seq.fromList $ V.toList fs  -- Conversion bottleneck?                              , Layer.keys      = Seq.fromList $ map Utf8 ks                              , Layer.values    = Seq.fromList $ map toProtobuf vs                              , Layer.extent    = Just . fromIntegral $ VT._extent l@@ -143,37 +147,38 @@ -- | 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 :: Seq Command -> Either Text (Seq g)-  toCommands :: Seq g -> Seq Command+  fromCommands :: [Command] -> Either Text (GeomVec g)+  toCommands   :: GeomVec g -> [Command]  -- | 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 :<| Seq.Empty) = Right $ expand' (0, 0) ps-  fromCommands (c :<| _) = Left . pack $ printf "Invalid command found in Point feature: %s" (show c)-  fromCommands Seq.Empty = Left "No points given!"+  fromCommands [ MoveTo ps ] = Right $ expand (G.Point 0 0) ps+  fromCommands (c : _)       = Left . pack $ printf "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 = Seq.singleton (MoveTo $ evalState (traverse collapse ps) (0,0))+  toCommands ps = [ MoveTo $ evalState (VS.mapM collapse ps) (G.Point 0 0) ]  -- | 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 :<| Seq.Empty) :<| LineTo ps :<| rs) = do+  fromCommands cs = evalStateT (V.unfoldrM f cs) (G.Point 0 0)+    where f :: [Command] -> StateT G.Point (Either Text) (Maybe (G.LineString, [Command]))+          f (MoveTo p : LineTo ps : rs) = do             curr <- get-            let ls = G.LineString . expand curr . U.fromList . toList $ p <| ps-            put . U.last $ G.lsPoints ls-            fmap (ls <|) <$> f rs-          f Seq.Empty = pure $ Right Seq.Empty-          f _ = pure $ Left "LineString decode: Invalid command sequence given."+            let ls = G.LineString . expand curr $ VS.head p `VS.cons` ps+            put . VS.last $ G.lsPoints ls+            pure $ Just (ls, rs)+          f [] = pure Nothing+          f _  = throwError "LineString decode: Invalid command sequence given." -  toCommands ls = fold $ evalState (traverse f ls) (0,0)+  toCommands ls = fold $ evalState (traverse f ls) (G.Point 0 0)     where f (G.LineString ps) = do-            l <- U.mapM collapse ps-            pure $ MoveTo (Seq.singleton $ U.head l) <| LineTo (Seq.fromList . U.toList $ U.tail l) <| Seq.Empty+            l <- VS.mapM collapse ps+            pure [ MoveTo (VS.singleton $ VS.head l), LineTo (VS.tail l) ]  -- | A valid `RawFeature` of polygons must contain at least one sequence of: --@@ -185,34 +190,33 @@ -- Performs no sanity checks for malformed Interior Rings. instance ProtobufGeom G.Polygon where   fromCommands cs = do-    h :<| t <- evalState (f cs) (0,0)-    let (ps',p') = runState (foldlM g Seq.Empty t) h-    pure $ ps' |> p'  -- Include the last Exterior Ring worked on.-    where f (MoveTo (p :<| Seq.Empty) :<| LineTo ps :<| ClosePath :<| rs) = do+    polys <- evalStateT (V.unfoldrM f cs) (G.Point 0 0)+    pure $ V.unfoldr g polys+    where f :: [Command] -> StateT G.Point (Either Text) (Maybe (G.Polygon, [Command]))+          f (MoveTo p : LineTo ps : ClosePath : rs) = do             curr <- get-            let ps' = expand curr . U.fromList . toList $ p <| ps  -- Conversion bottleneck?-            put $ U.last ps'-            fmap (G.Polygon (U.snoc ps' $ U.head ps') Seq.Empty <|) <$> f rs-          f Seq.Empty = pure $ Right Seq.Empty-          f _  = pure . Left . pack $ printf "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 $ acc |> curr-                  | otherwise = do  -- Next internal ring.-                      modify (\s -> s { G.inner = G.inner s |> p })-                      pure acc+            let ps' = expand curr $ VS.head p `VS.cons` ps+            put $ VS.last ps'+            pure $ Just (G.Polygon (VS.snoc ps' $ VS.head ps') mempty, rs)+          f [] = pure Nothing+          f _  = throwError . pack $ printf "Polygon decode: Invalid command sequence given: %s" (show cs) -  toCommands ps = fold $ evalState (traverse f ps) (0,0)-    where f :: G.Polygon -> State (Int, Int) (Seq Command)+          g :: V.Vector G.Polygon -> Maybe (G.Polygon, V.Vector G.Polygon)+          g v | V.null v  = Nothing+              | otherwise = Just (p, v')+                where p = (V.head v) { G.inner = is }+                      (is,v') = V.break (\i -> G.area i > 0) $ V.tail v++  toCommands ps = fold $ evalState (traverse f ps) (G.Point 0 0)+    where f :: G.Polygon -> State G.Point [Command]           f (G.Polygon p i) = do-            l <- U.mapM collapse $ U.init p  -- Exclude the final point.-            let cs = MoveTo (Seq.singleton $ U.head l) <| LineTo (Seq.fromList . U.toList $ U.tail l) <| ClosePath <| Seq.Empty-            fold . (cs <|) <$> traverse f i+            l <- VS.mapM collapse $ VS.init p  -- Exclude the final point.+            let cs = [ MoveTo (VS.singleton $ VS.head l), LineTo (VS.tail l), ClosePath ]+            fold . (cs :) <$> traverse f (V.toList i)  -- | The possible commands, and the values they hold.-data Command = MoveTo (Seq (Int,Int))-             | LineTo (Seq (Int,Int))+data Command = MoveTo (VS.Vector G.Point)+             | LineTo (VS.Vector G.Point)              | ClosePath deriving (Eq,Show)  -- | Z-encode a 64-bit Int.@@ -227,47 +231,47 @@ {-# INLINE unzig #-}  -- | Divide a "Command Integer" into its @(Command,Count)@.-parseCmd :: Word32 -> Either Text (Int,Int)-parseCmd n = case (cmd,count) of-  (1,m) -> Right (1, fromIntegral m)-  (2,m) -> Right (2, fromIntegral m)-  (7,1) -> Right (7,1)-  (7,m) -> Left $ "ClosePath was given a parameter count: " <> pack (show m)-  (m,_) -> Left . pack $ printf "Invalid command integer %d found in: %X" m n+-- Throws if illegal values are given.+unsafeParseCmd :: Word32 -> Pair+unsafeParseCmd n = case cmd of+  1 -> Pair 1 (fromIntegral count)+  2 -> Pair 2 (fromIntegral count)+  7 | count == 1 -> Pair 7 1+    | otherwise  -> error $ "ClosePath was given a parameter count: " <> show count+  m -> error $ printf "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+unparseCmd :: Pair -> Word32+unparseCmd (Pair cmd count) = fromIntegral $ (cmd .&. 7) .|. shift count 3 {-# INLINE unparseCmd #-}  -- | 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 :: Seq Word32 -> Either Text (Seq Command)-commands = go (Right Seq.Empty)-  where go !acc Seq.Empty = acc-        go (Left e) _ = Left e-        go (Right !acc) (n :<| ns) = parseCmd n >>= \case-          (1, count) -> do-            let (ls,rs) = Seq.splitAt (count * 2) ns-            mts <- MoveTo <$> pairsWith unzig ls-            go (Right $ acc |> mts) rs-          (2, count) -> do-            let (ls,rs) = Seq.splitAt (count * 2) ns-            mts <- LineTo <$> pairsWith unzig ls-            go (Right $ acc |> mts) rs-          (7, _) -> go (Right $ acc |> ClosePath) ns-          _ -> Left "Sentinel: You should never see this."+commands :: [Word32] -> [Command]+commands = unfoldr go+  where go [] = Nothing+        go (n : ns) = case unsafeParseCmd n of+          Pair 1 count ->+            let (ls, rs) = splitAt (count * 2) ns+                mts = MoveTo $ pairsWith unzig ls+            in Just (mts, rs)+          Pair 2 count ->+            let (ls, rs) = splitAt (count * 2) ns+                mts = LineTo $ pairsWith unzig ls+            in Just (mts, rs)+          Pair 7 _ -> Just (ClosePath, ns)+          _ -> error "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 :: Seq Command -> Seq Word32-uncommands = (>>= f)-  where f (MoveTo ps) = unparseCmd (1, length ps) <| params ps-        f (LineTo ls) = unparseCmd (2, length ls) <| params ls-        f ClosePath   = Seq.singleton $ unparseCmd (7,1)  -- ClosePath, Count 1.+uncommands :: [Command] -> Seq Word32+uncommands = Seq.fromList >=> f+  where f (MoveTo ps) = unparseCmd (Pair 1 (VS.length ps)) <| params ps+        f (LineTo ls) = unparseCmd (Pair 2 (VS.length ls)) <| params ls+        f ClosePath   = Seq.singleton $ unparseCmd (Pair 7 1)  -- ClosePath, Count 1.  {- FROM PROTOBUF -} @@ -290,29 +294,36 @@ -- > feature :: ProtobufGeom g => RawFeature -> Either Text (Feature g) -- -- is not possible.-feats :: Seq BL.ByteString -> Seq Value.Value -> Seq Feature.Feature-  -> Either Text (Seq (VT.Feature G.Point), Seq (VT.Feature G.LineString), Seq (VT.Feature G.Polygon))+feats :: Seq BL.ByteString -> Seq Value.Value -> Seq Feature.Feature -> Either Text Feats feats _ _ Seq.Empty = Left "VectorTile.features: `[RawFeature]` empty"-feats keys vals fs = foldlM g mempty fs-  where f :: ProtobufGeom g => Feature.Feature -> Either Text (VT.Feature g)+feats keys vals fs = foldlM g (Feats mempty mempty mempty) fs+  where f :: ProtobufGeom g => Feature.Feature -> Either Text (VT.Feature (GeomVec g))         f x = VT.Feature           <$> pure (maybe 0 fromIntegral $ Feature.id x)           <*> getMeta keys vals (Feature.tags x)-          <*> (commands (Feature.geometry x) >>= fromCommands)-        g (!pnt,!lin,!ply) fe = case Feature.type' fe of-          Just GeomType.POINT      -> (\fe' -> (pnt |> fe', lin, ply)) <$> f fe-          Just GeomType.LINESTRING -> (\fe' -> (pnt, lin |> fe', ply)) <$> f fe-          Just GeomType.POLYGON    -> (\fe' -> (pnt, lin, ply |> fe')) <$> f fe+          <*> (fromCommands . commands . toList $ Feature.geometry x)++        g feets@(Feats ps ls po) fe = case Feature.type' fe of+          Just GeomType.POINT      -> (\fe' -> feets { featPoints = ps |> fe' }) <$> f fe+          Just GeomType.LINESTRING -> (\fe' -> feets { featLines  = ls |> fe' }) <$> f fe+          Just GeomType.POLYGON    -> (\fe' -> feets { featPolys  = po |> fe' }) <$> f fe           _ -> Left "Geometry type of UNKNOWN given." +data Feats = Feats { featPoints :: !(Seq (VT.Feature (GeomVec G.Point)))+                   , featLines  :: !(Seq (VT.Feature (GeomVec G.LineString)))+                   , featPolys  :: !(Seq (VT.Feature (GeomVec G.Polygon))) }+ getMeta :: Seq BL.ByteString -> Seq Value.Value -> Seq Word32 -> Either Text (M.HashMap BL.ByteString VT.Val) getMeta keys vals tags = do-  kv <- pairsWith fromIntegral tags-  foldlM (\acc (k,v) -> (\v' -> M.insert (keys `Seq.index` k) v' acc) <$> fromProtobuf (vals `Seq.index` v)) M.empty kv+  let kv = pairsWith fromIntegral (toList tags)+  VS.foldM' (\acc (G.Point k v) -> (\v' -> M.insert (keys `Seq.index` k) v' acc) <$> fromProtobuf (vals `Seq.index` v)) M.empty kv  {- TO PROTOBUF -} -totalMeta :: Seq (VT.Feature G.Point) -> Seq (VT.Feature G.LineString) -> Seq (VT.Feature G.Polygon) -> ([BL.ByteString], [VT.Val])+totalMeta :: V.Vector (VT.Feature (GeomVec G.Point))+          -> V.Vector (VT.Feature (GeomVec G.LineString))+          -> V.Vector (VT.Feature (GeomVec G.Polygon))+          -> ([BL.ByteString], [VT.Val]) totalMeta ps ls polys = (keys, vals)   where keys = HS.toList $ f ps <> f ls <> f polys         vals = HS.toList $ g ps <> g ls <> g polys@@ -320,7 +331,12 @@         g = foldMap (HS.fromList . M.elems . VT._metadata)  -- | Encode a high-level `Feature` back into its mid-level `RawFeature` form.-unfeats :: ProtobufGeom g => M.HashMap BL.ByteString Int -> M.HashMap VT.Val Int -> GeomType.GeomType -> VT.Feature g -> Feature.Feature+unfeats :: ProtobufGeom g+        => M.HashMap BL.ByteString Int+        -> M.HashMap VT.Val Int+        -> GeomType.GeomType+        -> VT.Feature (GeomVec g)+        -> Feature.Feature unfeats keys vals gt fe = Feature.Feature                             { Feature.id       = Just . fromIntegral $ VT._featureId fe                             , Feature.tags     = Seq.fromList $ tags fe@@ -332,22 +348,19 @@ {- UTIL -}  -- | Transform a `Seq` of `Point`s into one of Z-encoded Parameter ints.-params :: Seq (Int,Int) -> Seq Word32-params = foldl' (\acc (a,b) -> acc |> zig a |> zig b) Seq.Empty+params :: VS.Vector G.Point -> Seq Word32+params = VS.foldl' (\acc (G.Point a b) -> acc |> zig a |> zig b) Seq.Empty  -- | Expand a pair of diffs from some reference point into that of a `Point` value.-expand :: (Int, Int) -> U.Vector (Int, Int) -> U.Vector (Int, Int)-expand = U.postscanl' (\(x, y) (dx, dy) -> (x + dx, y + dy))--expand' :: (Int, Int) -> Seq (Int, Int) -> Seq (Int, Int)-expand' curr s = Seq.drop 1 $ Seq.scanl (\(x, y) (dx, dy) -> (x + dx, y + dy)) curr s+expand :: G.Point -> VS.Vector G.Point -> VS.Vector G.Point+expand = VS.postscanl' (<>)  -- | 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 :: G.Point -> State G.Point G.Point collapse p = do   curr <- get-  let diff = (G.x p - G.x curr, G.y p - G.y curr)+  let diff = G.Point (G.x p - G.x curr) (G.y p - G.y curr)   put p   pure diff

@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- -- | -- Module    : Geography.VectorTile.Util -- Copyright : (c) Colin Woodbury 2016 - 2018@@ -8,20 +6,29 @@  module Geography.VectorTile.Util where -import Data.Sequence (Seq, (|>), Seq(Empty, (:<|)))-import Data.Text (Text)+import qualified Data.Vector.Storable as VS+import           Geography.VectorTile.Geometry (Point(..))  --- +-- | A strict pair of Ints.+data Pair = Pair !Int !Int+ -- | A sort of "self-zip", forming pairs from every two elements in a list. -- Fails if there is an uneven number of elements.-pairsWith :: (a -> b) -> Seq a -> Either Text (Seq (b, b))-pairsWith _ Empty = Right Empty-pairsWith f s | odd $ length s = Left "Uneven number of parameters given."-              | otherwise = Right $ go Empty s-  where go acc Empty = acc-        go acc (x :<| y :<| zs) = go (acc |> (f x, f y)) zs-        go acc (_ :<| Empty) = acc+-- pairsWith :: (a -> Int) -> [a] -> Either Text [Point]+-- pairsWith _ [] = Right []+-- pairsWith f s | odd $ length s = Left "Uneven number of parameters given."+--               | otherwise = Right $ go Empty s+--   where go !acc Empty = acc+--         go !acc (a :<| b :<| cs) = go (acc |> Point (f a) (f b)) cs+--         go !acc (_ :<| Empty) = acc++pairsWith :: (a -> Int) -> [a] -> VS.Vector Point+pairsWith f = VS.unfoldr g+  where g []  = Nothing+        g [_] = Nothing+        g (a:b:cs) = Just (Point (f a) (f b), cs)  -- | Flatten a list of pairs. Equivalent to: --

@@ -37,10 +37,11 @@  import           Control.DeepSeq (NFData) import qualified Data.ByteString.Lazy as BL+import qualified Data.HashMap.Lazy as M import           Data.Hashable (Hashable) import           Data.Int-import qualified Data.HashMap.Lazy as M-import qualified Data.Sequence as Seq+import qualified Data.Vector as V+import qualified Data.Vector.Storable as VS import           Data.Word import           GHC.Generics (Generic) import           Geography.VectorTile.Geometry@@ -70,11 +71,11 @@ -- them here explicitely to allow for more fine-grained access to each type. data Layer = Layer { _version     :: Word  -- ^ The version of the spec we follow. Should always be 2.                    , _name        :: BL.ByteString-                   , _points      :: Seq.Seq (Feature Point)-                   , _linestrings :: Seq.Seq (Feature LineString)-                   , _polygons    :: Seq.Seq (Feature Polygon)+                   , _points      :: V.Vector (Feature (VS.Vector Point))+                   , _linestrings :: V.Vector (Feature (V.Vector LineString))+                   , _polygons    :: V.Vector (Feature (V.Vector Polygon))                    , _extent      :: Word  -- ^ Default: 4096-                   } deriving (Eq,Show,Generic)+                   } deriving (Eq, Show, Generic)  version :: Lens' Layer Word version f l = (\v -> l { _version = v }) <$> f (_version l)@@ -84,15 +85,15 @@ name f l = (\v -> l { _name = v }) <$> f (_name l) {-# INLINE name #-} -points :: Lens' Layer (Seq.Seq (Feature Point))+points :: Lens' Layer (V.Vector (Feature (VS.Vector Point))) points f l = (\v -> l { _points = v }) <$> f (_points l) {-# INLINE points #-} -linestrings :: Lens' Layer (Seq.Seq (Feature LineString))+linestrings :: Lens' Layer (V.Vector (Feature (V.Vector LineString))) linestrings f l = (\v -> l { _linestrings = v }) <$> f (_linestrings l) {-# INLINE linestrings #-} -polygons :: Lens' Layer (Seq.Seq (Feature Polygon))+polygons :: Lens' Layer (V.Vector (Feature (V.Vector Polygon))) polygons f l = (\v -> l { _polygons = v }) <$> f (_polygons l) {-# INLINE polygons #-} @@ -118,23 +119,23 @@ -- -- Note: The keys to the metadata are `BL.ByteString`, but are guaranteed -- to be UTF-8.-data Feature g = Feature { _featureId :: Word  -- ^ Default: 0-                         , _metadata :: M.HashMap BL.ByteString Val-                         , _geometries :: Seq.Seq g } deriving (Eq,Show,Generic)+data Feature gs = Feature { _featureId  :: Word  -- ^ Default: 0+                          , _metadata   :: M.HashMap BL.ByteString Val+                          , _geometries :: gs } deriving (Eq, Show, Generic) -featureId :: Lens' (Feature g) Word+featureId :: Lens' (Feature gs) Word featureId f l = (\v -> l { _featureId = v }) <$> f (_featureId l) {-# INLINE featureId #-} -metadata :: Lens' (Feature g) (M.HashMap BL.ByteString Val)+metadata :: Lens' (Feature gs) (M.HashMap BL.ByteString Val) metadata f l = (\v -> l { _metadata = v }) <$> f (_metadata l) {-# INLINE metadata #-} -geometries :: Lens' (Feature g) (Seq.Seq g)+geometries :: Lens' (Feature gs) gs geometries f l = (\v -> l { _geometries = v }) <$> f (_geometries l) {-# INLINE geometries #-} -instance NFData g => NFData (Feature g)+instance (NFData gs) => NFData (Feature gs)  -- | Legal Metadata /Value/ types. Note that `S64` are Z-encoded automatically -- by the underlying "Text.ProtocolBuffers" library.

@@ -1,23 +1,21 @@--- -*- dante-target: "vectortiles-test"; -*-- {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeApplications #-}  module Main where  import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL+import           Data.Foldable (toList) import qualified Data.Sequence as Seq import qualified Data.Text as T-import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Storable as VS import           Geography.VectorTile import qualified Geography.VectorTile.Internal as I import           Test.Tasty import           Test.Tasty.HUnit import           Text.ProtocolBuffers.Basic (Utf8(..), defaultValue)-import           Text.ProtocolBuffers.WireMessage (Wire, messageGet) import           Text.ProtocolBuffers.Reflections (ReflectDescriptor)+import           Text.ProtocolBuffers.WireMessage (Wire, messageGet)  --- @@ -52,16 +50,18 @@     ]   , testGroup "Geometries"     [ testCase "area" $ area poly @?= 1-    , testCase "surveyor - outer" . assert $ surveyor (polyPoints poly) > 0-    , testCase "surveyor - inner" . assert $ surveyor (U.reverse $ polyPoints poly) < 0+    , testCase "surveyor - outer" . assertBool "surveyor outer" $ surveyor (polyPoints poly) > 0+    , testCase "surveyor - inner" . assertBool "surveyor inner" $ surveyor (VS.reverse $ polyPoints poly) < 0     , testCase "Z-encoding Isomorphism" zencoding     , testCase "Command Parsing" commandTest+    , testCase "Polygon Validity" $ VS.head (polyPoints poly) @?= VS.last (polyPoints poly)     , testCase "[Word32] <-> [Command]" commandIso     , testCase "[Word32] <-> V.Vector Point" pointIso     , testCase "[Word32] <-> V.Vector LineString" linestringIso     , testCase "[Word32] <-> V.Vector Polygon (2 solid)" polygonIso     , testCase "[Word32] <-> V.Vector Polygon (1 holed)" polygonIso2     , testCase "[Word32] <-> V.Vector Polygon (1 holed, 1 solid)" polygonIso3+    , testCase "Point Storable Instance" $ VS.toList (VS.fromList [Point 1 2, Point 3 4]) @?= [Point 1 2, Point 3 4]     ]   ] @@ -80,7 +80,7 @@                           Right (t, _) -> t @?= res  tileDecode :: BS.ByteString -> Assertion-tileDecode bs = assert . isRight $ tile bs+tileDecode bs = assertBool "tileDecode" . isRight $ tile bs  isRight :: Either a b -> Bool isRight (Right _) = True@@ -154,49 +154,49 @@                       , I.geometry = Seq.fromList [9, 4, 4, 18, 6, 4, 5, 4, 15] }  zencoding :: Assertion-zencoding = assert $ map (I.unzig . I.zig) vs @?= vs+zencoding = map (I.unzig . I.zig) vs @?= vs   where vs = [0,(-1),1,(-2),2,(-3),3,2147483647,(-2147483648)]  commandTest :: Assertion-commandTest = assert $ I.commands (Seq.fromList [9,4,4,18,6,4,5,4,15]) @?= Right (-  Seq.fromList [ I.MoveTo $ Seq.singleton (2,2)-               , I.LineTo $ Seq.fromList [(3,2),(-3,2)]-               , I.ClosePath ]-  )+commandTest = I.commands [9,4,4,18,6,4,5,4,15]+  @?= [ I.MoveTo $ VS.singleton (Point 2 2)+      , I.LineTo $ VS.fromList [ Point 3 2, Point (-3) 2 ]+      , I.ClosePath ]  commandIso :: Assertion-commandIso = assert $ (I.uncommands . fromRight $ I.commands cs) @?= cs-  where cs = Seq.fromList [9,4,4,18,6,4,5,4,15]+commandIso = (I.uncommands $ I.commands cs) @?= Seq.fromList cs+  where cs = [9,4,4,18,6,4,5,4,15]  pointIso :: Assertion pointIso = cs' @?= cs-  where cs = Seq.fromList [25,4,4,6,6,3,3]-        cs' = fromRight $ I.uncommands . I.toCommands <$> (I.commands cs >>= I.fromCommands @Point)+  where cs = [25,4,4,6,6,3,3]+        cs' = toList . fromRight $ I.uncommands . I.toCommands <$> (I.fromCommands @Point $ I.commands cs)  linestringIso :: Assertion linestringIso = cs' @?= cs-  where cs = Seq.fromList [9,4,4,18,6,4,5,4,9,4,4,18,6,4,5,4]-        cs' = fromRight $ I.uncommands . I.toCommands <$> (I.commands cs >>= I.fromCommands @LineString)+  where cs = [9,4,4,18,6,4,5,4,9,4,4,18,6,4,5,4]+        cs' = toList . fromRight $ I.uncommands . I.toCommands <$> (I.fromCommands @LineString $ I.commands cs)  -- | Two solids polygonIso :: Assertion polygonIso = cs' @?= cs-  where cs = Seq.fromList [9,4,4,18,6,4,5,4,15,9,4,4,18,6,4,5,4,15]-        cs' = fromRight $ I.uncommands . I.toCommands <$> (I.commands cs >>= I.fromCommands @Polygon)+  where cs = [9,4,4,18,6,4,5,4,15,9,4,4,18,6,4,5,4,15]+        cs' = toList . fromRight $ I.uncommands . I.toCommands <$> (I.fromCommands @Polygon $ I.commands cs)  -- | One holed polygonIso2 :: Assertion polygonIso2 = cs' @?= cs-  where cs = Seq.fromList [9,4,4,26,6,0,0,6,5,0,15,9,2,3,26,0,2,2,0,0,1,15]-        cs' = fromRight $ I.uncommands . I.toCommands <$> (I.commands cs >>= I.fromCommands @Polygon)+  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' = toList . fromRight $ I.uncommands . I.toCommands <$> (I.fromCommands @Polygon $ I.commands cs)  -- | One Holed, one solid polygonIso3 :: Assertion polygonIso3 = cs' @?= cs-  where cs = Seq.fromList [ 9, 4, 4, 26, 6, 0, 0, 6, 5, 0, 15, 9, 2, 3, 26, 0, 2, 2, 0, 0, 1, 15+  where cs = [ 9, 4, 4, 26, 6, 0, 0, 6, 5, 0, 15+             , 9, 2, 3, 26, 0, 2, 2, 0, 0, 1, 15              , 9, 4, 4, 26, 6, 0, 0, 6, 5, 0, 15 ]-        cs' = fromRight $ I.uncommands . I.toCommands <$> (I.commands cs >>= I.fromCommands @Polygon)+        cs' = toList . fromRight . fmap (I.uncommands . I.toCommands) . I.fromCommands @Polygon $ I.commands cs  poly :: Polygon poly = Polygon ps mempty-  where ps = U.fromList [(0,0), (1,0), (1,1), (0,1), (0,0)]+  where ps = VS.fromList [(Point 0 0), (Point 1 0), (Point 1 1), (Point 0 1), (Point 0 0)]

@@ -1,11 +1,11 @@--- This file has been generated from package.yaml by hpack version 0.21.2.+-- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack ----- hash: f96750e12d765b16fd1c39222cb53517096cf37a3363913c0dd655e08e652bc9+-- hash: 14a8d5b05c51ee218be6a71cd1ca968c3d331d9da687075300ffae7f4686228e  name:           vectortiles-version:        1.3.0+version:        1.4.0 synopsis:       GIS Vector Tiles, as defined by Mapbox. description:    GIS Vector Tiles, as defined by Mapbox.                 This library implements version 2.1 of the official Mapbox spec, as defined@@ -32,51 +32,51 @@     test/roads.mvt  library-  exposed-modules:-      Geography.VectorTile-      Geography.VectorTile.Internal-  other-modules:-      Geography.VectorTile.Geometry-      Geography.VectorTile.Protobuf.Internal.Vector_tile-      Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile-      Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.Feature-      Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.GeomType-      Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.Layer-      Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.Value-      Geography.VectorTile.Util-      Geography.VectorTile.VectorTile-      Paths_vectortiles   hs-source-dirs:       lib   ghc-options: -fwarn-unused-imports -fwarn-unused-binds -fwarn-name-shadowing -fwarn-unused-matches -fwarn-incomplete-patterns -Wincomplete-uni-patterns   build-depends:-      base >=4.9 && <4.11+      base >=4.9 && <4.12     , bytestring     , containers     , deepseq >=1.4 && <1.5     , hashable+    , mtl     , protocol-buffers >=2.4 && <2.5     , protocol-buffers-descriptor >=2.4 && <2.5     , text >=1.2 && <1.3     , transformers >=0.5 && <0.6     , unordered-containers     , vector >=0.11 && <0.13+  exposed-modules:+      Geography.VectorTile+      Geography.VectorTile.Internal+  other-modules:+      Geography.VectorTile.Geometry+      Geography.VectorTile.Protobuf.Internal.Vector_tile+      Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile+      Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.Feature+      Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.GeomType+      Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.Layer+      Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.Value+      Geography.VectorTile.Util+      Geography.VectorTile.VectorTile+      Paths_vectortiles   default-language: Haskell2010  test-suite vectortiles-test   type: exitcode-stdio-1.0   main-is: Test.hs-  other-modules:-      Paths_vectortiles   hs-source-dirs:       test   ghc-options: -fwarn-unused-imports -fwarn-unused-binds -fwarn-name-shadowing -fwarn-unused-matches -fwarn-incomplete-patterns -Wincomplete-uni-patterns -threaded   build-depends:-      base >=4.9 && <4.11+      base >=4.9 && <4.12     , bytestring     , containers     , hashable     , hex >=0.1 && <0.2+    , mtl     , protocol-buffers >=2.4 && <2.5     , protocol-buffers-descriptor >=2.4 && <2.5     , tasty >=0.10.1.2@@ -85,28 +85,31 @@     , unordered-containers     , vector >=0.11 && <0.13     , vectortiles+  other-modules:+      Paths_vectortiles   default-language: Haskell2010  benchmark vectortiles-bench   type: exitcode-stdio-1.0   main-is: Bench.hs-  other-modules:-      Paths_vectortiles   hs-source-dirs:       bench   ghc-options: -fwarn-unused-imports -fwarn-unused-binds -fwarn-name-shadowing -fwarn-unused-matches -fwarn-incomplete-patterns -Wincomplete-uni-patterns -threaded -rtsopts -O2   build-depends:-      base >=4.9 && <4.11+      base >=4.9 && <4.12     , bytestring     , containers-    , criterion >=1.1 && <1.4+    , criterion >=1.1 && <1.5     , hashable     , microlens >=0.4 && <0.5     , microlens-platform >=0.3 && <0.4+    , mtl     , protocol-buffers >=2.4 && <2.5     , protocol-buffers-descriptor >=2.4 && <2.5     , text >=1.2 && <1.3     , unordered-containers     , vector >=0.11 && <0.13     , vectortiles+  other-modules:+      Paths_vectortiles   default-language: Haskell2010