{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NoImplicitPrelude #-} ------------------------------------------------------------------- -- | -- Module : Data.LinearRing -- Copyright : (C) 2014-2018 HS-GeoJSON Project -- License : BSD-style (see the file LICENSE.md) -- Maintainer : Andrew Newman -- -- Refer to the GeoJSON Spec -- -- 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(..) , VectorToLinearRingError(..) -- * Functions , toVector , combineToVector , fromVector , fromLinearRing , fromList , fromListWithEqCheck , makeLinearRing , Data.LinearRing.map , Data.LinearRing.foldr , Data.LinearRing.foldMap , ringHead , ringLength ) where #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 import Prelude hiding (foldr) #else import Prelude #endif import Control.Applicative (Applicative (..)) import Control.DeepSeq import Control.Lens (( # ), (^?)) import Control.Monad (mzero) import Data.Aeson (FromJSON (..), ToJSON (..), Value) import Data.Aeson.Types (Parser, typeMismatch) import Data.Functor ((<$>)) import Data.List (intercalate) import Data.List.NonEmpty as NL (NonEmpty, toList) import qualified Data.Validation as Validation import qualified Data.Vector.Storable as VectorStorable import GHC.Generics (Generic) -- | -- a LinearRing has at least 3 (distinct) elements -- data LinearRing a = LinearRing a a a (VectorStorable.Vector a) deriving (Eq, Show, Generic, NFData) -- | -- When converting a List to a LinearRing there are some things that can go wrong -- -- * 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) -- | -- When converting a Vector to a LinearRing there are some things that can go wrong -- -- * The vector can be too short -- * The head may not be equal to the last element in the list -- data VectorToLinearRingError a = VectorTooShort Int | FirstNotEqualToLast a a deriving (Eq) -- functions -- | -- returns the element at the head of the ring -- ringHead :: LinearRing a -> a ringHead (LinearRing x _ _ _) = x -- | -- returns the number of elements in the list, including the replicated element at the end of the list. -- ringLength :: (VectorStorable.Storable a) => LinearRing a -> Int ringLength (LinearRing _ _ _ xs) = 4 + VectorStorable.length xs -- | -- This function converts it into a list and appends the given element to the end. -- fromLinearRing :: (VectorStorable.Storable a) => LinearRing a -> [a] fromLinearRing (LinearRing x y z ws) = x : y : z : VectorStorable.foldr (:) [x] ws -- | -- creates a LinearRing out of a list of elements, -- if there arent enough elements (needs at least 4) elements -- -- This version doesnt check equality of the head and tail in case -- you wish to use it for elements with no Eq instance defined. -- -- Also its a list, finding the last element could be expensive with large -- lists. So just follow the spec and make sure the ring is closed. -- -- Ideally the Spec would be modified to remove the redundant last element from the Polygons/LineRings. -- Its just going to waste bandwidth... -- -- 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, VectorStorable.Storable 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)) {-# INLINE fromList #-} -- | -- The expensive version of fromList that checks whether the head and last elements -- are equal. -- fromListWithEqCheck :: (Eq a, Show a, VectorStorable.Storable a, Validation.Validate v, Applicative (v (NonEmpty (ListToLinearRingError a)))) => [a] -> v (NonEmpty (ListToLinearRingError a)) (LinearRing a) fromListWithEqCheck xs = checkHeadAndLastEq xs *> fromList xs -- | -- create a vector from a LinearRing by combining values. -- LinearRing 1 2 3 [4,1] (,) --> Vector [(1,2),(2,3),(3,4),(4,1)] -- combineToVector :: (VectorStorable.Storable a, VectorStorable.Storable b) => (a -> a -> b) -> LinearRing a -> VectorStorable.Vector b combineToVector combine (LinearRing a b c rest) = VectorStorable.cons (combine a b) (VectorStorable.cons (combine b c) combineRest) where combineRest = if VectorStorable.null rest then VectorStorable.empty else (VectorStorable.zipWith combine <*> VectorStorable.tail) (VectorStorable.cons c rest) {-# INLINE combineToVector #-} -- | -- create a vector from a LinearRing. -- LinearRing 1 2 3 [4,1] --> Vector [1,2,3,4,1)] -- toVector :: (VectorStorable.Storable a) => LinearRing a -> VectorStorable.Vector a toVector (LinearRing a b c rest) = VectorStorable.cons a (VectorStorable.cons b (VectorStorable.cons c rest)) {-# INLINE toVector #-} -- | -- creates a LinearRing out of a vector of elements, -- if there are enough elements (needs at least 3) elements -- -- fromVector (x:y:z:ws@(_:_)) = _Success # LinearRing x y z (fromListDropLast ws) -- fromList xs = _Failure # return (ListTooShort (length xs)) fromVector :: (Eq a, Show a, VectorStorable.Storable a, Validation.Validate v, Functor (v (NonEmpty (ListToLinearRingError a)))) => VectorStorable.Vector a -> v (NonEmpty (VectorToLinearRingError a)) (LinearRing a) fromVector v = if VectorStorable.length v >= 3 then if VectorStorable.head v == VectorStorable.last v then Validation._Success # LinearRing (VectorStorable.unsafeIndex v 0) (VectorStorable.unsafeIndex v 1) (VectorStorable.unsafeIndex v 2) (VectorStorable.drop 3 v) else Validation._Failure # pure (FirstNotEqualToLast (VectorStorable.head v) (VectorStorable.last v)) else Validation._Failure # pure (VectorTooShort (VectorStorable.length v)) {-# INLINE fromVector #-} -- | -- Creates a LinearRing -- @makeLinearRing x y z xs@ creates a `LinearRing` homomorphic to the list @[x, y, z] ++ xs@ -- the list @xs@ should NOT contain the first element repeated, i.e the loop does not need to -- be closed, makeLinearRing will close it off. -- -- Repeating the first element is just redundant. -- makeLinearRing :: (Eq a, Show a, VectorStorable.Storable a) => a -- ^ The first element -> a -- ^ The second element -> a -- ^ The third element -> VectorStorable.Vector a -- ^ The rest of the optional elements (WITHOUT the first element repeated at the end) -> LinearRing a makeLinearRing = LinearRing -- instances instance (Show a, VectorStorable.Storable a) => Show (ListToLinearRingError a) where show (ListTooShort n) = "List too short: (length = " ++ show n ++ ")" show (HeadNotEqualToLast h l) = "head (" ++ show h ++ ") /= last(" ++ show l ++ ")" instance (Show a, VectorStorable.Storable a) => Show (VectorToLinearRingError a) where show (VectorTooShort n) = "Vector too short: (length = " ++ show n ++ ")" show (FirstNotEqualToLast h l) = "head (" ++ show h ++ ") /= last(" ++ show l ++ ")" map :: (VectorStorable.Storable a, VectorStorable.Storable b) => (a -> b) -> LinearRing a -> LinearRing b map f (LinearRing x y z ws) = LinearRing (f x) (f y) (f z) (VectorStorable.map f ws) {-# INLINE map #-} -- | This will run through the entire ring, closing the -- loop by also passing the initial element in again at the end. -- foldr :: VectorStorable.Storable a => (a -> b -> b) -> b -> LinearRing a -> b foldr f u (LinearRing x y z ws) = f x (f y (f z (VectorStorable.foldr f (f x u) ws))) {-# INLINE foldr #-} foldMap :: (Monoid m, VectorStorable.Storable a) => (a -> m) -> LinearRing a -> m foldMap f = foldr (mappend . f) mempty {-# INLINE foldMap #-} instance (ToJSON a, VectorStorable.Storable a) => ToJSON (LinearRing a) where -- toJSON :: a -> Value toJSON = toJSON . fromLinearRing instance (Eq a, FromJSON a, Show a, VectorStorable.Storable 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) -- helpers fromListAcc :: (Eq a, Show a, VectorStorable.Storable a) => [a] -> Validation.Validation (NonEmpty (ListToLinearRingError a)) (LinearRing a) fromListAcc = fromList showErrors :: (Show a, VectorStorable.Storable a) => NonEmpty (ListToLinearRingError a) -> String showErrors = intercalate ", " . NL.toList . fmap show parseError :: (Show a, VectorStorable.Storable a) => Value -> Maybe (NonEmpty (ListToLinearRingError a)) -> Parser b parseError v = maybe mzero (\e -> typeMismatch (showErrors e) v) checkHeadAndLastEq :: (Eq a, VectorStorable.Storable 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 safeHead :: [a] -> Maybe a safeHead [] = Nothing safeHead (x:_) = Just x safeLast :: [a] -> Maybe a safeLast [] = Nothing safeLast [x] = Just x safeLast (_:xs) = safeLast xs fromListDropLast :: (Eq a, VectorStorable.Storable a) => [a] -> VectorStorable.Vector a fromListDropLast [] = VectorStorable.empty fromListDropLast [_] = VectorStorable.empty fromListDropLast x = VectorStorable.unsafeInit $ VectorStorable.fromList x