{-# LANGUAGE BangPatterns, CPP, MultiParamTypeClasses, TypeFamilies, FlexibleContexts #-}
#if __GLASGOW_HASKELL__ >= 707
{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
#endif
{-# OPTIONS_HADDOCK hide #-}

-- |
-- Module      : Data.Vector.Unboxed.Base
-- Copyright   : (c) Roman Leshchinskiy 2009-2010
-- License     : BSD-style
--
-- Maintainer  : Roman Leshchinskiy <rl@cse.unsw.edu.au>
-- Stability   : experimental
-- Portability : non-portable
--
-- Adaptive unboxed vectors: basic implementation
--

module Data.Vector.Unboxed.Base (
  MVector(..), IOVector, STVector, Vector(..), Unbox
) where

import qualified Data.Vector.Generic         as G
import qualified Data.Vector.Generic.Mutable as M

import qualified Data.Vector.Primitive as P

import Control.DeepSeq ( NFData(rnf) )

import Control.Monad.Primitive
import Control.Monad ( liftM )

import Data.Word ( Word8, Word16, Word32, Word64 )
import Data.Int  ( Int8, Int16, Int32, Int64 )
import Data.Complex

#if !MIN_VERSION_base(4,8,0)
import Data.Word ( Word )
#endif

#if __GLASGOW_HASKELL__ >= 707
import Data.Typeable ( Typeable )
#else
import Data.Typeable ( Typeable1(..), Typeable2(..), mkTyConApp,
#if MIN_VERSION_base(4,4,0)
                       mkTyCon3
#else
                       mkTyCon
#endif
                     )
#endif

import Data.Data     ( Data(..) )

-- Data.Vector.Internal.Check is unused
#define NOT_VECTOR_MODULE
#include "vector.h"

data family MVector s a
data family Vector    a

type IOVector = MVector RealWorld
type STVector s = MVector s

type instance G.Mutable Vector = MVector

class (G.Vector Vector a, M.MVector MVector a) => Unbox a

instance NFData (Vector a) where rnf !_ = ()
instance NFData (MVector s a) where rnf !_ = ()

-- -----------------
-- Data and Typeable
-- -----------------
#if __GLASGOW_HASKELL__ >= 707
deriving instance Typeable Vector
deriving instance Typeable MVector
#else
#if MIN_VERSION_base(4,4,0)
vectorTyCon = mkTyCon3 "vector"
#else
vectorTyCon m s = mkTyCon $ m ++ "." ++ s
#endif

instance Typeable1 Vector where
  typeOf1 _ = mkTyConApp (vectorTyCon "Data.Vector.Unboxed" "Vector") []

instance Typeable2 MVector where
  typeOf2 _ = mkTyConApp (vectorTyCon "Data.Vector.Unboxed.Mutable" "MVector") []
#endif

instance (Data a, Unbox a) => Data (Vector a) where
  gfoldl       = G.gfoldl
  toConstr _   = error "toConstr"
  gunfold _ _  = error "gunfold"
  dataTypeOf _ = G.mkType "Data.Vector.Unboxed.Vector"
  dataCast1    = G.dataCast

-- ----
-- Unit
-- ----

newtype instance MVector s () = MV_Unit Int
newtype instance Vector    () = V_Unit Int

instance Unbox ()

instance M.MVector MVector () where
  {-# INLINE basicLength #-}
  {-# INLINE basicUnsafeSlice #-}
  {-# INLINE basicOverlaps #-}
  {-# INLINE basicUnsafeNew #-}
  {-# INLINE basicInitialize #-}
  {-# INLINE basicUnsafeRead #-}
  {-# INLINE basicUnsafeWrite #-}
  {-# INLINE basicClear #-}
  {-# INLINE basicSet #-}
  {-# INLINE basicUnsafeCopy #-}
  {-# INLINE basicUnsafeGrow #-}

  basicLength (MV_Unit n) = n

  basicUnsafeSlice _ m (MV_Unit _) = MV_Unit m

  basicOverlaps _ _ = False

  basicUnsafeNew n = return (MV_Unit n)

  -- Nothing to initialize
  basicInitialize _ = return ()

  basicUnsafeRead (MV_Unit _) _ = return ()

  basicUnsafeWrite (MV_Unit _) _ () = return ()

  basicClear _ = return ()

  basicSet (MV_Unit _) () = return ()

  basicUnsafeCopy (MV_Unit _) (MV_Unit _) = return ()

  basicUnsafeGrow (MV_Unit n) m = return $ MV_Unit (n+m)

instance G.Vector Vector () where
  {-# INLINE basicUnsafeFreeze #-}
  basicUnsafeFreeze (MV_Unit n) = return $ V_Unit n

  {-# INLINE basicUnsafeThaw #-}
  basicUnsafeThaw (V_Unit n) = return $ MV_Unit n

  {-# INLINE basicLength #-}
  basicLength (V_Unit n) = n

  {-# INLINE basicUnsafeSlice #-}
  basicUnsafeSlice _ m (V_Unit _) = V_Unit m

  {-# INLINE basicUnsafeIndexM #-}
  basicUnsafeIndexM (V_Unit _) _ = return ()

  {-# INLINE basicUnsafeCopy #-}
  basicUnsafeCopy (MV_Unit _) (V_Unit _) = return ()

  {-# INLINE elemseq #-}
  elemseq _ = seq

-- ---------------
-- Primitive types
-- ---------------

#define primMVector(ty,con)                                             \
instance M.MVector MVector ty where {                                   \
  {-# INLINE basicLength #-}                                            \
; {-# INLINE basicUnsafeSlice #-}                                       \
; {-# INLINE basicOverlaps #-}                                          \
; {-# INLINE basicUnsafeNew #-}                                         \
; {-# INLINE basicInitialize #-}                                        \
; {-# INLINE basicUnsafeReplicate #-}                                   \
; {-# INLINE basicUnsafeRead #-}                                        \
; {-# INLINE basicUnsafeWrite #-}                                       \
; {-# INLINE basicClear #-}                                             \
; {-# INLINE basicSet #-}                                               \
; {-# INLINE basicUnsafeCopy #-}                                        \
; {-# INLINE basicUnsafeGrow #-}                                        \
; basicLength (con v) = M.basicLength v                                 \
; basicUnsafeSlice i n (con v) = con $ M.basicUnsafeSlice i n v         \
; basicOverlaps (con v1) (con v2) = M.basicOverlaps v1 v2               \
; basicUnsafeNew n = con `liftM` M.basicUnsafeNew n                     \
; basicInitialize (con v) = M.basicInitialize v                         \
; basicUnsafeReplicate n x = con `liftM` M.basicUnsafeReplicate n x     \
; basicUnsafeRead (con v) i = M.basicUnsafeRead v i                     \
; basicUnsafeWrite (con v) i x = M.basicUnsafeWrite v i x               \
; basicClear (con v) = M.basicClear v                                   \
; basicSet (con v) x = M.basicSet v x                                   \
; basicUnsafeCopy (con v1) (con v2) = M.basicUnsafeCopy v1 v2           \
; basicUnsafeMove (con v1) (con v2) = M.basicUnsafeMove v1 v2           \
; basicUnsafeGrow (con v) n = con `liftM` M.basicUnsafeGrow v n }

#define primVector(ty,con,mcon)                                         \
instance G.Vector Vector ty where {                                     \
  {-# INLINE basicUnsafeFreeze #-}                                      \
; {-# INLINE basicUnsafeThaw #-}                                        \
; {-# INLINE basicLength #-}                                            \
; {-# INLINE basicUnsafeSlice #-}                                       \
; {-# INLINE basicUnsafeIndexM #-}                                      \
; {-# INLINE elemseq #-}                                                \
; basicUnsafeFreeze (mcon v) = con `liftM` G.basicUnsafeFreeze v        \
; basicUnsafeThaw (con v) = mcon `liftM` G.basicUnsafeThaw v            \
; basicLength (con v) = G.basicLength v                                 \
; basicUnsafeSlice i n (con v) = con $ G.basicUnsafeSlice i n v         \
; basicUnsafeIndexM (con v) i = G.basicUnsafeIndexM v i                 \
; basicUnsafeCopy (mcon mv) (con v) = G.basicUnsafeCopy mv v            \
; elemseq _ = seq }

newtype instance MVector s Int = MV_Int (P.MVector s Int)
newtype instance Vector    Int = V_Int  (P.Vector    Int)
instance Unbox Int
primMVector(Int, MV_Int)
primVector(Int, V_Int, MV_Int)

newtype instance MVector s Int8 = MV_Int8 (P.MVector s Int8)
newtype instance Vector    Int8 = V_Int8  (P.Vector    Int8)
instance Unbox Int8
primMVector(Int8, MV_Int8)
primVector(Int8, V_Int8, MV_Int8)

newtype instance MVector s Int16 = MV_Int16 (P.MVector s Int16)
newtype instance Vector    Int16 = V_Int16  (P.Vector    Int16)
instance Unbox Int16
primMVector(Int16, MV_Int16)
primVector(Int16, V_Int16, MV_Int16)

newtype instance MVector s Int32 = MV_Int32 (P.MVector s Int32)
newtype instance Vector    Int32 = V_Int32  (P.Vector    Int32)
instance Unbox Int32
primMVector(Int32, MV_Int32)
primVector(Int32, V_Int32, MV_Int32)

newtype instance MVector s Int64 = MV_Int64 (P.MVector s Int64)
newtype instance Vector    Int64 = V_Int64  (P.Vector    Int64)
instance Unbox Int64
primMVector(Int64, MV_Int64)
primVector(Int64, V_Int64, MV_Int64)

newtype instance MVector s Word = MV_Word (P.MVector s Word)
newtype instance Vector    Word = V_Word  (P.Vector    Word)
instance Unbox Word
primMVector(Word, MV_Word)
primVector(Word, V_Word, MV_Word)

newtype instance MVector s Word8 = MV_Word8 (P.MVector s Word8)
newtype instance Vector    Word8 = V_Word8  (P.Vector    Word8)
instance Unbox Word8
primMVector(Word8, MV_Word8)
primVector(Word8, V_Word8, MV_Word8)

newtype instance MVector s Word16 = MV_Word16 (P.MVector s Word16)
newtype instance Vector    Word16 = V_Word16  (P.Vector    Word16)
instance Unbox Word16
primMVector(Word16, MV_Word16)
primVector(Word16, V_Word16, MV_Word16)

newtype instance MVector s Word32 = MV_Word32 (P.MVector s Word32)
newtype instance Vector    Word32 = V_Word32  (P.Vector    Word32)
instance Unbox Word32
primMVector(Word32, MV_Word32)
primVector(Word32, V_Word32, MV_Word32)

newtype instance MVector s Word64 = MV_Word64 (P.MVector s Word64)
newtype instance Vector    Word64 = V_Word64  (P.Vector    Word64)
instance Unbox Word64
primMVector(Word64, MV_Word64)
primVector(Word64, V_Word64, MV_Word64)

newtype instance MVector s Float = MV_Float (P.MVector s Float)
newtype instance Vector    Float = V_Float  (P.Vector    Float)
instance Unbox Float
primMVector(Float, MV_Float)
primVector(Float, V_Float, MV_Float)

newtype instance MVector s Double = MV_Double (P.MVector s Double)
newtype instance Vector    Double = V_Double  (P.Vector    Double)
instance Unbox Double
primMVector(Double, MV_Double)
primVector(Double, V_Double, MV_Double)

newtype instance MVector s Char = MV_Char (P.MVector s Char)
newtype instance Vector    Char = V_Char  (P.Vector    Char)
instance Unbox Char
primMVector(Char, MV_Char)
primVector(Char, V_Char, MV_Char)

-- ----
-- Bool
-- ----

fromBool :: Bool -> Word8
{-# INLINE fromBool #-}
fromBool True = 1
fromBool False = 0

toBool :: Word8 -> Bool
{-# INLINE toBool #-}
toBool 0 = False
toBool _ = True

newtype instance MVector s Bool = MV_Bool (P.MVector s Word8)
newtype instance Vector    Bool = V_Bool  (P.Vector    Word8)

instance Unbox Bool

instance M.MVector MVector Bool where
  {-# INLINE basicLength #-}
  {-# INLINE basicUnsafeSlice #-}
  {-# INLINE basicOverlaps #-}
  {-# INLINE basicUnsafeNew #-}
  {-# INLINE basicInitialize #-}
  {-# INLINE basicUnsafeReplicate #-}
  {-# INLINE basicUnsafeRead #-}
  {-# INLINE basicUnsafeWrite #-}
  {-# INLINE basicClear #-}
  {-# INLINE basicSet #-}
  {-# INLINE basicUnsafeCopy #-}
  {-# INLINE basicUnsafeGrow #-}
  basicLength (MV_Bool v) = M.basicLength v
  basicUnsafeSlice i n (MV_Bool v) = MV_Bool $ M.basicUnsafeSlice i n v
  basicOverlaps (MV_Bool v1) (MV_Bool v2) = M.basicOverlaps v1 v2
  basicUnsafeNew n = MV_Bool `liftM` M.basicUnsafeNew n
  basicInitialize (MV_Bool v) = M.basicInitialize v
  basicUnsafeReplicate n x = MV_Bool `liftM` M.basicUnsafeReplicate n (fromBool x)
  basicUnsafeRead (MV_Bool v) i = toBool `liftM` M.basicUnsafeRead v i
  basicUnsafeWrite (MV_Bool v) i x = M.basicUnsafeWrite v i (fromBool x)
  basicClear (MV_Bool v) = M.basicClear v
  basicSet (MV_Bool v) x = M.basicSet v (fromBool x)
  basicUnsafeCopy (MV_Bool v1) (MV_Bool v2) = M.basicUnsafeCopy v1 v2
  basicUnsafeMove (MV_Bool v1) (MV_Bool v2) = M.basicUnsafeMove v1 v2
  basicUnsafeGrow (MV_Bool v) n = MV_Bool `liftM` M.basicUnsafeGrow v n

instance G.Vector Vector Bool where
  {-# INLINE basicUnsafeFreeze #-}
  {-# INLINE basicUnsafeThaw #-}
  {-# INLINE basicLength #-}
  {-# INLINE basicUnsafeSlice #-}
  {-# INLINE basicUnsafeIndexM #-}
  {-# INLINE elemseq #-}
  basicUnsafeFreeze (MV_Bool v) = V_Bool `liftM` G.basicUnsafeFreeze v
  basicUnsafeThaw (V_Bool v) = MV_Bool `liftM` G.basicUnsafeThaw v
  basicLength (V_Bool v) = G.basicLength v
  basicUnsafeSlice i n (V_Bool v) = V_Bool $ G.basicUnsafeSlice i n v
  basicUnsafeIndexM (V_Bool v) i = toBool `liftM` G.basicUnsafeIndexM v i
  basicUnsafeCopy (MV_Bool mv) (V_Bool v) = G.basicUnsafeCopy mv v
  elemseq _ = seq

-- -------
-- Complex
-- -------

newtype instance MVector s (Complex a) = MV_Complex (MVector s (a,a))
newtype instance Vector    (Complex a) = V_Complex  (Vector    (a,a))

instance (RealFloat a, Unbox a) => Unbox (Complex a)

instance (RealFloat a, Unbox a) => M.MVector MVector (Complex a) where
  {-# INLINE basicLength #-}
  {-# INLINE basicUnsafeSlice #-}
  {-# INLINE basicOverlaps #-}
  {-# INLINE basicUnsafeNew #-}
  {-# INLINE basicInitialize #-}
  {-# INLINE basicUnsafeReplicate #-}
  {-# INLINE basicUnsafeRead #-}
  {-# INLINE basicUnsafeWrite #-}
  {-# INLINE basicClear #-}
  {-# INLINE basicSet #-}
  {-# INLINE basicUnsafeCopy #-}
  {-# INLINE basicUnsafeGrow #-}
  basicLength (MV_Complex v) = M.basicLength v
  basicUnsafeSlice i n (MV_Complex v) = MV_Complex $ M.basicUnsafeSlice i n v
  basicOverlaps (MV_Complex v1) (MV_Complex v2) = M.basicOverlaps v1 v2
  basicUnsafeNew n = MV_Complex `liftM` M.basicUnsafeNew n
  basicInitialize (MV_Complex v) = M.basicInitialize v
  basicUnsafeReplicate n (x :+ y) = MV_Complex `liftM` M.basicUnsafeReplicate n (x,y)
  basicUnsafeRead (MV_Complex v) i = uncurry (:+) `liftM` M.basicUnsafeRead v i
  basicUnsafeWrite (MV_Complex v) i (x :+ y) = M.basicUnsafeWrite v i (x,y)
  basicClear (MV_Complex v) = M.basicClear v
  basicSet (MV_Complex v) (x :+ y) = M.basicSet v (x,y)
  basicUnsafeCopy (MV_Complex v1) (MV_Complex v2) = M.basicUnsafeCopy v1 v2
  basicUnsafeMove (MV_Complex v1) (MV_Complex v2) = M.basicUnsafeMove v1 v2
  basicUnsafeGrow (MV_Complex v) n = MV_Complex `liftM` M.basicUnsafeGrow v n

instance (RealFloat a, Unbox a) => G.Vector Vector (Complex a) where
  {-# INLINE basicUnsafeFreeze #-}
  {-# INLINE basicUnsafeThaw #-}
  {-# INLINE basicLength #-}
  {-# INLINE basicUnsafeSlice #-}
  {-# INLINE basicUnsafeIndexM #-}
  {-# INLINE elemseq #-}
  basicUnsafeFreeze (MV_Complex v) = V_Complex `liftM` G.basicUnsafeFreeze v
  basicUnsafeThaw (V_Complex v) = MV_Complex `liftM` G.basicUnsafeThaw v
  basicLength (V_Complex v) = G.basicLength v
  basicUnsafeSlice i n (V_Complex v) = V_Complex $ G.basicUnsafeSlice i n v
  basicUnsafeIndexM (V_Complex v) i
                = uncurry (:+) `liftM` G.basicUnsafeIndexM v i
  basicUnsafeCopy (MV_Complex mv) (V_Complex v)
                = G.basicUnsafeCopy mv v
  elemseq _ (x :+ y) z = G.elemseq (undefined :: Vector a) x
                       $ G.elemseq (undefined :: Vector a) y z

-- ------
-- Tuples
-- ------

#define DEFINE_INSTANCES
#include "unbox-tuple-instances"


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}

#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE Trustworthy #-}
#endif

#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE EmptyCase #-}
#endif

module Generics.Deriving.Show (
  -- * Generic show class
    GShow(..)

  -- * Default definition
  , gshowsPrecdefault

  -- * Internal show class
  , GShow'(..)

  ) where

import           Control.Applicative (Const, ZipList)

import           Data.Char (GeneralCategory)
import           Data.Int
import           Data.Monoid (All, Any, Dual, Product, Sum)
import qualified Data.Monoid as Monoid (First, Last)
import           Data.Version (Version)
import           Data.Word

import           Foreign.C.Types
import           Foreign.ForeignPtr (ForeignPtr)
import           Foreign.Ptr

import           Generics.Linear

import           GHC.Exts hiding (Any)

import           System.Exit (ExitCode)
import           System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode)
import           System.IO.Error (IOErrorType)
import           System.Posix.Types

#if MIN_VERSION_base(4,4,0)
import           Data.Complex (Complex)
#endif

#if MIN_VERSION_base(4,7,0)
import           Data.Proxy (Proxy)
#endif

#if MIN_VERSION_base(4,8,0)
import           Data.Functor.Identity (Identity)
import           Data.Monoid (Alt)
import           Data.Void (Void)
import           Numeric.Natural (Natural)
#endif

#if MIN_VERSION_base(4,9,0)
import           Data.List.NonEmpty (NonEmpty)
import qualified Data.Semigroup as Semigroup (First, Last)
import           Data.Semigroup (Arg, Max, Min, WrappedMonoid)
#endif

--------------------------------------------------------------------------------
-- Generic show
--------------------------------------------------------------------------------

intersperse :: a -> [a] -> [a]
intersperse _ []    = []
intersperse _ [h]   = [h]
intersperse x (h:t) = h : x : (intersperse x t)

appPrec :: Int
appPrec = 2

data Type = Rec | Tup | Pref | Inf String

class GShow' f where
  gshowsPrec' :: Type -> Int -> f a -> ShowS
  isNullary   :: f a -> Bool
  isNullary = error "generic show (isNullary): unnecessary case"

instance GShow' V1 where
  gshowsPrec' _ _ x = case x of
#if __GLASGOW_HASKELL__ >= 708
                        {}
#else
                        !_ -> error "Void gshowsPrec"
#endif

instance GShow' U1 where
  gshowsPrec' _ _ U1 = id
  isNullary _ = True

instance (GShow c) => GShow' (K1 i c) where
  gshowsPrec' _ n (K1 a) = gshowsPrec n a
  isNullary _ = False

-- No instances for P or Rec because gshow is only applicable to types of kind *

instance (GShow' a, Constructor c) => GShow' (M1 C c a) where
  gshowsPrec' _ n c@(M1 x) =
    case fixity of
      Prefix    -> showParen (n > appPrec && not (isNullary x))
                    ( showString (conName c)
                    . if (isNullary x) then id else showChar ' '
                    . showBraces t (gshowsPrec' t appPrec x))
      Infix _ m -> showParen (n > m) (showBraces t (gshowsPrec' t m x))
      where fixity = conFixity c
            t = if (conIsRecord c) then Rec else
                  case (conIsTuple c) of
                    True -> Tup
                    False -> case fixity of
                                Prefix    -> Pref
                                Infix _ _ -> Inf (show (conName c))
            showBraces :: Type -> ShowS -> ShowS
            showBraces Rec     p = showChar '{' . p . showChar '}'
            showBraces Tup     p = showChar '(' . p . showChar ')'
            showBraces Pref    p = p
            showBraces (Inf _) p = p

            conIsTuple :: C1 c f p -> Bool
            conIsTuple y = tupleName (conName y) where
              tupleName ('(':',':_) = True
              tupleName _           = False

instance (Selector s, GShow' a) => GShow' (M1 S s a) where
  gshowsPrec' t n s@(M1 x) | selName s == "" = --showParen (n > appPrec)
                                                 (gshowsPrec' t n x)
                           | otherwise       =   showString (selName s)
                                               . showString " = "
                                               . gshowsPrec' t 0 x
  isNullary (M1 x) = isNullary x

instance GShow' a => GShow' (M1 D d a) where
  gshowsPrec' t n (M1 x) = gshowsPrec' t n x

instance GShow' a => GShow' (MP1 m a) where
  gshowsPrec' t n (MP1 x) = gshowsPrec' t n x

instance (GShow' a, GShow' b) => GShow' (a :+: b) where
  gshowsPrec' t n (L1 x) = gshowsPrec' t n x
  gshowsPrec' t n (R1 x) = gshowsPrec' t n x

instance (GShow' a, GShow' b) => GShow' (a :*: b) where
  gshowsPrec' t@Rec     n (a :*: b) =
    gshowsPrec' t n     a . showString ", " . gshowsPrec' t n     b
  gshowsPrec' t@(Inf s) n (a :*: b) =
    gshowsPrec' t n     a . showString s    . gshowsPrec' t n     b
  gshowsPrec' t@Tup     n (a :*: b) =
    gshowsPrec' t n     a . showChar ','    . gshowsPrec' t n     b
  gshowsPrec' t@Pref    n (a :*: b) =
    gshowsPrec' t (n+1) a . showChar ' '    . gshowsPrec' t (n+1) b

  -- If we have a product then it is not a nullary constructor
  isNullary _ = False

-- Unboxed types
instance GShow' UChar where
  gshowsPrec' _ _ (UChar c)   = showsPrec 0 (C# c) . showChar '#'
instance GShow' UDouble where
  gshowsPrec' _ _ (UDouble d) = showsPrec 0 (D# d) . showString "##"
instance GShow' UFloat where
  gshowsPrec' _ _ (UFloat f)  = showsPrec 0 (F# f) . showChar '#'
instance GShow' UInt where
  gshowsPrec' _ _ (UInt i)    = showsPrec 0 (I# i) . showChar '#'
instance GShow' UWord where
  gshowsPrec' _ _ (UWord w)   = showsPrec 0 (W# w) . showString "##"

class GShow a where
  gshowsPrec :: Int -> a -> ShowS
#if __GLASGOW_HASKELL__ >= 701
  default gshowsPrec :: (Generic a, GShow' (Rep a))
                     => Int -> a -> ShowS
  gshowsPrec = gshowsPrecdefault
#endif

  gshows :: a -> ShowS
  gshows = gshowsPrec 0

  gshow :: a -> String
  gshow x = gshows x ""

  gshowList :: [a] -> ShowS
  gshowList l =   showChar '['
                . foldr (.) id
                   (intersperse (showChar ',') (map (gshowsPrec 0) l))
                . showChar ']'

gshowsPrecdefault :: (Generic a, GShow' (Rep a))
                  => Int -> a -> ShowS
gshowsPrecdefault n = gshowsPrec' Pref n . from

-- Base types instances
-- Base types instances
instance GShow () where
  gshowsPrec = gshowsPrecdefault

instance (GShow a, GShow b) => GShow (a, b) where
  gshowsPrec = gshowsPrecdefault

instance (GShow a, GShow b, GShow c) => GShow (a, b, c) where
  gshowsPrec = gshowsPrecdefault

instance (GShow a, GShow b, GShow c, GShow d) => GShow (a, b, c, d) where
  gshowsPrec = gshowsPrecdefault

instance (GShow a, GShow b, GShow c, GShow d, GShow e) => GShow (a, b, c, d, e) where
  gshowsPrec = gshowsPrecdefault

instance (GShow a, GShow b, GShow c, GShow d, GShow e, GShow f)
    => GShow (a, b, c, d, e, f) where
  gshowsPrec = gshowsPrecdefault

instance (GShow a, GShow b, GShow c, GShow d, GShow e, GShow f, GShow g)
    => GShow (a, b, c, d, e, f, g) where
  gshowsPrec = gshowsPrecdefault

instance GShow a => GShow [a] where
  gshowsPrec _ = gshowList

instance (GShow (f p), GShow (g p)) => GShow ((f :+: g) p) where
  gshowsPrec = gshowsPrecdefault

instance (GShow (f p), GShow (g p)) => GShow ((f :*: g) p) where
  gshowsPrec = gshowsPrecdefault

instance GShow (f (g p)) => GShow ((f :.: g) p) where
  gshowsPrec = gshowsPrecdefault

instance GShow All where
  gshowsPrec = gshowsPrecdefault

#if MIN_VERSION_base(4,8,0)
instance GShow (f a) => GShow (Alt f a) where
  gshowsPrec = gshowsPrecdefault
#endif

instance GShow Any where
  gshowsPrec = gshowsPrecdefault

#if MIN_VERSION_base(4,9,0)
instance (GShow a, GShow b) => GShow (Arg a b) where
  gshowsPrec = gshowsPrecdefault
#endif

#if !(MIN_VERSION_base(4,9,0))
instance GShow Arity where
  gshowsPrec = gshowsPrecdefault
#endif

instance GShow Associativity where
  gshowsPrec = gshowsPrecdefault

instance GShow Bool where
  gshowsPrec = gshowsPrecdefault

instance GShow BufferMode where
  gshowsPrec = showsPrec

#if defined(HTYPE_CC_T)
instance GShow CCc where
  gshowsPrec = showsPrec
#endif

instance GShow CChar where
  gshowsPrec = showsPrec

instance GShow CClock where
  gshowsPrec = showsPrec

#if defined(HTYPE_DEV_T)
instance GShow CDev where
  gshowsPrec = showsPrec
#endif

instance GShow CDouble where
  gshowsPrec = showsPrec

instance GShow CFloat where
  gshowsPrec = showsPrec

#if defined(HTYPE_GID_T)
instance GShow CGid where
  gshowsPrec = showsPrec
#endif

instance GShow Char where
  gshowsPrec = showsPrec
  gshowList  = showList

#if defined(HTYPE_INO_T)
instance GShow CIno where
  gshowsPrec = showsPrec
#endif

instance GShow CInt where
  gshowsPrec = showsPrec

instance GShow CIntMax where
  gshowsPrec = showsPrec

instance GShow CIntPtr where
  gshowsPrec = showsPrec

instance GShow CLLong where
  gshowsPrec = showsPrec

instance GShow CLong where
  gshowsPrec = showsPrec

#if defined(HTYPE_MODE_T)
instance GShow CMode where
  gshowsPrec = showsPrec
#endif

#if defined(HTYPE_NLINK_T)
instance GShow CNlink where
  gshowsPrec = showsPrec
#endif

#if defined(HTYPE_OFF_T)
instance GShow COff where
  gshowsPrec = showsPrec
#endif

#if MIN_VERSION_base(4,4,0)
instance GShow a => GShow (Complex a) where
  gshowsPrec = gshowsPrecdefault
#endif

instance GShow a => GShow (Const a b) where
  gshowsPrec = gshowsPrecdefault

#if defined(HTYPE_PID_T)
instance GShow CPid where
  gshowsPrec = showsPrec
#endif

instance GShow CPtrdiff where
  gshowsPrec = showsPrec

#if defined(HTYPE_RLIM_T)
instance GShow CRLim where
  gshowsPrec = showsPrec
#endif

instance GShow CSChar where
  gshowsPrec = showsPrec

#if defined(HTYPE_SPEED_T)
instance GShow CSpeed where
  gshowsPrec = showsPrec
#endif

#if MIN_VERSION_base(4,4,0)
instance GShow CSUSeconds where
  gshowsPrec = showsPrec
#endif

instance GShow CShort where
  gshowsPrec = showsPrec

instance GShow CSigAtomic where
  gshowsPrec = showsPrec

instance GShow CSize where
  gshowsPrec = showsPrec

#if defined(HTYPE_SSIZE_T)
instance GShow CSsize where
  gshowsPrec = showsPrec
#endif

#if defined(HTYPE_TCFLAG_T)
instance GShow CTcflag where
  gshowsPrec = showsPrec
#endif

instance GShow CTime where
  gshowsPrec = showsPrec

instance GShow CUChar where
  gshowsPrec = showsPrec

#if defined(HTYPE_UID_T)
instance GShow CUid where
  gshowsPrec = showsPrec
#endif

instance GShow CUInt where
  gshowsPrec = showsPrec

instance GShow CUIntMax where
  gshowsPrec = showsPrec

instance GShow CUIntPtr where
  gshowsPrec = showsPrec

instance GShow CULLong where
  gshowsPrec = showsPrec

instance GShow CULong where
  gshowsPrec = showsPrec

#if MIN_VERSION_base(4,4,0)
instance GShow CUSeconds where
  gshowsPrec = showsPrec
#endif

instance GShow CUShort where
  gshowsPrec = showsPrec

instance GShow CWchar where
  gshowsPrec = showsPrec

instance GShow Double where
  gshowsPrec = showsPrec

instance GShow a => GShow (Down a) where
  gshowsPrec = gshowsPrecdefault

instance GShow a => GShow (Dual a) where
  gshowsPrec = gshowsPrecdefault

instance (GShow a, GShow b) => GShow (Either a b) where
  gshowsPrec = gshowsPrecdefault

instance GShow ExitCode where
  gshowsPrec = gshowsPrecdefault

instance GShow Fd where
  gshowsPrec = showsPrec

instance GShow a => GShow (Monoid.First a) where
  gshowsPrec = gshowsPrecdefault

#if MIN_VERSION_base(4,9,0)
instance GShow a => GShow (Semigroup.First a) where
  gshowsPrec = gshowsPrecdefault
#endif

instance GShow Fixity where
  gshowsPrec = gshowsPrecdefault

instance GShow Float where
  gshowsPrec = showsPrec

instance GShow (ForeignPtr a) where
  gshowsPrec = showsPrec

instance GShow (FunPtr a) where
  gshowsPrec = showsPrec

instance GShow GeneralCategory where
  gshowsPrec = showsPrec

instance GShow Handle where
  gshowsPrec = showsPrec

instance GShow HandlePosn where
  gshowsPrec = showsPrec

#if MIN_VERSION_base(4,8,0)
instance GShow a => GShow (Identity a) where
  gshowsPrec = gshowsPrecdefault
#endif

instance GShow Int where
  gshowsPrec = showsPrec

instance GShow Int8 where
  gshowsPrec = showsPrec

instance GShow Int16 where
  gshowsPrec = showsPrec

instance GShow Int32 where
  gshowsPrec = showsPrec

instance GShow Int64 where
  gshowsPrec = showsPrec

instance GShow Integer where
  gshowsPrec = showsPrec

instance GShow IntPtr where
  gshowsPrec = showsPrec

instance GShow IOError where
  gshowsPrec = showsPrec

instance GShow IOErrorType where
  gshowsPrec = showsPrec

instance GShow IOMode where
  gshowsPrec = showsPrec

instance GShow c => GShow (K1 i c p) where
  gshowsPrec = gshowsPrecdefault

instance GShow a => GShow (Monoid.Last a) where
  gshowsPrec = gshowsPrecdefault

#if MIN_VERSION_base(4,9,0)
instance GShow a => GShow (Semigroup.Last a) where
  gshowsPrec = gshowsPrecdefault
#endif

instance GShow (f p) => GShow (M1 i c f p) where
  gshowsPrec = gshowsPrecdefault

#if MIN_VERSION_base(4,9,0)
instance GShow a => GShow (Max a) where
  gshowsPrec = gshowsPrecdefault
#endif

instance GShow a => GShow (Maybe a) where
  gshowsPrec = gshowsPrecdefault

#if MIN_VERSION_base(4,9,0)
instance GShow a => GShow (Min a) where
  gshowsPrec = gshowsPrecdefault
#endif

#if MIN_VERSION_base(4,8,0)
instance GShow Natural where
  gshowsPrec = showsPrec
#endif

#if MIN_VERSION_base(4,9,0)
instance GShow a => GShow (NonEmpty a) where
  gshowsPrec = gshowsPrecdefault
#endif

instance GShow Ordering where
  gshowsPrec = gshowsPrecdefault

instance GShow p => GShow (Par1 p) where
  gshowsPrec = gshowsPrecdefault

instance GShow a => GShow (Product a) where
  gshowsPrec = gshowsPrecdefault

#if MIN_VERSION_base(4,7,0)
instance GShow (Proxy s) where
  gshowsPrec = gshowsPrecdefault
#endif

instance GShow (Ptr a) where
  gshowsPrec = showsPrec

instance GShow SeekMode where
  gshowsPrec = showsPrec

instance GShow a => GShow (Sum a) where
  gshowsPrec = gshowsPrecdefault

instance GShow (U1 p) where
  gshowsPrec = gshowsPrecdefault

instance GShow (UChar p) where
  gshowsPrec = gshowsPrecdefault

instance GShow (UDouble p) where
  gshowsPrec = gshowsPrecdefault

instance GShow (UFloat p) where
  gshowsPrec = gshowsPrecdefault

instance GShow (UInt p) where
  gshowsPrec = gshowsPrecdefault

instance GShow (UWord p) where
  gshowsPrec = gshowsPrecdefault

instance GShow Version where
  gshowsPrec = gshowsPrecdefault

#if MIN_VERSION_base(4,8,0)
instance GShow Void where
  gshowsPrec = showsPrec
#endif

instance GShow Word where
  gshowsPrec = showsPrec

instance GShow Word8 where
  gshowsPrec = showsPrec

instance GShow Word16 where
  gshowsPrec = showsPrec

instance GShow Word32 where
  gshowsPrec = showsPrec

instance GShow Word64 where
  gshowsPrec = showsPrec

instance GShow WordPtr where
  gshowsPrec = showsPrec

#if MIN_VERSION_base(4,9,0)
instance GShow m => GShow (WrappedMonoid m) where
  gshowsPrec = gshowsPrecdefault
#endif

instance GShow a => GShow (ZipList a) where
  gshowsPrec = gshowsPrecdefault

#if MIN_VERSION_base(4,10,0)
instance GShow CBool where
  gshowsPrec = showsPrec

# if defined(HTYPE_BLKSIZE_T)
instance GShow CBlkSize where
  gshowsPrec = showsPrec
# endif

# if defined(HTYPE_BLKCNT_T)
instance GShow CBlkCnt where
  gshowsPrec = showsPrec
# endif

# if defined(HTYPE_CLOCKID_T)
instance GShow CClockId where
  gshowsPrec = showsPrec
# endif

# if defined(HTYPE_FSBLKCNT_T)
instance GShow CFsBlkCnt where
  gshowsPrec = showsPrec
# endif

# if defined(HTYPE_FSFILCNT_T)
instance GShow CFsFilCnt where
  gshowsPrec = showsPrec
# endif

# if defined(HTYPE_ID_T)
instance GShow CId where
  gshowsPrec = showsPrec
# endif

# if defined(HTYPE_KEY_T)
instance GShow CKey where
  gshowsPrec = showsPrec
# endif

# if defined(HTYPE_TIMER_T)
instance GShow CTimer where
  gshowsPrec = showsPrec
# endif
#endif


module Environment where

import           Prelude
import           Control.Applicative
import           Control.Arrow
import qualified Control.Exception as E
import           Control.Monad
import           Control.Monad.Fix
import           Control.Monad.Reader
import           Control.Monad.State
import           Control.Monad.Trans
import           Control.Monad.Writer
import           Control.Parallel
import           Data.Bits
import qualified Data.ByteString.Lazy as B
import           Data.Char
import           Data.Complex
import           Data.Function
import           Data.Functor
import           Data.List
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Maybe
import           Data.Monoid
import           Data.Ratio
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Typeable
import           Data.Word
import           Numeric
import           System
import           System.IO
import           System.Process
import           System.Random
import           Text.Printf
import           Text.Regex
import           Text.Show.Functions

instance Typeable a => Show (IO a) where
  show io = '<' : show (typeOf io) ++ ">"

data PutStr = PutStr String

instance Show PutStr where
  show (PutStr s) = s


module PostgreSQL.Binary.Prelude
(
  module Exports,
  LazyByteString,
  ByteStringBuilder,
  LazyText,
  TextBuilder,
  mapLeft,
  joinMap,
)
where

-- base
-------------------------
import Control.Applicative as Exports
import Control.Arrow as Exports hiding (first, second)
import Control.Category as Exports
import Control.Concurrent as Exports
import Control.Exception as Exports
import Control.Monad as Exports hiding (fail, mapM_, sequence_, forM_, msum, mapM, sequence, forM)
import Control.Monad.IO.Class as Exports
import Control.Monad.Fail as Exports
import Control.Monad.Fix as Exports hiding (fix)
import Control.Monad.ST as Exports
import Data.Bifunctor as Exports
import Data.Bits as Exports
import Data.Bool as Exports
import Data.Char as Exports
import Data.Coerce as Exports
import Data.Complex as Exports
import Data.Data as Exports
import Data.Dynamic as Exports
import Data.Either as Exports
import Data.Fixed as Exports
import Data.Foldable as Exports
import Data.Function as Exports hiding (id, (.))
import Data.Functor as Exports
import Data.Functor.Identity as Exports
import Data.Int as Exports
import Data.IORef as Exports
import Data.Ix as Exports
import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')
import Data.List.NonEmpty as Exports (NonEmpty(..))
import Data.Maybe as Exports
import Data.Monoid as Exports hiding (Last(..), First(..), (<>))
import Data.Ord as Exports
import Data.Proxy as Exports
import Data.Ratio as Exports
import Data.Semigroup as Exports
import Data.STRef as Exports
import Data.String as Exports
import Data.Traversable as Exports
import Data.Tuple as Exports
import Data.Unique as Exports
import Data.Version as Exports
import Data.Void as Exports
import Data.Word as Exports
import Debug.Trace as Exports
import Foreign.ForeignPtr as Exports
import Foreign.Ptr as Exports
import Foreign.StablePtr as Exports
import Foreign.Storable as Exports hiding (sizeOf, alignment)
import GHC.Conc as Exports hiding (orElse, withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)
import GHC.Exts as Exports (lazy, inline, sortWith, groupWith, IsList(fromList, Item))
import GHC.Generics as Exports (Generic, Generic1)
import GHC.IO.Exception as Exports
import Numeric as Exports
import Prelude as Exports hiding (fail, concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.))
import System.Environment as Exports
import System.Exit as Exports
import System.IO as Exports
import System.IO.Error as Exports
import System.IO.Unsafe as Exports
import System.Mem as Exports
import System.Mem.StableName as Exports
import System.Timeout as Exports
import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)
import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)
import Text.Printf as Exports (printf, hPrintf)
import Text.Read as Exports (Read(..), readMaybe, readEither)
import Unsafe.Coerce as Exports

-- transformers
-------------------------
import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch)
import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch)
import Control.Monad.Trans.Class as Exports
import Data.Functor.Identity as Exports

-- bytestring
-------------------------
import Data.ByteString as Exports (ByteString)

-- text
-------------------------
import Data.Text as Exports (Text)

-- vector
-------------------------
import Data.Vector as Exports (Vector)

-- scientific
-------------------------
import Data.Scientific as Exports (Scientific)

-- uuid
-------------------------
import Data.UUID as Exports (UUID)

-- time
-------------------------
import Data.Time as Exports

-- unordered-containers
-------------------------
import Data.HashMap.Strict as Exports (HashMap)

-- containers
-------------------------
import Data.Map.Strict as Exports (Map)

-- custom
-------------------------
import qualified Data.ByteString.Lazy
import qualified Data.ByteString.Builder
import qualified Data.Text.Lazy
import qualified Data.Text.Lazy.Builder

type LazyByteString =
  Data.ByteString.Lazy.ByteString

type ByteStringBuilder =
  Data.ByteString.Builder.Builder

type LazyText =
  Data.Text.Lazy.Text

type TextBuilder =
  Data.Text.Lazy.Builder.Builder

{-# INLINE mapLeft #-}
mapLeft :: (a -> b) -> Either a x -> Either b x
mapLeft f =
  either (Left . f) Right

joinMap :: Monad m => (a -> m b) -> m a -> m b
joinMap f =
  join . liftM f


module Statistics
    ( runJSONFold
    , receivedCreatedF
    , module Statistics.Block
    , module Statistics.Chart
    , module Statistics.CSV
    , module Statistics.Focus
    , module Statistics.Graph
    , module Statistics.Histogram
    , module Statistics.MemPool
    , module Statistics.Report
    , module Statistics.Throughput
    , module Statistics.Tx
    ) where

import           Control.Foldl   (Fold (..))
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as M

import JSONLog
import Statistics.Block
import Statistics.Chart
import Statistics.CSV
import Statistics.Focus
import Statistics.Graph
import Statistics.Histogram
import Statistics.MemPool
import Statistics.Report
-- import Statistics.Relay
import Statistics.Throughput
import Statistics.Tx
import Types
import Universum
import Util.Pipes    (fold')

runJSONFold :: FilePath -> Fold IndexedJLTimedEvent a -> IO a
runJSONFold logDir fd = runParseLogs logDir $ fold' fd

receivedCreatedF :: Fold IndexedJLTimedEvent (Map TxHash (Maybe Timestamp))
receivedCreatedF = f <$> txFirstReceivedF <*> inBlockChainF
  where
    f :: Map TxHash Timestamp -> Map TxHash Timestamp -> Map TxHash (Maybe Timestamp)
    f rm cm = M.mapWithKey g rm
      where
        g :: TxHash -> Timestamp -> Maybe Timestamp
        g tx ts = maybe Nothing (\ts' -> Just $ ts' - ts) $ M.lookup tx cm


{-|
Module      : Flipper.Bufferable
Description : Serialization/Deserialization typeclass.
Copyright   : George Morgan, Travis Whitaker 2016
License     : All rights reserved.
Maintainer  : travis@flipper.io
Stability   : Provisional
Portability : Windows, POSIX

This module provides the 'Bufferable' typeclass, representing any data that may
be sent to or received from the device over an arbitrary bus. This is
accomplished by providing a 'Put' serializer and a 'Get' deserializer. While
serializers and deserializers may be written from scratch, often the Haskell
data type representing the data being exchanged is analogous to the
corresponding C struct. When this is the case, a 'Bufferable' instance may be
derived automatically with GHC generics. For example:

> -- Needs -XDeriveGeneric, -XDeriveAnyClass
>
> import GHC.Generics
>
> import qualified Data.ByteString as B
>
> import Flipper.Bufferable
>
> data SomeStruct = SomeStruct {
>     ssID      :: Int
>   , ssName    :: String
>   , ssPayload :: B.ByteString
>   } deriving (Generic, Bufferable)

The following conditions must be satisfied for a 'Bufferable' instance to be
automatically generated:

 - The data type must have exactly one constructor.
 - The data type's constructor's arguments' types must have 'Bufferable'
   instances.
 - The data type's constructor must not be recursive.

== Struct Packing

The machinery for deriving 'Bufferable' instances assumes that the analogous C
struct's fields are arranged in the same order as the Haskell data type
constructor's arguments. However, no assumptions are made about how the struct
is packed. If possible, use @\_\_attribute\_\_((\_\_packed\_\_))@ on the
corresponding struct, and use fundamental Haskell types from "Data.Int",
"Data.Word", and "Foreign.C.Types" whose widths are guaranteed.

Even if the use of a padded struct unavoidable, it is still not necessary to
write a serializer/deserializer pair by hand. The 'Padding' type may be used in
Haskell data types to indicate where padding is present in the corresponding C
struct and how wide it is. Suppose we're dealing with the following C struct on
a machine with 32-bit words (like Flipper):

> typedef struct _rec
> {
>         uint8_t   a;
>         uint16_t b;
>         uint8_t  c;
>         uint32_t d;
> } rec;

If this struct is not packed, it will look like this in memory:

> ┌───────────┬─────────────────┬────────────┬───────────┬──────────────────┬────────────┐
> │8 bits of a│8 bits of padding│16 bits of b│8 bits of c│24 bits of padding│32 bits of d│
> └───────────┴─────────────────┴────────────┴───────────┴──────────────────┴────────────┘

This struct may be represented with the following Haskell data type:

> -- Needs -XDeriveGeneric, -XDeriveAnyClass, -XDataKinds
>
> import Data.Word
>
> import GHC.Generics
>
> import Flipper.Bufferable
>
> data Rec = Rec {
>    a    :: Word8
>  , pad1 :: Padding 1
>  , b    :: Word16
>  , c    :: Word8
>  , pad2 :: Padding 3
>  , d    :: Word32
>  } deriving (Generic, Bufferable)

== C Arrays

In C there are two common strategies for delimiting arrays. The first involves
a distinguished sentinel element whose presence indicates the end of the array;
C strings are an example of this strategy. To accomodate such structures the
'SentinelSequence' data type and accompanying 'Sentinel' typeclass are provided.
A value of type @SentinelSequence a s@ will generate a 'Bufferable' instance
that reads consecutive values of type @a@ until the 'sentinel' value of type @s@
is encountered. Analogously the generated serializer will encode adjacent values
of type @a@, followed by the 'sentinel' value of type @s@. An example for C
strings:

> newtype CString = CString { unCString :: SentinelSequence Char Char }
>                 deriving (Generic, Bufferable)
>
> instance Sentinel Char where
>     sentinel = '\0'

This example is redundant; the 'Bufferable' instance for 'String' already
provides this exact behavior, and the 'CBlock' 'Bufferable' instance provides
this behavior for 'B.ByteStrings'.

Another technique is to lead the array with an unsigned integer providing the
number of elements in the array. Applied to character data, such a structure is
known as a Pascal string. The 'SizedSequence' data type provides 'Bufferable'
instances for such structures. A value of type @SizedSequence a l@ will first
read a quantity of type @l@, and then read @l@ following elements. Here @l@ is a
phantom type that merely encodes what sort of integer is present at the
beginning of the array. Analogously the generated serializer will encode the
length of the sequence as type @l@, then encode adjacent values of type @a@. An
example for 32-bit led Pascal strings:

> newtype PString = PString { unPascalString :: SizedSequence Char Word32 }
>                 deriving (Generic, Bufferable)

The related type 'SizedByteString' provides the same behavior for
'B.ByteStrings'.

-}

{-# LANGUAGE FlexibleInstances
           , TypeOperators
           , DataKinds
           , DefaultSignatures
           , KindSignatures
           , FlexibleContexts
           , LambdaCase
           , ScopedTypeVariables
           , DeriveFunctor
           , DeriveFoldable
           , DeriveGeneric
           , DeriveTraversable
           , GeneralizedNewtypeDeriving
           #-}

module Flipper.Bufferable (
    -- * The 'Bufferable' Class
    Bufferable(..)
    -- * Types for Generic 'Bufferable' Instances
  , Sentinel(..)
  , SentinelSequence(..)
  , SizedSequence(..)
  , CBlock(..)
  , SizedByteString(..)
  , Padding()
  ) where

import Control.Applicative
import Control.DeepSeq
import Control.Monad

import Data.Complex
import Data.Data
import Data.Int
import Data.Ix
import Data.Monoid
import Data.Ratio
import Data.Word

import qualified Data.ByteString as B
import qualified Data.Text       as T

import Flipper.Buffer
import Flipper.Get
import Flipper.Put

import Foreign.C.Types
import Foreign.Ptr
import Foreign.StablePtr
import Foreign.Storable

import GHC.Generics
import GHC.TypeLits

import System.Posix.Types

import Text.Read hiding (get)

-- | Generic class for 'Bufferable'.
class GBufferable g where
    gput :: g p -> Put
    gget :: Get (g p)

-- | Instance for uninhabited types.
instance GBufferable V1 where
    gput = undefined
    gget = undefined

-- | Instance for concretized types.
instance (Bufferable a) => GBufferable (K1 i a) where
    gput (K1 x) = put x
    gget        = K1 <$> get

-- | Instance for sum types.
instance (GBufferable f, GBufferable g) => GBufferable (f :*: g) where
    gput (f :*: g) = gput f <> gput g
    gget           = (:*:) <$> gget <*> gget

-- | Instance for metadata.
instance GBufferable a => GBufferable (M1 i t a) where
    gput (M1 x) = gput x
    gget        = M1 <$> gget

-- | Provides a 'Bufferable' instance whose deserializer sequentially decodes
--   values of type @a@ until the 'sentinel' value of type @s@ is encoded, where
--   'sentinel' is provided by the 'Sentinel' class. Analogously the generated
--   serializer will sequentially encode values of type @a@, followed by the
--   'sentinel' value of type @s@. @s@ is a phantom type, merely encoding the
--   type whose 'Sentinel' instance provides the 'sentinel' for values of this
--   type.
newtype SentinelSequence a s = SentinelSequence { unSentinelSequence :: [a] }
                             deriving ( Eq
                                      , Ord
                                      , Read
                                      , Show
                                      , Functor
                                      , Monoid
                                      , Foldable
                                      , Traversable
                                      )

-- | The class of types containing a single 'sentinel' value.
class Sentinel s where
    -- | The sentinel value.
    sentinel :: s

-- | Provides a 'Bufferable' instance whose deserializer first decodes an
--   integer of type @l@, then decodes @l@ values of type @a@. Analogously the
--   generated serializer will first encode the length of the sequence as type
--   @l@, then sequentially encode values of type @a@. @l@ is a phantom type,
--   merely encoding the width and interpretation of the integer leading the
--   array.
newtype SizedSequence a l = SizedSequence { unSizedSequence :: [a] }
                          deriving ( Eq
                                   , Ord
                                   , Read
                                   , Show
                                   , Functor
                                   , Monoid
                                   , Foldable
                                   , Traversable
                                   )

-- | Provides a 'Bufferable' instance for C strings, i.e. a contiguous block of
--   non-null bytes terminted by the null byte.
newtype CBlock = CBlock { unCBlock :: B.ByteString }
               deriving ( Eq
                        , Ord
                        , Read
                        , Show
                        , Generic
                        , NFData
                        , Monoid
                        )

-- | Provides a 'Bufferable' instance for arrays of bytes accompanied by a
--   leading integer of type @l@ indicating the number of bytes in the array.
newtype SizedByteString l = SizedByteString { unSizedByteString :: B.ByteString }
                          deriving ( Eq
                                   , Ord
                                   , Read
                                   , Show
                                   , Generic
                                   , NFData
                                   , Monoid
                                   )

-- | A type for encoding struct padding at the Haskell type level. Use of this
--   type requires a recent GHC supporting the @-XDataKinds@ language extension.
--   The type level natural @s@ is the number of bytes of padding provided by
--   the generated 'Bufferable' instance. Although this type is uninhabited
--   (i.e. 'undefined' or ⊥ is the only value of any 'Padding' type), degenerate
--   instances are provided for common typeclasses so that they may be derived
--   for data types containing padding.
data Padding (s :: Nat) deriving (Generic)

instance NFData (Padding s)

-- | '(==)' always returns 'True'.
instance Eq (Padding s) where
    _ == _ = True

-- | 'compare' always returns 'EQ'.
instance Ord (Padding s) where
    compare _ _ = EQ

-- | 'readPrec' consumes no input and returns 'undefined'.
instance Read (Padding s) where
    readPrec = pure undefined

-- | Outputs "Padding s" where s is a type level natural.
instance KnownNat s => Show (Padding s) where
    show p = "Padding " ++ show (padSize p)

-- | 'toEnum' returns 'undefined', 'fromEnum' returns 0.
instance Enum (Padding s) where
    toEnum _   = undefined
    fromEnum _ = 0

-- | 'minBound' = 'maxBound' = 0
instance Bounded (Padding s) where
    minBound = undefined
    maxBound = undefined

-- | 'range' = [], 'index' = 0, 'inRange' = True
instance Ix (Padding s) where
    range _     = []
    index _ _   = 0
    inRange _ _ = True

-- | Returns a 'Proxy' for the padding width.
padProxy :: Padding s -> Proxy s
padProxy _ = Proxy

-- | Provides the padding width at the term level.
padSize :: KnownNat s => Padding s -> Integer
padSize = natVal . padProxy

-- | The class of types for which 'Put' serializers and 'Get' deserializers are
--   available. Instances may be derived with GHC generics or written by hand
--   with the utilities in the "Flipper.Put" and "Flipper.Get" modules.
class Bufferable a where
    put :: a -> Put -- ^ Serializer.
    get :: Get a    -- ^ Deserializer.
    default put :: (Generic a, GBufferable (Rep a)) => a -> Put
    put = gput . from
    default get :: (Generic a, GBufferable (Rep a)) => Get a
    get = to <$> gget

instance ( Bufferable a
         , Bufferable s
         , Sentinel s
         ) => Bufferable (SentinelSequence a s) where
    put (SentinelSequence as) = mconcat (map put as) <> put (sentinel :: s)
    get = SentinelSequence <$> g
        where g = (Nothing <$ (get :: Get s)) <|> (Just <$> (get :: Get a))
                  >>= \case Nothing  -> return []
                            (Just v) -> (v:) <$> g

instance ( Bufferable a
         , Integral l
         , Num l
         , Bufferable l
         ) => Bufferable (SizedSequence a l) where
    put (SizedSequence as) = put (fromIntegral (length as) :: l)
                          <> mconcat (map put as)
    get = SizedSequence <$> ( (get :: Get l) >>= (\s ->
                              replicateM (fromIntegral s) (get :: Get a))
                            )

instance Bufferable CBlock where
    put = putBufferC . fromByteString . unCBlock
    get = (CBlock . B.pack) <$> getCBlock

instance ( Bufferable l
         , Integral l
         , Num l
         ) => Bufferable (SizedByteString l) where
    put (SizedByteString bs) = put (fromIntegral (B.length bs) :: l)
                            <> putBuffer (fromByteString bs)
    get = SizedByteString <$> ( (get :: Get l) >>=
                                (getSizedByteString . fromIntegral)
                              )

instance KnownNat p => Bufferable (Padding p) where
    put p = mconcat (replicate (fromIntegral (padSize p)) (putWord8 0))
    get = getSizedBlock (fromIntegral (padSize (undefined :: Padding p)))
       *> pure undefined

instance Bufferable Bool where
    put = putStorable
    get = getStorable

instance Bufferable Char where
    put = putStorable
    get = getStorable

instance Bufferable Double where
    put = putStorable
    get = getStorable

instance Bufferable Float where
    put = putStorable
    get = getStorable

instance Bufferable Int where
    put = putStorable
    get = getStorable

instance Bufferable Int8 where
    put = putStorable
    get = getStorable

instance Bufferable Int16 where
    put = putStorable
    get = getStorable

instance Bufferable Int32 where
    put = putStorable
    get = getStorable

instance Bufferable Int64 where
    put = putStorable
    get = getStorable

instance Bufferable Word where
    put = putStorable
    get = getStorable

instance Bufferable Word8 where
    put = putStorable
    get = getStorable

instance Bufferable Word16 where
    put = putStorable
    get = getStorable

instance Bufferable Word32 where
    put = putStorable
    get = getStorable

instance Bufferable Word64 where
    put = putStorable
    get = getStorable

instance Bufferable CUIntMax where
    put = putStorable
    get = getStorable

instance Bufferable CIntMax where
    put = putStorable
    get = getStorable

instance Bufferable CUIntPtr where
    put = putStorable
    get = getStorable

instance Bufferable CSUSeconds where
    put = putStorable
    get = getStorable

instance Bufferable CUSeconds where
    put = putStorable
    get = getStorable

instance Bufferable CTime where
    put = putStorable
    get = getStorable

instance Bufferable CClock where
    put = putStorable
    get = getStorable

instance Bufferable CSigAtomic where
    put = putStorable
    get = getStorable

instance Bufferable CWchar where
    put = putStorable
    get = getStorable

instance Bufferable CSize where
    put = putStorable
    get = getStorable

instance Bufferable CPtrdiff where
    put = putStorable
    get = getStorable

instance Bufferable CDouble where
    put = putStorable
    get = getStorable

instance Bufferable CFloat where
    put = putStorable
    get = getStorable

instance Bufferable CULLong where
    put = putStorable
    get = getStorable

instance Bufferable CULong where
    put = putStorable
    get = getStorable

instance Bufferable CLong where
    put = putStorable
    get = getStorable

instance Bufferable CUInt where
    put = putStorable
    get = getStorable

instance Bufferable CInt where
    put = putStorable
    get = getStorable

instance Bufferable CUShort where
    put = putStorable
    get = getStorable

instance Bufferable CShort where
    put = putStorable
    get = getStorable

instance Bufferable CUChar where
    put = putStorable
    get = getStorable

instance Bufferable CSChar where
    put = putStorable
    get = getStorable

instance Bufferable CChar where
    put = putStorable
    get = getStorable

instance Bufferable IntPtr where
    put = putStorable
    get = getStorable

instance Bufferable WordPtr where
    put = putStorable
    get = getStorable

instance Bufferable Fd where
    put = putStorable
    get = getStorable

instance Bufferable CRLim where
    put = putStorable
    get = getStorable

instance Bufferable CTcflag where
    put = putStorable
    get = getStorable

instance Bufferable CSpeed where
    put = putStorable
    get = getStorable

instance Bufferable CCc where
    put = putStorable
    get = getStorable

instance Bufferable CUid where
    put = putStorable
    get = getStorable

instance Bufferable CNlink where
    put = putStorable
    get = getStorable

instance Bufferable CGid where
    put = putStorable
    get = getStorable

instance Bufferable CSsize where
    put = putStorable
    get = getStorable

instance Bufferable CPid where
    put = putStorable
    get = getStorable

instance Bufferable COff where
    put = putStorable
    get = getStorable

instance Bufferable CMode where
    put = putStorable
    get = getStorable

instance Bufferable CIno where
    put = putStorable
    get = getStorable

instance Bufferable CDev where
    put = putStorable
    get = getStorable

instance (Storable a, Integral a) => Bufferable (Ratio a) where
    put = putStorable
    get = getStorable

instance Bufferable (StablePtr a) where
    put = putStorable
    get = getStorable

instance Bufferable (Ptr a) where
    put = putStorable
    get = getStorable

instance Bufferable (FunPtr a) where
    put = putStorable
    get = getStorable

instance Storable a => Bufferable (Complex a) where
    put = putStorable
    get = getStorable

-- | Assumes ASCII encoding and the presence of a null terminator.
instance Bufferable String where
    put = putString
    get = getString

-- | Assumes UTF8 encoding and the presence of a null terminator.
instance Bufferable T.Text where
    put = putText
    get = getText

-- | Assumes the initial 4 bytes are an unsigned 32-bit little-endian length.
--   Identical to 'SizedByteString Word32'.
instance Bufferable B.ByteString where
    put = putByteString
    get = getByteString