flat-0.5.2: src/Flat/Instances/Base.hs

{-# LANGUAGE CPP                #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE StandaloneDeriving #-}

-- | Flat instances for the base library
module Flat.Instances.Base () where

import           Control.Monad         (liftM2)
import           Data.Bool
import           Data.Char
import           Data.Complex          (Complex (..))
import           Data.Fixed
-- #if MIN_VERSION_base(4,9,0)
import qualified Data.List.NonEmpty    as B
-- #endif

#if ! MIN_VERSION_base(4,8,0)
import           Control.Applicative
import           Data.Monoid           (mempty)
#endif

#if MIN_VERSION_base(4,9,0)
import qualified Data.Semigroup        as Semigroup
#endif

import qualified Data.Monoid           as Monoid
import           Data.Ratio
import           Flat.Instances.Util
import           Prelude               hiding (mempty)

-- #if !MIN_VERSION_base(4,9,0)
-- import           Data.Monoid           ((<>))
-- #endif

#if MIN_VERSION_base(4,9,0)
import           Data.Functor.Identity (Identity (..))
#endif

-- #if !MIN_VERSION_base(4,9,0)
-- deriving instance Generic (Complex a)
-- #endif

{- ORMOLU_DISABLE -}
-- $setup
-- >>> :set -XNegativeLiterals -XTypeApplications
-- >>> import Flat.Instances.Test
-- >>> import Data.Fixed
-- >>> import Data.Int
-- >>> import Data.Complex(Complex(..))
-- >>> import Numeric.Natural
-- >>> import Data.Word
-- >>> import Data.Ratio
-- >>> import Flat.Run
-- >>> import Data.Monoid
-- >>> import qualified Data.List.NonEmpty as B
-- >>> let test = tstBits
-- >>> let y = 33
{- ORMOLU_ENABLE -}

-- >>> y

-- | @since 0.4.4
#if MIN_VERSION_base(4,8,0)
instance Flat Monoid.All where
    encode (Monoid.All a) = encode a
    size (Monoid.All a) = size a
    decode = Monoid.All <$> decode

{- |

>>> let w = Just (11::Word8); a = Alt w <> Alt (Just 24) in tst a == tst w
True

>>> let w = Just (11::Word8); a = Alt Nothing <> Alt w in tst a == tst w
True

@since 0.4.4
-}
instance Flat (f a) => Flat (Monoid.Alt f a) where
    encode (Monoid.Alt a) = encode a
    size (Monoid.Alt a) = size a
    decode = Monoid.Alt <$> decode
#endif

#if MIN_VERSION_base(4,9,0)
-- | @since 0.4.4
instance Flat a => Flat (Identity a) where
    encode (Identity a) = encode a
    size (Identity a) = size a
    decode = Identity <$> decode
#endif

-- | @since 0.4.4
instance Flat a => Flat (Monoid.Dual a) where
    encode (Monoid.Dual a) = encode a
    size (Monoid.Dual a) = size a
    decode = Monoid.Dual <$> decode

-- | @since 0.4.4
instance Flat Monoid.Any where
    encode (Monoid.Any a) = encode a
    size (Monoid.Any a) = size a
    decode = Monoid.Any <$> decode

-- | @since 0.4.4
instance Flat a => Flat (Monoid.Sum a) where
    encode (Monoid.Sum a) = encode a
    size (Monoid.Sum a) = size a
    decode = Monoid.Sum <$> decode

-- | @since 0.4.4
instance Flat a => Flat (Monoid.Product a) where
    encode (Monoid.Product a) = encode a
    size (Monoid.Product a) = size a
    decode = Monoid.Product <$> decode

#if MIN_VERSION_base(4,9,0)
-- | @since 0.4.4
instance Flat a => Flat (Semigroup.Min a) where
    encode (Semigroup.Min a) = encode a
    size (Semigroup.Min a) = size a
    decode = Semigroup.Min <$> decode

-- | @since 0.4.4
instance Flat a => Flat (Semigroup.Max a) where
    encode (Semigroup.Max a) = encode a
    size (Semigroup.Max a) = size a
    decode = Semigroup.Max <$> decode

-- | @since 0.4.4
instance Flat a => Flat (Semigroup.First a) where
    encode (Semigroup.First a) = encode a
    size (Semigroup.First a) = size a
    decode = Semigroup.First <$> decode

-- | @since 0.4.4
instance Flat a => Flat (Semigroup.Last a) where
    encode (Semigroup.Last a) = encode a
    size (Semigroup.Last a) = size a
    decode = Semigroup.Last <$> decode
#endif

{- |
`()`, as all data types with a single constructor, has a zero-length encoding.

>>> test ()
(True,0,"")
-}
instance Flat () where
    encode _ = mempty

    size _ = id

    decode = pure ()

{- |
One bit is plenty for a Bool.

>>> test False
(True,1,"0")

>>> test True
(True,1,"1")
-}
instance Flat Bool where
    encode = eBool

    size = sBool

    decode = dBool

{- |
Char's are mapped to Word32 and then encoded.

For ascii characters, the encoding is standard ascii.

>>> test 'a'
(True,8,"01100001")

For unicode characters, the encoding is non standard.

>>> test 'È'
(True,16,"11001000 00000001")

>>> test '不'
(True,24,"10001101 10011100 00000001")

#ifndef ETA
>>> test "\x1F600"
(True,26,"11000000 01110110 00000011 10")
#endif
-}
instance Flat Char where
    size = sChar

    encode = eChar

    decode = dChar

{- |
>>> test (Nothing::Maybe Bool)
(True,1,"0")

>>> test (Just False::Maybe Bool)
(True,2,"10")
-}
instance Flat a => Flat (Maybe a)

{- |
>>> test (Left False::Either Bool ())
(True,2,"00")

>>> test (Right ()::Either Bool ())
(True,1,"1")
-}
instance (Flat a, Flat b) => Flat (Either a b)

{- |
>>> test (MkFixed 123 :: Fixed E0)
(True,16,"11110110 00000001")

>>> test (MkFixed 123 :: Fixed E0) == test (MkFixed 123 :: Fixed E2)
True
-}
instance Flat (Fixed a) where
    encode (MkFixed n) = encode n

    size (MkFixed n) = size n

    decode = MkFixed <$> decode

{- |
Word8 always take 8 bits.

>>> test (0::Word8)
(True,8,"00000000")

>>> test (255::Word8)
(True,8,"11111111")
-}
instance Flat Word8 where
    encode = eWord8

    decode = dWord8

    size = sWord8

{- |
Natural, Word, Word16, Word32 and Word64 are encoded as a non empty list of 7 bits chunks (least significant chunk first and most significant bit first in every chunk).

Words are always encoded in a whole number of bytes, as every chunk is 8 bits long (1 bit for the List constructor, plus 7 bits for the value).

The actual definition is:

@
Word64 ≡   Word64 Word

Word32 ≡   Word32 Word

Word16 ≡   Word16 Word

Word ≡   Word (LeastSignificantFirst (NonEmptyList (MostSignificantFirst Word7)))

LeastSignificantFirst a ≡   LeastSignificantFirst a

NonEmptyList a ≡   Elem a
                 | Cons a (NonEmptyList a)

MostSignificantFirst a ≡   MostSignificantFirst a

Word7 ≡   V0
        | V1
        | V2
        ...
        | V127
@

Values between as 0 and 127 fit in a single byte.

127 (0b1111111) is represented as Elem V127 and encoded as: Elem=0 127=1111111

>>> test (127::Word)
(True,8,"01111111")

254 (0b11111110) is represented as Cons V126 (Elem V1) (254=128+126) and encoded as: Cons=1 V126=1111110 (Elem=0 V1=0000001):

>>> test (254::Word)
(True,16,"11111110 00000001")

Another example, 32768 (Ob1000000000000000 = 0000010 0000000 0000000):

>>> test (32768::Word32)
(True,24,"10000000 10000000 00000010")

As this is a variable length encoding, values are encoded in the same way, whatever their type:

>>> all (test (3::Word) ==) [test (3::Word16),test (3::Word32),test (3::Word64)]
True


Word/Int decoders return an error if the encoded value is outside their valid range:

>>> unflat @Word16 (flat @Word32 $ fromIntegral @Word16 maxBound)
Right 65535

>>> unflat @Word16 (flat @Word32 $ fromIntegral @Word16 maxBound + 1)
Left (BadEncoding ...

>>> unflat @Word32 (flat @Word64 $ fromIntegral @Word32 maxBound)
Right 4294967295

>>> unflat @Word32 (flat @Word64 $ fromIntegral @Word32 maxBound + 1)
Left (BadEncoding ...

>>> unflat @Word64 (flat @Natural $ fromIntegral @Word64 maxBound)
Right 18446744073709551615

>>> unflat @Word64 (flat @Natural $ fromIntegral @Word64 maxBound + 1)
Left (BadEncoding ...



>>> unflat @Int16 (flat @Int32 $ fromIntegral @Int16 maxBound)
Right 32767

>>> unflat @Int16 (flat @Int32 $ fromIntegral @Int16 maxBound + 1)
Left (BadEncoding ...

>>> unflat @Int32 (flat @Int64 $ fromIntegral @Int32 maxBound)
Right 2147483647

>>> unflat @Int32 (flat @Int64 $ fromIntegral @Int32 maxBound + 1)
Left (BadEncoding ...

>>> unflat @Int64 (flat @Integer $ fromIntegral @Int64 maxBound)
Right 9223372036854775807

>>> unflat @Int64 (flat @Integer $ fromIntegral @Int64 maxBound + 1)
Left (BadEncoding ...


>>> unflat @Int16 (flat @Int32 $ fromIntegral @Int16 minBound)
Right (-32768)

>>> unflat @Int16 (flat @Int32 $ fromIntegral @Int16 minBound - 1)
Left (BadEncoding ...

>>> unflat @Int32 (flat @Int64 $ fromIntegral @Int32 minBound)
Right (-2147483648)

>>> unflat @Int32 (flat @Int64 $ fromIntegral @Int32 minBound - 1)
Left (BadEncoding ...

>>> unflat @Int64 (flat @Integer $ fromIntegral @Int64 minBound)
Right (-9223372036854775808)

>>> unflat @Int64 (flat @Integer $ fromIntegral @Int64 minBound - 1)
Left (BadEncoding ...
-}
instance Flat Word where
    size = sWord

    encode = eWord

    decode = dWord

{- |
Naturals are encoded just as the fixed size Words.

>>> test (0::Natural)
(True,8,"00000000")

>>> test (2^120::Natural)
(True,144,"10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 00000010")
-}
instance Flat Natural where
    size = sNatural

    encode = eNatural

    decode = dNatural

instance Flat Word16 where
    encode = eWord16

    decode = dWord16

    size = sWord16

instance Flat Word32 where
    encode = eWord32

    decode = dWord32

    size = sWord32

instance Flat Word64 where
    encode = eWord64

    decode = dWord64

    size = sWord64

{- |
Integer, Int, Int16, Int32 and Int64 are defined as the <https://developers.google.com/protocol-buffers/docs/encoding#signed-integers ZigZag> encoded version of the equivalent unsigned Word:

@
Int   ≡  Int   (ZigZag Word)

Int64 ≡  Int64 (ZigZag Word64)

Int32 ≡  Int32 (ZigZag Word32)

Int16 ≡  Int16 (ZigZag Word16)

Int8  ≡  Int8  (ZigZag Word8)

ZigZag a ≡ ZigZag a
@

ZigZag encoding alternates between positive and negative numbers, so that numbers whose absolute value is small can be encoded efficiently:

>>> test (0::Int)
(True,8,"00000000")

>>> test (-1::Int)
(True,8,"00000001")

>>> test (1::Int)
(True,8,"00000010")

>>> test (-2::Int)
(True,8,"00000011")

>>> test (2::Int)
(True,8,"00000100")
-}
instance Flat Int where
    size = sInt

    encode = eInt

    decode = dInt

{- |
Integers are encoded just as the fixed size Ints.

>>> test (0::Integer)
(True,8,"00000000")

>>> test (-1::Integer)
(True,8,"00000001")

>>> test (1::Integer)
(True,8,"00000010")

>>> test (-(2^4)::Integer)
(True,8,"00011111")

>>> test (2^4::Integer)
(True,8,"00100000")

>>> test (-(2^120)::Integer)
(True,144,"11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000011")

>>> test (2^120::Integer)
(True,144,"10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 00000100")
-}
instance Flat Integer where
    size = sInteger

    encode = eInteger

    decode = dInteger

{- |
>>> test (0::Int8)
(True,8,"00000000")

>>> test (127::Int8)
(True,8,"11111110")

>>> test (-128::Int8)
(True,8,"11111111")
-}
instance Flat Int8 where
    encode = eInt8

    decode = dInt8

    size = sInt8

{- |
>>> test (0::Int16)
(True,8,"00000000")

>>> test (1::Int16)
(True,8,"00000010")

>>> test (-1::Int16)
(True,8,"00000001")

>>> test (minBound::Int16)
(True,24,"11111111 11111111 00000011")

equivalent to 0b1111111111111111

>>> test (maxBound::Int16)
(True,24,"11111110 11111111 00000011")

equivalent to 0b1111111111111110
-}
instance Flat Int16 where
    size = sInt16

    encode = eInt16

    decode = dInt16

{- |
>>> test (0::Int32)
(True,8,"00000000")

>>> test (minBound::Int32)
(True,40,"11111111 11111111 11111111 11111111 00001111")

>>> test (maxBound::Int32)
(True,40,"11111110 11111111 11111111 11111111 00001111")
-}
instance Flat Int32 where
    size = sInt32

    encode = eInt32

    decode = dInt32

{- |
>>> test (0::Int64)
(True,8,"00000000")

>>> test (minBound::Int64)
(True,80,"11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000001")

>>> test (maxBound::Int64)
(True,80,"11111110 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000001")
-}
instance Flat Int64 where
    size = sInt64

    encode = eInt64

    decode = dInt64

{- |
Floats are encoded as standard IEEE binary32 values:

@
IEEE_754_binary32 ≡ IEEE_754_binary32 {sign :: Sign,
                                        exponent :: MostSignificantFirst Bits8,
                                        fraction :: MostSignificantFirst Bits23}
@

>>> test (0::Float)
(True,32,"00000000 00000000 00000000 00000000")

>>> test (1.4012984643E-45::Float)
(True,32,"00000000 00000000 00000000 00000001")

>>> test (1.1754942107E-38::Float)
(True,32,"00000000 01111111 11111111 11111111")
-}
instance Flat Float where
    size = sFloat

    encode = eFloat

    decode = dFloat

{- |
Doubles are encoded as standard IEEE binary64 values:

@
IEEE_754_binary64 ≡ IEEE_754_binary64 {sign :: Sign,
                                        exponent :: MostSignificantFirst Bits11,
                                        fraction :: MostSignificantFirst Bits52}
@
-}
instance Flat Double where
    size = sDouble

    encode = eDouble

    decode = dDouble

{- |
>>> test (4 :+ 2 :: Complex Word8)
(True,16,"00000100 00000010")
-}
instance Flat a => Flat (Complex a)

{- |
Ratios are encoded as tuples of (numerator,denominator)

>>> test (3%4::Ratio Word8)
(True,16,"00000011 00000100")
-}
instance (Integral a, Flat a) => Flat (Ratio a) where
    size a = size (numerator a, denominator a)

    encode a = encode (numerator a, denominator a)

    -- decode = uncurry (%) <$> decode
    decode = liftM2 (%) decode decode

{- |
>>> test ([]::[Bool])
(True,1,"0")

>>> test [False,False]
(True,5,"10100")

This instance and other similar ones are declared as @OVERLAPPABLE@, because for better encoding/decoding
performance it can be useful to declare instances of concrete types, such as @[Char]@ (not provided out of the box).
-}
instance {-# OVERLAPPABLE #-} Flat a => Flat [a]

{-
>>> import Weigh
>>> flat [1..10::Int]
-}


-- Generic list instance (stack overflows with ETA, see https://github.com/typelead/eta/issues/901)
-- where
--size [] n = n+1
--size (h:t) n = trampoline size t (trampoline size h (n+1))
-- size = sizeListWith size -- foldl' (\n e -> ) n
-- encode = error "BAD"
-- encode = trampoline . encodeListWith encode
-- decode = decodeListWith decode
-- sizeListWith siz l n = foldl' (\n e -> 1 + n + siz e 0) n l
-- #ifdef ETA_VERSION
-- import Data.Function(trampoline)
-- import GHC.IO(trampolineIO)
-- #else
-- trampoline = id
-- trampolineIO = id
-- #endif

-- #if MIN_VERSION_base(4,9,0)

{- |
>>> test (B.fromList [True])
(True,2,"10")

>>> test (B.fromList [False,False])
(True,4,"0100")
-}
instance {-# OVERLAPPABLE #-} Flat a => Flat (B.NonEmpty a)

-- #endif

{- |
Tuples are supported up to 7 elements.

>>> test (False,())
(True,1,"0")

>>> test ((),())
(True,0,"")

"7 elements tuples ought to be enough for anybody" (Bill Gates - apocryphal)

>>> test (False,True,True,True,False,True,True)
(True,7,"0111011")

tst (1::Int,"2","3","4","5","6","7","8")
...error
-}

-- Not sure if these should be OVERLAPPABLE
instance {-# OVERLAPPABLE #-} (Flat a, Flat b) => Flat (a, b)

instance {-# OVERLAPPABLE #-} (Flat a, Flat b, Flat c) => Flat (a, b, c)

instance
    {-# OVERLAPPABLE #-}
    (Flat a, Flat b, Flat c, Flat d) =>
    Flat (a, b, c, d)

instance
    {-# OVERLAPPABLE #-}
    (Flat a, Flat b, Flat c, Flat d, Flat e) =>
    Flat (a, b, c, d, e)

instance
    {-# OVERLAPPABLE #-}
    (Flat a, Flat b, Flat c, Flat d, Flat e, Flat f) =>
    Flat (a, b, c, d, e, f)

instance
    {-# OVERLAPPABLE #-}
    ( Flat a
    , Flat b
    , Flat c
    , Flat d
    , Flat e
    , Flat f
    , Flat g
    ) =>
    Flat (a, b, c, d, e, f, g)