{-# LANGUAGE InstanceSigs              #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables       #-}

{- | Wrapper type to decode a value to its flat serialisation.

See <../test/Big.hs> for an example of use.

See also 'Flat.Decoder.listTDecoder' and "Flat.AsSize" for other ways to handle large decoded values.

In 0.5.X this type was called @Repr@.

@since 0.6
-}
module Flat.AsBin(AsBin,unbin) where

import qualified Data.ByteString                as B
import           Flat.Bits                      (bits, fromBools, toBools)
import           Flat.Class                     (Flat (..))
import           Flat.Decoder.Prim              (binOf)
import           Flat.Decoder.Types             (Get (Get, runGet),
                                                 GetResult (GetResult),
                                                 S (S, currPtr, usedBits))
import           Flat.Run                       (unflatRawWithOffset)
import           Foreign                        (plusPtr)
import           Text.PrettyPrint.HughesPJClass (Doc, Pretty (pPrint),
                                                 prettyShow, text)

-- $setup
-- >>> :set -XScopedTypeVariables
-- >>> import Flat.Instances.Base
-- >>> import Flat.Instances.Text
-- >>> import Flat.Decoder.Types
-- >>> import Flat.Types
-- >>> import Flat.Run
-- >>> import Data.Word
-- >>> import qualified Data.Text as T
-- >>> import Text.PrettyPrint.HughesPJClass

{- |

When the flat serialisation of a value takes a lot less memory than the value itself, it can be convenient to keep the value in its encoded representation and decode it on demand.

To do so, just decode a value `a` as a `AsBin a`.

Examples:

Encode a list of Ints and then decode it to a list of AsBin Int:

>>> unflat (flat [1::Int .. 3]) :: Decoded ([AsBin Int])
Right [AsBin {repr = "\129A", offsetBits = 1},AsBin {repr = "A ", offsetBits = 2},AsBin {repr = " \193", offsetBits = 3}]

To decode an `AsBin a` to an `a`, use `unbin`:

>>> unbin <$> (unflat (flat 'a') :: Decoded (AsBin Char))
Right 'a'

Keep the values of a list of Ints encoded and decode just one on demand:

>>> let Right l :: Decoded [AsBin Int] = unflat (flat [1..5]) in unbin (l  !! 2)
3

Show exactly how values are encoded:

>>> let Right t :: Decoded (AsBin Bool,AsBin Word8,AsBin Bool) = unflat (flat (False,3:: Word64,True)) in prettyShow t
"(0, _0000001 1, _1)"

Ten bits in total spread over two bytes:

@
0
_0000001 1
         _1
=
00000001 11
@

Tests:

>>> unflat (flat ()) :: Decoded (AsBin ())
Right (AsBin {repr = "", offsetBits = 0})

>>> unflat (flat (False,True)) :: Decoded (Bool,AsBin Bool)
Right (False,AsBin {repr = "A", offsetBits = 1})

>>> unflat (flat (False,False,255 :: Word8)) :: Decoded (Bool,Bool,AsBin Word8)
Right (False,False,AsBin {repr = "?\193", offsetBits = 2})

>>> let Right (b0,b1,rw,b3) :: Decoded (Bool,Bool,AsBin Word8,Bool) = unflat (flat (False,False,255 :: Word8,True)) in (b0,b1,unbin rw,b3)
(False,False,255,True)
-}

data AsBin a = AsBin {
    forall a. AsBin a -> ByteString
repr        :: B.ByteString -- ^ Flat encoding of the value (encoding starts after offset bits in the first byte and ends in an unspecified position in the last byte)
    ,forall a. AsBin a -> Int
offsetBits :: Int -- ^ First byte offset: number of unused most significant bits in the first byte
    } deriving Int -> AsBin a -> ShowS
forall a. Int -> AsBin a -> ShowS
forall a. [AsBin a] -> ShowS
forall a. AsBin a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AsBin a] -> ShowS
$cshowList :: forall a. [AsBin a] -> ShowS
show :: AsBin a -> String
$cshow :: forall a. AsBin a -> String
showsPrec :: Int -> AsBin a -> ShowS
$cshowsPrec :: forall a. Int -> AsBin a -> ShowS
Show

instance Flat a => Pretty (AsBin a) where
    pPrint :: AsBin a -> Doc
    pPrint :: AsBin a -> Doc
pPrint AsBin a
r = let n :: a -> [a]
n = forall a. Int -> a -> [a]
replicate (forall a. AsBin a -> Int
offsetBits AsBin a
r) in String -> Doc
text forall a b. (a -> b) -> a -> b
$ forall {a}. a -> [a]
n Char
'_' forall a. [a] -> [a] -> [a]
++  (forall a. Int -> [a] -> [a]
drop (forall a. AsBin a -> Int
offsetBits AsBin a
r) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> String
prettyShow forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> Bits
fromBools forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall {a}. a -> [a]
n Bool
False forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bits -> [Bool]
toBools forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Flat a => a -> Bits
bits forall a b. (a -> b) -> a -> b
$ forall a. Flat a => AsBin a -> a
unbin AsBin a
r)

-- | Decode a value
unbin :: Flat a => AsBin a -> a
unbin :: forall a. Flat a => AsBin a -> a
unbin AsBin a
a =
    case forall b a. AsByteString b => Get a -> b -> Int -> Decoded a
unflatRawWithOffset forall {a}. Flat a => Get a
dec (forall a. AsBin a -> ByteString
repr AsBin a
a) (forall a. AsBin a -> Int
offsetBits AsBin a
a) of
        Right a
a -> a
a
        Left DecodeException
e  -> forall a. HasCallStack => String -> a
error (forall a. Show a => a -> String
show DecodeException
e) -- impossible, as it is a valid encoding
    where
        dec :: Get a
dec = forall a. (Ptr Word8 -> S -> IO (GetResult a)) -> Get a
Get forall a b. (a -> b) -> a -> b
$ \Ptr Word8
end S
s -> do
          GetResult S
s' a
a <- forall a. Get a -> Ptr Word8 -> S -> IO (GetResult a)
runGet forall {a}. Flat a => Get a
decode Ptr Word8
end S
s
          let s'' :: S
s'' = Ptr Word8 -> Int -> S
S (S -> Ptr Word8
currPtr S
s' forall a b. Ptr a -> Int -> Ptr b
`plusPtr` if S -> Int
usedBits S
s' forall a. Eq a => a -> a -> Bool
== Int
0 then Int
0 else Int
1) Int
0
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. S -> a -> GetResult a
GetResult S
s'' a
a

instance Flat a => Flat (AsBin a) where
    size :: AsBin a -> Int -> Int
size = forall a. HasCallStack => String -> a
error String
"unused"

    encode :: AsBin a -> Encoding
encode = forall a. HasCallStack => String -> a
error String
"unused"

    decode :: Flat a => Get (AsBin a)
    decode :: Flat a => Get (AsBin a)
decode = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. ByteString -> Int -> AsBin a
AsBin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Get a -> Get (ByteString, Int)
binOf (forall {a}. Flat a => Get a
decode :: Get a)