{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.LinearRing (
LinearRing
, ListToLinearRingError(..)
, VectorToLinearRingError(..)
, 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)
data LinearRing a = LinearRing a a a (VectorStorable.Vector a) deriving (Eq, Show, Generic, NFData)
data ListToLinearRingError a =
ListTooShort Int
| HeadNotEqualToLast a a
deriving (Eq)
data VectorToLinearRingError a =
VectorTooShort Int
| FirstNotEqualToLast a a
deriving (Eq)
ringHead :: LinearRing a -> a
ringHead (LinearRing x _ _ _) = x
ringLength :: (VectorStorable.Storable a) => LinearRing a -> Int
ringLength (LinearRing _ _ _ xs) = 4 + VectorStorable.length xs
fromLinearRing :: (VectorStorable.Storable a) => LinearRing a -> [a]
fromLinearRing (LinearRing x y z ws) = x : y : z : VectorStorable.foldr (:) [x] ws
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 #-}
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
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 #-}
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 #-}
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 #-}
makeLinearRing :: (Eq a, Show a, VectorStorable.Storable a) =>
a
-> a
-> a
-> VectorStorable.Vector a
-> LinearRing a
makeLinearRing = LinearRing
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 #-}
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 = toJSON . fromLinearRing
instance (Eq a, FromJSON a, Show a, VectorStorable.Storable a) => FromJSON (LinearRing a) where
parseJSON v = do
xs <- parseJSON v
let vxs = fromListAcc xs
maybe (parseError v (vxs ^? Validation._Failure)) return (vxs ^? Validation._Success)
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