{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Database.Postgis.Trivial.Internal
--
-- Low level operations on the Postgis extention of the PostgreSQL Database
--
-----------------------------------------------------------------------------

{- Some techniques in this module were taken from
haskell-postgis <https://hackage.haskell.org/package/haskell-postgis>

Since that package comes with MIT license, we provide it here.

> Copyright (c) 2014 Peter
>
> Permission is hereby granted, free of charge, to any person obtaining
> a copy of this software and associated documentation files (the
> "Software"), to deal in the Software without restriction, including
> without limitation the rights to use, copy, modify, merge, publish,
> distribute, sublicense, and/or sell copies of the Software, and to
> permit persons to whom the Software is furnished to do so, subject to
> the following conditions:
>
> The above copyright notice and this permission notice shall be included
> in all copies or substantial portions of the Software.
>
> THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
> EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
> MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
> IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
> CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
> TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
> SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-}


module Database.Postgis.Trivial.Internal where

import GHC.Base hiding ( foldr )
import GHC.Num ( Num(..) )
import GHC.Show ( Show(show) )
import GHC.Real ( fromIntegral, Integral )
import System.Endian ( getSystemEndianness, Endianness(..) )
import Foreign ( Int64, Bits((.&.), (.|.)) )
import Control.Applicative ( (<$>) )
import Control.Monad (void )
import Control.Monad.Reader ( ReaderT(runReaderT), asks, MonadTrans(lift) )
import Control.Exception ( throw )
import Data.Foldable ( Foldable(..) )
import Data.ByteString.Lex.Integral ( packHexadecimal, readHexadecimal )
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BC
import Data.Binary ( Word8, Word32, Word64, Get, Put, byteSwap32, byteSwap64,
    Binary(get, put) )
import Data.Binary.Get ( getLazyByteString, lookAhead )
import Data.Binary.Put ( putLazyByteString )
import Data.Maybe ( isJust )
import Data.Binary.IEEE754 ( wordToDouble, doubleToWord )

import Database.Postgis.Trivial.PGISConst
import Database.Postgis.Trivial.Types


type HeaderGetter = Getter Header

newtype ByteOrder = ByteOrder Endianness deriving Int -> ByteOrder -> ShowS
[ByteOrder] -> ShowS
ByteOrder -> String
(Int -> ByteOrder -> ShowS)
-> (ByteOrder -> String)
-> ([ByteOrder] -> ShowS)
-> Show ByteOrder
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ByteOrder -> ShowS
showsPrec :: Int -> ByteOrder -> ShowS
$cshow :: ByteOrder -> String
show :: ByteOrder -> String
$cshowList :: [ByteOrder] -> ShowS
showList :: [ByteOrder] -> ShowS
Show

-- | Header record
data Header = Header {
    Header -> ByteOrder
_byteOrder  :: ByteOrder
  , Header -> Word32
_geoType    :: Word32
  , Header -> SRID
_srid       :: SRID
} deriving Int -> Header -> ShowS
[Header] -> ShowS
Header -> String
(Int -> Header -> ShowS)
-> (Header -> String) -> ([Header] -> ShowS) -> Show Header
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Header -> ShowS
showsPrec :: Int -> Header -> ShowS
$cshow :: Header -> String
show :: Header -> String
$cshowList :: [Header] -> ShowS
showList :: [Header] -> ShowS
Show

instance Binary ByteOrder where
    get :: Get ByteOrder
get = ByteString -> ByteOrder
forall a. Serializable a => ByteString -> a
fromBin (ByteString -> ByteOrder) -> Get ByteString -> Get ByteOrder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int64 -> Get ByteString
getLazyByteString Int64
2
    put :: ByteOrder -> Put
put = ByteString -> Put
putLazyByteString (ByteString -> Put)
-> (ByteOrder -> ByteString) -> ByteOrder -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteOrder -> ByteString
forall a. Serializable a => a -> ByteString
toBin

instance Binary Header where
    get :: Get Header
get = Get Header
getHeader
    put :: Header -> Put
put (Header ByteOrder
bo Word32
gt SRID
s) =
        ByteOrder -> Put
forall t. Binary t => t -> Put
put ByteOrder
bo Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Putter Int
putInt Putter Int -> (Word32 -> Int) -> Word32 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Word32
gt  Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SRID -> Putter Int -> Put
forall a. Maybe a -> Putter a -> Put
putMaybe SRID
s Putter Int
putInt

-- | Serializable class
class Serializable a where
    toBin :: a -> BL.ByteString
    fromBin :: BL.ByteString -> a

instance Serializable ByteOrder where
    toBin :: ByteOrder -> ByteString
toBin (ByteOrder Endianness
BigEndian) = ByteString
"00" :: BL.ByteString
    toBin (ByteOrder Endianness
LittleEndian) = ByteString
"01" :: BL.ByteString
    fromBin :: ByteString -> ByteOrder
fromBin ByteString
bo = case ByteString -> Word8
forall a. Integral a => ByteString -> a
_fromBin ByteString
bo :: Word8 of
        Word8
0 -> Endianness -> ByteOrder
ByteOrder Endianness
BigEndian
        Word8
1 -> Endianness -> ByteOrder
ByteOrder Endianness
LittleEndian
        Word8
_ -> GeometryError -> ByteOrder
forall a e. Exception e => e -> a
throw (GeometryError -> ByteOrder) -> GeometryError -> ByteOrder
forall a b. (a -> b) -> a -> b
$ String -> GeometryError
GeometryError (String -> GeometryError) -> String -> GeometryError
forall a b. (a -> b) -> a -> b
$ String
"Incorrect ByteOrder " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
bo

instance Serializable Word32 where
    toBin :: Word32 -> ByteString
toBin = Int -> Word32 -> ByteString
forall a. Integral a => Int -> a -> ByteString
_toBin Int
8
    fromBin :: ByteString -> Word32
fromBin = ByteString -> Word32
forall a. Integral a => ByteString -> a
_fromBin

instance Serializable Word64 where
    toBin :: Word64 -> ByteString
toBin = Int -> Word64 -> ByteString
forall a. Integral a => Int -> a -> ByteString
_toBin Int
16
    fromBin :: ByteString -> Word64
fromBin = ByteString -> Word64
forall a. Integral a => ByteString -> a
_fromBin

_toBin :: Integral a => Int -> a -> BL.ByteString
_toBin :: forall a. Integral a => Int -> a -> ByteString
_toBin Int
l a
w = case Maybe ByteString
bsRes of
    Just ByteString
s -> [ByteString] -> ByteString
BL.fromChunks [Int -> ByteString -> ByteString
pad Int
l ByteString
s]
    Maybe ByteString
Nothing -> GeometryError -> ByteString
forall a e. Exception e => e -> a
throw (GeometryError -> ByteString) -> GeometryError -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> GeometryError
GeometryError String
"toBin: cannot convert word"
    where
        bsRes :: Maybe ByteString
bsRes = a -> Maybe ByteString
forall a. Integral a => a -> Maybe ByteString
packHexadecimal a
w
        pad :: Int -> ByteString -> ByteString
pad Int
l' ByteString
bs' = ByteString -> ByteString -> ByteString
BS.append (Int -> Char -> ByteString
BC.replicate (Int
l' Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
bs') Char
'0') ByteString
bs'

_fromBin :: Integral a => BL.ByteString -> a
_fromBin :: forall a. Integral a => ByteString -> a
_fromBin ByteString
bs = case Maybe (a, ByteString)
hexRes of
    Just (a
v, ByteString
_) -> a
v
    Maybe (a, ByteString)
Nothing -> GeometryError -> a
forall a e. Exception e => e -> a
throw (GeometryError -> a) -> GeometryError -> a
forall a b. (a -> b) -> a -> b
$ String -> GeometryError
GeometryError String
"fromBin: cannot parse hexadecimal"
    where
        hexRes :: Maybe (a, ByteString)
hexRes = ByteString -> Maybe (a, ByteString)
forall a. Integral a => ByteString -> Maybe (a, ByteString)
readHexadecimal (ByteString -> Maybe (a, ByteString))
-> ByteString -> Maybe (a, ByteString)
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BL.toChunks (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
bs

{-# INLINE byteSwapFn #-}
byteSwapFn :: ByteOrder -> (a -> a) -> a -> a
byteSwapFn :: forall a. ByteOrder -> (a -> a) -> a -> a
byteSwapFn ByteOrder
bo a -> a
f = case ByteOrder
bo of
    ByteOrder Endianness
BigEndian     -> a -> a
forall a. a -> a
id
    ByteOrder Endianness
LittleEndian  -> a -> a
f

makeHeader :: SRID -> Word32 -> (Bool, Bool) -> Header
makeHeader :: SRID -> Word32 -> (Bool, Bool) -> Header
makeHeader SRID
srid Word32
geoType (Bool
hasM, Bool
hasZ) =
    ByteOrder -> Word32 -> SRID -> Header
Header (Endianness -> ByteOrder
ByteOrder Endianness
getSystemEndianness) Word32
gt SRID
srid where
        wOr :: a -> (Bool, a) -> a
wOr a
acc (Bool
p, a
h) = if Bool
p then a
h a -> a -> a
forall a. Bits a => a -> a -> a
.|. a
acc else a
acc
        gt :: Word32
gt = (Word32 -> (Bool, Word32) -> Word32)
-> Word32 -> [(Bool, Word32)] -> Word32
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Word32 -> (Bool, Word32) -> Word32
forall {a}. Bits a => a -> (Bool, a) -> a
wOr Word32
geoType
            [(Bool
hasM, Word32
wkbM), (Bool
hasZ, Word32
wkbZ), (SRID -> Bool
forall a. Maybe a -> Bool
isJust SRID
srid, Word32
wkbSRID)]

{-# INLINE lookupType #-}
lookupType :: Header -> Word32
lookupType :: Header -> Word32
lookupType Header
h = Header -> Word32
_geoType Header
h Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
ewkbTypeOffset

-- | Putters
putDouble :: Putter Double
putDouble :: Putter Double
putDouble = ByteString -> Put
putLazyByteString (ByteString -> Put) -> (Double -> ByteString) -> Putter Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> ByteString
forall a. Serializable a => a -> ByteString
toBin (Word64 -> ByteString)
-> (Double -> Word64) -> Double -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    ByteOrder -> (Word64 -> Word64) -> Word64 -> Word64
forall a. ByteOrder -> (a -> a) -> a -> a
byteSwapFn (Endianness -> ByteOrder
ByteOrder Endianness
getSystemEndianness) Word64 -> Word64
byteSwap64 (Word64 -> Word64) -> (Double -> Word64) -> Double -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Word64
doubleToWord

putInt :: Putter Int
putInt :: Putter Int
putInt = ByteString -> Put
putLazyByteString (ByteString -> Put) -> (Int -> ByteString) -> Putter Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> ByteString
forall a. Serializable a => a -> ByteString
toBin (Word32 -> ByteString) -> (Int -> Word32) -> Int -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    ByteOrder -> (Word32 -> Word32) -> Word32 -> Word32
forall a. ByteOrder -> (a -> a) -> a -> a
byteSwapFn (Endianness -> ByteOrder
ByteOrder Endianness
getSystemEndianness) Word32 -> Word32
byteSwap32 (Word32 -> Word32) -> (Int -> Word32) -> Int -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral

{-# INLINE putMaybe #-}
putMaybe :: Maybe a -> Putter a -> Put
putMaybe :: forall a. Maybe a -> Putter a -> Put
putMaybe Maybe a
mi = case Maybe a
mi of
    Just a
i -> (Putter a -> Putter a
forall a b. (a -> b) -> a -> b
$ a
i)
    Maybe a
Nothing -> \Putter a
_ -> () -> Put
forall a. a -> PutM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

{-# INLINE putChainLen #-}
putChainLen :: Putter Int
putChainLen :: Putter Int
putChainLen = Putter Int
putInt

putHeader :: SRID -> Word32 -> (Bool, Bool) -> Put
putHeader :: SRID -> Word32 -> (Bool, Bool) -> Put
putHeader SRID
s Word32
geoType (Bool
hasMBool, Bool
hasZBool) =
    Header -> Put
forall t. Binary t => t -> Put
put (Header -> Put) -> Header -> Put
forall a b. (a -> b) -> a -> b
$ SRID -> Word32 -> (Bool, Bool) -> Header
makeHeader SRID
s Word32
geoType (Bool
hasMBool, Bool
hasZBool)

putPoint :: Putter (Double, Double, Maybe Double, Maybe Double)
putPoint :: Putter (Double, Double, Maybe Double, Maybe Double)
putPoint (Double
x, Double
y, Maybe Double
Nothing, Maybe Double
Nothing)   = Putter Double
putDouble Double
x Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Double
putDouble Double
y
putPoint (Double
x, Double
y, Just Double
z, Maybe Double
Nothing)    = Putter Double
putDouble Double
x Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Double
putDouble Double
y Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Double
putDouble Double
z
putPoint (Double
x, Double
y, Maybe Double
Nothing, Just Double
m)    = Putter Double
putDouble Double
x Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Double
putDouble Double
y Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Double
putDouble Double
m
putPoint (Double
x, Double
y, Just Double
z, Just Double
m)     = Putter Double
putDouble Double
x Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Double
putDouble Double
y Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Double
putDouble Double
z
                                        Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Double
putDouble Double
m

{-# INLINE putPointND #-}
putPointND :: PointND a => Putter a
putPointND :: forall a. PointND a => Putter a
putPointND a
a = Putter (Double, Double, Maybe Double, Maybe Double)
putPoint Putter (Double, Double, Maybe Double, Maybe Double)
-> Putter (Double, Double, Maybe Double, Maybe Double)
forall a b. (a -> b) -> a -> b
$ a -> (Double, Double, Maybe Double, Maybe Double)
forall a.
PointND a =>
a -> (Double, Double, Maybe Double, Maybe Double)
components a
a

-- | BinGetters
getHeader :: Get Header
getHeader :: Get Header
getHeader = do
    ByteOrder
bo <- Get ByteOrder
forall t. Binary t => Get t
get
    Word32
t <- Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Get Int -> Get Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  ByteOrder -> Get Int
_getInt ByteOrder
bo
    SRID
s <- if Word32
t Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
wkbSRID Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
0
        then Int -> SRID
forall a. a -> Maybe a
Just (Int -> SRID) -> (Int -> Int) -> Int -> SRID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> SRID) -> Get Int -> Get SRID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteOrder -> Get Int
_getInt ByteOrder
bo
        else SRID -> Get SRID
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return SRID
forall a. Maybe a
Nothing
    Header -> Get Header
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Header -> Get Header) -> Header -> Get Header
forall a b. (a -> b) -> a -> b
$ ByteOrder -> Word32 -> SRID -> Header
Header ByteOrder
bo Word32
t SRID
s

{-# INLINE skipHeader #-}
skipHeader :: HeaderGetter ()
skipHeader :: HeaderGetter ()
skipHeader = ReaderT Header Get Header -> HeaderGetter ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Get Header -> ReaderT Header Get Header
forall (m :: * -> *) a. Monad m => m a -> ReaderT Header m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get Header
getHeader)

{-# INLINE getHeaderPre #-}
getHeaderPre :: Get Header
getHeaderPre :: Get Header
getHeaderPre = Get Header -> Get Header
forall a. Get a -> Get a
lookAhead Get Header
forall t. Binary t => Get t
get

getPoint :: HeaderGetter (Double, Double, Maybe Double, Maybe Double)
getPoint :: HeaderGetter (Double, Double, Maybe Double, Maybe Double)
getPoint = do
    Word32
gt <- (Header -> Word32) -> ReaderT Header Get Word32
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Header -> Word32
_geoType
    let hasM :: Bool
hasM = (Word32
gt Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
wkbM) Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
0
        hasZ :: Bool
hasZ = (Word32
gt Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
wkbZ) Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
0
    Double
x <- HeaderGetter Double
getDouble
    Double
y <- HeaderGetter Double
getDouble
    Maybe Double
zMb <- if Bool
hasZ then Double -> Maybe Double
forall a. a -> Maybe a
Just (Double -> Maybe Double)
-> HeaderGetter Double -> ReaderT Header Get (Maybe Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderGetter Double
getDouble else Maybe Double -> ReaderT Header Get (Maybe Double)
forall a. a -> ReaderT Header Get a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Double
forall a. Maybe a
Nothing
    Maybe Double
mMb <- if Bool
hasM then Double -> Maybe Double
forall a. a -> Maybe a
Just (Double -> Maybe Double)
-> HeaderGetter Double -> ReaderT Header Get (Maybe Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderGetter Double
getDouble else Maybe Double -> ReaderT Header Get (Maybe Double)
forall a. a -> ReaderT Header Get a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Double
forall a. Maybe a
Nothing
    (Double, Double, Maybe Double, Maybe Double)
-> HeaderGetter (Double, Double, Maybe Double, Maybe Double)
forall a. a -> ReaderT Header Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
x, Double
y, Maybe Double
zMb, Maybe Double
mMb)

{-# INLINE getPointND #-}
getPointND :: PointND a => HeaderGetter a
getPointND :: forall a. PointND a => HeaderGetter a
getPointND = do
    (Double
x, Double
y, Maybe Double
zMb, Maybe Double
mMb) <- HeaderGetter (Double, Double, Maybe Double, Maybe Double)
getPoint
    a -> HeaderGetter a
forall a. a -> ReaderT Header Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> HeaderGetter a) -> a -> HeaderGetter a
forall a b. (a -> b) -> a -> b
$ (Double, Double, Maybe Double, Maybe Double) -> a
forall a.
PointND a =>
(Double, Double, Maybe Double, Maybe Double) -> a
fromComponents (Double
x, Double
y, Maybe Double
zMb, Maybe Double
mMb)

{-# INLINE getNumber #-}
getNumber :: (Serializable a) => (a -> a) -> Int64 -> ByteOrder -> Get a
getNumber :: forall a. Serializable a => (a -> a) -> Int64 -> ByteOrder -> Get a
getNumber a -> a
f Int64
l ByteOrder
bo  = do
    ByteString
bs <- Int64 -> Get ByteString
getLazyByteString Int64
l
    case ByteOrder
bo of
        ByteOrder Endianness
BigEndian     -> a -> Get a
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Get a) -> a -> Get a
forall a b. (a -> b) -> a -> b
$ ByteString -> a
forall a. Serializable a => ByteString -> a
fromBin ByteString
bs
        ByteOrder Endianness
LittleEndian  -> a -> Get a
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Get a) -> (ByteString -> a) -> ByteString -> Get a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f (a -> a) -> (ByteString -> a) -> ByteString -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> a
forall a. Serializable a => ByteString -> a
fromBin (ByteString -> Get a) -> ByteString -> Get a
forall a b. (a -> b) -> a -> b
$ ByteString
bs

_getInt :: ByteOrder -> Get Int
_getInt :: ByteOrder -> Get Int
_getInt = (Word32 -> Int) -> Get Word32 -> Get Int
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Get Word32 -> Get Int)
-> (ByteOrder -> Get Word32) -> ByteOrder -> Get Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word32 -> Word32) -> Int64 -> ByteOrder -> Get Word32
forall a. Serializable a => (a -> a) -> Int64 -> ByteOrder -> Get a
getNumber Word32 -> Word32
byteSwap32 Int64
8

getInt :: HeaderGetter Int
getInt :: HeaderGetter Int
getInt = (Header -> ByteOrder) -> ReaderT Header Get ByteOrder
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Header -> ByteOrder
_byteOrder ReaderT Header Get ByteOrder
-> (ByteOrder -> HeaderGetter Int) -> HeaderGetter Int
forall a b.
ReaderT Header Get a
-> (a -> ReaderT Header Get b) -> ReaderT Header Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Get Int -> HeaderGetter Int
forall (m :: * -> *) a. Monad m => m a -> ReaderT Header m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Get Int -> HeaderGetter Int)
-> (ByteOrder -> Get Int) -> ByteOrder -> HeaderGetter Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteOrder -> Get Int
_getInt

_getDouble :: ByteOrder -> Get Double
_getDouble :: ByteOrder -> Get Double
_getDouble = (Word64 -> Double) -> Get Word64 -> Get Double
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word64 -> Double
wordToDouble (Get Word64 -> Get Double)
-> (ByteOrder -> Get Word64) -> ByteOrder -> Get Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64 -> Word64) -> Int64 -> ByteOrder -> Get Word64
forall a. Serializable a => (a -> a) -> Int64 -> ByteOrder -> Get a
getNumber Word64 -> Word64
byteSwap64 Int64
16

getDouble :: HeaderGetter Double
getDouble :: HeaderGetter Double
getDouble = (Header -> ByteOrder) -> ReaderT Header Get ByteOrder
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Header -> ByteOrder
_byteOrder ReaderT Header Get ByteOrder
-> (ByteOrder -> HeaderGetter Double) -> HeaderGetter Double
forall a b.
ReaderT Header Get a
-> (a -> ReaderT Header Get b) -> ReaderT Header Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Get Double -> HeaderGetter Double
forall (m :: * -> *) a. Monad m => m a -> ReaderT Header m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Get Double -> HeaderGetter Double)
-> (ByteOrder -> Get Double) -> ByteOrder -> HeaderGetter Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteOrder -> Get Double
_getDouble

{-# INLINE getChainLen #-}
getChainLen :: HeaderGetter Int
getChainLen :: HeaderGetter Int
getChainLen = HeaderGetter Int
getInt

-- | Geometry returning function
makeResult :: Header -> HeaderGetter a -> Get (a, SRID)
makeResult :: forall a. Header -> HeaderGetter a -> Get (a, SRID)
makeResult Header
h HeaderGetter a
getter = (,Header -> SRID
_srid Header
h) (a -> (a, SRID)) -> Get a -> Get (a, SRID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderGetter a -> Header -> Get a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT HeaderGetter a
getter Header
h