diff --git a/LICENCE b/LICENCE --- a/LICENCE +++ b/LICENCE @@ -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: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,37 @@ -# geojson [![Build Status](https://travis-ci.org/indicatrix/hs-geojson.png?branch=master)](https://travis-ci.org/indicatrix/hs-geojson) [Hackage](https://hackage.haskell.org/package/geojson) +# geojson ![Build Status](https://github.com/zellige/hs-geojson/actions/workflows/ci.yaml/badge.svg) [Hackage](https://hackage.haskell.org/package/geojson) A thin GeoJSON Layer above the `aeson` library ## 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` diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,4 +1,3 @@ - module Main (main) where import Distribution.Simple diff --git a/geojson.cabal b/geojson.cabal --- a/geojson.cabal +++ b/geojson.cabal @@ -1,10 +1,10 @@ name: geojson -version: 4.0.4 +version: 4.1.3 license: BSD3 license-file: LICENCE author: Dom De Re maintainer: Andrew Newman -copyright: Copyright (C) 2013-2021 +copyright: Copyright (C) 2013-2026 synopsis: A thin GeoJSON Layer above the aeson library category: Data description: A thin GeoJSON Layer above the aeson library. @@ -27,20 +27,20 @@ source-repository this type: git location: https://github.com/zellige/hs-geojson.git - tag: 4.0.4 + tag: 4.1.3 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.9 + , deepseq >= 1.4.2.0 && < 1.6 , lens >= 4.11 , semigroups >= 0.16 - , text >= 1.2 - , scientific >= 0.2.0 - , transformers >= 0.3 - , validation >= 1 + , text >= 1.2.3.0 && < 2.2 + , scientific >= 0.2.0 && < 0.4 + , transformers >= 0.3 && < 0.7 + , validation >= 1 && < 2.0 , vector exposed-modules: Data.Geospatial , Data.LinearRing @@ -66,16 +66,17 @@ hs-source-dirs: test 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 + build-depends: base >= 4.9 && < 5 + , aeson >= 2.0.1.0 && < 3 + , bytestring >= 0.10.8.1 && < 0.13 + , containers >= 0.5.7.1 && < 0.9 , geojson - , tasty - , tasty-hspec - , tasty-quickcheck - , text >= 1.2 - , validation >= 1 + , hspec >= 2.5 && < 2.12 + , tasty >= 0.8 && <0.13 || >=1.0 && <1.6 + , tasty-hspec >= 1.2 && < 1.3 + , tasty-quickcheck >= 0.3 && <0.9 || >=0.9.1 && <0.12 + , text >= 1.2.3.0 && < 2.2 + , validation >= 1 && < 2.0 other-modules: Arbitrary , Fixture , Data.LinearRingTests @@ -85,16 +86,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 diff --git a/hlint/Main.hs b/hlint/Main.hs deleted file mode 100644 --- a/hlint/Main.hs +++ /dev/null @@ -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 diff --git a/src/Data/Geospatial.hs b/src/Data/Geospatial.hs --- a/src/Data/Geospatial.hs +++ b/src/Data/Geospatial.hs @@ -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 diff --git a/src/Data/Geospatial/Internal/BasicTypes.hs b/src/Data/Geospatial/Internal/BasicTypes.hs --- a/src/Data/Geospatial/Internal/BasicTypes.hs +++ b/src/Data/Geospatial/Internal/BasicTypes.hs @@ -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 diff --git a/src/Data/Geospatial/Internal/CRS.hs b/src/Data/Geospatial/Internal/CRS.hs --- a/src/Data/Geospatial/Internal/CRS.hs +++ b/src/Data/Geospatial/Internal/CRS.hs @@ -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 diff --git a/src/Data/Geospatial/Internal/GeoFeature.hs b/src/Data/Geospatial/Internal/GeoFeature.hs --- a/src/Data/Geospatial/Internal/GeoFeature.hs +++ b/src/Data/Geospatial/Internal/GeoFeature.hs @@ -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] diff --git a/src/Data/Geospatial/Internal/GeoFeatureCollection.hs b/src/Data/Geospatial/Internal/GeoFeatureCollection.hs --- a/src/Data/Geospatial/Internal/GeoFeatureCollection.hs +++ b/src/Data/Geospatial/Internal/GeoFeatureCollection.hs @@ -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] diff --git a/src/Data/Geospatial/Internal/GeoPosition.hs b/src/Data/Geospatial/Internal/GeoPosition.hs --- a/src/Data/Geospatial/Internal/GeoPosition.hs +++ b/src/Data/Geospatial/Internal/GeoPosition.hs @@ -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 diff --git a/src/Data/Geospatial/Internal/Geometry.hs b/src/Data/Geospatial/Internal/Geometry.hs --- a/src/Data/Geospatial/Internal/Geometry.hs +++ b/src/Data/Geospatial/Internal/Geometry.hs @@ -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 diff --git a/src/Data/Geospatial/Internal/Geometry/Aeson.hs b/src/Data/Geospatial/Internal/Geometry/Aeson.hs --- a/src/Data/Geospatial/Internal/Geometry/Aeson.hs +++ b/src/Data/Geospatial/Internal/Geometry/Aeson.hs @@ -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] diff --git a/src/Data/Geospatial/Internal/Geometry/GeoLine.hs b/src/Data/Geospatial/Internal/Geometry/GeoLine.hs --- a/src/Data/Geospatial/Internal/Geometry/GeoLine.hs +++ b/src/Data/Geospatial/Internal/Geometry/GeoLine.hs @@ -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 diff --git a/src/Data/Geospatial/Internal/Geometry/GeoMultiLine.hs b/src/Data/Geospatial/Internal/Geometry/GeoMultiLine.hs --- a/src/Data/Geospatial/Internal/Geometry/GeoMultiLine.hs +++ b/src/Data/Geospatial/Internal/Geometry/GeoMultiLine.hs @@ -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 diff --git a/src/Data/Geospatial/Internal/Geometry/GeoMultiPoint.hs b/src/Data/Geospatial/Internal/Geometry/GeoMultiPoint.hs --- a/src/Data/Geospatial/Internal/Geometry/GeoMultiPoint.hs +++ b/src/Data/Geospatial/Internal/Geometry/GeoMultiPoint.hs @@ -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 diff --git a/src/Data/Geospatial/Internal/Geometry/GeoMultiPolygon.hs b/src/Data/Geospatial/Internal/Geometry/GeoMultiPolygon.hs --- a/src/Data/Geospatial/Internal/Geometry/GeoMultiPolygon.hs +++ b/src/Data/Geospatial/Internal/Geometry/GeoMultiPolygon.hs @@ -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 diff --git a/src/Data/Geospatial/Internal/Geometry/GeoPoint.hs b/src/Data/Geospatial/Internal/Geometry/GeoPoint.hs --- a/src/Data/Geospatial/Internal/Geometry/GeoPoint.hs +++ b/src/Data/Geospatial/Internal/Geometry/GeoPoint.hs @@ -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 diff --git a/src/Data/Geospatial/Internal/Geometry/GeoPolygon.hs b/src/Data/Geospatial/Internal/Geometry/GeoPolygon.hs --- a/src/Data/Geospatial/Internal/Geometry/GeoPolygon.hs +++ b/src/Data/Geospatial/Internal/Geometry/GeoPolygon.hs @@ -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 diff --git a/src/Data/LineString.hs b/src/Data/LineString.hs --- a/src/Data/LineString.hs +++ b/src/Data/LineString.hs @@ -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 -- -- 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,142 @@ -- -- * 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)) + -- we implement these methods for improved performance + null _ = False + length (LineString _ _ zs) = 2 + Sequence.length 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 +203,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 #-} diff --git a/src/Data/LinearRing.hs b/src/Data/LinearRing.hs --- a/src/Data/LinearRing.hs +++ b/src/Data/LinearRing.hs @@ -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,59 @@ -- 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))) + -- we implement these methods for improved performance + null _ = False + length (LinearRing _ _ _ ws) = 4 + Sequence.length 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 +233,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 diff --git a/src/Data/SeqHelper.hs b/src/Data/SeqHelper.hs --- a/src/Data/SeqHelper.hs +++ b/src/Data/SeqHelper.hs @@ -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 :: (Eq a) => Sequence.Seq a -> Sequence.Seq a +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 diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs --- a/test/Arbitrary.hs +++ b/test/Arbitrary.hs @@ -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 diff --git a/test/Data/Geospatial/Internal/CRSTests.hs b/test/Data/Geospatial/Internal/CRSTests.hs --- a/test/Data/Geospatial/Internal/CRSTests.hs +++ b/test/Data/Geospatial/Internal/CRSTests.hs @@ -2,15 +2,22 @@ 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.Hspec + ( Spec, + context, + describe, + it, + shouldBe, + ) +import Test.Tasty +import Test.Tasty.Hspec + ( testSpec, + ) -- Tests @@ -21,10 +28,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 +53,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 +76,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" diff --git a/test/Data/Geospatial/Internal/GeoFeatureCollectionTests.hs b/test/Data/Geospatial/Internal/GeoFeatureCollectionTests.hs --- a/test/Data/Geospatial/Internal/GeoFeatureCollectionTests.hs +++ b/test/Data/Geospatial/Internal/GeoFeatureCollectionTests.hs @@ -1,11 +1,19 @@ 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.Hspec + ( Spec, + context, + describe, + it, + shouldBe, + ) +import Test.Tasty +import Test.Tasty.Hspec + ( testSpec, + ) -- Tests @@ -16,13 +24,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 +49,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 +70,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 diff --git a/test/Data/Geospatial/Internal/GeoFeatureTests.hs b/test/Data/Geospatial/Internal/GeoFeatureTests.hs --- a/test/Data/Geospatial/Internal/GeoFeatureTests.hs +++ b/test/Data/Geospatial/Internal/GeoFeatureTests.hs @@ -1,11 +1,19 @@ 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.Hspec + ( Spec, + context, + describe, + it, + shouldBe, + ) +import Test.Tasty +import Test.Tasty.Hspec + ( testSpec, + ) -- Tests @@ -16,10 +24,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 +52,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 +77,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 diff --git a/test/Data/Geospatial/Internal/GeometryTests.hs b/test/Data/Geospatial/Internal/GeometryTests.hs --- a/test/Data/Geospatial/Internal/GeometryTests.hs +++ b/test/Data/Geospatial/Internal/GeometryTests.hs @@ -2,14 +2,22 @@ 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.Hspec + ( Spec, + context, + describe, + it, + shouldBe, + ) +import Test.Tasty +import Test.Tasty.Hspec + ( testSpec, + ) -- Tests @@ -20,10 +28,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 +66,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 +103,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 diff --git a/test/Data/LineStringTests.hs b/test/Data/LineStringTests.hs --- a/test/Data/LineStringTests.hs +++ b/test/Data/LineStringTests.hs @@ -1,16 +1,28 @@ 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.Hspec + ( Spec, + context, + describe, + it, + shouldBe, + ) +import Test.Tasty +import Test.Tasty.Hspec + ( testSpec, + ) +import Test.Tasty.QuickCheck + ( Property, + property, + testProperty, + ) + -- Tests tests :: IO TestTree @@ -19,20 +31,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 +90,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 diff --git a/test/Data/LinearRingTests.hs b/test/Data/LinearRingTests.hs --- a/test/Data/LinearRingTests.hs +++ b/test/Data/LinearRingTests.hs @@ -1,17 +1,28 @@ 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.Hspec + ( Spec, + context, + describe, + it, + shouldBe, + ) +import Test.Tasty +import Test.Tasty.Hspec + ( testSpec, + ) +import Test.Tasty.QuickCheck + ( Property, + property, + testProperty, + ) -- Tests @@ -21,21 +32,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 +101,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) diff --git a/test/Data/SeqHelperTests.hs b/test/Data/SeqHelperTests.hs --- a/test/Data/SeqHelperTests.hs +++ b/test/Data/SeqHelperTests.hs @@ -1,11 +1,25 @@ 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.Hspec + ( Spec, + context, + describe, + it, + shouldBe, + ) +import Test.Tasty +import Test.Tasty.Hspec + ( testSpec, + ) +import Test.Tasty.QuickCheck + ( Property, + property, + testProperty, + ) -- Tests diff --git a/test/Fixture.hs b/test/Fixture.hs --- a/test/Fixture.hs +++ b/test/Fixture.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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)