diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,202 +1,30 @@ - - Apache License - Version 2.0, January 2004 - http://www.apache.org/licenses/ - - TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION - - 1. Definitions. - - "License" shall mean the terms and conditions for use, reproduction, - and distribution as defined by Sections 1 through 9 of this document. - - "Licensor" shall mean the copyright owner or entity authorized by - the copyright owner that is granting the License. - - "Legal Entity" shall mean the union of the acting entity and all - other entities that control, are controlled by, or are under common - control with that entity. For the purposes of this definition, - "control" means (i) the power, direct or indirect, to cause the - direction or management of such entity, whether by contract or - otherwise, or (ii) ownership of fifty percent (50%) or more of the - outstanding shares, or (iii) beneficial ownership of such entity. - - "You" (or "Your") shall mean an individual or Legal Entity - exercising permissions granted by this License. - - "Source" form shall mean the preferred form for making modifications, - including but not limited to software source code, documentation - source, and configuration files. - - "Object" form shall mean any form resulting from mechanical - transformation or translation of a Source form, including but - not limited to compiled object code, generated documentation, - and conversions to other media types. - - "Work" shall mean the work of authorship, whether in Source or - Object form, made available under the License, as indicated by a - copyright notice that is included in or attached to the work - (an example is provided in the Appendix below). - - "Derivative Works" shall mean any work, whether in Source or Object - form, that is based on (or derived from) the Work and for which the - editorial revisions, annotations, elaborations, or other modifications - represent, as a whole, an original work of authorship. For the purposes - of this License, Derivative Works shall not include works that remain - separable from, or merely link (or bind by name) to the interfaces of, - the Work and Derivative Works thereof. - - "Contribution" shall mean any work of authorship, including - the original version of the Work and any modifications or additions - to that Work or Derivative Works thereof, that is intentionally - submitted to Licensor for inclusion in the Work by the copyright owner - or by an individual or Legal Entity authorized to submit on behalf of - the copyright owner. For the purposes of this definition, "submitted" - means any form of electronic, verbal, or written communication sent - to the Licensor or its representatives, including but not limited to - communication on electronic mailing lists, source code control systems, - and issue tracking systems that are managed by, or on behalf of, the - Licensor for the purpose of discussing and improving the Work, but - excluding communication that is conspicuously marked or otherwise - designated in writing by the copyright owner as "Not a Contribution." - - "Contributor" shall mean Licensor and any individual or Legal Entity - on behalf of whom a Contribution has been received by Licensor and - subsequently incorporated within the Work. - - 2. Grant of Copyright License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - copyright license to reproduce, prepare Derivative Works of, - publicly display, publicly perform, sublicense, and distribute the - Work and such Derivative Works in Source or Object form. - - 3. Grant of Patent License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - (except as stated in this section) patent license to make, have made, - use, offer to sell, sell, import, and otherwise transfer the Work, - where such license applies only to those patent claims licensable - by such Contributor that are necessarily infringed by their - Contribution(s) alone or by combination of their Contribution(s) - with the Work to which such Contribution(s) was submitted. If You - institute patent litigation against any entity (including a - cross-claim or counterclaim in a lawsuit) alleging that the Work - or a Contribution incorporated within the Work constitutes direct - or contributory patent infringement, then any patent licenses - granted to You under this License for that Work shall terminate - as of the date such litigation is filed. - - 4. Redistribution. You may reproduce and distribute copies of the - Work or Derivative Works thereof in any medium, with or without - modifications, and in Source or Object form, provided that You - meet the following conditions: - - (a) You must give any other recipients of the Work or - Derivative Works a copy of this License; and - - (b) You must cause any modified files to carry prominent notices - stating that You changed the files; and - - (c) You must retain, in the Source form of any Derivative Works - that You distribute, all copyright, patent, trademark, and - attribution notices from the Source form of the Work, - excluding those notices that do not pertain to any part of - the Derivative Works; and - - (d) If the Work includes a "NOTICE" text file as part of its - distribution, then any Derivative Works that You distribute must - include a readable copy of the attribution notices contained - within such NOTICE file, excluding those notices that do not - pertain to any part of the Derivative Works, in at least one - of the following places: within a NOTICE text file distributed - as part of the Derivative Works; within the Source form or - documentation, if provided along with the Derivative Works; or, - within a display generated by the Derivative Works, if and - wherever such third-party notices normally appear. The contents - of the NOTICE file are for informational purposes only and - do not modify the License. You may add Your own attribution - notices within Derivative Works that You distribute, alongside - or as an addendum to the NOTICE text from the Work, provided - that such additional attribution notices cannot be construed - as modifying the License. - - You may add Your own copyright statement to Your modifications and - may provide additional or different license terms and conditions - for use, reproduction, or distribution of Your modifications, or - for any such Derivative Works as a whole, provided Your use, - reproduction, and distribution of the Work otherwise complies with - the conditions stated in this License. - - 5. Submission of Contributions. Unless You explicitly state otherwise, - any Contribution intentionally submitted for inclusion in the Work - by You to the Licensor shall be under the terms and conditions of - this License, without any additional terms or conditions. - Notwithstanding the above, nothing herein shall supersede or modify - the terms of any separate license agreement you may have executed - with Licensor regarding such Contributions. - - 6. Trademarks. This License does not grant permission to use the trade - names, trademarks, service marks, or product names of the Licensor, - except as required for reasonable and customary use in describing the - origin of the Work and reproducing the content of the NOTICE file. - - 7. Disclaimer of Warranty. Unless required by applicable law or - agreed to in writing, Licensor provides the Work (and each - Contributor provides its Contributions) on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or - implied, including, without limitation, any warranties or conditions - of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A - PARTICULAR PURPOSE. You are solely responsible for determining the - appropriateness of using or redistributing the Work and assume any - risks associated with Your exercise of permissions under this License. - - 8. Limitation of Liability. In no event and under no legal theory, - whether in tort (including negligence), contract, or otherwise, - unless required by applicable law (such as deliberate and grossly - negligent acts) or agreed to in writing, shall any Contributor be - liable to You for damages, including any direct, indirect, special, - incidental, or consequential damages of any character arising as a - result of this License or out of the use or inability to use the - Work (including but not limited to damages for loss of goodwill, - work stoppage, computer failure or malfunction, or any and all - other commercial damages or losses), even if such Contributor - has been advised of the possibility of such damages. - - 9. Accepting Warranty or Additional Liability. While redistributing - the Work or Derivative Works thereof, You may choose to offer, - and charge a fee for, acceptance of support, warranty, indemnity, - or other liability obligations and/or rights consistent with this - License. However, in accepting such obligations, You may act only - on Your own behalf and on Your sole responsibility, not on behalf - of any other Contributor, and only if You agree to indemnify, - defend, and hold each Contributor harmless for any liability - incurred by, or claims asserted against, such Contributor by reason - of your accepting any such warranty or additional liability. - - END OF TERMS AND CONDITIONS +Copyright Colin Woodbury (c) 2017 - APPENDIX: How to apply the Apache License to your work. +All rights reserved. - To apply the Apache License to your work, attach the following - boilerplate notice, with the fields enclosed by brackets "[]" - replaced with your own identifying information. (Don't include - the brackets!) The text should be enclosed in the appropriate - comment syntax for the file format. We also recommend that a - file or class name and description of purpose be included on the - same "printed page" as the copyright notice for easier - identification within third-party archives. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: - Copyright [yyyy] [name of copyright owner] + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. - http://www.apache.org/licenses/LICENSE-2.0 + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -1,14 +1,14 @@ +-- -*- dante-target: "vectortiles-bench"; -*- + {-# LANGUAGE OverloadedStrings #-} module Main where -import Control.Monad ((>=>)) import Criterion.Main import qualified Data.ByteString as BS -import qualified Data.Map.Lazy as M -import Data.Text (Text) +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Lazy as M import Geography.VectorTile -import Geography.VectorTile.Geometry (Polygon) import Lens.Micro import Lens.Micro.Platform () -- Instances only. @@ -20,10 +20,10 @@ ls <- BS.readFile "test/linestring.mvt" pl <- BS.readFile "test/polygon.mvt" rd <- BS.readFile "test/roads.mvt" - let op' = fromRight $ decode op >>= tile - ls' = fromRight $ decode ls >>= tile - pl' = fromRight $ decode pl >>= tile - rd' = fromRight $ decode rd >>= tile + let op' = fromRight $ tile op + 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 @@ -51,22 +51,16 @@ ] decodes :: BS.ByteString -> [Benchmark] -decodes bs = [ bench "Raw.VectorTile" $ nf decode bs - , bench "VectorTile" $ nf (decode >=> tile) bs - ] +decodes bs = [ bench "VectorTile" $ nf tile bs ] encodes :: VectorTile -> [Benchmark] -encodes vt = [ bench "Raw.VectorTile" $ nf untile vt - , bench "ByteString" $ nf (encode . untile) vt - ] +encodes vt = [ bench "ByteString" $ nf untile vt ] -layerNames :: BS.ByteString -> [Text] -layerNames mvt = M.keys $ _layers t - where t = fromRight $ decode mvt >>= tile +layerNames :: BS.ByteString -> [BL.ByteString] +layerNames = M.keys . _layers . fromRight . tile -firstPoly :: Text -> BS.ByteString -> Maybe Polygon -firstPoly ln mvt = r ^? _Right . layers . ix ln . polygons . _head . geometries . _head - where r = decode mvt >>= tile +firstPoly :: BL.ByteString -> BS.ByteString -> Maybe Polygon +firstPoly ln mvt = tile mvt ^? _Right . layers . ix ln . polygons . _head . geometries . _head fromRight :: Either a b -> b fromRight (Right b) = b diff --git a/lib/Geography/VectorTile.hs b/lib/Geography/VectorTile.hs --- a/lib/Geography/VectorTile.hs +++ b/lib/Geography/VectorTile.hs @@ -1,8 +1,8 @@ -- | -- Module : Geography.VectorTile --- Copyright : (c) Azavea, 2016 --- License : Apache 2 --- Maintainer: Colin Woodbury +-- Copyright : (c) Colin Woodbury 2016 - 2018 +-- License : BSD3 +-- Maintainer: Colin Woodbury -- -- GIS Vector Tiles, as defined by Mapbox. -- @@ -12,17 +12,10 @@ -- Note that currently this library ignores top-level protobuf extensions, -- /Value/ extensions, and /UNKNOWN/ geometries. -- --- The order in which to explore the modules of this library is as follows: --- --- 1. "Geography.VectorTile.VectorTile" --- 2. "Geography.VectorTile.Geometry" --- 3. "Geography.VectorTile.Protobuf" --- -- == Usage -- --- 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@: +-- This library reads and writes strict `BS.ByteString`s. +-- Given some legal VectorTile file called @roads.mvt@: -- -- > import qualified Data.ByteString as BS -- > import Data.Text (Text) @@ -30,39 +23,54 @@ -- > -- > -- | 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 $ decode mvt >>= tile --- --- Or encode a `VectorTile` back into a `ByteString`: +-- > roads = tile <$> BS.readFile "roads.mvt" -- --- > roadsBytes :: VectorTile -> BS.ByteString --- > roadsBytes = encode . untile - +-- Likewise, use the `untile` function to convert a `VectorTile` back into a `ByteString`. module Geography.VectorTile - ( -- * High-level Types - -- | This module also provides lenses for data field access, - -- as `VectorTile`s are highly nested objects. - module Geography.VectorTile.VectorTile - , -- * Protobuf Backend - -- ** Conversions - tile + ( -- * Vector Tiles + VectorTile(..) + , tile , untile - -- ** ByteString Encoding / Decoding - , decode - , encode + , Lens' + , layers + , Layer(..) + , version + , name + , points + , linestrings + , polygons + , extent + , Feature(..) + , featureId + , metadata + , geometries + , Val(..) + -- * Geometries + , Point, x, y + , LineString(..) + , Polygon(..) + , area + , surveyor + , distance ) where -import Data.Text (Text) -import qualified Geography.VectorTile.Protobuf.Internal as PB -import Geography.VectorTile.Protobuf (decode, encode) +import Control.Monad ((>=>)) +import Data.Bifunctor (bimap) +import qualified Data.ByteString as BS +import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.Text (Text, pack) +import Geography.VectorTile.Internal (fromProtobuf, toProtobuf) import Geography.VectorTile.VectorTile +import Geography.VectorTile.Geometry +import Text.ProtocolBuffers.WireMessage (messageGet, messagePut) --- -tile :: PB.RawVectorTile -> Either Text VectorTile -tile = PB.fromProtobuf +-- | Attempt to parse a `VectorTile` from a strict collection of bytes. +tile :: BS.ByteString -> Either Text VectorTile +tile = bimap pack id . messageGet . fromStrict >=> fromProtobuf . fst -untile :: VectorTile -> PB.RawVectorTile -untile = PB.toProtobuf +-- | Convert a `VectorTile` back into bytes. +untile :: VectorTile -> BS.ByteString +untile = toStrict . messagePut . toProtobuf diff --git a/lib/Geography/VectorTile/Geometry.hs b/lib/Geography/VectorTile/Geometry.hs --- a/lib/Geography/VectorTile/Geometry.hs +++ b/lib/Geography/VectorTile/Geometry.hs @@ -3,14 +3,14 @@ -- | -- Module : Geography.VectorTile.Geometry --- Copyright : (c) Azavea, 2016 --- License : Apache 2 --- Maintainer: Colin Woodbury +-- Copyright : (c) Colin Woodbury 2016 - 2018 +-- License : BSD3 +-- Maintainer: Colin Woodbury module Geography.VectorTile.Geometry ( -- * Geometries -- ** Types - Point, x, y + Point, pattern Point, x, y , LineString(..) , Polygon(..) -- ** Operations @@ -20,7 +20,8 @@ ) where import Control.DeepSeq (NFData) -import qualified Data.Vector as V +import Data.Foldable (foldl') +import qualified Data.Sequence as Seq import qualified Data.Vector.Unboxed as U import GHC.Generics (Generic) @@ -40,27 +41,26 @@ instance NFData LineString -- | A polygon aware of its interior rings. +-- +-- 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 :: V.Vector Polygon } deriving (Eq,Show,Generic) + , inner :: Seq.Seq Polygon } deriving (Eq,Show,Generic) instance NFData Polygon -{- --- | Very performant for the same reason as `LineString`. -newtype Polygon = Polygon { points :: U.Vector Point } deriving (Eq,Show) --} - -- | The area of a `Polygon` is the difference between the areas of its -- outer ring and inner rings. -area :: Polygon -> Float -area p = surveyor (polyPoints p) + sum (V.map area $ inner p) +area :: Polygon -> Double +area p = surveyor (polyPoints p) + foldl' (\acc i -> acc + area i) 0 (inner p) -- | The surveyor's formula for calculating the area of a `Polygon`. -- 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 -> Float +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' @@ -68,7 +68,7 @@ yps = U.map y . U.init $ U.cons (U.last v') v' -- | Euclidean distance. -distance :: Point -> Point -> Float +distance :: Point -> Point -> Double distance p1 p2 = sqrt . fromIntegral $ dx ^ 2 + dy ^ 2 where dx = x p1 - x p2 dy = y p1 - y p2 diff --git a/lib/Geography/VectorTile/Internal.hs b/lib/Geography/VectorTile/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Geography/VectorTile/Internal.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + +-- | +-- Module : Geography.VectorTile.Internal +-- Copyright : (c) Colin Woodbury 2016 - 2018 +-- License : BSD3 +-- Maintainer: Colin Woodbury +-- +-- 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. + +module Geography.VectorTile.Internal + ( -- * Types + -- ** Protobuf Conversion + Protobuf(..) + , Protobuffable(..) + , ProtobufGeom(..) + -- ** Decoded Middle-Types + , Tile.Tile(Tile, layers) + , Layer.Layer(Layer, version, name, features, keys, values, extent) + , Feature.Feature(..) + , Value.Value(..) + , GeomType.GeomType(..) + -- * Commands + , Command(..) + , commands + , uncommands + -- * Z-Encoding + , zig + , unzig + -- * Protobuf Conversions + -- | Due to Protobuf Layers and Features having their data coupled, + -- we can't define a `Protobuffable` instance for `VT.Feature`s, + -- and instead must use the two functions below. + , feats + , unfeats + ) where + +import Control.Applicative ((<|>)) +import Control.Monad (void) +import Control.Monad.Trans.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 qualified Data.HashSet as HS +import Data.Maybe (fromJust) +import Data.Monoid +import qualified Data.Sequence as Seq +import Data.Sequence (Seq, (<|), (|>), Seq((:<|))) +import Data.Text (Text, pack) +import qualified Data.Vector.Unboxed as U +import Data.Word +import qualified Geography.VectorTile.Geometry as G +import qualified Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile as Tile +import qualified Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.Feature as Feature +import qualified Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.GeomType as GeomType +import qualified Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.Layer as Layer +import qualified Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.Value as Value +import Geography.VectorTile.Util +import qualified Geography.VectorTile.VectorTile as VT +import Text.Printf +import Text.ProtocolBuffers.Basic (defaultValue, Utf8(..), utf8) + +--- + +-- | A family of data types which can associated with concrete underlying +-- Protobuf types. +type family Protobuf a = pb | pb -> a +type instance Protobuf VT.VectorTile = Tile.Tile +type instance Protobuf VT.Layer = Layer.Layer +type instance Protobuf VT.Val = Value.Value + +-- | A type which can be converted to and from an underlying Protobuf type, +-- according to the `Protobuf` type family. +class Protobuffable a where + fromProtobuf :: Protobuf a -> Either Text a + toProtobuf :: a -> Protobuf a + +instance Protobuffable VT.VectorTile where + fromProtobuf raw = do + ls <- traverse fromProtobuf . toList $ Tile.layers raw + pure . VT.VectorTile . M.fromList $ map (\l -> (VT._name l, l)) ls + + toProtobuf vt = Tile.Tile { Tile.layers = Seq.fromList . map toProtobuf . M.elems $ VT._layers vt + , Tile.ext'field = defaultValue } + +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) } + + toProtobuf l = Layer.Layer { Layer.version = fromIntegral $ VT._version l + , Layer.name = Utf8 $ VT._name l + , Layer.features = fs + , Layer.keys = Seq.fromList $ map Utf8 ks + , Layer.values = Seq.fromList $ map toProtobuf vs + , Layer.extent = Just . fromIntegral $ VT._extent l + , Layer.ext'field = defaultValue } + where (ks,vs) = totalMeta (VT._points l) (VT._linestrings l) (VT._polygons l) + (km,vm) = (M.fromList $ zip ks [0..], M.fromList $ zip vs [0..]) + fs = fold [ fmap (unfeats km vm GeomType.POINT) (VT._points l) + , fmap (unfeats km vm GeomType.LINESTRING) (VT._linestrings l) + , fmap (unfeats km vm GeomType.POLYGON) (VT._polygons l) ] + +instance Protobuffable VT.Val where + fromProtobuf v = maybe (Left "Value decode: No legal Value type offered") Right $ + fmap (VT.St . utf8) (Value.string_value v) + <|> fmap VT.Fl (Value.float_value v) + <|> fmap VT.Do (Value.double_value v) + <|> fmap VT.I64 (Value.int_value v) + <|> fmap VT.W64 (Value.uint_value v) + <|> fmap VT.S64 (Value.sint_value v) + <|> fmap VT.B (Value.bool_value v) + + toProtobuf (VT.St v) = defaultValue { Value.string_value = Just $ Utf8 v } + toProtobuf (VT.Fl v) = defaultValue { Value.float_value = Just v } + toProtobuf (VT.Do v) = defaultValue { Value.double_value = Just v } + toProtobuf (VT.I64 v) = defaultValue { Value.int_value = Just v } + toProtobuf (VT.W64 v) = defaultValue { Value.uint_value = Just v } + toProtobuf (VT.S64 v) = defaultValue { Value.sint_value = Just v } + toProtobuf (VT.B v) = defaultValue { Value.bool_value = Just v } + +-- | 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 + +-- | 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!" + + -- | A multipoint geometry must reduce to a single `MoveTo` command. + toCommands ps = Seq.singleton (MoveTo $ evalState (traverse collapse ps) (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 + 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." + + toCommands ls = fold $ evalState (traverse f ls) (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 + +-- | 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 + 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 + 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 + + toCommands ps = fold $ evalState (traverse f ps) (0,0) + where f :: G.Polygon -> State (Int, Int) (Seq 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 + +-- | The possible commands, and the values they hold. +data Command = MoveTo (Seq (Int,Int)) + | LineTo (Seq (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) +{-# INLINE zig #-} + +-- | 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) +{-# 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 + 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 +{-# 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." + +-- | 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. + +{- FROM PROTOBUF -} + +-- | 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. +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.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) + 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 + _ -> Left "Geometry type of UNKNOWN given." + +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 + +{- TO PROTOBUF -} + +totalMeta :: Seq (VT.Feature G.Point) -> Seq (VT.Feature G.LineString) -> Seq (VT.Feature 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 + f = foldMap (HS.fromMap . void . VT._metadata) + 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 keys vals gt fe = Feature.Feature + { Feature.id = Just . fromIntegral $ VT._featureId fe + , Feature.tags = Seq.fromList $ tags fe + , Feature.type' = Just gt + , Feature.geometry = uncommands . toCommands $ VT._geometries fe } + where tags = unpairs . map f . M.toList . VT._metadata + f (k,v) = (fromIntegral . fromJust $ M.lookup k keys, fromIntegral . fromJust $ M.lookup v vals) + +{- 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 + +-- | 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 + +-- | 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 diff --git a/lib/Geography/VectorTile/Protobuf.hs b/lib/Geography/VectorTile/Protobuf.hs deleted file mode 100644 --- a/lib/Geography/VectorTile/Protobuf.hs +++ /dev/null @@ -1,59 +0,0 @@ --- | --- Module : Geography.VectorTile.Protobuf --- Copyright : (c) Azavea, 2016 --- License : Apache 2 --- Maintainer: Colin Woodbury --- --- Most of the details of Protobuf conversion are kept in --- "Geometry.VectorTile.Protobuf.Internal", a module which is not intended --- to be imported. --- --- A user's main concern here should be the `Protobuffable` class, and its --- `VectorTile` instance. With it, one can do the following: --- --- > import Geography.VectorTile.Protobuf --- > --- > decode bytes >>= fromProtobuf -- Either Text VectorTile --- --- which in fact is sugared in the top-level module of this library as: --- --- > decode bytes >>= tile - -module Geography.VectorTile.Protobuf - ( -- * Types - Protobuffable(..) - -- * ByteString Encoding / Decoding - , decode - , encode - , decodeIO - , encodeIO - ) where - -import qualified Data.ByteString as BS -import Data.ProtocolBuffers hiding (decode, encode) -import Data.Serialize.Get -import Data.Serialize.Put -import Data.Text (Text, pack) -import Geography.VectorTile.Protobuf.Internal - ---- - --- | 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 diff --git a/lib/Geography/VectorTile/Protobuf/Internal.hs b/lib/Geography/VectorTile/Protobuf/Internal.hs deleted file mode 100644 --- a/lib/Geography/VectorTile/Protobuf/Internal.hs +++ /dev/null @@ -1,410 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilyDependencies #-} - --- | --- Module : Geography.VectorTile.Protobuf.Internal --- Copyright : (c) Azavea, 2016 - 2017 --- License : Apache 2 --- Maintainer: Colin Woodbury --- --- 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.VectorTile" for the user-friendly version. --- --- Please import this module @qualified@ to avoid namespace clashes: --- --- > import qualified Geography.VectorTile.Protobuf.Internal as PB - -module Geography.VectorTile.Protobuf.Internal - ( -- * Types - Protobuf(..) - , Protobuffable(..) - , ProtobufGeom(..) - , RawVectorTile(..) - , RawLayer(..) - , RawVal(..) - , RawFeature(..) - , GeomType(..) - -- * Commands - , Command(..) - , commands - , uncommands - -- * Z-Encoding - , zig - , unzig - -- * Protobuf Conversions - -- | Due to Protobuf Layers and Features having their data coupled, - -- we can't define a `Protobuffable` instance for `VT.Feature`s, - -- and instead must use the two functions below. - , features - , unfeature - ) where - -import Control.Applicative ((<|>)) -import Control.DeepSeq (NFData) -import Control.Monad.Trans.State.Lazy -import Data.Bits -import Data.Foldable (foldrM, foldlM) -import Data.Int -import Data.List (nub) -import qualified Data.Map.Lazy as M -import Data.Maybe (fromJust) -import Data.Monoid -import Data.ProtocolBuffers hiding (decode, encode) -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.Geometry as G -import Geography.VectorTile.Util -import qualified Geography.VectorTile.VectorTile as VT -import Text.Printf - ---- - --- | A family of data types which can associated with concrete underlying --- Protobuf types. -type family Protobuf a = pb | pb -> a -type instance Protobuf VT.VectorTile = RawVectorTile -type instance Protobuf VT.Layer = RawLayer -type instance Protobuf VT.Val = RawVal - --- | A type which can be converted to and from an underlying Protobuf type, --- according to the `Protobuf` type family. -class Protobuffable a where - fromProtobuf :: Protobuf a -> Either Text a - toProtobuf :: a -> Protobuf a - -instance Protobuffable VT.VectorTile where - fromProtobuf raw = do - ls <- mapM fromProtobuf . getField $ _layers raw - pure . VT.VectorTile . M.fromList $ map (\l -> (VT._name l, l)) ls - - toProtobuf vt = RawVectorTile { _layers = putField . map toProtobuf . M.elems $ VT._layers vt } - -instance Protobuffable VT.Layer where - fromProtobuf 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 - - toProtobuf l = RawLayer { _version = putField . fromIntegral $ VT._version l - , _name = putField $ VT._name l - , _features = putField fs - , _keys = putField ks - , _values = putField $ map toProtobuf vs - , _extent = putField . Just . fromIntegral $ VT._extent l } - where (ks,vs) = totalMeta (VT._points l) (VT._linestrings l) (VT._polygons l) - (km,vm) = (M.fromList $ zip ks [0..], M.fromList $ zip vs [0..]) - fs = V.toList $ V.concat [ V.map (unfeature km vm Point) (VT._points l) - , V.map (unfeature km vm LineString) (VT._linestrings l) - , V.map (unfeature km vm Polygon) (VT._polygons l) ] - -instance Protobuffable VT.Val where - fromProtobuf 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) - - toProtobuf (VT.St v) = def { _string = putField $ Just v } - toProtobuf (VT.Fl v) = def { _float = putField $ Just v } - toProtobuf (VT.Do v) = def { _double = putField $ Just v } - toProtobuf (VT.I64 v) = def { _int64 = putField $ Just v } - toProtobuf (VT.W64 v) = def { _uint64 = putField $ Just v } - toProtobuf (VT.S64 v) = def { _sint = putField . Just $ Signed v } - toProtobuf (VT.B v) = def { _bool = putField $ Just v } - --- | 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] - --- | 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 . 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 = [MoveTo $ evalState (U.mapM collapse $ U.convert ps) (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 : 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 - l <- U.mapM collapse ps - pure [MoveTo . U.singleton $ U.head l, LineTo $ U.tail l] - --- | 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 . 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 $ 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 - l <- U.mapM collapse $ U.init p -- Exclude the final point. - let cs = [MoveTo . U.singleton $ U.head l, LineTo $ U.tail 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 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 . pack $ 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 - --- | 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. - -{- FROM PROTOBUF -} - --- | 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 - -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) <$> fromProtobuf (vals !! v)) M.empty kv - -{- TO PROTOBUF -} - -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 (\feat acc -> M.keysSet (VT._metadata feat) : acc) [] - g = V.foldr (\feat acc -> M.elems (VT._metadata feat) : acc) [] - --- | Encode a high-level `Feature` back into its mid-level `RawFeature` form. -unfeature :: ProtobufGeom g => M.Map Text Int -> M.Map VT.Val Int -> GeomType -> VT.Feature g -> RawFeature -unfeature keys vals gt fe = RawFeature - { _featureId = putField . Just . fromIntegral $ VT._featureId fe - , _tags = putField $ tags fe - , _geom = putField $ Just gt - , _geometries = putField . uncommands . toCommands $ VT._geometries fe } - where tags = unpairs . map f . M.toList . VT._metadata - f (k,v) = both (fromIntegral . fromJust) (M.lookup k keys, M.lookup v vals) - -{- 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 diff --git a/lib/Geography/VectorTile/Protobuf/Internal/Vector_tile.hs b/lib/Geography/VectorTile/Protobuf/Internal/Vector_tile.hs new file mode 100644 --- /dev/null +++ b/lib/Geography/VectorTile/Protobuf/Internal/Vector_tile.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Geography.VectorTile.Protobuf.Internal.Vector_tile (protoInfo, fileDescriptorProto) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import Text.DescriptorProtos.FileDescriptorProto (FileDescriptorProto) +import Text.ProtocolBuffers.Reflections (ProtoInfo) +import qualified Text.ProtocolBuffers.WireMessage as P' (wireGet,getFromBS) + +protoInfo :: ProtoInfo +protoInfo + = Prelude'.read + "ProtoInfo {protoMod = ProtoName {protobufName = FIName \".vector_tile\", haskellPrefix = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule = [], baseName = MName \"Vector_tile\"}, protoFilePath = [\"Geography\",\"VectorTile\",\"Protobuf\",\"Internal\",\"Vector_tile.hs\"], protoSource = \"vector_tile.proto\", extensionKeys = fromList [], messages = [DescriptorInfo {descName = ProtoName {protobufName = FIName \".vector_tile.Tile\", haskellPrefix = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule = [MName \"Vector_tile\"], baseName = MName \"Tile\"}, descFilePath = [\"Geography\",\"VectorTile\",\"Protobuf\",\"Internal\",\"Vector_tile\",\"Tile.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.layers\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\"], baseName' = FName \"layers\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 26}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".vector_tile.Tile.Layer\", haskellPrefix = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule = [MName \"Vector_tile\",MName \"Tile\"], baseName = MName \"Layer\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [(FieldId {getFieldId = 16},FieldId {getFieldId = 8191})], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".vector_tile.Tile.Value\", haskellPrefix = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule = [MName \"Vector_tile\",MName \"Tile\"], baseName = MName \"Value\"}, descFilePath = [\"Geography\",\"VectorTile\",\"Protobuf\",\"Internal\",\"Vector_tile\",\"Tile\",\"Value.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Value.string_value\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Value\"], baseName' = FName \"string_value\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Value.float_value\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Value\"], baseName' = FName \"float_value\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 21}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 2}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Value.double_value\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Value\"], baseName' = FName \"double_value\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 25}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 1}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Value.int_value\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Value\"], baseName' = FName \"int_value\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 4}, wireTag = WireTag {getWireTag = 32}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 3}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Value.uint_value\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Value\"], baseName' = FName \"uint_value\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 5}, wireTag = WireTag {getWireTag = 40}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 4}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Value.sint_value\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Value\"], baseName' = FName \"sint_value\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 6}, wireTag = WireTag {getWireTag = 48}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 18}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Value.bool_value\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Value\"], baseName' = FName \"bool_value\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 7}, wireTag = WireTag {getWireTag = 56}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 8}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [(FieldId {getFieldId = 8},FieldId {getFieldId = 18999}),(FieldId {getFieldId = 20000},FieldId {getFieldId = 536870911})], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".vector_tile.Tile.Feature\", haskellPrefix = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule = [MName \"Vector_tile\",MName \"Tile\"], baseName = MName \"Feature\"}, descFilePath = [\"Geography\",\"VectorTile\",\"Protobuf\",\"Internal\",\"Vector_tile\",\"Tile\",\"Feature.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Feature.id\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Feature\"], baseName' = FName \"id\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 4}, typeName = Nothing, hsRawDefault = Just \"0\", hsDefault = Just (HsDef'Integer 0)},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Feature.tags\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Feature\"], baseName' = FName \"tags\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Just (WireTag {getWireTag = 16},WireTag {getWireTag = 18}), wireTagLength = 1, isPacked = True, isRequired = False, canRepeat = True, mightPack = True, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Feature.type\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Feature\"], baseName' = FName \"type'\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 24}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 14}, typeName = Just (ProtoName {protobufName = FIName \".vector_tile.Tile.GeomType\", haskellPrefix = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule = [MName \"Vector_tile\",MName \"Tile\"], baseName = MName \"GeomType\"}), hsRawDefault = Just \"UNKNOWN\", hsDefault = Just (HsDef'Enum \"UNKNOWN\")},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Feature.geometry\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Feature\"], baseName' = FName \"geometry\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 4}, wireTag = WireTag {getWireTag = 34}, packedTag = Just (WireTag {getWireTag = 32},WireTag {getWireTag = 34}), wireTagLength = 1, isPacked = True, isRequired = False, canRepeat = True, mightPack = True, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False},DescriptorInfo {descName = ProtoName {protobufName = FIName \".vector_tile.Tile.Layer\", haskellPrefix = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule = [MName \"Vector_tile\",MName \"Tile\"], baseName = MName \"Layer\"}, descFilePath = [\"Geography\",\"VectorTile\",\"Protobuf\",\"Internal\",\"Vector_tile\",\"Tile\",\"Layer.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Layer.version\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Layer\"], baseName' = FName \"version\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 15}, wireTag = WireTag {getWireTag = 120}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Just \"1\", hsDefault = Just (HsDef'Integer 1)},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Layer.name\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Layer\"], baseName' = FName \"name\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Layer.features\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Layer\"], baseName' = FName \"features\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".vector_tile.Tile.Feature\", haskellPrefix = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule = [MName \"Vector_tile\",MName \"Tile\"], baseName = MName \"Feature\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Layer.keys\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Layer\"], baseName' = FName \"keys\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 26}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Layer.values\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Layer\"], baseName' = FName \"values\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 4}, wireTag = WireTag {getWireTag = 34}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".vector_tile.Tile.Value\", haskellPrefix = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule = [MName \"Vector_tile\",MName \"Tile\"], baseName = MName \"Value\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Layer.extent\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Layer\"], baseName' = FName \"extent\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 5}, wireTag = WireTag {getWireTag = 40}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Just \"4096\", hsDefault = Just (HsDef'Integer 4096)}], descOneofs = fromList [], keys = fromList [], extRanges = [(FieldId {getFieldId = 16},FieldId {getFieldId = 18999}),(FieldId {getFieldId = 20000},FieldId {getFieldId = 536870911})], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}], enums = [EnumInfo {enumName = ProtoName {protobufName = FIName \".vector_tile.Tile.GeomType\", haskellPrefix = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule = [MName \"Vector_tile\",MName \"Tile\"], baseName = MName \"GeomType\"}, enumFilePath = [\"Geography\",\"VectorTile\",\"Protobuf\",\"Internal\",\"Vector_tile\",\"Tile\",\"GeomType.hs\"], enumValues = [(EnumCode {getEnumCode = 0},\"UNKNOWN\"),(EnumCode {getEnumCode = 1},\"POINT\"),(EnumCode {getEnumCode = 2},\"LINESTRING\"),(EnumCode {getEnumCode = 3},\"POLYGON\")]}], oneofs = [], knownKeyMap = fromList []}" + +fileDescriptorProto :: FileDescriptorProto +fileDescriptorProto + = P'.getFromBS (P'.wireGet 11) + (P'.pack + "\147\ENQ\n\DC1vector_tile.proto\DC2\vvector_tile\"\213\EOT\n\EOTTile\DC2'\n\ACKlayers\CAN\ETX \ETX(\v2\ETB.vector_tile.Tile.Layer\SUB\161\SOH\n\ENQValue\DC2\DC4\n\fstring_value\CAN\SOH \SOH(\t\DC2\DC3\n\vfloat_value\CAN\STX \SOH(\STX\DC2\DC4\n\fdouble_value\CAN\ETX \SOH(\SOH\DC2\DC1\n\tint_value\CAN\EOT \SOH(\ETX\DC2\DC2\n\nuint_value\CAN\ENQ \SOH(\EOT\DC2\DC2\n\nsint_value\CAN\ACK \SOH(\DC2\DC2\DC2\n\nbool_value\CAN\a \SOH(\b*\b\b\b\DLE\128\128\128\128\STX\SUB\135\SOH\n\aFeature\DC2\r\n\STXid\CAN\SOH \SOH(\EOT:\SOH0\DC2\SUB\n\EOTtags\CAN\STX \ETX(\rB\f\b\NUL\DLE\SOH\CAN\NUL(\NUL0\NULP\NUL\DC21\n\EOTtype\CAN\ETX \SOH(\SO2\SUB.vector_tile.Tile.GeomType:\aUNKNOWN\DC2\RS\n\bgeometry\CAN\EOT \ETX(\rB\f\b\NUL\DLE\SOH\CAN\NUL(\NUL0\NULP\NUL\SUB\173\SOH\n\ENQLayer\DC2\DC2\n\aversion\CAN\SI \STX(\r:\SOH1\DC2\f\n\EOTname\CAN\SOH \STX(\t\DC2+\n\bfeatures\CAN\STX \ETX(\v2\EM.vector_tile.Tile.Feature\DC2\f\n\EOTkeys\CAN\ETX \ETX(\t\DC2'\n\ACKvalues\CAN\EOT \ETX(\v2\ETB.vector_tile.Tile.Value\DC2\DC4\n\ACKextent\CAN\ENQ \SOH(\r:\EOT4096*\b\b\DLE\DLE\128\128\128\128\STX\"?\n\bGeomType\DC2\v\n\aUNKNOWN\DLE\NUL\DC2\t\n\ENQPOINT\DLE\SOH\DC2\SO\n\nLINESTRING\DLE\STX\DC2\v\n\aPOLYGON\DLE\ETX*\ENQ\b\DLE\DLE\128@B\EMH\ETXP\NUL\128\SOH\NUL\136\SOH\NUL\144\SOH\NUL\160\SOH\NUL\184\SOH\NUL\216\SOH\NUL\248\SOH\NUL") diff --git a/lib/Geography/VectorTile/Protobuf/Internal/Vector_tile/Tile.hs b/lib/Geography/VectorTile/Protobuf/Internal/Vector_tile/Tile.hs new file mode 100644 --- /dev/null +++ b/lib/Geography/VectorTile/Protobuf/Internal/Vector_tile/Tile.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile (Tile(..)) where +import Prelude ((+), (/), (==), (<=), (&&)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import qualified Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.Layer as Vector_tile.Tile (Layer) + +data Tile = Tile{layers :: !(P'.Seq Vector_tile.Tile.Layer), ext'field :: !(P'.ExtField)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.ExtendMessage Tile where + getExtField = ext'field + putExtField e'f msg = msg{ext'field = e'f} + validExtRanges msg = P'.extRanges (P'.reflectDescriptorInfo msg) + +instance P'.Mergeable Tile where + mergeAppend (Tile x'1 x'2) (Tile y'1 y'2) = Tile (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) + +instance P'.Default Tile where + defaultValue = Tile P'.defaultValue P'.defaultValue + +instance P'.Wire Tile where + wireSize ft' self'@(Tile x'1 x'2) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeRep 1 11 x'1 + P'.wireSizeExtField x'2) + wirePut ft' self'@(Tile x'1 x'2) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutRep 26 11 x'1 + P'.wirePutExtField x'2 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 26 -> Prelude'.fmap (\ !new'Field -> old'Self{layers = P'.append (layers old'Self) new'Field}) (P'.wireGet 11) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in + if Prelude'.or [16 <= field'Number && field'Number <= 8191] then P'.loadExtension field'Number wire'Type old'Self + else P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> Tile) Tile where + getVal m' f' = f' m' + +instance P'.GPB Tile + +instance P'.ReflectDescriptor Tile where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [26]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".vector_tile.Tile\", haskellPrefix = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule = [MName \"Vector_tile\"], baseName = MName \"Tile\"}, descFilePath = [\"Geography\",\"VectorTile\",\"Protobuf\",\"Internal\",\"Vector_tile\",\"Tile.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.layers\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\"], baseName' = FName \"layers\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 26}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".vector_tile.Tile.Layer\", haskellPrefix = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule = [MName \"Vector_tile\",MName \"Tile\"], baseName = MName \"Layer\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [(FieldId {getFieldId = 16},FieldId {getFieldId = 8191})], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType Tile where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg Tile where + textPut msg + = do + P'.tellT "layers" (layers msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'layers]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'layers + = P'.try + (do + v <- P'.getT "layers" + Prelude'.return (\ o -> o{layers = P'.append (layers o) v})) diff --git a/lib/Geography/VectorTile/Protobuf/Internal/Vector_tile/Tile/Feature.hs b/lib/Geography/VectorTile/Protobuf/Internal/Vector_tile/Tile/Feature.hs new file mode 100644 --- /dev/null +++ b/lib/Geography/VectorTile/Protobuf/Internal/Vector_tile/Tile/Feature.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.Feature (Feature(..)) where +import Prelude ((+), (/)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import qualified Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.GeomType as Vector_tile.Tile (GeomType) + +data Feature = Feature{id :: !(P'.Maybe P'.Word64), tags :: !(P'.Seq P'.Word32), type' :: !(P'.Maybe Vector_tile.Tile.GeomType), + geometry :: !(P'.Seq P'.Word32)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable Feature where + mergeAppend (Feature x'1 x'2 x'3 x'4) (Feature y'1 y'2 y'3 y'4) + = Feature (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) (P'.mergeAppend x'3 y'3) (P'.mergeAppend x'4 y'4) + +instance P'.Default Feature where + defaultValue = Feature (Prelude'.Just 0) P'.defaultValue (Prelude'.Just (Prelude'.read "UNKNOWN")) P'.defaultValue + +instance P'.Wire Feature where + wireSize ft' self'@(Feature x'1 x'2 x'3 x'4) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size = (P'.wireSizeOpt 1 4 x'1 + P'.wireSizePacked 1 13 x'2 + P'.wireSizeOpt 1 14 x'3 + P'.wireSizePacked 1 13 x'4) + wirePut ft' self'@(Feature x'1 x'2 x'3 x'4) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutOpt 8 4 x'1 + P'.wirePutPacked 18 13 x'2 + P'.wirePutOpt 24 14 x'3 + P'.wirePutPacked 34 13 x'4 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 8 -> Prelude'.fmap (\ !new'Field -> old'Self{id = Prelude'.Just new'Field}) (P'.wireGet 4) + 16 -> Prelude'.fmap (\ !new'Field -> old'Self{tags = P'.append (tags old'Self) new'Field}) (P'.wireGet 13) + 18 -> Prelude'.fmap (\ !new'Field -> old'Self{tags = P'.mergeAppend (tags old'Self) new'Field}) (P'.wireGetPacked 13) + 24 -> Prelude'.fmap (\ !new'Field -> old'Self{type' = Prelude'.Just new'Field}) (P'.wireGet 14) + 32 -> Prelude'.fmap (\ !new'Field -> old'Self{geometry = P'.append (geometry old'Self) new'Field}) (P'.wireGet 13) + 34 -> Prelude'.fmap (\ !new'Field -> old'Self{geometry = P'.mergeAppend (geometry old'Self) new'Field}) + (P'.wireGetPacked 13) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> Feature) Feature where + getVal m' f' = f' m' + +instance P'.GPB Feature + +instance P'.ReflectDescriptor Feature where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [8, 16, 18, 24, 32, 34]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".vector_tile.Tile.Feature\", haskellPrefix = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule = [MName \"Vector_tile\",MName \"Tile\"], baseName = MName \"Feature\"}, descFilePath = [\"Geography\",\"VectorTile\",\"Protobuf\",\"Internal\",\"Vector_tile\",\"Tile\",\"Feature.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Feature.id\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Feature\"], baseName' = FName \"id\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 4}, typeName = Nothing, hsRawDefault = Just \"0\", hsDefault = Just (HsDef'Integer 0)},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Feature.tags\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Feature\"], baseName' = FName \"tags\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Just (WireTag {getWireTag = 16},WireTag {getWireTag = 18}), wireTagLength = 1, isPacked = True, isRequired = False, canRepeat = True, mightPack = True, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Feature.type\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Feature\"], baseName' = FName \"type'\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 24}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 14}, typeName = Just (ProtoName {protobufName = FIName \".vector_tile.Tile.GeomType\", haskellPrefix = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule = [MName \"Vector_tile\",MName \"Tile\"], baseName = MName \"GeomType\"}), hsRawDefault = Just \"UNKNOWN\", hsDefault = Just (HsDef'Enum \"UNKNOWN\")},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Feature.geometry\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Feature\"], baseName' = FName \"geometry\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 4}, wireTag = WireTag {getWireTag = 34}, packedTag = Just (WireTag {getWireTag = 32},WireTag {getWireTag = 34}), wireTagLength = 1, isPacked = True, isRequired = False, canRepeat = True, mightPack = True, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType Feature where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg Feature where + textPut msg + = do + P'.tellT "id" (id msg) + P'.tellT "tags" (tags msg) + P'.tellT "type" (type' msg) + P'.tellT "geometry" (geometry msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'id, parse'tags, parse'type', parse'geometry]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'id + = P'.try + (do + v <- P'.getT "id" + Prelude'.return (\ o -> o{id = v})) + parse'tags + = P'.try + (do + v <- P'.getT "tags" + Prelude'.return (\ o -> o{tags = P'.append (tags o) v})) + parse'type' + = P'.try + (do + v <- P'.getT "type" + Prelude'.return (\ o -> o{type' = v})) + parse'geometry + = P'.try + (do + v <- P'.getT "geometry" + Prelude'.return (\ o -> o{geometry = P'.append (geometry o) v})) diff --git a/lib/Geography/VectorTile/Protobuf/Internal/Vector_tile/Tile/GeomType.hs b/lib/Geography/VectorTile/Protobuf/Internal/Vector_tile/Tile/GeomType.hs new file mode 100644 --- /dev/null +++ b/lib/Geography/VectorTile/Protobuf/Internal/Vector_tile/Tile/GeomType.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.GeomType (GeomType(..)) where +import Prelude ((+), (/), (.)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' + +data GeomType = UNKNOWN + | POINT + | LINESTRING + | POLYGON + deriving (Prelude'.Read, Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.Mergeable GeomType + +instance Prelude'.Bounded GeomType where + minBound = UNKNOWN + maxBound = POLYGON + +instance P'.Default GeomType where + defaultValue = UNKNOWN + +toMaybe'Enum :: Prelude'.Int -> P'.Maybe GeomType +toMaybe'Enum 0 = Prelude'.Just UNKNOWN +toMaybe'Enum 1 = Prelude'.Just POINT +toMaybe'Enum 2 = Prelude'.Just LINESTRING +toMaybe'Enum 3 = Prelude'.Just POLYGON +toMaybe'Enum _ = Prelude'.Nothing + +instance Prelude'.Enum GeomType where + fromEnum UNKNOWN = 0 + fromEnum POINT = 1 + fromEnum LINESTRING = 2 + fromEnum POLYGON = 3 + toEnum + = P'.fromMaybe + (Prelude'.error + "hprotoc generated code: toEnum failure for type Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.GeomType") + . toMaybe'Enum + succ UNKNOWN = POINT + succ POINT = LINESTRING + succ LINESTRING = POLYGON + succ _ + = Prelude'.error "hprotoc generated code: succ failure for type Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.GeomType" + pred POINT = UNKNOWN + pred LINESTRING = POINT + pred POLYGON = LINESTRING + pred _ + = Prelude'.error "hprotoc generated code: pred failure for type Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.GeomType" + +instance P'.Wire GeomType where + wireSize ft' enum = P'.wireSize ft' (Prelude'.fromEnum enum) + wirePut ft' enum = P'.wirePut ft' (Prelude'.fromEnum enum) + wireGet 14 = P'.wireGetEnum toMaybe'Enum + wireGet ft' = P'.wireGetErr ft' + wireGetPacked 14 = P'.wireGetPackedEnum toMaybe'Enum + wireGetPacked ft' = P'.wireGetErr ft' + +instance P'.GPB GeomType + +instance P'.MessageAPI msg' (msg' -> GeomType) GeomType where + getVal m' f' = f' m' + +instance P'.ReflectEnum GeomType where + reflectEnum = [(0, "UNKNOWN", UNKNOWN), (1, "POINT", POINT), (2, "LINESTRING", LINESTRING), (3, "POLYGON", POLYGON)] + reflectEnumInfo _ + = P'.EnumInfo + (P'.makePNF (P'.pack ".vector_tile.Tile.GeomType") ["Geography", "VectorTile", "Protobuf", "Internal"] ["Vector_tile", "Tile"] + "GeomType") + ["Geography", "VectorTile", "Protobuf", "Internal", "Vector_tile", "Tile", "GeomType.hs"] + [(0, "UNKNOWN"), (1, "POINT"), (2, "LINESTRING"), (3, "POLYGON")] + +instance P'.TextType GeomType where + tellT = P'.tellShow + getT = P'.getRead diff --git a/lib/Geography/VectorTile/Protobuf/Internal/Vector_tile/Tile/Layer.hs b/lib/Geography/VectorTile/Protobuf/Internal/Vector_tile/Tile/Layer.hs new file mode 100644 --- /dev/null +++ b/lib/Geography/VectorTile/Protobuf/Internal/Vector_tile/Tile/Layer.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.Layer (Layer(..)) where +import Prelude ((+), (/), (==), (<=), (&&)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' +import qualified Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.Feature as Vector_tile.Tile (Feature) +import qualified Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.Value as Vector_tile.Tile (Value) + +data Layer = Layer{version :: !(P'.Word32), name :: !(P'.Utf8), features :: !(P'.Seq Vector_tile.Tile.Feature), + keys :: !(P'.Seq P'.Utf8), values :: !(P'.Seq Vector_tile.Tile.Value), extent :: !(P'.Maybe P'.Word32), + ext'field :: !(P'.ExtField)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.ExtendMessage Layer where + getExtField = ext'field + putExtField e'f msg = msg{ext'field = e'f} + validExtRanges msg = P'.extRanges (P'.reflectDescriptorInfo msg) + +instance P'.Mergeable Layer where + mergeAppend (Layer x'1 x'2 x'3 x'4 x'5 x'6 x'7) (Layer y'1 y'2 y'3 y'4 y'5 y'6 y'7) + = Layer (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) (P'.mergeAppend x'3 y'3) (P'.mergeAppend x'4 y'4) + (P'.mergeAppend x'5 y'5) + (P'.mergeAppend x'6 y'6) + (P'.mergeAppend x'7 y'7) + +instance P'.Default Layer where + defaultValue = Layer 1 P'.defaultValue P'.defaultValue P'.defaultValue P'.defaultValue (Prelude'.Just 4096) P'.defaultValue + +instance P'.Wire Layer where + wireSize ft' self'@(Layer x'1 x'2 x'3 x'4 x'5 x'6 x'7) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size + = (P'.wireSizeReq 1 13 x'1 + P'.wireSizeReq 1 9 x'2 + P'.wireSizeRep 1 11 x'3 + P'.wireSizeRep 1 9 x'4 + + P'.wireSizeRep 1 11 x'5 + + P'.wireSizeOpt 1 13 x'6 + + P'.wireSizeExtField x'7) + wirePut ft' self'@(Layer x'1 x'2 x'3 x'4 x'5 x'6 x'7) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutReq 10 9 x'2 + P'.wirePutRep 18 11 x'3 + P'.wirePutRep 26 9 x'4 + P'.wirePutRep 34 11 x'5 + P'.wirePutOpt 40 13 x'6 + P'.wirePutReq 120 13 x'1 + P'.wirePutExtField x'7 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 120 -> Prelude'.fmap (\ !new'Field -> old'Self{version = new'Field}) (P'.wireGet 13) + 10 -> Prelude'.fmap (\ !new'Field -> old'Self{name = new'Field}) (P'.wireGet 9) + 18 -> Prelude'.fmap (\ !new'Field -> old'Self{features = P'.append (features old'Self) new'Field}) (P'.wireGet 11) + 26 -> Prelude'.fmap (\ !new'Field -> old'Self{keys = P'.append (keys old'Self) new'Field}) (P'.wireGet 9) + 34 -> Prelude'.fmap (\ !new'Field -> old'Self{values = P'.append (values old'Self) new'Field}) (P'.wireGet 11) + 40 -> Prelude'.fmap (\ !new'Field -> old'Self{extent = Prelude'.Just new'Field}) (P'.wireGet 13) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in + if Prelude'.or [16 <= field'Number && field'Number <= 18999, 20000 <= field'Number] then + P'.loadExtension field'Number wire'Type old'Self else P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> Layer) Layer where + getVal m' f' = f' m' + +instance P'.GPB Layer + +instance P'.ReflectDescriptor Layer where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [10, 120]) (P'.fromDistinctAscList [10, 18, 26, 34, 40, 120]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".vector_tile.Tile.Layer\", haskellPrefix = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule = [MName \"Vector_tile\",MName \"Tile\"], baseName = MName \"Layer\"}, descFilePath = [\"Geography\",\"VectorTile\",\"Protobuf\",\"Internal\",\"Vector_tile\",\"Tile\",\"Layer.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Layer.version\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Layer\"], baseName' = FName \"version\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 15}, wireTag = WireTag {getWireTag = 120}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Just \"1\", hsDefault = Just (HsDef'Integer 1)},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Layer.name\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Layer\"], baseName' = FName \"name\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Layer.features\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Layer\"], baseName' = FName \"features\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".vector_tile.Tile.Feature\", haskellPrefix = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule = [MName \"Vector_tile\",MName \"Tile\"], baseName = MName \"Feature\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Layer.keys\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Layer\"], baseName' = FName \"keys\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 26}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Layer.values\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Layer\"], baseName' = FName \"values\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 4}, wireTag = WireTag {getWireTag = 34}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".vector_tile.Tile.Value\", haskellPrefix = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule = [MName \"Vector_tile\",MName \"Tile\"], baseName = MName \"Value\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Layer.extent\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Layer\"], baseName' = FName \"extent\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 5}, wireTag = WireTag {getWireTag = 40}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 13}, typeName = Nothing, hsRawDefault = Just \"4096\", hsDefault = Just (HsDef'Integer 4096)}], descOneofs = fromList [], keys = fromList [], extRanges = [(FieldId {getFieldId = 16},FieldId {getFieldId = 18999}),(FieldId {getFieldId = 20000},FieldId {getFieldId = 536870911})], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType Layer where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg Layer where + textPut msg + = do + P'.tellT "version" (version msg) + P'.tellT "name" (name msg) + P'.tellT "features" (features msg) + P'.tellT "keys" (keys msg) + P'.tellT "values" (values msg) + P'.tellT "extent" (extent msg) + textGet + = do + mods <- P'.sepEndBy (P'.choice [parse'version, parse'name, parse'features, parse'keys, parse'values, parse'extent]) P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'version + = P'.try + (do + v <- P'.getT "version" + Prelude'.return (\ o -> o{version = v})) + parse'name + = P'.try + (do + v <- P'.getT "name" + Prelude'.return (\ o -> o{name = v})) + parse'features + = P'.try + (do + v <- P'.getT "features" + Prelude'.return (\ o -> o{features = P'.append (features o) v})) + parse'keys + = P'.try + (do + v <- P'.getT "keys" + Prelude'.return (\ o -> o{keys = P'.append (keys o) v})) + parse'values + = P'.try + (do + v <- P'.getT "values" + Prelude'.return (\ o -> o{values = P'.append (values o) v})) + parse'extent + = P'.try + (do + v <- P'.getT "extent" + Prelude'.return (\ o -> o{extent = v})) diff --git a/lib/Geography/VectorTile/Protobuf/Internal/Vector_tile/Tile/Value.hs b/lib/Geography/VectorTile/Protobuf/Internal/Vector_tile/Tile/Value.hs new file mode 100644 --- /dev/null +++ b/lib/Geography/VectorTile/Protobuf/Internal/Vector_tile/Tile/Value.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Geography.VectorTile.Protobuf.Internal.Vector_tile.Tile.Value (Value(..)) where +import Prelude ((+), (/), (==), (<=), (&&)) +import qualified Prelude as Prelude' +import qualified Data.Typeable as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Data.Data as Prelude' +import qualified Text.ProtocolBuffers.Header as P' + +data Value = Value{string_value :: !(P'.Maybe P'.Utf8), float_value :: !(P'.Maybe P'.Float), double_value :: !(P'.Maybe P'.Double), + int_value :: !(P'.Maybe P'.Int64), uint_value :: !(P'.Maybe P'.Word64), sint_value :: !(P'.Maybe P'.Int64), + bool_value :: !(P'.Maybe P'.Bool), ext'field :: !(P'.ExtField)} + deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) + +instance P'.ExtendMessage Value where + getExtField = ext'field + putExtField e'f msg = msg{ext'field = e'f} + validExtRanges msg = P'.extRanges (P'.reflectDescriptorInfo msg) + +instance P'.Mergeable Value where + mergeAppend (Value x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8) (Value y'1 y'2 y'3 y'4 y'5 y'6 y'7 y'8) + = Value (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) (P'.mergeAppend x'3 y'3) (P'.mergeAppend x'4 y'4) + (P'.mergeAppend x'5 y'5) + (P'.mergeAppend x'6 y'6) + (P'.mergeAppend x'7 y'7) + (P'.mergeAppend x'8 y'8) + +instance P'.Default Value where + defaultValue + = Value P'.defaultValue P'.defaultValue P'.defaultValue P'.defaultValue P'.defaultValue P'.defaultValue P'.defaultValue + P'.defaultValue + +instance P'.Wire Value where + wireSize ft' self'@(Value x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8) + = case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' + where + calc'Size + = (P'.wireSizeOpt 1 9 x'1 + P'.wireSizeOpt 1 2 x'2 + P'.wireSizeOpt 1 1 x'3 + P'.wireSizeOpt 1 3 x'4 + + P'.wireSizeOpt 1 4 x'5 + + P'.wireSizeOpt 1 18 x'6 + + P'.wireSizeOpt 1 8 x'7 + + P'.wireSizeExtField x'8) + wirePut ft' self'@(Value x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8) + = case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') + put'Fields + _ -> P'.wirePutErr ft' self' + where + put'Fields + = do + P'.wirePutOpt 10 9 x'1 + P'.wirePutOpt 21 2 x'2 + P'.wirePutOpt 25 1 x'3 + P'.wirePutOpt 32 3 x'4 + P'.wirePutOpt 40 4 x'5 + P'.wirePutOpt 48 18 x'6 + P'.wirePutOpt 56 8 x'7 + P'.wirePutExtField x'8 + wireGet ft' + = case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self + = case wire'Tag of + 10 -> Prelude'.fmap (\ !new'Field -> old'Self{string_value = Prelude'.Just new'Field}) (P'.wireGet 9) + 21 -> Prelude'.fmap (\ !new'Field -> old'Self{float_value = Prelude'.Just new'Field}) (P'.wireGet 2) + 25 -> Prelude'.fmap (\ !new'Field -> old'Self{double_value = Prelude'.Just new'Field}) (P'.wireGet 1) + 32 -> Prelude'.fmap (\ !new'Field -> old'Self{int_value = Prelude'.Just new'Field}) (P'.wireGet 3) + 40 -> Prelude'.fmap (\ !new'Field -> old'Self{uint_value = Prelude'.Just new'Field}) (P'.wireGet 4) + 48 -> Prelude'.fmap (\ !new'Field -> old'Self{sint_value = Prelude'.Just new'Field}) (P'.wireGet 18) + 56 -> Prelude'.fmap (\ !new'Field -> old'Self{bool_value = Prelude'.Just new'Field}) (P'.wireGet 8) + _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in + if Prelude'.or [8 <= field'Number && field'Number <= 18999, 20000 <= field'Number] then + P'.loadExtension field'Number wire'Type old'Self else P'.unknown field'Number wire'Type old'Self + +instance P'.MessageAPI msg' (msg' -> Value) Value where + getVal m' f' = f' m' + +instance P'.GPB Value + +instance P'.ReflectDescriptor Value where + getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [10, 21, 25, 32, 40, 48, 56]) + reflectDescriptorInfo _ + = Prelude'.read + "DescriptorInfo {descName = ProtoName {protobufName = FIName \".vector_tile.Tile.Value\", haskellPrefix = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule = [MName \"Vector_tile\",MName \"Tile\"], baseName = MName \"Value\"}, descFilePath = [\"Geography\",\"VectorTile\",\"Protobuf\",\"Internal\",\"Vector_tile\",\"Tile\",\"Value.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Value.string_value\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Value\"], baseName' = FName \"string_value\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Value.float_value\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Value\"], baseName' = FName \"float_value\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 21}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 2}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Value.double_value\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Value\"], baseName' = FName \"double_value\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 25}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 1}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Value.int_value\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Value\"], baseName' = FName \"int_value\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 4}, wireTag = WireTag {getWireTag = 32}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 3}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Value.uint_value\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Value\"], baseName' = FName \"uint_value\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 5}, wireTag = WireTag {getWireTag = 40}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 4}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Value.sint_value\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Value\"], baseName' = FName \"sint_value\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 6}, wireTag = WireTag {getWireTag = 48}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 18}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".vector_tile.Tile.Value.bool_value\", haskellPrefix' = [MName \"Geography\",MName \"VectorTile\",MName \"Protobuf\",MName \"Internal\"], parentModule' = [MName \"Vector_tile\",MName \"Tile\",MName \"Value\"], baseName' = FName \"bool_value\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 7}, wireTag = WireTag {getWireTag = 56}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 8}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [(FieldId {getFieldId = 8},FieldId {getFieldId = 18999}),(FieldId {getFieldId = 20000},FieldId {getFieldId = 536870911})], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" + +instance P'.TextType Value where + tellT = P'.tellSubMessage + getT = P'.getSubMessage + +instance P'.TextMsg Value where + textPut msg + = do + P'.tellT "string_value" (string_value msg) + P'.tellT "float_value" (float_value msg) + P'.tellT "double_value" (double_value msg) + P'.tellT "int_value" (int_value msg) + P'.tellT "uint_value" (uint_value msg) + P'.tellT "sint_value" (sint_value msg) + P'.tellT "bool_value" (bool_value msg) + textGet + = do + mods <- P'.sepEndBy + (P'.choice + [parse'string_value, parse'float_value, parse'double_value, parse'int_value, parse'uint_value, parse'sint_value, + parse'bool_value]) + P'.spaces + Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + where + parse'string_value + = P'.try + (do + v <- P'.getT "string_value" + Prelude'.return (\ o -> o{string_value = v})) + parse'float_value + = P'.try + (do + v <- P'.getT "float_value" + Prelude'.return (\ o -> o{float_value = v})) + parse'double_value + = P'.try + (do + v <- P'.getT "double_value" + Prelude'.return (\ o -> o{double_value = v})) + parse'int_value + = P'.try + (do + v <- P'.getT "int_value" + Prelude'.return (\ o -> o{int_value = v})) + parse'uint_value + = P'.try + (do + v <- P'.getT "uint_value" + Prelude'.return (\ o -> o{uint_value = v})) + parse'sint_value + = P'.try + (do + v <- P'.getT "sint_value" + Prelude'.return (\ o -> o{sint_value = v})) + parse'bool_value + = P'.try + (do + v <- P'.getT "bool_value" + Prelude'.return (\ o -> o{bool_value = v})) diff --git a/lib/Geography/VectorTile/Util.hs b/lib/Geography/VectorTile/Util.hs --- a/lib/Geography/VectorTile/Util.hs +++ b/lib/Geography/VectorTile/Util.hs @@ -2,35 +2,30 @@ -- | -- Module : Geography.VectorTile.Util --- Copyright : (c) Azavea, 2016 --- License : Apache 2 --- Maintainer: Colin Woodbury +-- Copyright : (c) Colin Woodbury 2016 - 2018 +-- License : BSD3 +-- Maintainer: Colin Woodbury module Geography.VectorTile.Util where +import Data.Sequence (Seq, (|>), Seq(Empty, (:<|))) import Data.Text (Text) --- -- | A sort of "self-zip", forming pairs from every two elements in a list. -- Fails if there is an uneven number of elements. -pairs :: [a] -> Either Text [(a,a)] -pairs [] = Right [] -pairs [_] = Left "Uneven number of parameters given." -pairs (x:y:zs) = ((x,y) :) <$> pairs zs +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 -- | Flatten a list of pairs. Equivalent to: -- -- > ps ^.. each . both unpairs :: [(a,a)] -> [a] unpairs = foldr (\(a,b) acc -> a : b : acc) [] - --- | Apply a pure function to both elements of a tuple. -both :: (a -> b) -> (a,a) -> (b,b) -both f (x,y) = (f x, f y) - --- | Convert a `Maybe` to an `Either`, with some given default value --- should the result of the `Maybe` be `Nothing`. -mtoe :: a -> Maybe b -> Either a b -mtoe _ (Just b) = Right b -mtoe a _ = Left a +{-# INLINE unpairs #-} diff --git a/lib/Geography/VectorTile/VectorTile.hs b/lib/Geography/VectorTile/VectorTile.hs --- a/lib/Geography/VectorTile/VectorTile.hs +++ b/lib/Geography/VectorTile/VectorTile.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +{-# LANGUAGE Rank2Types #-} -- | -- Module : Geography.VectorTile.VectorTile --- Copyright : (c) Azavea, 2016 - 2017 --- License : Apache 2 --- Maintainer: Colin Woodbury +-- Copyright : (c) Colin Woodbury 2016 - 2018 +-- License : BSD3 +-- Maintainer: Colin Woodbury -- -- High-level types for representing Vector Tiles. @@ -22,6 +22,7 @@ -- -- These lenses are written in a generic way to avoid taking a dependency -- on one of the lens libraries. + , Lens' , layers , version , name @@ -35,23 +36,30 @@ ) where import Control.DeepSeq (NFData) +import qualified Data.ByteString.Lazy as BL +import Data.Hashable (Hashable) import Data.Int -import qualified Data.Map.Lazy as M -import Data.Text (Text) -import qualified Data.Vector as V +import qualified Data.HashMap.Lazy as M +import qualified Data.Sequence as Seq import Data.Word import GHC.Generics (Generic) import Geography.VectorTile.Geometry --- +-- | Simple Lenses compatible with both lens and microlens. +type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s + -- | A high-level representation of a Vector Tile. Implemented internally --- as a `M.Map`, so that access to individual layers can be fast if you +-- as a `M.HashMap`, so that access to individual layers can be fast if you -- know the layer names ahead of time. -newtype VectorTile = VectorTile { _layers :: M.Map Text Layer } deriving (Eq,Show,Generic) +-- +-- The layer name itself, a lazy `BL.ByteString`, is guaranteed to be UTF-8. +-- If you wish to convert it to `Data.Text.Lazy.Text`, consider +-- `Data.Text.Lazy.Encoding.decodeUtf8`. +newtype VectorTile = VectorTile { _layers :: M.HashMap BL.ByteString Layer } deriving (Eq,Show,Generic) --- | > Lens' VectorTile (Map Text Layer) -layers :: Functor f => (M.Map Text Layer -> f (M.Map Text Layer)) -> VectorTile -> f VectorTile +layers :: Lens' VectorTile (M.HashMap BL.ByteString Layer) layers f v = VectorTile <$> f (_layers v) {-# INLINE layers #-} @@ -60,41 +68,35 @@ -- | 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 +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) + , _extent :: Word -- ^ Default: 4096 } deriving (Eq,Show,Generic) --- | > Lens' Layer Int -version :: Functor f => (Int -> f Int) -> Layer -> f Layer +version :: Lens' Layer Word version f l = (\v -> l { _version = v }) <$> f (_version l) {-# INLINE version #-} --- | > Lens' Layer Text -name :: Functor f => (Text -> f Text) -> Layer -> f Layer +name :: Lens' Layer BL.ByteString name f l = (\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 :: Lens' Layer (Seq.Seq (Feature Point)) points f l = (\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 :: Lens' Layer (Seq.Seq (Feature LineString)) linestrings f l = (\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 :: Lens' Layer (Seq.Seq (Feature Polygon)) polygons f l = (\v -> l { _polygons = v }) <$> f (_polygons l) {-# INLINE polygons #-} --- | > Lens' Layer Int -extent :: Functor f => (Int -> f Int) -> Layer -> f Layer +extent :: Lens' Layer Word extent f l = (\v -> l { _extent = v }) <$> f (_extent l) {-# INLINE extent #-} @@ -113,30 +115,30 @@ -- -- 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) +-- +-- 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) --- | > Lens' (Feature g) Int -featureId :: Functor f => (Int -> f Int) -> Feature g -> f (Feature g) +featureId :: Lens' (Feature g) Word featureId f l = (\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 :: Lens' (Feature g) (M.HashMap BL.ByteString Val) metadata f l = (\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 :: Lens' (Feature g) (Seq.Seq g) geometries f l = (\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,Ord,Show,Generic) +-- by the underlying "Text.ProtocolBuffers" library. +data Val = St BL.ByteString | Fl Float | Do Double | I64 Int64 | W64 Word64 | S64 Int64 | B Bool + deriving (Eq,Ord,Show,Generic,Hashable) instance NFData Val diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,3 +1,5 @@ +-- -*- dante-target: "vectortiles-test"; -*- + {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeApplications #-} @@ -5,16 +7,17 @@ module Main where import qualified Data.ByteString as BS -import Data.Hex -import Data.ProtocolBuffers hiding (decode) -import Data.Serialize.Get -import Data.Serialize.Put -import qualified Geography.VectorTile.Protobuf.Internal as R +import qualified Data.ByteString.Lazy as BL +import qualified Data.Sequence as Seq +import qualified Data.Text as T +import qualified Data.Vector.Unboxed as U +import Geography.VectorTile +import qualified Geography.VectorTile.Internal as I import Test.Tasty import Test.Tasty.HUnit -import Geography.VectorTile -import Geography.VectorTile.Geometry -import qualified Data.Vector.Unboxed as U +import Text.ProtocolBuffers.Basic (Utf8(..), defaultValue) +import Text.ProtocolBuffers.WireMessage (Wire, messageGet) +import Text.ProtocolBuffers.Reflections (ReflectDescriptor) --- @@ -33,35 +36,25 @@ suite op ls pl rd cl = testGroup "Unit Tests" [ testGroup "Protobuf" [ testGroup "Decoding" - [ testCase "onepoint.mvt -> Raw.Tile" $ testOnePoint op - , testCase "linestring.mvt -> Raw.Tile" $ testLineString ls - , testCase "polygon.mvt -> Raw.Tile" $ testPolygon pl - , testCase "roads.mvt -> Raw.Tile" $ testDecode rd - , testCase "clearlake.mvt -> Raw.Tile" $ testDecode cl - , testCase "onepoint.mvt -> VectorTile" $ tileDecode op + [ testCase "onepoint.mvt -> VectorTile" $ tileDecode op , testCase "linestring.mvt -> VectorTile" $ tileDecode ls , testCase "polygon.mvt -> VectorTile" $ tileDecode pl , testCase "roads.mvt -> VectorTile" $ tileDecode rd - , testCase "clearlake.mvt -> VectorTile" $ tileDecode cl - ] + , testCase "clearlake.mvt -> VectorTile" $ tileDecode cl ] , testGroup "Encoding" [ testGroup "RawVectorTile <-> VectorTile" [ testCase "One Point" $ encodeIso onePoint , testCase "One LineString" $ encodeIso oneLineString , testCase "One Polygon" $ encodeIso onePolygon - , testCase "roads.mvt" . encodeIso . fromRight $ decode rd + , testCase "roads.mvt" . encodeIso . I.toProtobuf . fromRight $ tile rd ] ] - , testGroup "Serialization Isomorphism" - [ --testCase "onepoint.mvt <-> Raw.Tile" $ fromRaw op --- , testCase "linestring.mvt <-> Raw.Tile" $ fromRaw ls --- , testCase "polygon.mvt <-> Raw.Tile" $ fromRaw pl - -- , testCase "roads.mvt <-> Raw.Tile" $ fromRaw rd - testCase "testTile <-> protobuf bytes" testTileIso - ] ] , testGroup "Geometries" - [ testCase "Z-encoding Isomorphism" zencoding + [ testCase "area" $ area poly @?= 1 + , testCase "surveyor - outer" . assert $ surveyor (polyPoints poly) > 0 + , testCase "surveyor - inner" . assert $ surveyor (U.reverse $ polyPoints poly) < 0 + , testCase "Z-encoding Isomorphism" zencoding , testCase "Command Parsing" commandTest , testCase "[Word32] <-> [Command]" commandIso , testCase "[Word32] <-> V.Vector Point" pointIso @@ -73,49 +66,21 @@ ] testOnePoint :: BS.ByteString -> Assertion -testOnePoint vt = case decodeIt vt of - Left e -> assertFailure e - Right t -> t @?= onePoint +testOnePoint bs = protobufDecode bs onePoint testLineString :: BS.ByteString -> Assertion -testLineString vt = case decodeIt vt of - Left e -> assertFailure e - Right t -> t @?= oneLineString +testLineString bs = protobufDecode bs oneLineString testPolygon :: BS.ByteString -> Assertion -testPolygon vt = case decodeIt vt of - Left e -> assertFailure e - Right t -> t @?= onePolygon +testPolygon bs = protobufDecode bs onePolygon --- | For testing is decoding succeeded in generally. Makes no guarantee --- about the quality of the content, only that the parse succeeded. -testDecode :: BS.ByteString -> Assertion -testDecode = assert . isRight . decodeIt +protobufDecode :: (ReflectDescriptor a, Wire a, Eq a, Show a) => BS.ByteString -> a -> Assertion +protobufDecode bs res = case messageGet $ BL.fromStrict bs of + Left e -> assertFailure e + Right (t, _) -> t @?= res tileDecode :: BS.ByteString -> Assertion -tileDecode bs = case decodeIt bs of - Left e -> assertFailure e - Right t -> assert . isRight $ R.fromProtobuf t - -fromRaw :: BS.ByteString -> Assertion -fromRaw vt = case decodeIt vt of - Left e -> assertFailure e - Right l -> hex (encodeIt l) @?= hex vt --- Right l -> if runPut (encodeMessage l) == vt --- then assert True --- else assertString "Isomorphism failed." - -testTileIso :: Assertion -testTileIso = case decodeIt pb of - Right tl -> assertEqual "" tl testTile - Left e -> assertFailure e - where pb = encodeIt testTile - -decodeIt :: BS.ByteString -> Either String R.RawVectorTile -decodeIt = runGet decodeMessage - -encodeIt :: R.RawVectorTile -> BS.ByteString -encodeIt = runPut . encodeMessage +tileDecode bs = assert . isRight $ tile bs isRight :: Either a b -> Bool isRight (Right _) = True @@ -125,133 +90,113 @@ fromRight (Right b) = b fromRight _ = error "`Left` given to fromRight!" -rawTest :: IO (Either String R.RawVectorTile) -rawTest = decodeIt <$> BS.readFile "onepoint.mvt" - -encodeIso :: R.RawVectorTile -> Assertion -encodeIso vt = assert . isRight . fmap R.toProtobuf $ R.fromProtobuf vt +encodeIso :: I.Tile -> Assertion +encodeIso vt = case I.fromProtobuf vt of + Left e -> assertFailure $ T.unpack e + Right t -> I.toProtobuf t @?= 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 - } - 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 - } +testTile :: I.Tile +testTile = I.Tile (Seq.singleton l) defaultValue + where l = defaultValue { I.version = 2 + , I.name = Utf8 "testlayer" + , I.features = Seq.singleton f + , I.keys = Seq.singleton $ Utf8 "somekey" + , I.values = Seq.singleton v + , I.extent = Just 4096 } + f = I.Feature { I.id = Just 0 + , I.tags = Seq.fromList [0,0] + , I.type' = Just I.POINT + , I.geometry = Seq.fromList [9, 50, 34] } -- MoveTo(+25,+17) + v = defaultValue { I.string_value = Just $ Utf8 "Some Value" } -- | 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 - } - 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) - } +onePoint :: I.Tile +onePoint = I.Tile (Seq.singleton l) defaultValue + where l = defaultValue { I.version = 1 + , I.name = Utf8 "OnePoint" + , I.features = Seq.singleton f + , I.keys = Seq.Empty + , I.values = Seq.Empty + , I.extent = Just 4096 } + f = I.Feature { I.id = Just 0 + , I.tags = Seq.Empty + , I.type' = Just I.POINT + , I.geometry = Seq.fromList [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 - } - 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] - } +oneLineString :: I.Tile +oneLineString = I.Tile (Seq.singleton l) defaultValue + where l = defaultValue { I.version = 1 + , I.name = Utf8 "OneLineString" + , I.features = Seq.singleton f + , I.keys = Seq.Empty + , I.values = Seq.Empty + , I.extent = Just 4096 } + f = I.Feature { I.id = Just 0 + , I.tags = Seq.Empty + , I.type' = Just I.LINESTRING + -- MoveTo(+5,+5), LineTo(+1195,+1195) + , I.geometry = Seq.fromList [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 - } - 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] - } +onePolygon :: I.Tile +onePolygon = I.Tile (Seq.singleton l) defaultValue + where l = defaultValue { I.version = 1 + , I.name = Utf8 "OnePolygon" + , I.features = Seq.singleton f + , I.keys = Seq.Empty + , I.values = Seq.Empty + , I.extent = Just 4096 } + f = I.Feature { I.id = Just 0 + , I.tags = Seq.Empty + , I.type' = Just I.POLYGON + -- MoveTo(+2,+2), LineTo(+3,+2), LineTo(-3,+2), ClosePath + , I.geometry = Seq.fromList [9, 4, 4, 18, 6, 4, 5, 4, 15] } zencoding :: Assertion -zencoding = assert $ map (R.unzig . R.zig) vs @?= vs +zencoding = assert $ map (I.unzig . I.zig) vs @?= vs where vs = [0,(-1),1,(-2),2,(-3),3,2147483647,(-2147483648)] commandTest :: Assertion -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 ] +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 ] + ) commandIso :: Assertion -commandIso = assert $ (R.uncommands . fromRight $ R.commands cs) @?= cs - where cs = [9,4,4,18,6,4,5,4,15] +commandIso = assert $ (I.uncommands . fromRight $ I.commands cs) @?= cs + where cs = Seq.fromList [9,4,4,18,6,4,5,4,15] pointIso :: Assertion pointIso = cs' @?= cs - where cs = [25,4,4,6,6,3,3] - cs' = fromRight $ R.uncommands . R.toCommands <$> (R.commands cs >>= R.fromCommands @Point) + where cs = Seq.fromList [25,4,4,6,6,3,3] + cs' = fromRight $ I.uncommands . I.toCommands <$> (I.commands cs >>= I.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 $ R.uncommands . R.toCommands <$> (R.commands cs >>= R.fromCommands @LineString) + 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) -- | Two solids 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 $ R.uncommands . R.toCommands <$> (R.commands cs >>= R.fromCommands @Polygon) + 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) -- | One holed 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 $ R.uncommands . R.toCommands <$> (R.commands cs >>= R.fromCommands @Polygon) + 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) -- | One Holed, one solid polygonIso3 :: Assertion polygonIso3 = 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 + 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 , 9, 4, 4, 26, 6, 0, 0, 6, 5, 0, 15 ] - cs' = fromRight $ R.uncommands . R.toCommands <$> (R.commands cs >>= R.fromCommands @Polygon) - -{-} -foo :: FilePath -> IO (Either Text VectorTile) -foo bs = do - mvt <- BS.readFile bs - pure $ R.decode mvt >>= tile + cs' = fromRight $ I.uncommands . I.toCommands <$> (I.commands cs >>= I.fromCommands @Polygon) --- fmap (V.length . layers <$>) $ foo "roads.mvt" --} +poly :: Polygon +poly = Polygon ps mempty + where ps = U.fromList [(0,0), (1,0), (1,1), (0,1), (0,0)] diff --git a/vectortiles.cabal b/vectortiles.cabal --- a/vectortiles.cabal +++ b/vectortiles.cabal @@ -1,31 +1,24 @@ --- This file has been generated from package.yaml by hpack version 0.17.1. +-- This file has been generated from package.yaml by hpack version 0.21.2. -- -- see: https://github.com/sol/hpack +-- +-- hash: f96750e12d765b16fd1c39222cb53517096cf37a3363913c0dd655e08e652bc9 name: vectortiles -version: 1.2.0.6 +version: 1.3.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 here: . Note that currently this library ignores top-level protobuf extensions, /Value/ extensions, and /UNKNOWN/ geometries. - . - The order in which to explore the modules of this library is as follows: - . - 1. "Geography.VectorTile.VectorTile" (high-level types) - . - 2. "Geography.VectorTile.Geometry" (typical GIS geometry types) - . - 3. "Geography.VectorTile.Protobuf" (mid-level representation of parsed protobuf data with conversion functions) +category: Geography homepage: https://github.com/fosskers/vectortiles -license: Apache-2.0 -license-file: LICENSE author: Colin Woodbury -maintainer: cwoodbury@azavea.com -category: Geography +maintainer: colingw@gmail.com +license: BSD3 +license-file: LICENSE build-type: Simple cabal-version: >= 1.10 @@ -39,64 +32,81 @@ test/roads.mvt library - hs-source-dirs: - lib exposed-modules: Geography.VectorTile + Geography.VectorTile.Internal + other-modules: Geography.VectorTile.Geometry - Geography.VectorTile.Protobuf - Geography.VectorTile.Protobuf.Internal + 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 , bytestring - , cereal >=0.5 && <0.6 , containers - , protobuf >=0.2.1.1 && <0.3 - , text >=1.2 && <1.3 - , vector >=0.11 && <0.13 , deepseq >=1.4 && <1.5 + , hashable + , 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 default-language: Haskell2010 - ghc-options: -fwarn-unused-imports -fwarn-unused-binds 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 , bytestring - , cereal >=0.5 && <0.6 , containers - , protobuf >=0.2.1.1 && <0.3 - , text >=1.2 && <1.3 - , vector >=0.11 && <0.13 + , hashable , hex >=0.1 && <0.2 + , protocol-buffers >=2.4 && <2.5 + , protocol-buffers-descriptor >=2.4 && <2.5 , tasty >=0.10.1.2 , tasty-hunit >=0.9.2 + , text >=1.2 && <1.3 + , unordered-containers + , vector >=0.11 && <0.13 , vectortiles - hs-source-dirs: - test - main-is: Test.hs default-language: Haskell2010 - ghc-options: -fwarn-unused-imports -fwarn-unused-binds -threaded 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 , bytestring - , cereal >=0.5 && <0.6 , containers - , protobuf >=0.2.1.1 && <0.3 - , text >=1.2 && <1.3 - , vector >=0.11 && <0.13 - , criterion >=1.1 && <1.3 + , criterion >=1.1 && <1.4 + , hashable , microlens >=0.4 && <0.5 , microlens-platform >=0.3 && <0.4 + , 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 - hs-source-dirs: - bench - main-is: Bench.hs default-language: Haskell2010 - ghc-options: -fwarn-unused-imports -fwarn-unused-binds -threaded