{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.LineString (
LineString
, ListToLineStringError(..)
, VectorToLineStringError(..)
, toVector
, combineToVector
, fromVector
, fromLineString
, fromList
, makeLineString
, lineStringHead
, lineStringLast
, lineStringLength
) where
import Prelude hiding (foldr)
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 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)
data LineString a = LineString a a (Sequence.Seq a) deriving (Eq, Generic, NFData)
data ListToLineStringError =
ListEmpty
| SingletonList
deriving (Eq)
data VectorToLineStringError =
VectorEmpty
| SingletonVector
deriving (Eq)
lineStringHead :: LineString a -> a
lineStringHead (LineString x _ _) = x
lineStringLast :: LineString a -> a
lineStringLast (LineString _ x xs) = fromMaybe x (safeLast xs)
lineStringLength :: LineString a -> Int
lineStringLength (LineString _ _ xs) = 2 + Sequence.length xs
fromLineString :: LineString a -> [a]
fromLineString (LineString x y zs) = x : y : Foldable.toList zs
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)
{-# INLINE fromList #-}
combineToVector :: (a -> a -> b) -> LineString a -> Sequence.Seq b
combineToVector combine (LineString a b rest) = combine a b Sequence.<| combineRest
where
combineRest =
if Sequence.null rest
then
Sequence.empty
else
(Sequence.zipWith combine <*> sequenceTail) (b Sequence.<| rest)
{-# INLINE combineToVector #-}
sequenceTail :: Sequence.Seq a -> Sequence.Seq a
sequenceTail (_ Sequence.:<| tailS) = tailS
sequenceTail _ = Sequence.empty
toVector :: LineString a -> Sequence.Seq a
toVector (LineString a b rest) = a Sequence.<| ( b Sequence.<| rest)
{-# INLINE toVector #-}
fromVector :: (Validation.Validate v) => Sequence.Seq a -> v VectorToLineStringError (LineString a)
fromVector v@(headS Sequence.:<| tailS) =
if Sequence.null v then
Validation._Failure # SingletonVector
else
fromVector' headS tailS
fromVector _ = Validation._Failure # VectorEmpty
{-# INLINE fromVector #-}
fromVector' :: (Validation.Validate v) => a -> Sequence.Seq a -> v VectorToLineStringError (LineString a)
fromVector' first v@(headS Sequence.:<| tailS) =
if Sequence.null v then
Validation._Failure # SingletonVector
else
Validation._Success # LineString first headS tailS
fromVector' _ _ = Validation._Failure # SingletonVector
{-# INLINE fromVector' #-}
makeLineString ::
a
-> a
-> Sequence.Seq a
-> LineString a
makeLineString = LineString
instance Show ListToLineStringError where
show ListEmpty = "List Empty"
show SingletonList = "Singleton List"
instance Show VectorToLineStringError where
show VectorEmpty = "Vector Empty"
show SingletonVector = "Singleton Vector"
instance (Show a) => Show (LineString a) where
show = show . fromLineString
instance Functor LineString where
fmap f (LineString x y zs) = LineString (f x) (f y) (fmap f zs)
instance Foldable LineString where
foldr f u (LineString x y zs) = f x (f y (Foldable.foldr f u zs))
instance Traversable LineString where
sequenceA (LineString fx fy fzs) = LineString <$> fx <*> fy <*> sequenceA fzs
instance (ToJSON a) => ToJSON (LineString a) where
toJSON = toJSON . fromLineString
instance (FromJSON a, Show a) => FromJSON (LineString a) where
parseJSON v = do
xs <- parseJSON v
let vxs = fromListValidated xs
maybe (parseError v (vxs ^? Validation._Failure)) return (vxs ^? Validation._Success)
fromListValidated :: [a] -> Validation.Validation ListToLineStringError (LineString a)
fromListValidated = fromList
parseError :: Value -> Maybe ListToLineStringError -> Parser b
parseError v = maybe mzero (\e -> typeMismatch (show e) v)
safeLast :: Sequence.Seq a -> Maybe a
safeLast x = case Sequence.viewr x of
Sequence.EmptyR -> Nothing
_ Sequence.:> b -> Just b
{-# INLINE safeLast #-}