{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeApplications #-}
module Data.PackStream.Internal.Type where

import Control.Monad.Except (ExceptT, MonadError (..), runExceptT)
import Control.Monad.State (State, MonadState, evalState)
import Data.ByteString (ByteString)
import Data.Binary (Word8)
import Data.Map.Strict (Map)
import Data.Text (Text)

-- * PackStream basics

-- PackStream is a general purpose data serialisation format, originally inspired 
-- by (but incompatible with) MessagePack. This module provides basic types
-- and typeclasses to help you to parse or to serialize.

-- |Basic 'PackStream' error type that is used to handle parsing errors.
data PackStreamError = NotNull             -- ^This 'ByteString' doesn't represent null object
                     | NotBool             -- ^This 'ByteString' doesn't represent any boolean
                     | NotWord             -- ^This 'ByteString' doesn't represent any unsigned integer
                     | NotInt              -- ^This 'ByteString' doesn't represent any integer
                     | NotFloat            -- ^This 'ByteString' doesn't represent any floating-point number
                     | NotString           -- ^This 'ByteString' doesn't represent any 'Text' string
                     | NotBytes            -- ^This 'ByteString' doesn't represent any 'ByteString' array
                     | NotList             -- ^This 'ByteString' doesn't represent any list of 'PackStream' values
                     | NotDict             -- ^This 'ByteString' doesn't represent any dictionary of 'PackStream' values
                     | NotStructure        -- ^This 'ByteString' doesn't represent any 'Structure'
                     | NotValue            -- ^This 'ByteString' doesn't represent any 'Value'
                     | WrongStructure Text -- ^This 'ByteString' doesn't represent specific 'Structure'
                     | DictHasNoKey Text   -- ^The dictionary doesn't have a specified 'Text' key
  deriving (Int -> PackStreamError -> ShowS
[PackStreamError] -> ShowS
PackStreamError -> String
(Int -> PackStreamError -> ShowS)
-> (PackStreamError -> String)
-> ([PackStreamError] -> ShowS)
-> Show PackStreamError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PackStreamError] -> ShowS
$cshowList :: [PackStreamError] -> ShowS
show :: PackStreamError -> String
$cshow :: PackStreamError -> String
showsPrec :: Int -> PackStreamError -> ShowS
$cshowsPrec :: Int -> PackStreamError -> ShowS
Show, PackStreamError -> PackStreamError -> Bool
(PackStreamError -> PackStreamError -> Bool)
-> (PackStreamError -> PackStreamError -> Bool)
-> Eq PackStreamError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackStreamError -> PackStreamError -> Bool
$c/= :: PackStreamError -> PackStreamError -> Bool
== :: PackStreamError -> PackStreamError -> Bool
$c== :: PackStreamError -> PackStreamError -> Bool
Eq, Eq PackStreamError
Eq PackStreamError
-> (PackStreamError -> PackStreamError -> Ordering)
-> (PackStreamError -> PackStreamError -> Bool)
-> (PackStreamError -> PackStreamError -> Bool)
-> (PackStreamError -> PackStreamError -> Bool)
-> (PackStreamError -> PackStreamError -> Bool)
-> (PackStreamError -> PackStreamError -> PackStreamError)
-> (PackStreamError -> PackStreamError -> PackStreamError)
-> Ord PackStreamError
PackStreamError -> PackStreamError -> Bool
PackStreamError -> PackStreamError -> Ordering
PackStreamError -> PackStreamError -> PackStreamError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PackStreamError -> PackStreamError -> PackStreamError
$cmin :: PackStreamError -> PackStreamError -> PackStreamError
max :: PackStreamError -> PackStreamError -> PackStreamError
$cmax :: PackStreamError -> PackStreamError -> PackStreamError
>= :: PackStreamError -> PackStreamError -> Bool
$c>= :: PackStreamError -> PackStreamError -> Bool
> :: PackStreamError -> PackStreamError -> Bool
$c> :: PackStreamError -> PackStreamError -> Bool
<= :: PackStreamError -> PackStreamError -> Bool
$c<= :: PackStreamError -> PackStreamError -> Bool
< :: PackStreamError -> PackStreamError -> Bool
$c< :: PackStreamError -> PackStreamError -> Bool
compare :: PackStreamError -> PackStreamError -> Ordering
$ccompare :: PackStreamError -> PackStreamError -> Ordering
$cp1Ord :: Eq PackStreamError
Ord)

-- |Basic parser type. It works like parser combinators for binary data that represents PackStream.
newtype PackStream a = PackStream { PackStream a -> ExceptT PackStreamError (State ByteString) a
runUnpackS :: ExceptT PackStreamError (State ByteString) a }
  deriving (a -> PackStream b -> PackStream a
(a -> b) -> PackStream a -> PackStream b
(forall a b. (a -> b) -> PackStream a -> PackStream b)
-> (forall a b. a -> PackStream b -> PackStream a)
-> Functor PackStream
forall a b. a -> PackStream b -> PackStream a
forall a b. (a -> b) -> PackStream a -> PackStream b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PackStream b -> PackStream a
$c<$ :: forall a b. a -> PackStream b -> PackStream a
fmap :: (a -> b) -> PackStream a -> PackStream b
$cfmap :: forall a b. (a -> b) -> PackStream a -> PackStream b
Functor, Functor PackStream
a -> PackStream a
Functor PackStream
-> (forall a. a -> PackStream a)
-> (forall a b.
    PackStream (a -> b) -> PackStream a -> PackStream b)
-> (forall a b c.
    (a -> b -> c) -> PackStream a -> PackStream b -> PackStream c)
-> (forall a b. PackStream a -> PackStream b -> PackStream b)
-> (forall a b. PackStream a -> PackStream b -> PackStream a)
-> Applicative PackStream
PackStream a -> PackStream b -> PackStream b
PackStream a -> PackStream b -> PackStream a
PackStream (a -> b) -> PackStream a -> PackStream b
(a -> b -> c) -> PackStream a -> PackStream b -> PackStream c
forall a. a -> PackStream a
forall a b. PackStream a -> PackStream b -> PackStream a
forall a b. PackStream a -> PackStream b -> PackStream b
forall a b. PackStream (a -> b) -> PackStream a -> PackStream b
forall a b c.
(a -> b -> c) -> PackStream a -> PackStream b -> PackStream c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: PackStream a -> PackStream b -> PackStream a
$c<* :: forall a b. PackStream a -> PackStream b -> PackStream a
*> :: PackStream a -> PackStream b -> PackStream b
$c*> :: forall a b. PackStream a -> PackStream b -> PackStream b
liftA2 :: (a -> b -> c) -> PackStream a -> PackStream b -> PackStream c
$cliftA2 :: forall a b c.
(a -> b -> c) -> PackStream a -> PackStream b -> PackStream c
<*> :: PackStream (a -> b) -> PackStream a -> PackStream b
$c<*> :: forall a b. PackStream (a -> b) -> PackStream a -> PackStream b
pure :: a -> PackStream a
$cpure :: forall a. a -> PackStream a
$cp1Applicative :: Functor PackStream
Applicative, Applicative PackStream
a -> PackStream a
Applicative PackStream
-> (forall a b.
    PackStream a -> (a -> PackStream b) -> PackStream b)
-> (forall a b. PackStream a -> PackStream b -> PackStream b)
-> (forall a. a -> PackStream a)
-> Monad PackStream
PackStream a -> (a -> PackStream b) -> PackStream b
PackStream a -> PackStream b -> PackStream b
forall a. a -> PackStream a
forall a b. PackStream a -> PackStream b -> PackStream b
forall a b. PackStream a -> (a -> PackStream b) -> PackStream b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> PackStream a
$creturn :: forall a. a -> PackStream a
>> :: PackStream a -> PackStream b -> PackStream b
$c>> :: forall a b. PackStream a -> PackStream b -> PackStream b
>>= :: PackStream a -> (a -> PackStream b) -> PackStream b
$c>>= :: forall a b. PackStream a -> (a -> PackStream b) -> PackStream b
$cp1Monad :: Applicative PackStream
Monad, MonadState ByteString, MonadError PackStreamError)

-- |Use specific parser combinator to parse the 'ByteString' that represents any 'PackStream' data.
unpackStream :: PackStream a -> ByteString -> Either PackStreamError a
unpackStream :: PackStream a -> ByteString -> Either PackStreamError a
unpackStream PackStream a
action = State ByteString (Either PackStreamError a)
-> ByteString -> Either PackStreamError a
forall s a. State s a -> s -> a
evalState (ExceptT PackStreamError (State ByteString) a
-> State ByteString (Either PackStreamError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT PackStreamError (State ByteString) a
 -> State ByteString (Either PackStreamError a))
-> ExceptT PackStreamError (State ByteString) a
-> State ByteString (Either PackStreamError a)
forall a b. (a -> b) -> a -> b
$ PackStream a -> ExceptT PackStreamError (State ByteString) a
forall a.
PackStream a -> ExceptT PackStreamError (State ByteString) a
runUnpackS PackStream a
action)

-- |PackStream offers a number of core data types, many supported by multiple binary representations, as well as a flexible extension mechanism.
data Value = N                   -- ^Missing or empty value
           | B Bool              -- ^True or False
           | I Int               -- ^Signed 64-bit integer
           | F Double            -- ^64-bit floating point number
           | U ByteString        -- ^Byte array
           | T Text              -- ^Unicode text, UTF-8
           | L [Value]           -- ^Ordered collection of 'Value's
           | D (Map Text Value)  -- ^Collection of key-value entries (no order guaranteed)
           | S Structure         -- ^Composite value with a type signature
  deriving (Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show, Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c== :: Value -> Value -> Bool
Eq)

-- |A structure is a composite value, comprised of fields and a unique type code.
-- Structure encodings consist, beyond the marker, of a single byte, the tag byte, followed 
-- by a sequence of up to 15 fields, each an individual value. The size of a structure is 
-- measured as the number of fields and not the total byte size. This count does not include the tag.
data Structure = Structure { Structure -> Word8
signature :: Word8   -- ^Type code
                           , Structure -> [Value]
fields    :: [Value] -- ^Structure fields
                           }
  deriving (Int -> Structure -> ShowS
[Structure] -> ShowS
Structure -> String
(Int -> Structure -> ShowS)
-> (Structure -> String)
-> ([Structure] -> ShowS)
-> Show Structure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Structure] -> ShowS
$cshowList :: [Structure] -> ShowS
show :: Structure -> String
$cshow :: Structure -> String
showsPrec :: Int -> Structure -> ShowS
$cshowsPrec :: Int -> Structure -> ShowS
Show, Structure -> Structure -> Bool
(Structure -> Structure -> Bool)
-> (Structure -> Structure -> Bool) -> Eq Structure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Structure -> Structure -> Bool
$c/= :: Structure -> Structure -> Bool
== :: Structure -> Structure -> Bool
$c== :: Structure -> Structure -> Bool
Eq)

-- |The data types that can be serialized as 'PackStream'
class ToValue a where
    -- |Convert data type to the generic 'Value'
    toValue :: a -> Value

instance ToValue () where
    toValue :: () -> Value
toValue = Value -> () -> Value
forall a b. a -> b -> a
const Value
N

instance ToValue Bool where
    toValue :: Bool -> Value
toValue = Bool -> Value
B

instance ToValue Int where
    toValue :: Int -> Value
toValue = Int -> Value
I

instance ToValue Integer where
    toValue :: Integer -> Value
toValue = ToValue Int => Int -> Value
forall a. ToValue a => a -> Value
toValue @Int (Int -> Value) -> (Integer -> Int) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance ToValue Double where
    toValue :: Double -> Value
toValue = Double -> Value
F

instance ToValue ByteString where
    toValue :: ByteString -> Value
toValue = ByteString -> Value
U

instance ToValue Text where
    toValue :: Text -> Value
toValue = Text -> Value
T

instance ToValue a => ToValue [a] where
    toValue :: [a] -> Value
toValue = [Value] -> Value
L ([Value] -> Value) -> ([a] -> [Value]) -> [a] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> [a] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Value
forall a. ToValue a => a -> Value
toValue

instance ToValue a => ToValue (Map Text a) where
    toValue :: Map Text a -> Value
toValue = Map Text Value -> Value
D (Map Text Value -> Value)
-> (Map Text a -> Map Text Value) -> Map Text a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> Map Text a -> Map Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Value
forall a. ToValue a => a -> Value
toValue

instance ToValue Structure where
    toValue :: Structure -> Value
toValue = Structure -> Value
S

instance ToValue Value where
    toValue :: Value -> Value
toValue = Value -> Value
forall a. a -> a
id

-- |Represent a 'Text' key and some 'ToValue' data into the 'Map' pair.
-- Can be useful to work with 'PackStream' dictionaries.
--
-- > fromList ["hello" =: 1, "world" =: False]
(=:) :: ToValue a => Text -> a -> (Text, Value)
=: :: Text -> a -> (Text, Value)
(=:) Text
key a
val = (Text
key, a -> Value
forall a. ToValue a => a -> Value
toValue a
val)

-- |The data types taht can be read from 'PackStream' representation
class FromValue a where
    -- |Converts generic 'Value' type to a specific one or raises 'PackStreamError'
    fromValue :: Value -> Either PackStreamError a

instance FromValue () where
    fromValue :: Value -> Either PackStreamError ()
fromValue Value
N = () -> Either PackStreamError ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    fromValue Value
_ = PackStreamError -> Either PackStreamError ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PackStreamError
NotNull

instance FromValue Bool where
    fromValue :: Value -> Either PackStreamError Bool
fromValue (B Bool
x) = Bool -> Either PackStreamError Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
x
    fromValue Value
_     = PackStreamError -> Either PackStreamError Bool
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PackStreamError
NotBool

instance FromValue Int where
    fromValue :: Value -> Either PackStreamError Int
fromValue (I Int
x) = Int -> Either PackStreamError Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
x
    fromValue Value
_     = PackStreamError -> Either PackStreamError Int
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PackStreamError
NotInt

instance FromValue Integer where
    fromValue :: Value -> Either PackStreamError Integer
fromValue = (Int -> Integer)
-> Either PackStreamError Int -> Either PackStreamError Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Either PackStreamError Int -> Either PackStreamError Integer)
-> (Value -> Either PackStreamError Int)
-> Value
-> Either PackStreamError Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromValue Int => Value -> Either PackStreamError Int
forall a. FromValue a => Value -> Either PackStreamError a
fromValue @Int

instance FromValue Double where
    fromValue :: Value -> Either PackStreamError Double
fromValue (F Double
x) = Double -> Either PackStreamError Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
x
    fromValue Value
_     = PackStreamError -> Either PackStreamError Double
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PackStreamError
NotFloat

instance FromValue ByteString where
    fromValue :: Value -> Either PackStreamError ByteString
fromValue (U ByteString
x) = ByteString -> Either PackStreamError ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
x
    fromValue Value
_     = PackStreamError -> Either PackStreamError ByteString
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PackStreamError
NotBytes

instance FromValue Text where
    fromValue :: Value -> Either PackStreamError Text
fromValue (T Text
x) = Text -> Either PackStreamError Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
x
    fromValue Value
_     = PackStreamError -> Either PackStreamError Text
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PackStreamError
NotString

instance FromValue a => FromValue [a] where
    fromValue :: Value -> Either PackStreamError [a]
fromValue (L [Value]
xs) = (Value -> Either PackStreamError a)
-> [Value] -> Either PackStreamError [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Either PackStreamError a
forall a. FromValue a => Value -> Either PackStreamError a
fromValue [Value]
xs
    fromValue Value
_      = PackStreamError -> Either PackStreamError [a]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PackStreamError
NotList

instance FromValue a => FromValue (Map Text a) where
    fromValue :: Value -> Either PackStreamError (Map Text a)
fromValue (D Map Text Value
mp) = (Value -> Either PackStreamError a)
-> Map Text Value -> Either PackStreamError (Map Text a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Either PackStreamError a
forall a. FromValue a => Value -> Either PackStreamError a
fromValue Map Text Value
mp
    fromValue Value
_      = PackStreamError -> Either PackStreamError (Map Text a)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PackStreamError
NotDict

instance FromValue Structure where
    fromValue :: Value -> Either PackStreamError Structure
fromValue (S Structure
x) = Structure -> Either PackStreamError Structure
forall (f :: * -> *) a. Applicative f => a -> f a
pure Structure
x
    fromValue Value
_     = PackStreamError -> Either PackStreamError Structure
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PackStreamError
NotStructure

instance FromValue Value where
    fromValue :: Value -> Either PackStreamError Value
fromValue = Value -> Either PackStreamError Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure