geojson 4.0.4 → 4.1.0
raw patch · 32 files changed
+1128/−1032 lines, 32 filesdep −hlintdep ~aesondep ~bytestringdep ~containerssetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies removed: hlint
Dependency ranges changed: aeson, bytestring, containers, deepseq, scientific, text, transformers, validation
API changes (from Hackage documentation)
- Data.Geospatial: bbox :: forall a_a1c7d. Lens' (GeoFeature a_a1c7d) (Maybe BoundingBoxWithoutCRS)
+ Data.Geospatial: bbox :: forall a_avv1. Lens' (GeoFeature a_avv1) (Maybe BoundingBoxWithoutCRS)
- Data.Geospatial: boundingbox :: forall a_a1hOi. Lens' (GeoFeatureCollection a_a1hOi) (Maybe BoundingBoxWithoutCRS)
+ Data.Geospatial: boundingbox :: forall a_ax15. Lens' (GeoFeatureCollection a_ax15) (Maybe BoundingBoxWithoutCRS)
- Data.Geospatial: class HasGeoPositionWithoutCRS c_agg5
+ Data.Geospatial: class HasGeoPositionWithoutCRS c_acGr
- Data.Geospatial: featureId :: forall a_a1c7d. Lens' (GeoFeature a_a1c7d) (Maybe FeatureID)
+ Data.Geospatial: featureId :: forall a_avv1. Lens' (GeoFeature a_avv1) (Maybe FeatureID)
- Data.Geospatial: geoPositionWithoutCRS :: HasGeoPositionWithoutCRS c_agg5 => Lens' c_agg5 GeoPositionWithoutCRS
+ Data.Geospatial: geoPositionWithoutCRS :: HasGeoPositionWithoutCRS c_acGr => Lens' c_acGr GeoPositionWithoutCRS
- Data.Geospatial: geofeatures :: forall a_a1hOi a_a1hQR. Lens (GeoFeatureCollection a_a1hOi) (GeoFeatureCollection a_a1hQR) (Seq (GeoFeature a_a1hOi)) (Seq (GeoFeature a_a1hQR))
+ Data.Geospatial: geofeatures :: forall a_ax15 a_ax3E. Lens (GeoFeatureCollection a_ax15) (GeoFeatureCollection a_ax3E) (Seq (GeoFeature a_ax15)) (Seq (GeoFeature a_ax3E))
- Data.Geospatial: geometry :: forall a_a1c7d. Lens' (GeoFeature a_a1c7d) GeospatialGeometry
+ Data.Geospatial: geometry :: forall a_avv1. Lens' (GeoFeature a_avv1) GeospatialGeometry
- Data.Geospatial: properties :: forall a_a1c7d a_a1ceF. Lens (GeoFeature a_a1c7d) (GeoFeature a_a1ceF) a_a1c7d a_a1ceF
+ Data.Geospatial: properties :: forall a_avv1 a_avCt. Lens (GeoFeature a_avv1) (GeoFeature a_avCt) a_avv1 a_avCt
- Data.Geospatial.Internal.BasicTypes: class HasGeoPositionWithoutCRS c_agg5
+ Data.Geospatial.Internal.BasicTypes: class HasGeoPositionWithoutCRS c_acGr
- Data.Geospatial.Internal.BasicTypes: geoPositionWithoutCRS :: HasGeoPositionWithoutCRS c_agg5 => Lens' c_agg5 GeoPositionWithoutCRS
+ Data.Geospatial.Internal.BasicTypes: geoPositionWithoutCRS :: HasGeoPositionWithoutCRS c_acGr => Lens' c_acGr GeoPositionWithoutCRS
- Data.Geospatial.Internal.GeoFeature: bbox :: forall a_a1c7d. Lens' (GeoFeature a_a1c7d) (Maybe BoundingBoxWithoutCRS)
+ Data.Geospatial.Internal.GeoFeature: bbox :: forall a_avv1. Lens' (GeoFeature a_avv1) (Maybe BoundingBoxWithoutCRS)
- Data.Geospatial.Internal.GeoFeature: featureId :: forall a_a1c7d. Lens' (GeoFeature a_a1c7d) (Maybe FeatureID)
+ Data.Geospatial.Internal.GeoFeature: featureId :: forall a_avv1. Lens' (GeoFeature a_avv1) (Maybe FeatureID)
- Data.Geospatial.Internal.GeoFeature: geometry :: forall a_a1c7d. Lens' (GeoFeature a_a1c7d) GeospatialGeometry
+ Data.Geospatial.Internal.GeoFeature: geometry :: forall a_avv1. Lens' (GeoFeature a_avv1) GeospatialGeometry
- Data.Geospatial.Internal.GeoFeature: properties :: forall a_a1c7d a_a1ceF. Lens (GeoFeature a_a1c7d) (GeoFeature a_a1ceF) a_a1c7d a_a1ceF
+ Data.Geospatial.Internal.GeoFeature: properties :: forall a_avv1 a_avCt. Lens (GeoFeature a_avv1) (GeoFeature a_avCt) a_avv1 a_avCt
- Data.Geospatial.Internal.GeoFeatureCollection: boundingbox :: forall a_a1hOi. Lens' (GeoFeatureCollection a_a1hOi) (Maybe BoundingBoxWithoutCRS)
+ Data.Geospatial.Internal.GeoFeatureCollection: boundingbox :: forall a_ax15. Lens' (GeoFeatureCollection a_ax15) (Maybe BoundingBoxWithoutCRS)
- Data.Geospatial.Internal.GeoFeatureCollection: geofeatures :: forall a_a1hOi a_a1hQR. Lens (GeoFeatureCollection a_a1hOi) (GeoFeatureCollection a_a1hQR) (Seq (GeoFeature a_a1hOi)) (Seq (GeoFeature a_a1hQR))
+ Data.Geospatial.Internal.GeoFeatureCollection: geofeatures :: forall a_ax15 a_ax3E. Lens (GeoFeatureCollection a_ax15) (GeoFeatureCollection a_ax3E) (Seq (GeoFeature a_ax15)) (Seq (GeoFeature a_ax3E))
Files
- LICENCE +1/−1
- README.md +29/−0
- Setup.hs +0/−1
- geojson.cabal +14/−24
- hlint/Main.hs +0/−12
- src/Data/Geospatial.hs +82/−66
- src/Data/Geospatial/Internal/BasicTypes.hs +88/−75
- src/Data/Geospatial/Internal/CRS.hs +52/−44
- src/Data/Geospatial/Internal/GeoFeature.hs +62/−56
- src/Data/Geospatial/Internal/GeoFeatureCollection.hs +51/−48
- src/Data/Geospatial/Internal/GeoPosition.hs +18/−18
- src/Data/Geospatial/Internal/Geometry.hs +99/−88
- src/Data/Geospatial/Internal/Geometry/Aeson.hs +34/−29
- src/Data/Geospatial/Internal/Geometry/GeoLine.hs +30/−27
- src/Data/Geospatial/Internal/Geometry/GeoMultiLine.hs +36/−33
- src/Data/Geospatial/Internal/Geometry/GeoMultiPoint.hs +27/−24
- src/Data/Geospatial/Internal/Geometry/GeoMultiPolygon.hs +28/−25
- src/Data/Geospatial/Internal/Geometry/GeoPoint.hs +25/−25
- src/Data/Geospatial/Internal/Geometry/GeoPolygon.hs +23/−21
- src/Data/LineString.hs +82/−96
- src/Data/LinearRing.hs +100/−111
- src/Data/SeqHelper.hs +12/−11
- test/Arbitrary.hs +3/−4
- test/Data/Geospatial/Internal/CRSTests.hs +23/−17
- test/Data/Geospatial/Internal/GeoFeatureCollectionTests.hs +15/−16
- test/Data/Geospatial/Internal/GeoFeatureTests.hs +17/−17
- test/Data/Geospatial/Internal/GeometryTests.hs +31/−25
- test/Data/LineStringTests.hs +43/−30
- test/Data/LinearRingTests.hs +54/−43
- test/Data/SeqHelperTests.hs +5/−5
- test/Fixture.hs +27/−23
- test/Main.hs +17/−17
LICENCE view
@@ -1,6 +1,6 @@ # BSD 3-Clause License -Copyright (c) 2014-2019, HS-GeoJSON Project+Copyright (c) 2014-2021, HS-GeoJSON Project All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
README.md view
@@ -4,6 +4,35 @@ ## Development +- We use [Ormolu](https://hackage.haskell.org/package/ormolu) for code formatting.++## Visual Studio Code Setup++Install Command Line Apps: ormolu and hlint.++Plugins:++- Haskell https://marketplace.visualstudio.com/items?itemName=haskell.haskell+- Haskell Syntax Highlighting https://marketplace.visualstudio.com/items?itemName=justusadam.language-haskell+- Haskell Linter https://marketplace.visualstudio.com/items?itemName=hoovercj.haskell-linter+- Run on Save https://marketplace.visualstudio.com/items?itemName=pucelle.run-on-save++One installed to reformat a file:++- Shift-Alt-F++Or configure Run on Save:++```+ {+ "globMatch": "{**/src/**/*.hs,**/test/**/*.hs}",+ "command": "ormolu --color always --check-idempotence --mode inplace ${file}",+ "runIn": "terminal",+ "runningStatusMessage": "Checking code style ${fileBasename}",+ "finishStatusMessage": "${fileBasename} checked"+ }+```+ Run tests: * `stack test :geojson-test`
Setup.hs view
@@ -1,4 +1,3 @@- module Main (main) where import Distribution.Simple
geojson.cabal view
@@ -1,5 +1,5 @@ name: geojson-version: 4.0.4+version: 4.1.0 license: BSD3 license-file: LICENCE author: Dom De Re@@ -27,20 +27,20 @@ source-repository this type: git location: https://github.com/zellige/hs-geojson.git- tag: 4.0.4+ tag: 4.1.0 library hs-source-dirs: src build-depends: base >= 4.9 && < 5- , aeson >= 0.8 && <1.6- , containers >= 0.5.10.1- , deepseq >= 1.4+ , aeson >= 2.0.1.0 && < 3+ , containers >= 0.5.7.1 && < 0.7+ , deepseq >= 1.4.2.0 && < 1.5 , lens >= 4.11 , semigroups >= 0.16- , text >= 1.2- , scientific >= 0.2.0- , transformers >= 0.3- , validation >= 1+ , text >= 1.2.3.0 && < 1.3+ , scientific >= 0.2.0 && < 0.4+ , transformers >= 0.3 && < 0.7+ , validation >= 1 && < 2.0 , vector exposed-modules: Data.Geospatial , Data.LinearRing@@ -67,15 +67,15 @@ main-is: Main.hs type: exitcode-stdio-1.0 build-depends: base >= 4.9 && < 5- , aeson >= 0.8 && < 1.6- , bytestring >= 0.10- , containers >= 0.5.10.1+ , aeson >= 2.0.1.0 && < 3+ , bytestring >= 0.10.8.1 && < 0.12+ , containers >= 0.5.7.1 && < 0.7 , geojson , tasty , tasty-hspec , tasty-quickcheck- , text >= 1.2- , validation >= 1+ , text >= 1.2.3.0 && < 1.3+ , validation >= 1 && < 2.0 other-modules: Arbitrary , Fixture , Data.LinearRingTests@@ -85,16 +85,6 @@ , Data.Geospatial.Internal.GeoFeatureCollectionTests , Data.Geospatial.Internal.GeoFeatureTests , Data.Geospatial.Internal.GeometryTests- default-language: Haskell2010- ghc-options: -Wall- -threaded--test-suite geojson-hlint- hs-source-dirs: hlint- main-is: Main.hs- type: exitcode-stdio-1.0- build-depends: base >= 4.9 && < 5- , hlint default-language: Haskell2010 ghc-options: -Wall -threaded
− hlint/Main.hs
@@ -1,12 +0,0 @@-module Main where--import Control.Monad (unless)-import Language.Haskell.HLint (hlint)-import System.Environment (getArgs)-import System.Exit (exitFailure)--main :: IO ()-main = do- args <- getArgs- hlints <- hlint $ ["src/", "test/", "hlint/", "--cpp-define=HLINT", "--cpp-ansi"] ++ args- unless (null hlints) exitFailure
src/Data/Geospatial.hs view
@@ -1,82 +1,98 @@ -------------------------------------------------------------------+ -- | -- Module : Data.Geospatial--- Copyright : (C) 2014-2019 HS-GeoJSON Project+-- Copyright : (C) 2014-2021 HS-GeoJSON Project -- License : BSD-style (see the file LICENSE.md) -- Maintainer : Andrew Newman -- -- Refer to the GeoJSON Spec http://www.geojson.org/geojson-spec.html------------------------------------------------------------------------module Data.Geospatial (- -- * Types- Latitude- , Longitude- , Easting- , Northing- , Altitude- , FeatureID (..)- , GeoPositionWithoutCRS (..)- , GeoPosition (..)- , GeoPoint (..), retrieveXY- , PointXY (..)- , PointXYZ (..)- , PointXYZM (..)- , GeoMultiPoint (..), splitGeoMultiPoint, mergeGeoPoints- , GeoPolygon (..)- , GeoMultiPolygon (..), splitGeoMultiPolygon, mergeGeoPolygons- , GeoLine (..)- , GeoMultiLine (..), splitGeoMultiLine, mergeGeoLines- , GeospatialGeometry (..)- , Name- , Code- , Href- , FormatString- , ProjectionType- , CRSObject (..)- , BoundingBoxWithoutCRS (..)- , GeoFeature (..), reWrapGeometry- , GeoFeatureCollection (..)+module Data.Geospatial+ ( -- * Types+ Latitude,+ Longitude,+ Easting,+ Northing,+ Altitude,+ FeatureID (..),+ GeoPositionWithoutCRS (..),+ GeoPosition (..),+ GeoPoint (..),+ retrieveXY,+ PointXY (..),+ PointXYZ (..),+ PointXYZM (..),+ GeoMultiPoint (..),+ splitGeoMultiPoint,+ mergeGeoPoints,+ GeoPolygon (..),+ GeoMultiPolygon (..),+ splitGeoMultiPolygon,+ mergeGeoPolygons,+ GeoLine (..),+ GeoMultiLine (..),+ splitGeoMultiLine,+ mergeGeoLines,+ GeospatialGeometry (..),+ Name,+ Code,+ Href,+ FormatString,+ ProjectionType,+ CRSObject (..),+ BoundingBoxWithoutCRS (..),+ GeoFeature (..),+ reWrapGeometry,+ GeoFeatureCollection (..),+ -- * Functions- , stripCRSFromPosition- , defaultCRS+ stripCRSFromPosition,+ defaultCRS,+ -- * Lenses+ -- ** Geometry Lenses- , unGeoPoint- , unGeoMultiPoint- , unGeoPolygon- , unGeoLine- , unGeoMultiLine- , unGeoMultiPolygon+ unGeoPoint,+ unGeoMultiPoint,+ unGeoPolygon,+ unGeoLine,+ unGeoMultiLine,+ unGeoMultiPolygon,+ -- ** Feature Lenses- , bbox- , geometry- , properties- , featureId- , boundingbox- , geofeatures+ bbox,+ geometry,+ properties,+ featureId,+ boundingbox,+ geofeatures,+ -- * Prisms+ -- ** BasicTypes- , HasGeoPositionWithoutCRS(..)+ HasGeoPositionWithoutCRS (..),+ -- ** Geometry- , _NoGeometry- , _Point- , _MultiPoint- , _Polygon- , _MultiPolygon- , _Line- , _MultiLine- , _Collection+ _NoGeometry,+ _Point,+ _MultiPoint,+ _Polygon,+ _MultiPolygon,+ _Line,+ _MultiLine,+ _Collection,+ -- ** CRS- , _NoCRS- , _NamedCRS- , _EPSG- , _LinkedCRS- ) where+ _NoCRS,+ _NamedCRS,+ _EPSG,+ _LinkedCRS,+ )+where -import Data.Geospatial.Internal.BasicTypes-import Data.Geospatial.Internal.CRS-import Data.Geospatial.Internal.GeoFeature-import Data.Geospatial.Internal.GeoFeatureCollection-import Data.Geospatial.Internal.Geometry-import Data.Geospatial.Internal.GeoPosition+import Data.Geospatial.Internal.BasicTypes+import Data.Geospatial.Internal.CRS+import Data.Geospatial.Internal.GeoFeature+import Data.Geospatial.Internal.GeoFeatureCollection+import Data.Geospatial.Internal.GeoPosition+import Data.Geospatial.Internal.Geometry
src/Data/Geospatial/Internal/BasicTypes.hs view
@@ -1,104 +1,113 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-} -------------------------------------------------------------------+ -- | -- Module : Data.Geospatial.Internal.BasicTypes--- Copyright : (C) 2014-2019 HS-GeoJSON Project+-- Copyright : (C) 2014-2021 HS-GeoJSON Project -- License : BSD-style (see the file LICENSE.md) -- Maintainer : Andrew Newman -- -- Basic types for GeoJSON representations.---------------------------------------------------------------------module Data.Geospatial.Internal.BasicTypes (- -- * Coordinate types- Latitude- , Longitude- , Easting- , Northing- , Altitude- , GeoPositionWithoutCRS (..)- , retrieveXY- , PointXY (..)- , PointXYZ (..)- , PointXYZM (..)- , DoubleArray (..)- , HasGeoPositionWithoutCRS(..)+module Data.Geospatial.Internal.BasicTypes+ ( -- * Coordinate types+ Latitude,+ Longitude,+ Easting,+ Northing,+ Altitude,+ GeoPositionWithoutCRS (..),+ retrieveXY,+ PointXY (..),+ PointXYZ (..),+ PointXYZM (..),+ DoubleArray (..),+ HasGeoPositionWithoutCRS (..),+ -- * CRS Reference types- , Name- , Code- , Href- , FormatString- , ProjectionType+ Name,+ Code,+ Href,+ FormatString,+ ProjectionType,+ -- * Feature Types- , BoundingBoxWithoutCRS (..)- , FeatureID (..)- ) where+ BoundingBoxWithoutCRS (..),+ FeatureID (..),+ )+where -import Control.DeepSeq-import Control.Lens.TH (makeClassy)-import qualified Data.Aeson as Aeson+import Control.DeepSeq+import Control.Lens.TH (makeClassy)+import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as AesonTypes-import qualified Data.Maybe as DataMaybe-import qualified Data.Scientific as Scientific-import qualified Data.Text as Text-import qualified Data.Vector as Vector-import GHC.Generics+import qualified Data.Maybe as DataMaybe+import qualified Data.Scientific as Scientific+import qualified Data.Text as Text+import qualified Data.Vector as Vector+import GHC.Generics type Latitude = Double+ type Longitude = Double+ type Easting = Double+ type Northing = Double+ type Altitude = Double newtype DoubleArray = DoubleArray [Double] deriving (Eq, Show, Generic, NFData, Aeson.FromJSON, Aeson.ToJSON) -- | (`GeoPositionWithoutCRS` is a catch all for indeterminate CRSs and for expression of positions -- before a CRS has been determined--- data PointXY = PointXY- { _xyX :: !Double- , _xyY :: !Double- } deriving (Show, Eq, Generic, NFData)+ { _xyX :: !Double,+ _xyY :: !Double+ }+ deriving (Show, Eq, Generic, NFData) data PointXYZ = PointXYZ- { _xyzX :: !Double- , _xyzY :: !Double- , _xyzZ :: !Double- } deriving (Show, Eq, Generic, NFData)+ { _xyzX :: !Double,+ _xyzY :: !Double,+ _xyzZ :: !Double+ }+ deriving (Show, Eq, Generic, NFData) data PointXYZM = PointXYZM- { _xyzmX :: !Double- , _xyzmY :: !Double- , _xyzmZ :: !Double- , _xyzmM :: !Double- } deriving (Show, Eq, Generic, NFData)+ { _xyzmX :: !Double,+ _xyzmY :: !Double,+ _xyzmZ :: !Double,+ _xyzmM :: !Double+ }+ deriving (Show, Eq, Generic, NFData) data GeoPositionWithoutCRS = GeoEmpty | GeoPointXY PointXY | GeoPointXYZ PointXYZ | GeoPointXYZM PointXYZM deriving (Show, Eq, Generic, NFData) makeClassy ''GeoPositionWithoutCRS _toDoubleArray :: GeoPositionWithoutCRS -> [Double]-_toDoubleArray GeoEmpty = []-_toDoubleArray (GeoPointXY (PointXY x y)) = [x, y]-_toDoubleArray (GeoPointXYZ (PointXYZ x y z)) = [x, y, z]+_toDoubleArray GeoEmpty = []+_toDoubleArray (GeoPointXY (PointXY x y)) = [x, y]+_toDoubleArray (GeoPointXYZ (PointXYZ x y z)) = [x, y, z] _toDoubleArray (GeoPointXYZM (PointXYZM x y z m)) = [x, y, z, m] _toGeoPoint :: DoubleArray -> Maybe GeoPositionWithoutCRS-_toGeoPoint (DoubleArray []) = Just GeoEmpty-_toGeoPoint (DoubleArray [x, y]) = Just $ GeoPointXY (PointXY x y)-_toGeoPoint (DoubleArray [x, y, z]) = Just $ GeoPointXYZ (PointXYZ x y z)+_toGeoPoint (DoubleArray []) = Just GeoEmpty+_toGeoPoint (DoubleArray [x, y]) = Just $ GeoPointXY (PointXY x y)+_toGeoPoint (DoubleArray [x, y, z]) = Just $ GeoPointXYZ (PointXYZ x y z) _toGeoPoint (DoubleArray [x, y, z, m]) = Just $ GeoPointXYZM (PointXYZM x y z m)-_toGeoPoint _ = Nothing+_toGeoPoint _ = Nothing retrieveXY :: GeoPositionWithoutCRS -> PointXY retrieveXY position = case position of- GeoEmpty -> undefined -- TODO - Fix - represent this like WKB - NaN value- (GeoPointXY p) -> p- (GeoPointXYZ (PointXYZ pX pY _)) -> PointXY pX pY+ GeoEmpty -> undefined -- TODO - Fix - represent this like WKB - NaN value+ (GeoPointXY p) -> p+ (GeoPointXYZ (PointXYZ pX pY _)) -> PointXY pX pY (GeoPointXYZM (PointXYZM pX pY _ _)) -> PointXY pX pY {-# INLINE retrieveXY #-} @@ -109,38 +118,41 @@ toJSON a = Aeson.toJSON $ _toDoubleArray a instance Aeson.FromJSON GeoPositionWithoutCRS where--- parseJSON :: Value -> Parser a+ -- parseJSON :: Value -> Parser a parseJSON o = do x <- Aeson.parseJSON o DataMaybe.maybe (fail "Illegal coordinates") pure (_toGeoPoint x) type Name = Text.Text+ type Code = Int+ type Href = Text.Text+ type FormatString = Text.Text+ type ProjectionType = Text.Text -- Feature Types -data FeatureID =- FeatureIDText Text.Text- | FeatureIDNumber Int deriving (Show, Eq, Generic, NFData)+data FeatureID+ = FeatureIDText Text.Text+ | FeatureIDNumber Int+ deriving (Show, Eq, Generic, NFData) instance Aeson.FromJSON FeatureID where- parseJSON (Aeson.Number nID) =- case x of- Nothing -> fail "Not an integer value"- Just z -> pure $ FeatureIDNumber z- where- x = Scientific.toBoundedInteger nID :: Maybe Int- parseJSON (Aeson.String sID) = pure $ FeatureIDText sID- parseJSON _ = fail "unknown id type"-+ parseJSON (Aeson.Number nID) =+ case x of+ Nothing -> fail "Not an integer value"+ Just z -> pure $ FeatureIDNumber z+ where+ x = Scientific.toBoundedInteger nID :: Maybe Int+ parseJSON (Aeson.String sID) = pure $ FeatureIDText sID+ parseJSON _ = fail "unknown id type" instance Aeson.ToJSON FeatureID where- toJSON (FeatureIDText a) = Aeson.String a- toJSON (FeatureIDNumber b) = Aeson.Number (fromInteger $ toInteger b :: Scientific.Scientific)-+ toJSON (FeatureIDText a) = Aeson.String a+ toJSON (FeatureIDNumber b) = Aeson.Number (fromInteger $ toInteger b :: Scientific.Scientific) -- | See Section 4 /Bounding Boxes/ of the GeoJSON spec, -- The length of the list/array must be 2*n where n is the dimensionality of the position type for the CRS@@ -151,7 +163,8 @@ data BoundingBoxWithoutCRS = BoundingBoxWithoutCRSXY PointXY PointXY | BoundingBoxWithoutCRSXYZ PointXYZ PointXYZ- | BoundingBoxWithoutCRSXYZM PointXYZM PointXYZM deriving (Eq, Show, Generic, NFData)+ | BoundingBoxWithoutCRSXYZM PointXYZM PointXYZM+ deriving (Eq, Show, Generic, NFData) instance Aeson.FromJSON BoundingBoxWithoutCRS where parseJSON json = do
src/Data/Geospatial/Internal/CRS.hs view
@@ -1,48 +1,58 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-}+ -------------------------------------------------------------------+ -- | -- Module : Data.Geospatial.Internal.CRS--- Copyright : (C) 2014-2019 HS-GeoJSON Project+-- Copyright : (C) 2014-2021 HS-GeoJSON Project -- License : BSD-style (see the file LICENSE.md) -- Maintainer : Andrew Newman -- -- See Section 3 /Coordinate Reference System Objects/ -- in the GeoJSON Spec------------------------------------------------------------------------module Data.Geospatial.Internal.CRS (- -- * Types- CRSObject(..)+module Data.Geospatial.Internal.CRS+ ( -- * Types+ CRSObject (..),+ -- * Functions- , defaultCRS- -- * Prisms- , _NoCRS- , _NamedCRS- , _EPSG- , _LinkedCRS- ) where+ defaultCRS, -import Data.Geospatial.Internal.BasicTypes+ -- * Prisms+ _NoCRS,+ _NamedCRS,+ _EPSG,+ _LinkedCRS,+ )+where -import Control.Lens (makePrisms)-import Control.Monad (mzero)-import Data.Aeson (FromJSON (..), Object,- ToJSON (..), Value (..),- object, (.:), (.=))-import Data.Aeson.Types (Parser)-import Data.Text (Text)+import Control.Lens (makePrisms)+import Control.Monad (mzero)+import Data.Aeson+ ( FromJSON (..),+ Object,+ ToJSON (..),+ Value (..),+ object,+ (.:),+ (.=),+ )+import qualified Data.Aeson.Key as AesonKey+import Data.Aeson.Types (Parser)+import Data.Geospatial.Internal.BasicTypes+import Data.Text (Text) -- | See Section 3 /Coordinate Reference System Objects/ in the GeoJSON Spec -- `NoCRS` is required because no 'crs' attribute in a GeoJSON feature is NOT the same thing as -- a null 'crs' attribute. no 'crs' value implies the default CRS, while a null CRS means -- you cannot assume a CRS, null will mapped to `NoCRS` while a non-existent attribute will -- be mapped to a `Nothing` `Maybe` value-data CRSObject =- NoCRS- | NamedCRS !Name- | EPSG Code- | LinkedCRS !Href !FormatString deriving (Show, Eq)+data CRSObject+ = NoCRS+ | NamedCRS !Name+ | EPSG Code+ | LinkedCRS !Href !FormatString+ deriving (Show, Eq) makePrisms ''CRSObject @@ -58,32 +68,30 @@ -- decode CRS Objects from GeoJSON -- -- Aeson doesnt decode "null" to `Null` unfortunately--- instance FromJSON CRSObject where- parseJSON Null = return NoCRS- parseJSON (Object obj) = do- crsType <- obj .: "type"- crsObjectFromAeson crsType obj- parseJSON _ = mzero+ parseJSON Null = return NoCRS+ parseJSON (Object obj) = do+ crsType <- obj .: "type"+ crsObjectFromAeson crsType obj+ parseJSON _ = mzero -- | -- encode CRS Objects to GeoJSON--- instance ToJSON CRSObject where- toJSON (NamedCRS name) = object ["type" .= ("name" :: Text), "properties" .= object ["name" .= name]]- toJSON (EPSG code) = object ["type" .= ("epsg" :: Text), "properties" .= object ["code" .= code]]- toJSON (LinkedCRS href format) = object ["type" .= ("link" :: Text), "properties" .= object ["href" .= href, "type" .= format]]- toJSON NoCRS = Null+ toJSON (NamedCRS name) = object ["type" .= ("name" :: Text), "properties" .= object ["name" .= name]]+ toJSON (EPSG code) = object ["type" .= ("epsg" :: Text), "properties" .= object ["code" .= code]]+ toJSON (LinkedCRS href format) = object ["type" .= ("link" :: Text), "properties" .= object ["href" .= href, "type" .= format]]+ toJSON NoCRS = Null -- helpers crsPropertyFromAesonObj :: (FromJSON a) => Text -> Object -> Parser a crsPropertyFromAesonObj name obj = do- props <- obj .: "properties"- props .: name+ props <- obj .: "properties"+ props .: AesonKey.fromText name crsObjectFromAeson :: Text -> Object -> Parser CRSObject-crsObjectFromAeson "name" obj = NamedCRS <$> crsPropertyFromAesonObj "name" obj-crsObjectFromAeson "epsg" obj = EPSG <$> crsPropertyFromAesonObj "code" obj-crsObjectFromAeson "link" obj = LinkedCRS <$> crsPropertyFromAesonObj "href" obj <*> crsPropertyFromAesonObj "type" obj-crsObjectFromAeson _ _ = mzero+crsObjectFromAeson "name" obj = NamedCRS <$> crsPropertyFromAesonObj "name" obj+crsObjectFromAeson "epsg" obj = EPSG <$> crsPropertyFromAesonObj "code" obj+crsObjectFromAeson "link" obj = LinkedCRS <$> crsPropertyFromAesonObj "href" obj <*> crsPropertyFromAesonObj "type" obj+crsObjectFromAeson _ _ = mzero
src/Data/Geospatial/Internal/GeoFeature.hs view
@@ -1,56 +1,65 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoImplicitPrelude #-}+ -------------------------------------------------------------------+ -- | -- Module : Data.Geospatial.Internal.GeoFeature--- Copyright : (C) 2014-2019 HS-GeoJSON Project+-- Copyright : (C) 2014-2021 HS-GeoJSON Project -- License : BSD-style (see the file LICENSE.md) -- Maintainer : Andrew Newman -- -- See Section 2.2 /Feature Objects/ of the GeoJSON spec. -- Parameterised on the property type------------------------------------------------------------------------module Data.Geospatial.Internal.GeoFeature (- -- * Types- GeoFeature(..)+module Data.Geospatial.Internal.GeoFeature+ ( -- * Types+ GeoFeature (..),+ -- * Lenses- , bbox- , geometry- , properties- , featureId- -- * Utils- , reWrapGeometry- ) where+ bbox,+ geometry,+ properties,+ featureId, -import Data.Geospatial.Internal.BasicTypes-import Data.Geospatial.Internal.Geometry-import Data.Geospatial.Internal.Geometry.Aeson+ -- * Utils+ reWrapGeometry,+ )+where -import Control.Applicative ((<$>), (<*>))-import Control.DeepSeq-import Control.Lens (makeLenses)-import Control.Monad (mzero)-import Data.Aeson (FromJSON (..),- ToJSON (..),- Value (..), object,- (.:), (.:?), (.=))-import Data.List ((++))-import Data.Maybe (Maybe)-import Data.Text (Text)-import GHC.Generics (Generic)-import Prelude (Eq (..), Show, ($))+import Control.Applicative ((<$>), (<*>))+import Control.DeepSeq+import Control.Lens (makeLenses)+import Control.Monad (mzero)+import Data.Aeson+ ( FromJSON (..),+ ToJSON (..),+ Value (..),+ object,+ (.:),+ (.:?),+ (.=),+ )+import Data.Geospatial.Internal.BasicTypes+import Data.Geospatial.Internal.Geometry+import Data.Geospatial.Internal.Geometry.Aeson+import Data.List ((++))+import Data.Maybe (Maybe)+import Data.Text (Text)+import GHC.Generics (Generic)+import Prelude (Eq (..), Show, ($)) -- | See Section 2.2 /Feature Objects/ of the GeoJSON spec. -- Parameterised on the property type-data GeoFeature a = GeoFeature {- _bbox :: Maybe BoundingBoxWithoutCRS,- _geometry :: GeospatialGeometry,+data GeoFeature a = GeoFeature+ { _bbox :: Maybe BoundingBoxWithoutCRS,+ _geometry :: GeospatialGeometry, _properties :: a,- _featureId :: Maybe FeatureID } deriving (Show, Eq, Generic, NFData)+ _featureId :: Maybe FeatureID+ }+ deriving (Show, Eq, Generic, NFData) reWrapGeometry :: GeoFeature a -> GeospatialGeometry -> GeoFeature a reWrapGeometry (GeoFeature bbox _ props fId) geom = GeoFeature bbox geom props fId@@ -60,26 +69,23 @@ -- instances -- | Decodes Feature objects from GeoJSON--- instance (FromJSON a) => FromJSON (GeoFeature a) where--- parseJSON :: Value -> Parse a- parseJSON (Object obj) = do- objType <- obj .: ("type" :: Text)- if objType /= ("Feature" :: Text)- then- mzero- else- GeoFeature- <$> obj .:? ("bbox" :: Text)- <*> obj .: ("geometry" :: Text)- <*> obj .: ("properties" :: Text)- <*> obj .:? ("id" :: Text)- parseJSON _ = mzero+ -- parseJSON :: Value -> Parse a+ parseJSON (Object obj) = do+ objType <- obj .: "type"+ if objType /= ("Feature" :: Text)+ then mzero+ else+ GeoFeature+ <$> obj .:? "bbox"+ <*> obj .: "geometry"+ <*> obj .: "properties"+ <*> obj .:? "id"+ parseJSON _ = mzero -- | Encodes Feature objects to GeoJSON--- instance (ToJSON a) => ToJSON (GeoFeature a) where--- toJSON :: a -> Value- toJSON (GeoFeature bbox' geom props featureId') = object $ baseAttributes ++ optAttributes "bbox" bbox' ++ optAttributes "id" featureId'- where- baseAttributes = ["type" .= ("Feature" :: Text), "properties" .= props, "geometry" .= geom]+ -- toJSON :: a -> Value+ toJSON (GeoFeature bbox' geom props featureId') = object $ baseAttributes ++ optAttributes "bbox" bbox' ++ optAttributes "id" featureId'+ where+ baseAttributes = ["type" .= ("Feature" :: Text), "properties" .= props, "geometry" .= geom]
src/Data/Geospatial/Internal/GeoFeatureCollection.hs view
@@ -1,71 +1,74 @@-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoImplicitPrelude #-}+ -------------------------------------------------------------------+ -- | -- Module : Data.Geospatial.Internal.GeoFeature--- Copyright : (C) 2014-2019 HS-GeoJSON Project+-- Copyright : (C) 2014-2021 HS-GeoJSON Project -- License : BSD-style (see the file LICENSE.md) -- Maintainer : Andrew Newman -- -- See Section 2.3 /Feature Collection Objects/ of the GeoJSON spec------------------------------------------------------------------------module Data.Geospatial.Internal.GeoFeatureCollection (- -- * Types- GeoFeatureCollection(..)- -- * Lenses- , boundingbox- , geofeatures- ) where+module Data.Geospatial.Internal.GeoFeatureCollection+ ( -- * Types+ GeoFeatureCollection (..), -import Data.Geospatial.Internal.BasicTypes-import Data.Geospatial.Internal.GeoFeature-import Data.Geospatial.Internal.Geometry.Aeson+ -- * Lenses+ boundingbox,+ geofeatures,+ )+where -import Control.Applicative ((<$>), (<*>))-import Control.Lens (makeLenses)-import Control.Monad (mzero)-import Data.Aeson (FromJSON (..),- ToJSON (..),- Value (..), object,- (.:), (.:?), (.=))-import Data.List ((++))-import Data.Maybe (Maybe (..))-import qualified Data.Sequence as Sequence-import Data.Text (Text)-import Prelude (Eq (..), Show, ($))+import Control.Applicative ((<$>), (<*>))+import Control.Lens (makeLenses)+import Control.Monad (mzero)+import Data.Aeson+ ( FromJSON (..),+ ToJSON (..),+ Value (..),+ object,+ (.:),+ (.:?),+ (.=),+ )+import Data.Geospatial.Internal.BasicTypes+import Data.Geospatial.Internal.GeoFeature+import Data.Geospatial.Internal.Geometry.Aeson+import Data.List ((++))+import Data.Maybe (Maybe (..))+import qualified Data.Sequence as Sequence+import Data.Text (Text)+import Prelude (Eq (..), Show, ($)) -- | See Section 2.3 /Feature Collection Objects/ of the GeoJSON spec--- data GeoFeatureCollection a = GeoFeatureCollection- { _boundingbox :: Maybe BoundingBoxWithoutCRS- , _geofeatures :: Sequence.Seq (GeoFeature a)- } deriving (Show, Eq)+ { _boundingbox :: Maybe BoundingBoxWithoutCRS,+ _geofeatures :: Sequence.Seq (GeoFeature a)+ }+ deriving (Show, Eq) makeLenses ''GeoFeatureCollection -- instances -- | Decode FeatureCollection objects from GeoJSON--- instance (FromJSON a) => FromJSON (GeoFeatureCollection a) where--- parseJSON :: Value -> Parse a- parseJSON (Object obj) = do- objType <- obj .: ("type" :: Text)- if objType /= ("FeatureCollection" :: Text)- then- mzero- else- GeoFeatureCollection- <$> obj .:? ("bbox" :: Text)- <*> obj .: ("features" :: Text)- parseJSON _ = mzero+ -- parseJSON :: Value -> Parse a+ parseJSON (Object obj) = do+ objType <- obj .: "type"+ if objType /= ("FeatureCollection" :: Text)+ then mzero+ else+ GeoFeatureCollection+ <$> obj .:? "bbox"+ <*> obj .: "features"+ parseJSON _ = mzero -- | Encode FeatureCollection objects to GeoJSON--- instance (ToJSON a) => ToJSON (GeoFeatureCollection a) where--- toJSON :: a -> Value- toJSON (GeoFeatureCollection bbox' features) = object $ baseAttributes ++ optAttributes "bbox" bbox'- where- baseAttributes = ["type" .= ("FeatureCollection" :: Text), "features" .= features]+ -- toJSON :: a -> Value+ toJSON (GeoFeatureCollection bbox' features) = object $ baseAttributes ++ optAttributes "bbox" bbox'+ where+ baseAttributes = ["type" .= ("FeatureCollection" :: Text), "features" .= features]
src/Data/Geospatial/Internal/GeoPosition.hs view
@@ -1,38 +1,38 @@ -------------------------------------------------------------------+ -- | -- Module : Data.Geospatial.Internal.GeoPosition--- Copyright : (C) 2014-2019 HS-GeoJSON Project+-- Copyright : (C) 2014-2021 HS-GeoJSON Project -- License : BSD-style (see the file LICENSE.md) -- Maintainer : Andrew Newman -- -- see Section 2.1.1 /Position/ in the GeoJSON Spec---------------------------------------------------------------------module Data.Geospatial.Internal.GeoPosition (- -- * Type- GeoPosition(..)+module Data.Geospatial.Internal.GeoPosition+ ( -- * Type+ GeoPosition (..),+ -- * Functions- , stripCRSFromPosition- ) where+ stripCRSFromPosition,+ )+where import qualified Data.Geospatial.Internal.BasicTypes as BasicTypes -- | see Section 2.1.1 /Position/ in the GeoJSON Spec, -- I make the assumption here that the only position types we will use will -- involve easting or northing (+ve or -ve Altitude) or lon or lat (+ve or -ve Altitude)-data GeoPosition =- LonLat BasicTypes.Longitude BasicTypes.Latitude- | LonLatAlt BasicTypes.Longitude BasicTypes.Latitude BasicTypes.Altitude- | EastingNorthing BasicTypes.Easting BasicTypes.Northing- | EastingNorthingAlt BasicTypes.Easting BasicTypes.Northing BasicTypes.Altitude+data GeoPosition+ = LonLat BasicTypes.Longitude BasicTypes.Latitude+ | LonLatAlt BasicTypes.Longitude BasicTypes.Latitude BasicTypes.Altitude+ | EastingNorthing BasicTypes.Easting BasicTypes.Northing+ | EastingNorthingAlt BasicTypes.Easting BasicTypes.Northing BasicTypes.Altitude -- | the `GeoPosition` is a bit special in that when you convert it to GeoJSON, -- it will lose the CRS info attached to it and cannot be read back in -- from the GeoJSON. Hence it is ineligible for the `FromJSON` type class, -- so this function will strip it down to a `GeoPositionWithoutCRS`, which is eligible stripCRSFromPosition :: GeoPosition -> BasicTypes.GeoPositionWithoutCRS-stripCRSFromPosition (LonLat lon lat) = BasicTypes.GeoPointXY $ BasicTypes.PointXY lon lat-stripCRSFromPosition (LonLatAlt lon lat alt) = BasicTypes.GeoPointXYZ $ BasicTypes.PointXYZ lon lat alt-stripCRSFromPosition (EastingNorthing easting northing) = BasicTypes.GeoPointXY $ BasicTypes.PointXY easting northing-stripCRSFromPosition (EastingNorthingAlt easting northing alt) = BasicTypes.GeoPointXYZ $ BasicTypes.PointXYZ easting northing alt--+stripCRSFromPosition (LonLat lon lat) = BasicTypes.GeoPointXY $ BasicTypes.PointXY lon lat+stripCRSFromPosition (LonLatAlt lon lat alt) = BasicTypes.GeoPointXYZ $ BasicTypes.PointXYZ lon lat alt+stripCRSFromPosition (EastingNorthing easting northing) = BasicTypes.GeoPointXY $ BasicTypes.PointXY easting northing+stripCRSFromPosition (EastingNorthingAlt easting northing alt) = BasicTypes.GeoPointXYZ $ BasicTypes.PointXYZ easting northing alt
src/Data/Geospatial/Internal/Geometry.hs view
@@ -1,115 +1,126 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-}+ -------------------------------------------------------------------+ -- | -- Module : Data.Geospatial.Internal.Geometry--- Copyright : (C) 2014-2019 HS-GeoJSON Project+-- Copyright : (C) 2014-2021 HS-GeoJSON Project -- License : BSD-style (see the file LICENSE.md) -- Maintainer : Andrew Newman -- -- See section 2.1 "Geometry Objects" in the GeoJSON Spec.------------------------------------------------------------------------module Data.Geospatial.Internal.Geometry (- -- * Types- GeoPoint(..), retrieveXY- , GeoMultiPoint(..), splitGeoMultiPoint, mergeGeoPoints- , GeoPolygon(..)- , GeoMultiPolygon(..), splitGeoMultiPolygon, mergeGeoPolygons- , GeoLine(..)- , GeoMultiLine(..), splitGeoMultiLine, mergeGeoLines- , GeospatialGeometry(..)- -- * Lenses- , unGeoPoint- , unGeoMultiPoint- , unGeoPolygon- , unGeoMultiPolygon- , unGeoLine- , unGeoMultiLine- -- * Prisms- , _NoGeometry- , _Point- , _MultiPoint- , _Polygon- , _MultiPolygon- , _Line- , _MultiLine- , _Collection- ) where+module Data.Geospatial.Internal.Geometry+ ( -- * Types+ GeoPoint (..),+ retrieveXY,+ GeoMultiPoint (..),+ splitGeoMultiPoint,+ mergeGeoPoints,+ GeoPolygon (..),+ GeoMultiPolygon (..),+ splitGeoMultiPolygon,+ mergeGeoPolygons,+ GeoLine (..),+ GeoMultiLine (..),+ splitGeoMultiLine,+ mergeGeoLines,+ GeospatialGeometry (..), -import Data.Geospatial.Internal.Geometry.GeoLine-import Data.Geospatial.Internal.Geometry.GeoMultiLine-import Data.Geospatial.Internal.Geometry.GeoMultiPoint-import Data.Geospatial.Internal.Geometry.GeoMultiPolygon-import Data.Geospatial.Internal.Geometry.GeoPoint-import Data.Geospatial.Internal.Geometry.GeoPolygon+ -- * Lenses+ unGeoPoint,+ unGeoMultiPoint,+ unGeoPolygon,+ unGeoMultiPolygon,+ unGeoLine,+ unGeoMultiLine, -import Control.DeepSeq-import Control.Lens (makePrisms)-import Control.Monad (mzero)-import Data.Aeson (FromJSON (..),- ToJSON (..),- Value (..),- object,- (.:), (.=))-import Data.Aeson.Types (Parser)-import qualified Data.Sequence as Sequence-import Data.Text (Text)-import GHC.Generics (Generic)+ -- * Prisms+ _NoGeometry,+ _Point,+ _MultiPoint,+ _Polygon,+ _MultiPolygon,+ _Line,+ _MultiLine,+ _Collection,+ )+where +import Control.DeepSeq+import Control.Lens (makePrisms)+import Control.Monad (mzero)+import Data.Aeson+ ( FromJSON (..),+ ToJSON (..),+ Value (..),+ object,+ (.:),+ (.=),+ )+import Data.Aeson.Types (Parser)+import Data.Geospatial.Internal.Geometry.GeoLine+import Data.Geospatial.Internal.Geometry.GeoMultiLine+import Data.Geospatial.Internal.Geometry.GeoMultiPoint+import Data.Geospatial.Internal.Geometry.GeoMultiPolygon+import Data.Geospatial.Internal.Geometry.GeoPoint+import Data.Geospatial.Internal.Geometry.GeoPolygon+import qualified Data.Sequence as Sequence+import Data.Text (Text)+import GHC.Generics (Generic) -- | See section 2.1 /Geometry Objects/ in the GeoJSON Spec.-data GeospatialGeometry =- NoGeometry- | Point GeoPoint- | MultiPoint GeoMultiPoint- | Polygon GeoPolygon- | MultiPolygon GeoMultiPolygon- | Line GeoLine- | MultiLine GeoMultiLine- | Collection (Sequence.Seq GeospatialGeometry) deriving (Show, Eq, Generic, NFData)+data GeospatialGeometry+ = NoGeometry+ | Point GeoPoint+ | MultiPoint GeoMultiPoint+ | Polygon GeoPolygon+ | MultiPolygon GeoMultiPolygon+ | Line GeoLine+ | MultiLine GeoMultiLine+ | Collection (Sequence.Seq GeospatialGeometry)+ deriving (Show, Eq, Generic, NFData) makePrisms ''GeospatialGeometry geometryFromAeson :: String -> Value -> Parser GeospatialGeometry-geometryFromAeson "Point" obj = Point <$> parseJSON obj-geometryFromAeson "MultiPoint" obj = MultiPoint <$> parseJSON obj-geometryFromAeson "Polygon" obj = Polygon <$> parseJSON obj-geometryFromAeson "MultiPolygon" obj = MultiPolygon <$> parseJSON obj-geometryFromAeson "LineString" obj = Line <$> parseJSON obj-geometryFromAeson "MultiLineString" obj = MultiLine <$> parseJSON obj-geometryFromAeson "GeometryCollection" (Object jsonObj) = Collection <$> (jsonObj .: ("geometries" :: Text))-geometryFromAeson "GeometryCollection" _ = mzero-geometryFromAeson _ _ = mzero+geometryFromAeson "Point" obj = Point <$> parseJSON obj+geometryFromAeson "MultiPoint" obj = MultiPoint <$> parseJSON obj+geometryFromAeson "Polygon" obj = Polygon <$> parseJSON obj+geometryFromAeson "MultiPolygon" obj = MultiPolygon <$> parseJSON obj+geometryFromAeson "LineString" obj = Line <$> parseJSON obj+geometryFromAeson "MultiLineString" obj = MultiLine <$> parseJSON obj+geometryFromAeson "GeometryCollection" (Object jsonObj) = Collection <$> (jsonObj .: "geometries")+geometryFromAeson "GeometryCollection" _ = mzero+geometryFromAeson _ _ = mzero -- | -- encodes Geometry Objects to GeoJSON--- instance ToJSON GeospatialGeometry where--- toJSON :: a -> Value- toJSON NoGeometry = Null- toJSON (Point point) = toJSON point- toJSON (MultiPoint points) = toJSON points- toJSON (Polygon vertices) = toJSON vertices- toJSON (MultiPolygon vertices) = toJSON vertices- toJSON (Line vertices) = toJSON vertices- toJSON (MultiLine vertices) = toJSON vertices- toJSON (Collection geometries) = object- [ "type" .= ("GeometryCollection" :: Text)- , "geometries" .= geometries- ]+ -- toJSON :: a -> Value+ toJSON NoGeometry = Null+ toJSON (Point point) = toJSON point+ toJSON (MultiPoint points) = toJSON points+ toJSON (Polygon vertices) = toJSON vertices+ toJSON (MultiPolygon vertices) = toJSON vertices+ toJSON (Line vertices) = toJSON vertices+ toJSON (MultiLine vertices) = toJSON vertices+ toJSON (Collection geometries) =+ object+ [ "type" .= ("GeometryCollection" :: Text),+ "geometries" .= geometries+ ] -- | -- decodes Geometry Objects from GeoJSON -- -- Aeson doesnt decode "null" into `Null` unfortunately--- instance FromJSON GeospatialGeometry where--- parseJSON :: Value -> Parser a- parseJSON Null = return NoGeometry- parseJSON (Object obj) = do- geometryType <- obj .: ("type" :: Text)- geometryFromAeson geometryType (Object obj)- parseJSON _ = mzero+ -- parseJSON :: Value -> Parser a+ parseJSON Null = return NoGeometry+ parseJSON (Object obj) = do+ geometryType <- obj .: "type"+ geometryFromAeson geometryType (Object obj)+ parseJSON _ = mzero
src/Data/Geospatial/Internal/Geometry/Aeson.hs view
@@ -1,58 +1,63 @@ {-# LANGUAGE OverloadedStrings #-}+ -------------------------------------------------------------------+ -- | -- Module : Data.Geosptial.Geometry.Aeson--- Copyright : (C) 2014-2019 HS-GeoJSON Project+-- Copyright : (C) 2014-2021 HS-GeoJSON Project -- License : BSD-style (see the file LICENSE.md) -- Maintainer : Andrew Newman -- -- Some helpers for some of the common Aeson ops---------------------------------------------------------------------module Data.Geospatial.Internal.Geometry.Aeson (- -- * Geometry- readGeometryGeoAeson- , makeGeometryGeoAeson- -- * Optional fields- , optValFromObj- , optAttributes- ) where+module Data.Geospatial.Internal.Geometry.Aeson+ ( -- * Geometry+ readGeometryGeoAeson,+ makeGeometryGeoAeson, -import Control.Monad (mzero)-import Data.Aeson (FromJSON (..), Object, ToJSON (..), Value,- object, (.:), (.:?), (.=))-import Data.Aeson.Types (Pair, Parser)-import Data.Text (Text)+ -- * Optional fields+ optValFromObj,+ optAttributes,+ )+where +import Control.Monad (mzero)+import Data.Aeson+ ( FromJSON (..),+ Object,+ ToJSON (..),+ Value,+ object,+ (.:),+ (.:?),+ (.=),+ )+import qualified Data.Aeson.Key as AesonKey+import Data.Aeson.Types (Pair, Parser)+import Data.Text (Text) -- | A generic function that can be used to read in the GeoJSON for: -- `GeoPoint`, `GeoMultiPoint`, `GeoLine`, `GeoMultiLine`, `GeoPolygon` and `GeoMultiPolygon` -- Takes in a String for the GeoJSON geometry type, the type constructor -- for the datatype and the JSON object containing both the 'type' val and the 'coordinates' val--- readGeometryGeoAeson :: (FromJSON a, FromJSON b) => String -> (a -> b) -> Object -> Parser b readGeometryGeoAeson geomTypeString geomType geopointObj = do- geometryType <- geopointObj .: "type"- if geometryType == geomTypeString- then- geomType <$> geopointObj .: "coordinates"- else- mzero+ geometryType <- geopointObj .: "type"+ if geometryType == geomTypeString+ then geomType <$> geopointObj .: "coordinates"+ else mzero -- | The inverse to the above, you just give it the type string and the value for the coordinates -- and it will create the JSON object--- makeGeometryGeoAeson :: (ToJSON a) => String -> a -> Value makeGeometryGeoAeson typeString coordinates =- object ["type" .= typeString, "coordinates" .= coordinates]+ object ["type" .= typeString, "coordinates" .= coordinates] -- | get an optional value out of a JSON object:--- optValFromObj :: (FromJSON a) => Text -> Object -> Parser (Maybe a)-optValFromObj = flip (.:?)+optValFromObj t = flip (.:?) (AesonKey.fromText t) -- | The other way around, given an optional value, will return the attributes that -- should be added to the makeObj input--- optAttributes :: (ToJSON a) => Text -> Maybe a -> [Pair]-optAttributes _ Nothing = []-optAttributes name (Just x) = [name .= x]+optAttributes _ Nothing = []+optAttributes name (Just x) = [AesonKey.fromText name .= x]
src/Data/Geospatial/Internal/Geometry/GeoLine.hs view
@@ -1,44 +1,47 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-}+ -------------------------------------------------------------------+ -- | -- Module : Data.Geospatial.Internal.Geometry.GeoLine--- Copyright : (C) 2014-2019 HS-GeoJSON Project+-- Copyright : (C) 2014-2021 HS-GeoJSON Project -- License : BSD-style (see the file LICENSE.md) -- Maintainer : Andrew Newman------------------------------------------------------------------------module Data.Geospatial.Internal.Geometry.GeoLine (- -- * Type- GeoLine(..)- -- * Lenses- , unGeoLine- ) where+module Data.Geospatial.Internal.Geometry.GeoLine+ ( -- * Type+ GeoLine (..), -import Data.Geospatial.Internal.BasicTypes-import Data.Geospatial.Internal.Geometry.Aeson-import Data.LineString+ -- * Lenses+ unGeoLine,+ )+where -import Control.DeepSeq-import Control.Lens (makeLenses)-import Control.Monad (mzero)-import Data.Aeson (FromJSON (..),- ToJSON (..),- Value (..))-import GHC.Generics (Generic)+import Control.DeepSeq+import Control.Lens (makeLenses)+import Control.Monad (mzero)+import Data.Aeson+ ( FromJSON (..),+ ToJSON (..),+ Value (..),+ )+import Data.Geospatial.Internal.BasicTypes+import Data.Geospatial.Internal.Geometry.Aeson+import Data.LineString+import GHC.Generics (Generic) -newtype GeoLine = GeoLine { _unGeoLine :: LineString GeoPositionWithoutCRS } deriving (Show, Eq, Generic, NFData)+newtype GeoLine = GeoLine {_unGeoLine :: LineString GeoPositionWithoutCRS} deriving (Show, Eq, Generic, NFData) makeLenses ''GeoLine -- instances instance ToJSON GeoLine where--- toJSON :: a -> Value- toJSON = makeGeometryGeoAeson "LineString" . _unGeoLine+ -- toJSON :: a -> Value+ toJSON = makeGeometryGeoAeson "LineString" . _unGeoLine instance FromJSON GeoLine where--- parseJSON :: Value -> Parser a- parseJSON (Object o) = readGeometryGeoAeson "LineString" GeoLine o- parseJSON _ = mzero+ -- parseJSON :: Value -> Parser a+ parseJSON (Object o) = readGeometryGeoAeson "LineString" GeoLine o+ parseJSON _ = mzero
src/Data/Geospatial/Internal/Geometry/GeoMultiLine.hs view
@@ -1,45 +1,48 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-}+ -------------------------------------------------------------------+ -- | -- Module : Data.Geospatial.Internal.Geometry.GeoMultiLine--- Copyright : (C) 2014-2019 HS-GeoJSON Project+-- Copyright : (C) 2014-2021 HS-GeoJSON Project -- License : BSD-style (see the file LICENSE.md) -- Maintainer : Andrew Newman------------------------------------------------------------------------module Data.Geospatial.Internal.Geometry.GeoMultiLine (- -- * Type- GeoMultiLine(..)- -- * Lenses- , unGeoMultiLine- -- * To Points- , splitGeoMultiLine, mergeGeoLines- ) where+module Data.Geospatial.Internal.Geometry.GeoMultiLine+ ( -- * Type+ GeoMultiLine (..), -import Data.Geospatial.Internal.BasicTypes-import Data.Geospatial.Internal.Geometry.Aeson-import Data.Geospatial.Internal.Geometry.GeoLine-import Data.LineString+ -- * Lenses+ unGeoMultiLine, -import Control.DeepSeq-import Control.Lens (makeLenses)-import Control.Monad (mzero)-import Data.Aeson (FromJSON (..),- ToJSON (..),- Value (..))-import qualified Data.Sequence as Sequence-import GHC.Generics (Generic)+ -- * To Points+ splitGeoMultiLine,+ mergeGeoLines,+ )+where +import Control.DeepSeq+import Control.Lens (makeLenses)+import Control.Monad (mzero)+import Data.Aeson+ ( FromJSON (..),+ ToJSON (..),+ Value (..),+ )+import Data.Geospatial.Internal.BasicTypes+import Data.Geospatial.Internal.Geometry.Aeson+import Data.Geospatial.Internal.Geometry.GeoLine+import Data.LineString+import qualified Data.Sequence as Sequence+import GHC.Generics (Generic) -newtype GeoMultiLine = GeoMultiLine { _unGeoMultiLine :: Sequence.Seq(LineString GeoPositionWithoutCRS) } deriving (Show, Eq, Generic, NFData)+newtype GeoMultiLine = GeoMultiLine {_unGeoMultiLine :: Sequence.Seq (LineString GeoPositionWithoutCRS)} deriving (Show, Eq, Generic, NFData) makeLenses ''GeoMultiLine - -- | Split GeoMultiLine coordinates into multiple GeoLines-splitGeoMultiLine:: GeoMultiLine -> Sequence.Seq GeoLine+splitGeoMultiLine :: GeoMultiLine -> Sequence.Seq GeoLine splitGeoMultiLine = fmap GeoLine . _unGeoMultiLine -- | Merge multiple GeoLines into one GeoMultiLine@@ -49,10 +52,10 @@ -- instances instance ToJSON GeoMultiLine where--- toJSON :: a -> Value- toJSON = makeGeometryGeoAeson "MultiLineString" . _unGeoMultiLine+ -- toJSON :: a -> Value+ toJSON = makeGeometryGeoAeson "MultiLineString" . _unGeoMultiLine instance FromJSON GeoMultiLine where--- parseJSON :: Value -> Parser a- parseJSON (Object o) = readGeometryGeoAeson "MultiLineString" GeoMultiLine o- parseJSON _ = mzero+ -- parseJSON :: Value -> Parser a+ parseJSON (Object o) = readGeometryGeoAeson "MultiLineString" GeoMultiLine o+ parseJSON _ = mzero
src/Data/Geospatial/Internal/Geometry/GeoMultiPoint.hs view
@@ -1,40 +1,43 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-}+ -------------------------------------------------------------------+ -- | -- Module : Data.Geospatial.Internal.Geometry.GeoMultiPoint--- Copyright : (C) 2014-2019 HS-GeoJSON Project+-- Copyright : (C) 2014-2021 HS-GeoJSON Project -- License : BSD-style (see the file LICENSE.md) -- Maintainer : Andrew Newman------------------------------------------------------------------------module Data.Geospatial.Internal.Geometry.GeoMultiPoint (- -- * Type- GeoMultiPoint(..)+module Data.Geospatial.Internal.Geometry.GeoMultiPoint+ ( -- * Type+ GeoMultiPoint (..),+ -- * Lenses- , unGeoMultiPoint- -- * To Points- , splitGeoMultiPoint, mergeGeoPoints- ) where+ unGeoMultiPoint, -import Data.Geospatial.Internal.BasicTypes-import Data.Geospatial.Internal.Geometry.Aeson-import Data.Geospatial.Internal.Geometry.GeoPoint+ -- * To Points+ splitGeoMultiPoint,+ mergeGeoPoints,+ )+where -import Control.DeepSeq-import Control.Lens (makeLenses)-import Control.Monad (mzero)-import qualified Data.Aeson as Aeson-import qualified Data.Sequence as Sequence-import GHC.Generics (Generic)+import Control.DeepSeq+import Control.Lens (makeLenses)+import Control.Monad (mzero)+import qualified Data.Aeson as Aeson+import Data.Geospatial.Internal.BasicTypes+import Data.Geospatial.Internal.Geometry.Aeson+import Data.Geospatial.Internal.Geometry.GeoPoint+import qualified Data.Sequence as Sequence+import GHC.Generics (Generic) -newtype GeoMultiPoint = GeoMultiPoint { _unGeoMultiPoint :: Sequence.Seq GeoPositionWithoutCRS } deriving (Show, Eq, Generic, NFData)+newtype GeoMultiPoint = GeoMultiPoint {_unGeoMultiPoint :: Sequence.Seq GeoPositionWithoutCRS} deriving (Show, Eq, Generic, NFData) makeLenses ''GeoMultiPoint -- | Split GeoMultiPoint coordinates into multiple GeoPoints-splitGeoMultiPoint:: GeoMultiPoint -> Sequence.Seq GeoPoint+splitGeoMultiPoint :: GeoMultiPoint -> Sequence.Seq GeoPoint splitGeoMultiPoint = fmap GeoPoint . _unGeoMultiPoint -- | Merge multiple GeoPoints into one GeoMultiPoint@@ -50,4 +53,4 @@ instance Aeson.FromJSON GeoMultiPoint where -- parseJSON :: Value -> Parser a parseJSON (Aeson.Object o) = readGeometryGeoAeson "MultiPoint" GeoMultiPoint o- parseJSON _ = mzero+ parseJSON _ = mzero
src/Data/Geospatial/Internal/Geometry/GeoMultiPolygon.hs view
@@ -1,36 +1,39 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-}+ -------------------------------------------------------------------+ -- | -- Module : Data.Geospatial.Internal.Geometry.GeoMultiPolygon--- Copyright : (C) 2014-2019 HS-GeoJSON Project+-- Copyright : (C) 2014-2021 HS-GeoJSON Project -- License : BSD-style (see the file LICENSE.md) -- Maintainer : Andrew Newman------------------------------------------------------------------------module Data.Geospatial.Internal.Geometry.GeoMultiPolygon (- -- * Type- GeoMultiPolygon(..)+module Data.Geospatial.Internal.Geometry.GeoMultiPolygon+ ( -- * Type+ GeoMultiPolygon (..),+ -- * Lenses- , unGeoMultiPolygon- -- * To Polygons- , splitGeoMultiPolygon, mergeGeoPolygons- ) where+ unGeoMultiPolygon, -import Data.Geospatial.Internal.BasicTypes-import Data.Geospatial.Internal.Geometry.Aeson-import Data.Geospatial.Internal.Geometry.GeoPolygon as GeoPolygon-import qualified Data.LinearRing as LinearRing+ -- * To Polygons+ splitGeoMultiPolygon,+ mergeGeoPolygons,+ )+where -import Control.DeepSeq-import Control.Lens (makeLenses)-import Control.Monad (mzero)-import qualified Data.Aeson as Aeson-import qualified Data.Sequence as Sequence-import GHC.Generics (Generic)+import Control.DeepSeq+import Control.Lens (makeLenses)+import Control.Monad (mzero)+import qualified Data.Aeson as Aeson+import Data.Geospatial.Internal.BasicTypes+import Data.Geospatial.Internal.Geometry.Aeson+import Data.Geospatial.Internal.Geometry.GeoPolygon as GeoPolygon+import qualified Data.LinearRing as LinearRing+import qualified Data.Sequence as Sequence+import GHC.Generics (Generic) -newtype GeoMultiPolygon = GeoMultiPolygon { _unGeoMultiPolygon :: Sequence.Seq (Sequence.Seq (LinearRing.LinearRing GeoPositionWithoutCRS)) } deriving (Show, Eq, Generic, NFData)+newtype GeoMultiPolygon = GeoMultiPolygon {_unGeoMultiPolygon :: Sequence.Seq (Sequence.Seq (LinearRing.LinearRing GeoPositionWithoutCRS))} deriving (Show, Eq, Generic, NFData) -- | Split GeoMultiPolygon coordinates into multiple GeoPolygons splitGeoMultiPolygon :: GeoMultiPolygon -> Sequence.Seq GeoPolygon@@ -50,5 +53,5 @@ instance Aeson.FromJSON GeoMultiPolygon where -- parseJSON :: Value -> Parser a- parseJSON (Aeson.Object o) = readGeometryGeoAeson "MultiPolygon" GeoMultiPolygon o- parseJSON _ = mzero+ parseJSON (Aeson.Object o) = readGeometryGeoAeson "MultiPolygon" GeoMultiPolygon o+ parseJSON _ = mzero
src/Data/Geospatial/Internal/Geometry/GeoPoint.hs view
@@ -1,41 +1,41 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-}+ -------------------------------------------------------------------+ -- | -- Module : Data.Geospatial.Internal.Geometry.GeoPoint--- Copyright : (C) 2014-2019 HS-GeoJSON Project+-- Copyright : (C) 2014-2021 HS-GeoJSON Project -- License : BSD-style (see the file LICENSE.md) -- Maintainer : Andrew Newman------------------------------------------------------------------------module Data.Geospatial.Internal.Geometry.GeoPoint (- -- * Type- GeoPoint(..)- , unGeoPoint- , retrieveXY- ) where--import Control.DeepSeq-import Control.Lens (makeLenses)-import Control.Monad (mzero)-import qualified Data.Aeson as Aeson-import Data.Geospatial.Internal.BasicTypes-import Data.Geospatial.Internal.Geometry.Aeson-import GHC.Generics (Generic)+module Data.Geospatial.Internal.Geometry.GeoPoint+ ( -- * Type+ GeoPoint (..),+ unGeoPoint,+ retrieveXY,+ )+where +import Control.DeepSeq+import Control.Lens (makeLenses)+import Control.Monad (mzero)+import qualified Data.Aeson as Aeson+import Data.Geospatial.Internal.BasicTypes+import Data.Geospatial.Internal.Geometry.Aeson+import GHC.Generics (Generic) -newtype GeoPoint = GeoPoint { _unGeoPoint :: GeoPositionWithoutCRS } deriving (Show, Eq, Generic, NFData)+newtype GeoPoint = GeoPoint {_unGeoPoint :: GeoPositionWithoutCRS} deriving (Show, Eq, Generic, NFData) makeLenses ''GeoPoint -- instances instance Aeson.ToJSON GeoPoint where--- toJSON :: a -> Value- toJSON = makeGeometryGeoAeson "Point" . _unGeoPoint+ -- toJSON :: a -> Value+ toJSON = makeGeometryGeoAeson "Point" . _unGeoPoint instance Aeson.FromJSON GeoPoint where--- parseJSON :: Value -> Parser a- parseJSON (Aeson.Object o) = readGeometryGeoAeson "Point" GeoPoint o- parseJSON _ = mzero+ -- parseJSON :: Value -> Parser a+ parseJSON (Aeson.Object o) = readGeometryGeoAeson "Point" GeoPoint o+ parseJSON _ = mzero
src/Data/Geospatial/Internal/Geometry/GeoPolygon.hs view
@@ -1,32 +1,34 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-}+ -------------------------------------------------------------------+ -- | -- Module : Data.Geospatial.Internal.Geometry.GeoPolygon--- Copyright : (C) 2014-2019 HS-GeoJSON Project+-- Copyright : (C) 2014-2021 HS-GeoJSON Project -- License : BSD-style (see the file LICENSE.md) -- Maintainer : Andrew Newman------------------------------------------------------------------------module Data.Geospatial.Internal.Geometry.GeoPolygon (- -- * Type- GeoPolygon(..)+module Data.Geospatial.Internal.Geometry.GeoPolygon+ ( -- * Type+ GeoPolygon (..),+ -- * Lenses- , unGeoPolygon- ) where+ unGeoPolygon,+ )+where -import Control.DeepSeq-import Control.Lens (makeLenses)-import Control.Monad (mzero)-import qualified Data.Aeson as Aeson-import Data.Geospatial.Internal.BasicTypes-import Data.Geospatial.Internal.Geometry.Aeson-import qualified Data.LinearRing as LinearRing-import qualified Data.Sequence as Sequence-import GHC.Generics (Generic)+import Control.DeepSeq+import Control.Lens (makeLenses)+import Control.Monad (mzero)+import qualified Data.Aeson as Aeson+import Data.Geospatial.Internal.BasicTypes+import Data.Geospatial.Internal.Geometry.Aeson+import qualified Data.LinearRing as LinearRing+import qualified Data.Sequence as Sequence+import GHC.Generics (Generic) -newtype GeoPolygon = GeoPolygon { _unGeoPolygon :: Sequence.Seq (LinearRing.LinearRing GeoPositionWithoutCRS) } deriving (Show, Eq, Generic, NFData)+newtype GeoPolygon = GeoPolygon {_unGeoPolygon :: Sequence.Seq (LinearRing.LinearRing GeoPositionWithoutCRS)} deriving (Show, Eq, Generic, NFData) -- Sequence.Seq (LinearRing.LinearRing DoubleArray) @@ -41,4 +43,4 @@ instance Aeson.FromJSON GeoPolygon where -- parseJSON :: Value -> Parser a parseJSON (Aeson.Object o) = readGeometryGeoAeson "Polygon" GeoPolygon o- parseJSON _ = mzero+ parseJSON _ = mzero
src/Data/LineString.hs view
@@ -1,53 +1,52 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NoImplicitPrelude #-}+ -------------------------------------------------------------------+ -- | -- Module : Data.LineString--- Copyright : (C) 2014-2019 HS-GeoJSON Project+-- Copyright : (C) 2014-2021 HS-GeoJSON Project -- License : BSD-style (see the file LICENSE.md) -- Maintainer : Andrew Newman -- -- Refer to the GeoJSON Spec <http://geojson.org/geojson-spec.html#linestring> -- -- A LinearString is a List with at least 2 elements------------------------------------------------------------------------module Data.LineString (- -- * Type- LineString- , ListToLineStringError(..)- , SequenceToLineStringError(..)- -- * Functions- , toSeq- , combineToSeq- , fromSeq- , fromLineString- , fromList- , makeLineString- , lineStringHead- , lineStringLast- , lineStringLength- ) where--import Prelude hiding (foldr)+module Data.LineString+ ( -- * Type+ LineString,+ ListToLineStringError (..),+ SequenceToLineStringError (..), -import Control.DeepSeq-import Control.Lens (( # ), (^?))-import Control.Monad (mzero)-import Data.Aeson (FromJSON (..), ToJSON (..), Value)-import Data.Aeson.Types (Parser, typeMismatch)-import qualified Data.Foldable as Foldable-import Data.Maybe (fromMaybe)-import qualified Data.Sequence as Sequence-import qualified Data.Validation as Validation-import GHC.Generics (Generic)+ -- * Functions+ toSeq,+ combineToSeq,+ fromSeq,+ fromLineString,+ fromList,+ makeLineString,+ lineStringHead,+ lineStringLast,+ lineStringLength,+ )+where -import qualified Data.SeqHelper as SeqHelper+import Control.DeepSeq+import Control.Lens ((#), (^?))+import Control.Monad (mzero)+import Data.Aeson (FromJSON (..), ToJSON (..), Value)+import Data.Aeson.Types (Parser, typeMismatch)+import qualified Data.Foldable as Foldable+import Data.Maybe (fromMaybe)+import qualified Data.SeqHelper as SeqHelper+import qualified Data.Sequence as Sequence+import qualified Data.Validation as Validation+import GHC.Generics (Generic)+import Prelude hiding (foldr) -- | -- a LineString has at least 2 elements--- data LineString a = LineString a a (Sequence.Seq a) deriving (Eq, Generic, NFData) -- |@@ -55,151 +54,138 @@ -- -- * The list was empty -- * The list only had one element----data ListToLineStringError =- ListEmpty- | SingletonList- deriving (Eq)+data ListToLineStringError+ = ListEmpty+ | SingletonList+ deriving (Eq) -- | -- When converting a Sequence to a LineString, here is a list of things that can go wrong: -- -- * The sequence was empty -- * The sequence only had one element----data SequenceToLineStringError =- SequenceEmpty- | SingletonSequence- deriving (Eq)+data SequenceToLineStringError+ = SequenceEmpty+ | SingletonSequence+ deriving (Eq) -- functions -- | -- returns the element at the head of the string--- lineStringHead :: LineString a -> a lineStringHead (LineString x _ _) = x -- | -- returns the last element in the string--- lineStringLast :: LineString a -> a lineStringLast (LineString _ x xs) = fromMaybe x (safeLast xs) -- | -- returns the number of elements in the list, including the replicated element at the end of the list.--- lineStringLength :: LineString a -> Int lineStringLength (LineString _ _ xs) = 2 + Sequence.length xs -- | -- This function converts it into a list and appends the given element to the end.--- fromLineString :: LineString a -> [a] fromLineString (LineString x y zs) = x : y : Foldable.toList zs -- | -- creates a LineString out of a list of elements, -- if there are enough elements (needs at least 2) elements--- fromList :: (Validation.Validate v) => [a] -> v ListToLineStringError (LineString a)-fromList [] = Validation._Failure # ListEmpty-fromList [_] = Validation._Failure # SingletonList-fromList (x:y:zs) = Validation._Success # LineString x y (Sequence.fromList zs)+fromList [] = Validation._Failure # ListEmpty+fromList [_] = Validation._Failure # SingletonList+fromList (x : y : zs) = Validation._Success # LineString x y (Sequence.fromList zs) {-# INLINE fromList #-} -- | -- create a sequence from a LineString by combining values. -- LineString 1 2 [3,4] (,) --> Sequence [(1,2),(2,3),(3,4)]--- combineToSeq :: (a -> a -> b) -> LineString a -> Sequence.Seq b combineToSeq combine (LineString a b rest) = combine a b Sequence.<| combineRest- where- combineRest =- if Sequence.null rest- then- Sequence.empty- else- (Sequence.zipWith combine <*> SeqHelper.sequenceTail) (b Sequence.<| rest)+ where+ combineRest =+ if Sequence.null rest+ then Sequence.empty+ else (Sequence.zipWith combine <*> SeqHelper.sequenceTail) (b Sequence.<| rest) {-# INLINE combineToSeq #-} -- | -- create a sequence from a LineString. -- LineString 1 2 [3,4] --> Sequence [1,2,3,4]--- toSeq :: LineString a -> Sequence.Seq a-toSeq (LineString a b rest) = a Sequence.<| ( b Sequence.<| rest)+toSeq (LineString a b rest) = a Sequence.<| (b Sequence.<| rest) {-# INLINE toSeq #-} -- | -- creates a LineString out of a sequence of elements, -- if there are enough elements (needs at least 2) elements--- fromSeq :: (Validation.Validate v) => Sequence.Seq a -> v SequenceToLineStringError (LineString a) fromSeq v@(headS Sequence.:<| tailS) =- if Sequence.null v then- Validation._Failure # SingletonSequence- else- fromSeq' headS tailS+ if Sequence.null v+ then Validation._Failure # SingletonSequence+ else fromSeq' headS tailS fromSeq _ = Validation._Failure # SequenceEmpty {-# INLINE fromSeq #-} fromSeq' :: (Validation.Validate v) => a -> Sequence.Seq a -> v SequenceToLineStringError (LineString a) fromSeq' first v@(headS Sequence.:<| tailS) =- if Sequence.null v then- Validation._Failure # SingletonSequence- else- Validation._Success # LineString first headS tailS+ if Sequence.null v+ then Validation._Failure # SingletonSequence+ else Validation._Success # LineString first headS tailS fromSeq' _ _ = Validation._Failure # SingletonSequence {-# INLINE fromSeq' #-} -- | -- Creates a LineString -- @makeLineString x y zs@ creates a `LineString` homomorphic to the list @[x, y] ++ zs@--- makeLineString ::- a -- ^ The first element- -> a -- ^ The second element- -> Sequence.Seq a -- ^ The rest of the optional elements- -> LineString a+ -- | The first element+ a ->+ -- | The second element+ a ->+ -- | The rest of the optional elements+ Sequence.Seq a ->+ LineString a makeLineString = LineString -- instances instance Show ListToLineStringError where- show ListEmpty = "List Empty"- show SingletonList = "Singleton List"+ show ListEmpty = "List Empty"+ show SingletonList = "Singleton List" instance Show SequenceToLineStringError where- show SequenceEmpty = "Sequence Empty"+ show SequenceEmpty = "Sequence Empty" show SingletonSequence = "Singleton Sequence" instance (Show a) => Show (LineString a) where- show = show . fromLineString+ show = show . fromLineString instance Functor LineString where- fmap f (LineString x y zs) = LineString (f x) (f y) (fmap f zs)+ fmap f (LineString x y zs) = LineString (f x) (f y) (fmap f zs) -- | This will run through the line string.--- instance Foldable LineString where- -- foldr :: (a -> b -> b) -> b -> LineString a -> b- foldr f u (LineString x y zs) = f x (f y (Foldable.foldr f u zs))+ -- foldr :: (a -> b -> b) -> b -> LineString a -> b+ foldr f u (LineString x y zs) = f x (f y (Foldable.foldr f u zs)) instance Traversable LineString where- -- sequenceA :: (Traversable t, Applicative f) => t (f a) -> f (t a)- sequenceA (LineString fx fy fzs) = LineString <$> fx <*> fy <*> sequenceA fzs+ -- sequenceA :: (Traversable t, Applicative f) => t (f a) -> f (t a)+ sequenceA (LineString fx fy fzs) = LineString <$> fx <*> fy <*> sequenceA fzs instance (ToJSON a) => ToJSON (LineString a) where--- toJSON :: a -> Value- toJSON = toJSON . fromLineString+ -- toJSON :: a -> Value+ toJSON = toJSON . fromLineString instance (FromJSON a, Show a) => FromJSON (LineString a) where--- parseJSON :: Value -> Parser a- parseJSON v = do- xs <- parseJSON v- let vxs = fromListValidated xs- maybe (parseError v (vxs ^? Validation._Failure)) return (vxs ^? Validation._Success)+ -- parseJSON :: Value -> Parser a+ parseJSON v = do+ xs <- parseJSON v+ let vxs = fromListValidated xs+ maybe (parseError v (vxs ^? Validation._Failure)) return (vxs ^? Validation._Success) -- helpers @@ -213,6 +199,6 @@ -- safeLast x = if Sequence.null x then Nothing else Just $ Sequence.last x safeLast :: Sequence.Seq a -> Maybe a safeLast x = case Sequence.viewr x of- Sequence.EmptyR -> Nothing- _ Sequence.:> b -> Just b+ Sequence.EmptyR -> Nothing+ _ Sequence.:> b -> Just b {-# INLINE safeLast #-}
src/Data/LinearRing.hs view
@@ -1,11 +1,13 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NoImplicitPrelude #-}+ -------------------------------------------------------------------+ -- | -- Module : Data.LinearRing--- Copyright : (C) 2014-2019 HS-GeoJSON Project+-- Copyright : (C) 2014-2021 HS-GeoJSON Project -- License : BSD-style (see the file LICENSE.md) -- Maintainer : Andrew Newman --@@ -13,24 +15,24 @@ -- -- A LinearRing is a List with at least 4 elements, where the -- first element is expected to be the same as the last.------------------------------------------------------------------------module Data.LinearRing (- -- * Type- LinearRing- , ListToLinearRingError(..)- , SequenceToLinearRingError(..)+module Data.LinearRing+ ( -- * Type+ LinearRing,+ ListToLinearRingError (..),+ SequenceToLinearRingError (..),+ -- * Functions- , toSeq- , combineToSeq- , fromSeq- , fromLinearRing- , fromList- , fromListWithEqCheck- , makeLinearRing- , ringHead- , ringLength- ) where+ toSeq,+ combineToSeq,+ fromSeq,+ fromLinearRing,+ fromList,+ fromListWithEqCheck,+ makeLinearRing,+ ringHead,+ ringLength,+ )+where #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 import Prelude hiding (foldr)@@ -38,23 +40,21 @@ import Prelude #endif -import Control.DeepSeq-import Control.Lens (( # ), (^?))-import Control.Monad (mzero)-import Data.Aeson (FromJSON (..), ToJSON (..), Value)-import Data.Aeson.Types (Parser, typeMismatch)-import qualified Data.Foldable as Foldable-import Data.List (intercalate)-import Data.List.NonEmpty as NL (NonEmpty, toList)-import qualified Data.Sequence as Sequence-import qualified Data.Validation as Validation-import GHC.Generics (Generic)--import qualified Data.SeqHelper as SeqHelper+import Control.DeepSeq+import Control.Lens ((#), (^?))+import Control.Monad (mzero)+import Data.Aeson (FromJSON (..), ToJSON (..), Value)+import Data.Aeson.Types (Parser, typeMismatch)+import qualified Data.Foldable as Foldable+import Data.List (intercalate)+import Data.List.NonEmpty as NL (NonEmpty, toList)+import qualified Data.SeqHelper as SeqHelper+import qualified Data.Sequence as Sequence+import qualified Data.Validation as Validation+import GHC.Generics (Generic) -- | -- a LinearRing has at least 3 (distinct) elements--- data LinearRing a = LinearRing a a a (Sequence.Seq a) deriving (Eq, Show, Generic, NFData) -- |@@ -63,20 +63,18 @@ -- * The list can be too short -- * The head may not be equal to the last element in the list (NB this is not currently checked due to performance concerns, -- and it also doesnt make much sense since its likely to contain doubles)----data ListToLinearRingError a =- ListTooShort Int- | HeadNotEqualToLast a a- deriving (Eq)+data ListToLinearRingError a+ = ListTooShort Int+ | HeadNotEqualToLast a a+ deriving (Eq) -- | -- When converting a Sequence to a LinearRing there are some things that can go wrong -- -- * The sequence can be too short -- * The head may not be equal to the last element in the list----data SequenceToLinearRingError a =- SequenceTooShort Int+data SequenceToLinearRingError a+ = SequenceTooShort Int | FirstNotEqualToLast a a deriving (Eq) @@ -84,19 +82,16 @@ -- | -- returns the element at the head of the ring--- ringHead :: LinearRing a -> a-ringHead (LinearRing x _ _ _) = x+ringHead (LinearRing x _ _ _) = x -- | -- returns the number of elements in the list, including the replicated element at the end of the list.--- ringLength :: LinearRing a -> Int ringLength (LinearRing _ _ _ xs) = 4 + Sequence.length xs -- | -- This function converts it into a list and appends the given element to the end.--- fromLinearRing :: LinearRing a -> [a] fromLinearRing (LinearRing x y z ws) = x : y : z : Foldable.foldr (:) [x] ws @@ -116,38 +111,32 @@ -- And be aware that the last element of the list will be dropped. -- -- Unfortunately it doesn't check that the last element is the same as the first at the moment...--- fromList :: (Eq a, Show a, Validation.Validate v, Functor (v (NonEmpty (ListToLinearRingError a)))) => [a] -> v (NonEmpty (ListToLinearRingError a)) (LinearRing a)-fromList (x:y:z:ws@(_:_)) = Validation._Success # LinearRing x y z (fromListDropLast ws)-fromList xs = Validation._Failure # pure (ListTooShort (length xs))+fromList (x : y : z : ws@(_ : _)) = Validation._Success # LinearRing x y z (fromListDropLast ws)+fromList xs = Validation._Failure # pure (ListTooShort (length xs)) {-# INLINE fromList #-} -- | -- The expensive version of fromList that checks whether the head and last elements -- are equal.--- fromListWithEqCheck :: (Eq a, Show a, Validation.Validate v, Applicative (v (NonEmpty (ListToLinearRingError a)))) => [a] -> v (NonEmpty (ListToLinearRingError a)) (LinearRing a) fromListWithEqCheck xs = checkHeadAndLastEq xs *> fromList xs -- | -- create a sequence from a LinearRing by combining values. -- LinearRing 1 2 3 [4,1] (,) --> Seq [(1,2),(2,3),(3,4),(4,1)]--- combineToSeq :: (a -> a -> b) -> LinearRing a -> Sequence.Seq b combineToSeq combine (LinearRing a b c rest) = combine a b Sequence.:<| (combine b c Sequence.:<| combineRest)- where- combineRest =- if Sequence.null rest- then- Sequence.empty- else- (Sequence.zipWith combine <*> SeqHelper.sequenceTail) (c Sequence.<| rest)+ where+ combineRest =+ if Sequence.null rest+ then Sequence.empty+ else (Sequence.zipWith combine <*> SeqHelper.sequenceTail) (c Sequence.<| rest) {-# INLINE combineToSeq #-} -- | -- create a sequence from a LinearRing. -- LinearRing 1 2 3 [4,1] --> Seq [1,2,3,4,1)]--- toSeq :: LinearRing a -> Sequence.Seq a toSeq (LinearRing a b c rest) = a Sequence.:<| (b Sequence.:<| (c Sequence.:<| rest)) {-# INLINE toSeq #-}@@ -160,18 +149,16 @@ -- fromSeq xs = _Failure # return (ListTooShort (length xs)) fromSeq :: (Eq a, Show a, Validation.Validate v, Functor (v (NonEmpty (ListToLinearRingError a)))) => Sequence.Seq a -> v (NonEmpty (SequenceToLinearRingError a)) (LinearRing a) fromSeq as =- case as of- (first Sequence.:<| (second Sequence.:<| (third Sequence.:<| rest@(_ Sequence.:|> lastS)))) ->- if first == lastS then- Validation._Success # LinearRing first second third rest- else- Validation._Failure # pure (FirstNotEqualToLast first lastS)- (first Sequence.:<| (second Sequence.:<| (third Sequence.:<| _))) ->- if first == third then- Validation._Success # LinearRing first second third Sequence.empty- else- Validation._Failure # pure (FirstNotEqualToLast first third)- v -> Validation._Failure # pure (SequenceTooShort (Sequence.length v))+ case as of+ (first Sequence.:<| (second Sequence.:<| (third Sequence.:<| rest@(_ Sequence.:|> lastS)))) ->+ if first == lastS+ then Validation._Success # LinearRing first second third rest+ else Validation._Failure # pure (FirstNotEqualToLast first lastS)+ (first Sequence.:<| (second Sequence.:<| (third Sequence.:<| _))) ->+ if first == third+ then Validation._Success # LinearRing first second third Sequence.empty+ else Validation._Failure # pure (FirstNotEqualToLast first third)+ v -> Validation._Failure # pure (SequenceTooShort (Sequence.length v)) {-# INLINE fromSeq #-} -- |@@ -181,53 +168,55 @@ -- be closed, makeLinearRing will close it off. -- -- Repeating the first element is just redundant.----makeLinearRing :: (Eq a, Show a) =>- a -- ^ The first element- -> a -- ^ The second element- -> a -- ^ The third element- -> Sequence.Seq a -- ^ The rest of the optional elements (WITHOUT the first element repeated at the end)- -> LinearRing a+makeLinearRing ::+ (Eq a, Show a) =>+ -- | The first element+ a ->+ -- | The second element+ a ->+ -- | The third element+ a ->+ -- | The rest of the optional elements (WITHOUT the first element repeated at the end)+ Sequence.Seq a ->+ LinearRing a makeLinearRing = LinearRing -- instances instance (Show a) => Show (ListToLinearRingError a) where- show (ListTooShort n) = "List too short: (length = " ++ show n ++ ")"- show (HeadNotEqualToLast h l) = "head (" ++ show h ++ ") /= last(" ++ show l ++ ")"+ show (ListTooShort n) = "List too short: (length = " ++ show n ++ ")"+ show (HeadNotEqualToLast h l) = "head (" ++ show h ++ ") /= last(" ++ show l ++ ")" instance (Show a) => Show (SequenceToLinearRingError a) where- show (SequenceTooShort n) = "Sequence too short: (length = " ++ show n ++ ")"- show (FirstNotEqualToLast h l) = "head (" ++ show h ++ ") /= last(" ++ show l ++ ")"+ show (SequenceTooShort n) = "Sequence too short: (length = " ++ show n ++ ")"+ show (FirstNotEqualToLast h l) = "head (" ++ show h ++ ") /= last(" ++ show l ++ ")" instance Functor LinearRing where- fmap f (LinearRing x y z ws) = LinearRing (f x) (f y) (f z) (fmap f ws)+ fmap f (LinearRing x y z ws) = LinearRing (f x) (f y) (f z) (fmap f ws) -- | This instance of Foldable will run through the entire ring, closing the -- loop by also passing the initial element in again at the end.--- instance Foldable LinearRing where- -- foldr :: (a -> b -> b) -> b -> LinearRing a -> b- foldr f u (LinearRing x y z ws) = f x (f y (f z (Foldable.foldr f (f x u) ws)))+ -- foldr :: (a -> b -> b) -> b -> LinearRing a -> b+ foldr f u (LinearRing x y z ws) = f x (f y (f z (Foldable.foldr f (f x u) ws))) -- | -- When traversing this Structure, the Applicative context -- of the last element will be appended to the end to close the loop--- instance Traversable LinearRing where- -- sequenceA :: (Traversable t, Applicative f) => t (f a) -> f (t a)- sequenceA (LinearRing fx fy fz fws) = (LinearRing <$> fx <*> fy <*> fz <*> sequenceA fws) <* fx+ -- sequenceA :: (Traversable t, Applicative f) => t (f a) -> f (t a)+ sequenceA (LinearRing fx fy fz fws) = (LinearRing <$> fx <*> fy <*> fz <*> sequenceA fws) <* fx instance (ToJSON a) => ToJSON (LinearRing a) where--- toJSON :: a -> Value- toJSON = toJSON . fromLinearRing+ -- toJSON :: a -> Value+ toJSON = toJSON . fromLinearRing instance (Eq a, FromJSON a, Show a) => FromJSON (LinearRing a) where--- parseJSON :: Value -> Parser a- parseJSON v = do- xs <- parseJSON v- let vxs = fromListAcc xs- maybe (parseError v (vxs ^? Validation._Failure)) return (vxs ^? Validation._Success)+ -- parseJSON :: Value -> Parser a+ parseJSON v = do+ xs <- parseJSON v+ let vxs = fromListAcc xs+ maybe (parseError v (vxs ^? Validation._Failure)) return (vxs ^? Validation._Success) -- helpers @@ -240,25 +229,25 @@ parseError :: (Show a) => Value -> Maybe (NonEmpty (ListToLinearRingError a)) -> Parser b parseError v = maybe mzero (\e -> typeMismatch (showErrors e) v) -checkHeadAndLastEq :: (Eq a, Validation.Validate v, Functor (v (NonEmpty (ListToLinearRingError a))))- => [a]- -> v (NonEmpty (ListToLinearRingError a)) ()+checkHeadAndLastEq ::+ (Eq a, Validation.Validate v, Functor (v (NonEmpty (ListToLinearRingError a)))) =>+ [a] ->+ v (NonEmpty (ListToLinearRingError a)) () checkHeadAndLastEq = maybe (Validation._Failure # pure (ListTooShort 0)) (\(h, l) -> if h == l then Validation._Success # () else Validation._Failure # pure (HeadNotEqualToLast h l)) . mhl- where- mhl ::[a] -> Maybe (a, a)- mhl xs = (,) <$> safeHead xs <*> safeLast xs+ where+ mhl :: [a] -> Maybe (a, a)+ mhl xs = (,) <$> safeHead xs <*> safeLast xs safeHead :: [a] -> Maybe a-safeHead [] = Nothing-safeHead (x:_) = Just x+safeHead [] = Nothing+safeHead (x : _) = Just x safeLast :: [a] -> Maybe a-safeLast [] = Nothing-safeLast [x] = Just x-safeLast (_:xs) = safeLast xs+safeLast [] = Nothing+safeLast [x] = Just x+safeLast (_ : xs) = safeLast xs fromListDropLast :: (Eq a) => [a] -> Sequence.Seq a-fromListDropLast [] = Sequence.empty+fromListDropLast [] = Sequence.empty fromListDropLast [_] = Sequence.empty-fromListDropLast x = SeqHelper.sequenceHead $ Sequence.fromList x-+fromListDropLast x = SeqHelper.sequenceHead $ Sequence.fromList x
src/Data/SeqHelper.hs view
@@ -1,33 +1,34 @@ -------------------------------------------------------------------+ -- | -- Module : Data.Geospatial.Internal.SeqHelpers--- Copyright : (C) 2014-2019 HS-GeoJSON Project+-- Copyright : (C) 2014-2021 HS-GeoJSON Project -- License : BSD-style (see the file LICENSE.md) -- Maintainer : Andrew Newman---------------------------------------------------------------------module Data.SeqHelper (- sequenceHead- , sequenceTail- , removeNextDuplicate- ) where+module Data.SeqHelper+ ( sequenceHead,+ sequenceTail,+ removeNextDuplicate,+ )+where import qualified Data.Sequence as Sequence -- All but the last sequenceHead :: Sequence.Seq a -> Sequence.Seq a sequenceHead (headS Sequence.:|> _) = headS-sequenceHead _ = Sequence.empty+sequenceHead _ = Sequence.empty {-# INLINE sequenceHead #-} -- All but the first sequenceTail :: Sequence.Seq a -> Sequence.Seq a sequenceTail (_ Sequence.:<| tailS) = tailS-sequenceTail _ = Sequence.empty+sequenceTail _ = Sequence.empty {-# INLINE sequenceTail #-} removeNextDuplicate :: Eq a => Sequence.Seq a -> Sequence.Seq a-removeNextDuplicate Sequence.Empty = Sequence.empty+removeNextDuplicate Sequence.Empty = Sequence.empty removeNextDuplicate xs@(_ Sequence.:<| Sequence.Empty) = xs removeNextDuplicate (x Sequence.:<| tailXs@(y Sequence.:<| _))- | x /= y = x Sequence.<| removeNextDuplicate tailXs+ | x /= y = x Sequence.<| removeNextDuplicate tailXs | otherwise = removeNextDuplicate tailXs
test/Arbitrary.hs view
@@ -2,12 +2,11 @@ module Arbitrary where -import Test.Tasty.QuickCheck (Arbitrary, arbitrary)- -- Local-import Data.LinearRing (LinearRing, makeLinearRing)-import Data.LineString (LineString, makeLineString) +import Data.LineString (LineString, makeLineString)+import Data.LinearRing (LinearRing, makeLinearRing)+import Test.Tasty.QuickCheck (Arbitrary, arbitrary) instance (Arbitrary a, Eq a, Show a) => Arbitrary (LinearRing a) where arbitrary = makeLinearRing <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
test/Data/Geospatial/Internal/CRSTests.hs view
@@ -2,15 +2,20 @@ module Data.Geospatial.Internal.CRSTests where -import qualified Data.Aeson as A-import qualified Data.ByteString.Lazy.Char8 as BS-import Test.Tasty-import Test.Tasty.Hspec (Spec, context, describe, it,- shouldBe, testSpec)+import qualified Data.Aeson as A+import qualified Data.ByteString.Lazy.Char8 as BS -- Local-import Data.Geospatial.Internal.CRS-import Fixture-+import Data.Geospatial.Internal.CRS+import Fixture+import Test.Tasty+import Test.Tasty.Hspec+ ( Spec,+ context,+ describe,+ it,+ shouldBe,+ testSpec,+ ) -- Tests @@ -21,10 +26,11 @@ specTests :: IO TestTree specTests = do- specs <- sequence- [ testSpec "Data.Geospatial.Internal.CRS.fromJSON" testFromJSON- , testSpec "Data.Geospatial.Internal.CRS.toJSON" testToJSON- ]+ specs <-+ sequence+ [ testSpec "Data.Geospatial.Internal.CRS.fromJSON" testFromJSON,+ testSpec "Data.Geospatial.Internal.CRS.toJSON" testToJSON+ ] pure $ testGroup "Data.Geospatial.Internal.CRSTests.Spec" specs -- Spec@@ -45,9 +51,9 @@ testFromJSON = describe "fromJSON" $ do it "decode CRS Objects from GeoJSON" $ do- A.decode testLinkCRSJSON `shouldBe` Just testLinkCRS+ A.decode testLinkCRSJSON `shouldBe` Just testLinkCRS A.decode testNamedCRSJSON `shouldBe` Just testNamedCRS- A.decode testEPSGJSON `shouldBe` Just testEPSG+ A.decode testEPSGJSON `shouldBe` Just testEPSG context "when provided with invalid input" $ it "fails" $ (A.decode . BS.pack) "null" `shouldBe` Just NoCRS@@ -68,9 +74,9 @@ testToJSON = describe "toJSON" $ do it "encode CRS Objects to GeoJSON" $ do- (A.decode . A.encode) testLinkCRS `shouldBe` Just testLinkCRS+ (A.decode . A.encode) testLinkCRS `shouldBe` Just testLinkCRS (A.decode . A.encode) testNamedCRS `shouldBe` Just testNamedCRS- (A.decode . A.encode) testEPSG `shouldBe` Just testEPSG+ (A.decode . A.encode) testEPSG `shouldBe` Just testEPSG context "when provided with invalid input" $ it "fails" $- A.encode NoCRS `shouldBe` "null"+ A.encode NoCRS `shouldBe` "null"
test/Data/Geospatial/Internal/GeoFeatureCollectionTests.hs view
@@ -1,11 +1,10 @@ module Data.Geospatial.Internal.GeoFeatureCollectionTests where -import qualified Data.Aeson as A-import Test.Tasty-import Test.Tasty.Hspec (Spec, describe, it, shouldBe, testSpec)+import qualified Data.Aeson as A -- Local-import Fixture-+import Fixture+import Test.Tasty+import Test.Tasty.Hspec (Spec, describe, it, shouldBe, testSpec) -- Tests @@ -16,13 +15,13 @@ specTests :: IO TestTree specTests = do- specs <- sequence- [ testSpec "Data.Geospatial.Internal.GeoFeatureCollection.fromJSON" testFromJSON- , testSpec "Data.Geospatial.Internal.GeoFeatureCollection.toJSON" testToJSON- ]+ specs <-+ sequence+ [ testSpec "Data.Geospatial.Internal.GeoFeatureCollection.fromJSON" testFromJSON,+ testSpec "Data.Geospatial.Internal.GeoFeatureCollection.toJSON" testToJSON+ ] pure $ testGroup "Data.Geospatial.Internal.GeoFeatureCollectionTests.Spec" specs - -- Spec -- >>> (A.decode . BS.pack) bigAssFeatureCollectionJSON == Just bigAssFeatureCollection@@ -41,10 +40,10 @@ testFromJSON = describe "fromJSON" $ it "decode FeatureCollection Objects from GeoJSON" $ do- A.decode bigAssFeatureCollectionJSON `shouldBe` Just bigAssFeatureCollection+ A.decode bigAssFeatureCollectionJSON `shouldBe` Just bigAssFeatureCollection A.decode bigAssFeatureCollectionWithNoBBoxJSON `shouldBe` Just bigAssFeatureCollectionWithNoBBox- A.decode emptyFeatureCollectionWithBBoxJSON `shouldBe` Just emptyFeatureCollectionWithBBox- A.decode emptyFeatureCollectionJSON `shouldBe` Just emptyFeatureCollection+ A.decode emptyFeatureCollectionWithBBoxJSON `shouldBe` Just emptyFeatureCollectionWithBBox+ A.decode emptyFeatureCollectionJSON `shouldBe` Just emptyFeatureCollection -- >>> (A.decode . A.encode) bigAssFeatureCollection == Just bigAssFeatureCollection -- True@@ -62,7 +61,7 @@ testToJSON = describe "toJSON" $ it "encode FeatureCollection Objects to GeoJSON" $ do- (A.decode . A.encode) bigAssFeatureCollection `shouldBe` Just bigAssFeatureCollection+ (A.decode . A.encode) bigAssFeatureCollection `shouldBe` Just bigAssFeatureCollection (A.decode . A.encode) bigAssFeatureCollectionWithNoBBox `shouldBe` Just bigAssFeatureCollectionWithNoBBox- (A.decode . A.encode) emptyFeatureCollectionWithBBox `shouldBe` Just emptyFeatureCollectionWithBBox- (A.decode . A.encode) emptyFeatureCollection `shouldBe` Just emptyFeatureCollection+ (A.decode . A.encode) emptyFeatureCollectionWithBBox `shouldBe` Just emptyFeatureCollectionWithBBox+ (A.decode . A.encode) emptyFeatureCollection `shouldBe` Just emptyFeatureCollection
test/Data/Geospatial/Internal/GeoFeatureTests.hs view
@@ -1,11 +1,10 @@ module Data.Geospatial.Internal.GeoFeatureTests where -import qualified Data.Aeson as A-import Test.Tasty-import Test.Tasty.Hspec (Spec, describe, it, shouldBe, testSpec)+import qualified Data.Aeson as A -- Local-import Fixture-+import Fixture+import Test.Tasty+import Test.Tasty.Hspec (Spec, describe, it, shouldBe, testSpec) -- Tests @@ -16,10 +15,11 @@ specTests :: IO TestTree specTests = do- specs <- sequence- [ testSpec "Data.Geospatial.Internal.GeoFeature.fromJSON" testFromJSON- , testSpec "Data.Geospatial.Internal.GeoFeature.toJSON" testToJSON- ]+ specs <-+ sequence+ [ testSpec "Data.Geospatial.Internal.GeoFeature.fromJSON" testFromJSON,+ testSpec "Data.Geospatial.Internal.GeoFeature.toJSON" testToJSON+ ] pure $ testGroup "Data.Geospatial.Internal.GeoFeatureTests.Spec" specs -- Spec@@ -43,11 +43,11 @@ testFromJSON = describe "fromJSON" $ it "decode Feature Objects from GeoJSON" $ do- A.decode bigFeatureJSON `shouldBe` Just bigFeature+ A.decode bigFeatureJSON `shouldBe` Just bigFeature A.decode featureWithNoPropertiesJSON `shouldBe` Just featureWithNoProperties- A.decode featureWithNoIdJSON `shouldBe` Just featureWithNoId- A.decode featureWithNoBBoxJSON `shouldBe` Just featureWithNoBBox- A.decode featureWithNoGeometryJSON `shouldBe` Just featureWithNoGeometry+ A.decode featureWithNoIdJSON `shouldBe` Just featureWithNoId+ A.decode featureWithNoBBoxJSON `shouldBe` Just featureWithNoBBox+ A.decode featureWithNoGeometryJSON `shouldBe` Just featureWithNoGeometry -- >>> (A.decode . A.encode) bigFeature == Just bigFeature -- True@@ -68,8 +68,8 @@ testToJSON = describe "toJSON" $ it "encode Feature Objects to GeoJSON" $ do- (A.decode . A.encode) bigFeature `shouldBe` Just bigFeature+ (A.decode . A.encode) bigFeature `shouldBe` Just bigFeature (A.decode . A.encode) featureWithNoProperties `shouldBe` Just featureWithNoProperties- (A.decode . A.encode) featureWithNoId `shouldBe` Just featureWithNoId- (A.decode . A.encode) featureWithNoBBox `shouldBe` Just featureWithNoBBox- (A.decode . A.encode) featureWithNoGeometry `shouldBe` Just featureWithNoGeometry+ (A.decode . A.encode) featureWithNoId `shouldBe` Just featureWithNoId+ (A.decode . A.encode) featureWithNoBBox `shouldBe` Just featureWithNoBBox+ (A.decode . A.encode) featureWithNoGeometry `shouldBe` Just featureWithNoGeometry
test/Data/Geospatial/Internal/GeometryTests.hs view
@@ -2,14 +2,19 @@ module Data.Geospatial.Internal.GeometryTests where -import qualified Data.Aeson as A-import qualified Data.ByteString.Lazy.Char8 as BS-import Test.Tasty-import Test.Tasty.Hspec (Spec, describe, it,- shouldBe, testSpec)+import qualified Data.Aeson as A+import qualified Data.ByteString.Lazy.Char8 as BS -- Local-import Data.Geospatial.Internal.Geometry-import Fixture+import Data.Geospatial.Internal.Geometry+import Fixture+import Test.Tasty+import Test.Tasty.Hspec+ ( Spec,+ describe,+ it,+ shouldBe,+ testSpec,+ ) -- Tests @@ -20,10 +25,11 @@ specTests :: IO TestTree specTests = do- specs <- sequence- [ testSpec "Data.Geospatial.Internal.Geometry.fromJSON" testFromJSON- , testSpec "Data.Geospatial.Internal.Geometry.toJSON" testToJSON- ]+ specs <-+ sequence+ [ testSpec "Data.Geospatial.Internal.Geometry.fromJSON" testFromJSON,+ testSpec "Data.Geospatial.Internal.Geometry.toJSON" testToJSON+ ] pure $ testGroup "Data.Geospatial.Internal.GeometryTests.Spec" specs -- Spec@@ -57,14 +63,14 @@ testFromJSON = describe "fromJSON" $ it "decode Feature Objects from GeoJSON" $ do- A.decode lShapedPolyJSON `shouldBe` Just lShapedPoly- A.decode emptyPolyJSON `shouldBe` Just emptyPoly- A.decode emptyMultiPolyJSON `shouldBe` Just emptyMultiPoly+ A.decode lShapedPolyJSON `shouldBe` Just lShapedPoly+ A.decode emptyPolyJSON `shouldBe` Just emptyPoly+ A.decode emptyMultiPolyJSON `shouldBe` Just emptyMultiPoly A.decode singleLineMultiLineJSON `shouldBe` Just singleLineMultiLine- A.decode multiLineJSON `shouldBe` Just multiLine- A.decode emptyCollectionJSON `shouldBe` Just emptyCollection- A.decode bigassCollectionJSON `shouldBe` Just bigassCollection- (A.decode . BS.pack) "null" `shouldBe` Just NoGeometry+ A.decode multiLineJSON `shouldBe` Just multiLine+ A.decode emptyCollectionJSON `shouldBe` Just emptyCollection+ A.decode bigassCollectionJSON `shouldBe` Just bigassCollection+ (A.decode . BS.pack) "null" `shouldBe` Just NoGeometry -- >>> A.encode NoGeometry -- "null"@@ -94,11 +100,11 @@ testToJSON = describe "toJSON" $ it "encode Feature Objects to GeoJSON" $ do- A.encode NoGeometry `shouldBe` "null"- (A.decode . A.encode) lShapedPoly `shouldBe` Just lShapedPoly- (A.decode . A.encode) emptyPoly `shouldBe` Just emptyPoly- (A.decode . A.encode) emptyMultiPoly `shouldBe` Just emptyMultiPoly+ A.encode NoGeometry `shouldBe` "null"+ (A.decode . A.encode) lShapedPoly `shouldBe` Just lShapedPoly+ (A.decode . A.encode) emptyPoly `shouldBe` Just emptyPoly+ (A.decode . A.encode) emptyMultiPoly `shouldBe` Just emptyMultiPoly (A.decode . A.encode) singleLineMultiLine `shouldBe` Just singleLineMultiLine- (A.decode . A.encode) multiLine `shouldBe` Just multiLine- (A.decode . A.encode) emptyCollection `shouldBe` Just emptyCollection- (A.decode . A.encode) bigassCollection `shouldBe` Just bigassCollection+ (A.decode . A.encode) multiLine `shouldBe` Just multiLine+ (A.decode . A.encode) emptyCollection `shouldBe` Just emptyCollection+ (A.decode . A.encode) bigassCollection `shouldBe` Just bigassCollection
test/Data/LineStringTests.hs view
@@ -1,16 +1,26 @@ module Data.LineStringTests where -import qualified Data.Sequence as Sequence-import Data.Validation (Validation (..))-import Test.Tasty-import Test.Tasty.Hspec (Spec, context, describe,- it, shouldBe, testSpec)-import Test.Tasty.QuickCheck (Property, property,- testProperty) -- Local-import Arbitrary ()+import Arbitrary () import qualified Data.Geospatial.Internal.BasicTypes as BasicTypes-import qualified Data.LineString as LineString+import qualified Data.LineString as LineString+import qualified Data.Sequence as Sequence+import Data.Validation (Validation (..))+import Test.Tasty+import Test.Tasty.Hspec+ ( Spec,+ context,+ describe,+ it,+ shouldBe,+ testSpec,+ )+import Test.Tasty.QuickCheck+ ( Property,+ property,+ testProperty,+ )+ -- Tests tests :: IO TestTree@@ -19,20 +29,23 @@ pure $ testGroup "Data.LineStringTests" [qcTests, specs] qcTests :: TestTree-qcTests = testGroup "Data.LineStringTests.QuickCheck"- [ testProperty "Data.LineString.lineStringLength" testLineStringLength- , testProperty "Data.LineString.fromLineString" testFromLineString- , testProperty "Data.LineString.Foldable" testFoldable- ]+qcTests =+ testGroup+ "Data.LineStringTests.QuickCheck"+ [ testProperty "Data.LineString.lineStringLength" testLineStringLength,+ testProperty "Data.LineString.fromLineString" testFromLineString,+ testProperty "Data.LineString.Foldable" testFoldable+ ] specTests :: IO TestTree specTests = do- specs <- sequence- [ testSpec "Data.LineString.fromList" testFromList- , testSpec "Data.LineString.fromSeq" testFromSequence- , testSpec "Data.LineString.toSeq" testToSequence- , testSpec "Data.LineString.combineToSequence" testCombineToSequence- ]+ specs <-+ sequence+ [ testSpec "Data.LineString.fromList" testFromList,+ testSpec "Data.LineString.fromSeq" testFromSequence,+ testSpec "Data.LineString.toSeq" testToSequence,+ testSpec "Data.LineString.combineToSequence" testCombineToSequence+ ] pure $ testGroup "Data.LineStringTests.Spec" specs -- QuickCheck@@ -75,40 +88,40 @@ testFromList = describe "fromList" $ do it "creates a LineString out of a list of elements" $ do- LineString.fromList ([0, 1] :: [Int]) `shouldBe` Success (LineString.makeLineString 0 1 Sequence.empty)- LineString.fromList ([0, 1, 2] :: [Int]) `shouldBe` Success (LineString.makeLineString 0 1 (Sequence.fromList [2]))+ LineString.fromList ([0, 1] :: [Int]) `shouldBe` Success (LineString.makeLineString 0 1 Sequence.empty)+ LineString.fromList ([0, 1, 2] :: [Int]) `shouldBe` Success (LineString.makeLineString 0 1 (Sequence.fromList [2])) LineString.fromList ([0, 1, 2, 4, 5, 0] :: [Int]) `shouldBe` Success (LineString.makeLineString 0 1 (Sequence.fromList [2, 4, 5, 0])) context "when provided with invalid input" $ it "fails" $ do- LineString.fromList ([] :: [Int]) `shouldBe` Failure LineString.ListEmpty+ LineString.fromList ([] :: [Int]) `shouldBe` Failure LineString.ListEmpty LineString.fromList ([0] :: [Int]) `shouldBe` Failure LineString.SingletonList testFromSequence :: Spec testFromSequence = describe "fromSeq" $ do it "creates a LineString out of a Sequence of elements" $ do- LineString.fromSeq (Sequence.fromList [0, 1] :: (Sequence.Seq Int)) `shouldBe` Success (LineString.makeLineString 0 1 Sequence.empty)- LineString.fromSeq (Sequence.fromList [0, 1, 2] :: (Sequence.Seq Int)) `shouldBe` Success (LineString.makeLineString 0 1 (Sequence.fromList [2]))+ LineString.fromSeq (Sequence.fromList [0, 1] :: (Sequence.Seq Int)) `shouldBe` Success (LineString.makeLineString 0 1 Sequence.empty)+ LineString.fromSeq (Sequence.fromList [0, 1, 2] :: (Sequence.Seq Int)) `shouldBe` Success (LineString.makeLineString 0 1 (Sequence.fromList [2])) LineString.fromSeq (Sequence.fromList [0, 1, 2, 4, 5, 0] :: (Sequence.Seq Int)) `shouldBe` Success (LineString.makeLineString 0 1 (Sequence.fromList [2, 4, 5, 0])) context "when provided with invalid input" $ it "fails" $ do- LineString.fromSeq (Sequence.fromList [] :: (Sequence.Seq Int)) `shouldBe` Failure LineString.SequenceEmpty+ LineString.fromSeq (Sequence.fromList [] :: (Sequence.Seq Int)) `shouldBe` Failure LineString.SequenceEmpty LineString.fromSeq (Sequence.fromList [0] :: (Sequence.Seq Int)) `shouldBe` Failure LineString.SingletonSequence testCombineToSequence :: Spec testCombineToSequence = describe "combineToSeq" $ it "combine a LineString using PointXY" $ do- LineString.combineToSeq BasicTypes.PointXY (LineString.makeLineString 0 1 Sequence.empty) `shouldBe` Sequence.fromList [BasicTypes.PointXY 0 1]- LineString.combineToSeq BasicTypes.PointXY (LineString.makeLineString 0 1 (Sequence.fromList [2])) `shouldBe` Sequence.fromList [BasicTypes.PointXY 0 1, BasicTypes.PointXY 1 2]+ LineString.combineToSeq BasicTypes.PointXY (LineString.makeLineString 0 1 Sequence.empty) `shouldBe` Sequence.fromList [BasicTypes.PointXY 0 1]+ LineString.combineToSeq BasicTypes.PointXY (LineString.makeLineString 0 1 (Sequence.fromList [2])) `shouldBe` Sequence.fromList [BasicTypes.PointXY 0 1, BasicTypes.PointXY 1 2] LineString.combineToSeq BasicTypes.PointXY (LineString.makeLineString 0 1 (Sequence.fromList [2, 4, 5, 0])) `shouldBe` Sequence.fromList [BasicTypes.PointXY 0 1, BasicTypes.PointXY 1 2, BasicTypes.PointXY 2 4, BasicTypes.PointXY 4 5, BasicTypes.PointXY 5 0] testToSequence :: Spec testToSequence = describe "toSeq" $ it "from a LineString to a Sequence" $ do- LineString.toSeq (LineString.makeLineString 0 1 Sequence.empty) `shouldBe` Sequence.fromList ([0, 1] :: [Int])- LineString.toSeq (LineString.makeLineString 0 1 (Sequence.fromList [2])) `shouldBe` Sequence.fromList ([0, 1, 2] :: [Int])+ LineString.toSeq (LineString.makeLineString 0 1 Sequence.empty) `shouldBe` Sequence.fromList ([0, 1] :: [Int])+ LineString.toSeq (LineString.makeLineString 0 1 (Sequence.fromList [2])) `shouldBe` Sequence.fromList ([0, 1, 2] :: [Int]) LineString.toSeq (LineString.makeLineString 0 1 (Sequence.fromList [2, 4, 5, 0])) `shouldBe` Sequence.fromList ([0, 1, 2, 4, 5, 0] :: [Int]) -- TODO
test/Data/LinearRingTests.hs view
@@ -1,17 +1,26 @@ module Data.LinearRingTests where -import qualified Data.List.NonEmpty as ListNonEmpty-import qualified Data.Sequence as Sequence-import qualified Data.Validation as Validation-import Test.Tasty-import Test.Tasty.Hspec (Spec, context, describe,- it, shouldBe, testSpec)-import Test.Tasty.QuickCheck (Property, property,- testProperty) -- Local-import Arbitrary ()+import Arbitrary () import qualified Data.Geospatial.Internal.BasicTypes as BasicTypes-import qualified Data.LinearRing as LinearRing+import qualified Data.LinearRing as LinearRing+import qualified Data.List.NonEmpty as ListNonEmpty+import qualified Data.Sequence as Sequence+import qualified Data.Validation as Validation+import Test.Tasty+import Test.Tasty.Hspec+ ( Spec,+ context,+ describe,+ it,+ shouldBe,+ testSpec,+ )+import Test.Tasty.QuickCheck+ ( Property,+ property,+ testProperty,+ ) -- Tests @@ -21,21 +30,24 @@ pure $ testGroup "Data.LinearRingTests" [qcTests, specs] qcTests :: TestTree-qcTests = testGroup "Data.LinearRingTests.QuickCheck"- [ testProperty "Data.LinearRing.ringLength" testRingLength- , testProperty "Data.LinearRing.fromLinearRing" testFromLinearRing- , testProperty "Data.LinearRing.Foldable" testFoldable- ]+qcTests =+ testGroup+ "Data.LinearRingTests.QuickCheck"+ [ testProperty "Data.LinearRing.ringLength" testRingLength,+ testProperty "Data.LinearRing.fromLinearRing" testFromLinearRing,+ testProperty "Data.LinearRing.Foldable" testFoldable+ ] specTests :: IO TestTree specTests = do- specs <- sequence- [ testSpec "Data.LinearRing.fromList" testFromList- , testSpec "Data.LinearRing.fromSeq" testFromSequence- , testSpec "Data.LinearRing.combineToSequence" testCombineToSequence- , testSpec "Data.LinearRing.toSequence" testToSequence- , testSpec "Data.LinearRing.foldMap" testFoldMap- ]+ specs <-+ sequence+ [ testSpec "Data.LinearRing.fromList" testFromList,+ testSpec "Data.LinearRing.fromSeq" testFromSequence,+ testSpec "Data.LinearRing.combineToSequence" testCombineToSequence,+ testSpec "Data.LinearRing.toSequence" testToSequence,+ testSpec "Data.LinearRing.foldMap" testFoldMap+ ] pure $ testGroup "Data.LinearRingTests.Spec" specs -- QuickCheck@@ -87,54 +99,53 @@ testFromList = describe "fromList" $ do it "creates a LinearRing out of a list of elements" $ do- LinearRing.fromList ([0, 1, 2, 3] :: [Int]) `shouldBe` Validation.Success (LinearRing.makeLinearRing 0 1 2 Sequence.empty)- LinearRing.fromList ([0, 1, 2, 4, 0] :: [Int]) `shouldBe` Validation.Success (LinearRing.makeLinearRing 0 1 2 (Sequence.fromList [4]))- LinearRing.fromList ([0, 1, 2, 4, 5, 0] :: [Int]) `shouldBe` Validation.Success (LinearRing.makeLinearRing 0 1 2 (Sequence.fromList [4,5]))- LinearRing.fromList ([0, 1, 2, 4, 5, 6] :: [Int]) `shouldBe` Validation.Success (LinearRing.makeLinearRing 0 1 2 (Sequence.fromList [4,5]))+ LinearRing.fromList ([0, 1, 2, 3] :: [Int]) `shouldBe` Validation.Success (LinearRing.makeLinearRing 0 1 2 Sequence.empty)+ LinearRing.fromList ([0, 1, 2, 4, 0] :: [Int]) `shouldBe` Validation.Success (LinearRing.makeLinearRing 0 1 2 (Sequence.fromList [4]))+ LinearRing.fromList ([0, 1, 2, 4, 5, 0] :: [Int]) `shouldBe` Validation.Success (LinearRing.makeLinearRing 0 1 2 (Sequence.fromList [4, 5]))+ LinearRing.fromList ([0, 1, 2, 4, 5, 6] :: [Int]) `shouldBe` Validation.Success (LinearRing.makeLinearRing 0 1 2 (Sequence.fromList [4, 5])) context "when provided with invalid input" $ it "fails" $ do- LinearRing.fromList [] `shouldBe` Validation.Failure (LinearRing.ListTooShort 0 ListNonEmpty.:| [] :: ListNonEmpty.NonEmpty (LinearRing.ListToLinearRingError Int))- LinearRing.fromList [0] `shouldBe` Validation.Failure (LinearRing.ListTooShort 1 ListNonEmpty.:| [] :: ListNonEmpty.NonEmpty (LinearRing.ListToLinearRingError Int))- LinearRing.fromList [0, 1] `shouldBe` Validation.Failure (LinearRing.ListTooShort 2 ListNonEmpty.:| [] :: ListNonEmpty.NonEmpty (LinearRing.ListToLinearRingError Int))+ LinearRing.fromList [] `shouldBe` Validation.Failure (LinearRing.ListTooShort 0 ListNonEmpty.:| [] :: ListNonEmpty.NonEmpty (LinearRing.ListToLinearRingError Int))+ LinearRing.fromList [0] `shouldBe` Validation.Failure (LinearRing.ListTooShort 1 ListNonEmpty.:| [] :: ListNonEmpty.NonEmpty (LinearRing.ListToLinearRingError Int))+ LinearRing.fromList [0, 1] `shouldBe` Validation.Failure (LinearRing.ListTooShort 2 ListNonEmpty.:| [] :: ListNonEmpty.NonEmpty (LinearRing.ListToLinearRingError Int)) LinearRing.fromList [0, 1, 2] `shouldBe` Validation.Failure (LinearRing.ListTooShort 3 ListNonEmpty.:| [] :: ListNonEmpty.NonEmpty (LinearRing.ListToLinearRingError Int)) testFromSequence :: Spec testFromSequence = describe "fromSeq" $ do it "creates a LinearRing out of a Sequence of elements" $ do- LinearRing.fromSeq (Sequence.fromList ([0, 1, 0] :: [Int])) `shouldBe` Validation.Success (LinearRing.makeLinearRing 0 1 0 Sequence.empty)- LinearRing.fromSeq (Sequence.fromList ([0, 1, 2, 0] :: [Int])) `shouldBe` Validation.Success (LinearRing.makeLinearRing 0 1 2 (Sequence.fromList [0]))- LinearRing.fromSeq (Sequence.fromList ([0, 1, 2, 4, 0] :: [Int])) `shouldBe` Validation.Success (LinearRing.makeLinearRing 0 1 2 (Sequence.fromList [4, 0]))- LinearRing.fromSeq (Sequence.fromList ([0, 1, 2, 4, 5, 0]:: [Int])) `shouldBe` Validation.Success (LinearRing.makeLinearRing 0 1 2 (Sequence.fromList [4, 5, 0]))+ LinearRing.fromSeq (Sequence.fromList ([0, 1, 0] :: [Int])) `shouldBe` Validation.Success (LinearRing.makeLinearRing 0 1 0 Sequence.empty)+ LinearRing.fromSeq (Sequence.fromList ([0, 1, 2, 0] :: [Int])) `shouldBe` Validation.Success (LinearRing.makeLinearRing 0 1 2 (Sequence.fromList [0]))+ LinearRing.fromSeq (Sequence.fromList ([0, 1, 2, 4, 0] :: [Int])) `shouldBe` Validation.Success (LinearRing.makeLinearRing 0 1 2 (Sequence.fromList [4, 0]))+ LinearRing.fromSeq (Sequence.fromList ([0, 1, 2, 4, 5, 0] :: [Int])) `shouldBe` Validation.Success (LinearRing.makeLinearRing 0 1 2 (Sequence.fromList [4, 5, 0])) context "when provided with invalid input" $ it "fails" $ do- LinearRing.fromSeq (Sequence.fromList []) `shouldBe` Validation.Failure (LinearRing.SequenceTooShort 0 ListNonEmpty.:| [] :: ListNonEmpty.NonEmpty (LinearRing.SequenceToLinearRingError Int))- LinearRing.fromSeq (Sequence.fromList [0]) `shouldBe` Validation.Failure (LinearRing.SequenceTooShort 1 ListNonEmpty.:| [] :: ListNonEmpty.NonEmpty (LinearRing.SequenceToLinearRingError Int))- LinearRing.fromSeq (Sequence.fromList [0, 1]) `shouldBe` Validation.Failure (LinearRing.SequenceTooShort 2 ListNonEmpty.:| [] :: ListNonEmpty.NonEmpty (LinearRing.SequenceToLinearRingError Int))+ LinearRing.fromSeq (Sequence.fromList []) `shouldBe` Validation.Failure (LinearRing.SequenceTooShort 0 ListNonEmpty.:| [] :: ListNonEmpty.NonEmpty (LinearRing.SequenceToLinearRingError Int))+ LinearRing.fromSeq (Sequence.fromList [0]) `shouldBe` Validation.Failure (LinearRing.SequenceTooShort 1 ListNonEmpty.:| [] :: ListNonEmpty.NonEmpty (LinearRing.SequenceToLinearRingError Int))+ LinearRing.fromSeq (Sequence.fromList [0, 1]) `shouldBe` Validation.Failure (LinearRing.SequenceTooShort 2 ListNonEmpty.:| [] :: ListNonEmpty.NonEmpty (LinearRing.SequenceToLinearRingError Int)) LinearRing.fromSeq (Sequence.fromList [0, 1, 2]) `shouldBe` Validation.Failure (LinearRing.FirstNotEqualToLast 0 2 ListNonEmpty.:| [] :: ListNonEmpty.NonEmpty (LinearRing.SequenceToLinearRingError Int)) testCombineToSequence :: Spec testCombineToSequence = describe "combineToSeq" $ it "combine a LinearRing using tuples" $ do- LinearRing.combineToSeq BasicTypes.PointXY (LinearRing.makeLinearRing 0 1 2 Sequence.empty) `shouldBe` Sequence.fromList [BasicTypes.PointXY 0 1, BasicTypes.PointXY 1 2]- LinearRing.combineToSeq BasicTypes.PointXY (LinearRing.makeLinearRing 0 1 2 (Sequence.fromList [4])) `shouldBe` Sequence.fromList [BasicTypes.PointXY 0 1, BasicTypes.PointXY 1 2, BasicTypes.PointXY 2 4]- LinearRing.combineToSeq BasicTypes.PointXY (LinearRing.makeLinearRing 0 1 2 (Sequence.fromList [4,5])) `shouldBe` Sequence.fromList [BasicTypes.PointXY 0 1, BasicTypes.PointXY 1 2, BasicTypes.PointXY 2 4, BasicTypes.PointXY 4 5]+ LinearRing.combineToSeq BasicTypes.PointXY (LinearRing.makeLinearRing 0 1 2 Sequence.empty) `shouldBe` Sequence.fromList [BasicTypes.PointXY 0 1, BasicTypes.PointXY 1 2]+ LinearRing.combineToSeq BasicTypes.PointXY (LinearRing.makeLinearRing 0 1 2 (Sequence.fromList [4])) `shouldBe` Sequence.fromList [BasicTypes.PointXY 0 1, BasicTypes.PointXY 1 2, BasicTypes.PointXY 2 4]+ LinearRing.combineToSeq BasicTypes.PointXY (LinearRing.makeLinearRing 0 1 2 (Sequence.fromList [4, 5])) `shouldBe` Sequence.fromList [BasicTypes.PointXY 0 1, BasicTypes.PointXY 1 2, BasicTypes.PointXY 2 4, BasicTypes.PointXY 4 5] testToSequence :: Spec testToSequence = describe "toSeq" $ it "from a LinearRing to a Sequence" $ do- LinearRing.toSeq (LinearRing.makeLinearRing 0 1 0 Sequence.empty) `shouldBe` Sequence.fromList ([0, 1, 0] :: [Int])- LinearRing.toSeq (LinearRing.makeLinearRing 0 1 2 (Sequence.fromList [0])) `shouldBe` Sequence.fromList ([0, 1, 2, 0] :: [Int])- LinearRing.toSeq (LinearRing.makeLinearRing 0 1 2 (Sequence.fromList [4,0])) `shouldBe` Sequence.fromList ([0, 1, 2, 4, 0] :: [Int])+ LinearRing.toSeq (LinearRing.makeLinearRing 0 1 0 Sequence.empty) `shouldBe` Sequence.fromList ([0, 1, 0] :: [Int])+ LinearRing.toSeq (LinearRing.makeLinearRing 0 1 2 (Sequence.fromList [0])) `shouldBe` Sequence.fromList ([0, 1, 2, 0] :: [Int])+ LinearRing.toSeq (LinearRing.makeLinearRing 0 1 2 (Sequence.fromList [4, 0])) `shouldBe` Sequence.fromList ([0, 1, 2, 4, 0] :: [Int]) testFoldMap :: Spec testFoldMap = describe "foldMap" $ it "foldMap of a LinearRing" $ foldMap (\x -> Sequence.singleton (x + 1)) (LinearRing.makeLinearRing 0 1 2 Sequence.empty) `shouldBe` Sequence.fromList ([1, 2, 3, 1] :: [Int])- -- TODO -- > (\xs -> safeLast (fromLinearRing xs) == Just (ringHead xs)) (xs :: LinearRing Int)
test/Data/SeqHelperTests.hs view
@@ -1,11 +1,11 @@ module Data.SeqHelperTests where -import qualified Data.Sequence as Sequence-import Test.Tasty-import Test.Tasty.Hspec (Spec, describe, it, shouldBe, testSpec) -- Local-import Arbitrary ()-import qualified Data.SeqHelper as SeqHelper+import Arbitrary ()+import qualified Data.SeqHelper as SeqHelper+import qualified Data.Sequence as Sequence+import Test.Tasty+import Test.Tasty.Hspec (Spec, describe, it, shouldBe, testSpec) -- Tests
test/Fixture.hs view
@@ -2,25 +2,29 @@ module Fixture where -import qualified Data.Aeson as Aeson-import qualified Data.ByteString.Lazy.Char8 as BS-import qualified Data.Text as T+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as AesonKey+import qualified Data.ByteString.Lazy.Char8 as BS -- Local-import qualified Data.Geospatial.Internal.BasicTypes as BasicTypes-import Data.Geospatial.Internal.CRS (CRSObject (..))-import Data.Geospatial.Internal.GeoFeature (GeoFeature (..))-import Data.Geospatial.Internal.GeoFeatureCollection (GeoFeatureCollection (..))-import Data.Geospatial.Internal.Geometry (GeospatialGeometry (..))-import Data.Geospatial.Internal.Geometry.GeoLine (GeoLine (..))-import Data.Geospatial.Internal.Geometry.GeoMultiLine (GeoMultiLine (..),- mergeGeoLines)-import Data.Geospatial.Internal.Geometry.GeoMultiPolygon (GeoMultiPolygon (..),- mergeGeoPolygons)-import Data.Geospatial.Internal.Geometry.GeoPoint (GeoPoint (..))-import Data.Geospatial.Internal.Geometry.GeoPolygon (GeoPolygon (..))-import qualified Data.LinearRing as LinearRing-import qualified Data.LineString as LineString-import qualified Data.Sequence as Sequence+import qualified Data.Geospatial.Internal.BasicTypes as BasicTypes+import Data.Geospatial.Internal.CRS (CRSObject (..))+import Data.Geospatial.Internal.GeoFeature (GeoFeature (..))+import Data.Geospatial.Internal.GeoFeatureCollection (GeoFeatureCollection (..))+import Data.Geospatial.Internal.Geometry (GeospatialGeometry (..))+import Data.Geospatial.Internal.Geometry.GeoLine (GeoLine (..))+import Data.Geospatial.Internal.Geometry.GeoMultiLine+ ( GeoMultiLine (..),+ mergeGeoLines,+ )+import Data.Geospatial.Internal.Geometry.GeoMultiPolygon+ ( GeoMultiPolygon (..),+ mergeGeoPolygons,+ )+import Data.Geospatial.Internal.Geometry.GeoPoint (GeoPoint (..))+import Data.Geospatial.Internal.Geometry.GeoPolygon (GeoPolygon (..))+import qualified Data.LineString as LineString+import qualified Data.LinearRing as LinearRing+import qualified Data.Sequence as Sequence -- CRS Data @@ -48,7 +52,7 @@ mkGeoPoint x y = BasicTypes.GeoPointXY $ BasicTypes.PointXY x y lshapedPolyVertices :: Sequence.Seq (LinearRing.LinearRing BasicTypes.GeoPositionWithoutCRS)-lshapedPolyVertices = Sequence.fromList [LinearRing.makeLinearRing (mkGeoPoint 120.0 (-15.0)) (mkGeoPoint 127.0 (-15.0)) (mkGeoPoint 127.0 (-25.0)) (Sequence.fromList [mkGeoPoint 124.0 (-25.0), mkGeoPoint 124.0 (-18.0), mkGeoPoint 120.0 (-18.0)])]+lshapedPolyVertices = Sequence.fromList [LinearRing.makeLinearRing (mkGeoPoint 120.0 (-15.0)) (mkGeoPoint 127.0 (-15.0)) (mkGeoPoint 127.0 (-25.0)) (Sequence.fromList [mkGeoPoint 124.0 (-25.0), mkGeoPoint 124.0 (-18.0), mkGeoPoint 120.0 (-18.0)])] lshapedPolyLineVertices :: LineString.LineString BasicTypes.GeoPositionWithoutCRS lshapedPolyLineVertices = LineString.makeLineString (mkGeoPoint 120.0 (-15.0)) (mkGeoPoint 127.0 (-15.0)) (Sequence.fromList [mkGeoPoint 127.0 (-25.0), mkGeoPoint 124.0 (-25.0), mkGeoPoint 124.0 (-18.0), mkGeoPoint 120.0 (-18.0)])@@ -67,7 +71,9 @@ -- Upside down L Shaped Poly -- -- (120, -15) (127, -15)--- *---------------------------*++-- * ---------------------------*+ -- | | -- | | -- | (124, -18) |@@ -81,7 +87,6 @@ -- | | -- *-----------* -- (124, -25) (127, -25)--- -- Points pointJSON :: BS.ByteString@@ -103,7 +108,6 @@ lShapedPoly :: GeospatialGeometry lShapedPoly = Polygon lShapedGeoPoly - emptyPolyJSON :: BS.ByteString emptyPolyJSON = "{\"type\":\"Polygon\",\"coordinates\":[]}" @@ -195,7 +199,7 @@ -- Properties Data testProperties :: Aeson.Value-testProperties = Aeson.object [T.pack "depth" Aeson..= (5 :: Int), T.pack "comment" Aeson..= T.pack "Bore run over by dump truck"]+testProperties = Aeson.object [AesonKey.fromText "depth" Aeson..= (5 :: Int), AesonKey.fromText "comment" Aeson..= AesonKey.fromText "Bore run over by dump truck"] -- Feature Data
test/Main.hs view
@@ -1,25 +1,25 @@ module Main (main) where -import Test.Tasty -- Local-import qualified Data.Geospatial.Internal.CRSTests as CRS+import qualified Data.Geospatial.Internal.CRSTests as CRS import qualified Data.Geospatial.Internal.GeoFeatureCollectionTests as FC-import qualified Data.Geospatial.Internal.GeoFeatureTests as F-import qualified Data.Geospatial.Internal.GeometryTests as G-import qualified Data.LinearRingTests as LR-import qualified Data.LineStringTests as LS-import qualified Data.SeqHelperTests as SH-+import qualified Data.Geospatial.Internal.GeoFeatureTests as F+import qualified Data.Geospatial.Internal.GeometryTests as G+import qualified Data.LineStringTests as LS+import qualified Data.LinearRingTests as LR+import qualified Data.SeqHelperTests as SH+import Test.Tasty main :: IO () main = do- tests <- sequence- [ LR.tests- , LS.tests- , SH.tests- , CRS.tests- , FC.tests- , F.tests- , G.tests- ]+ tests <-+ sequence+ [ LR.tests,+ LS.tests,+ SH.tests,+ CRS.tests,+ FC.tests,+ F.tests,+ G.tests+ ] defaultMain (testGroup "tests" tests)