{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
# if MIN_VERSION_array(0,4,0)
{-# LANGUAGE Safe #-}
# endif
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.DeepSeq
-- Copyright   :  (c) The University of Glasgow 2001-2009
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  stable
-- Portability :  portable
--
-- This module provides an overloaded function, 'deepseq', for fully
-- evaluating data structures (that is, evaluating to \"Normal Form\").
--
-- A typical use is to prevent resource leaks in lazy IO programs, by
-- forcing all characters from a file to be read. For example:
--
-- > import System.IO
-- > import Control.DeepSeq
-- >
-- > main = do
-- >     h <- openFile "f" ReadMode
-- >     s <- hGetContents h
-- >     s `deepseq` hClose h
-- >     return s
--
-- 'deepseq' differs from 'seq' as it traverses data structures deeply,
-- for example, 'seq' will evaluate only to the first constructor in
-- the list:
--
-- > > [1,2,undefined] `seq` 3
-- > 3
--
-- While 'deepseq' will force evaluation of all the list elements:
--
-- > > [1,2,undefined] `deepseq` 3
-- > *** Exception: Prelude.undefined
--
-- Another common use is to ensure any exceptions hidden within lazy
-- fields of a data structure do not leak outside the scope of the
-- exception handler, or to force evaluation of a data structure in one
-- thread, before passing to another thread (preventing work moving to
-- the wrong threads).
--
-- /Since: 1.1.0.0/
module Control.DeepSeq (
     deepseq, ($!!), force,
     NFData(..),
  ) where

import Control.Applicative
import Control.Concurrent ( ThreadId )
import Data.Int
import Data.Word
import Data.Ratio
import Data.Complex
import Data.Array
import Data.Fixed
import Data.Version
import Data.Monoid
import Data.Unique ( Unique )
import Foreign.C.Types
import System.Mem.StableName ( StableName )

#if MIN_VERSION_base(4,6,0)
import Data.Ord ( Down(Down) )
#endif

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

#if MIN_VERSION_base(4,8,0)
import Data.Functor.Identity ( Identity(..) )
import Data.Typeable ( TypeRep, TyCon, rnfTypeRep, rnfTyCon )
import Data.Void ( Void, absurd )
import Numeric.Natural ( Natural )
#endif

#if __GLASGOW_HASKELL__ >= 702
import GHC.Fingerprint.Type ( Fingerprint(..) )
import GHC.Generics

-- | Hidden internal type-class
class GNFData f where
  grnf :: f a -> ()

instance GNFData V1 where
  grnf = error "Control.DeepSeq.rnf: uninhabited type"

instance GNFData U1 where
  grnf U1 = ()

instance NFData a => GNFData (K1 i a) where
  grnf = rnf . unK1
  {-# INLINEABLE grnf #-}

instance GNFData a => GNFData (M1 i c a) where
  grnf = grnf . unM1
  {-# INLINEABLE grnf #-}

instance (GNFData a, GNFData b) => GNFData (a :*: b) where
  grnf (x :*: y) = grnf x `seq` grnf y
  {-# INLINEABLE grnf #-}

instance (GNFData a, GNFData b) => GNFData (a :+: b) where
  grnf (L1 x) = grnf x
  grnf (R1 x) = grnf x
  {-# INLINEABLE grnf #-}
#endif

infixr 0 $!!

-- | 'deepseq': fully evaluates the first argument, before returning the
-- second.
--
-- The name 'deepseq' is used to illustrate the relationship to 'seq':
-- where 'seq' is shallow in the sense that it only evaluates the top
-- level of its argument, 'deepseq' traverses the entire data structure
-- evaluating it completely.
--
-- 'deepseq' can be useful for forcing pending exceptions,
-- eradicating space leaks, or forcing lazy I/O to happen.  It is
-- also useful in conjunction with parallel Strategies (see the
-- @parallel@ package).
--
-- There is no guarantee about the ordering of evaluation.  The
-- implementation may evaluate the components of the structure in
-- any order or in parallel.  To impose an actual order on
-- evaluation, use 'pseq' from "Control.Parallel" in the
-- @parallel@ package.
--
-- /Since: 1.1.0.0/
deepseq :: NFData a => a -> b -> b
deepseq a b = rnf a `seq` b

-- | the deep analogue of '$!'.  In the expression @f $!! x@, @x@ is
-- fully evaluated before the function @f@ is applied to it.
--
-- /Since: 1.2.0.0/
($!!) :: (NFData a) => (a -> b) -> a -> b
f $!! x = x `deepseq` f x

-- | a variant of 'deepseq' that is useful in some circumstances:
--
-- > force x = x `deepseq` x
--
-- @force x@ fully evaluates @x@, and then returns it.  Note that
-- @force x@ only performs evaluation when the value of @force x@
-- itself is demanded, so essentially it turns shallow evaluation into
-- deep evaluation.
--
-- 'force' can be conveniently used in combination with @ViewPatterns@:
--
-- > {-# LANGUAGE BangPatterns, ViewPatterns #-}
-- > import Control.DeepSeq
-- >
-- > someFun :: ComplexData -> SomeResult
-- > someFun (force -> !arg) = {- 'arg' will be fully evaluated -}
--
-- Another useful application is to combine 'force' with
-- 'Control.Exception.evaluate' in order to force deep evaluation
-- relative to other 'IO' operations:
--
-- > import Control.Exception (evaluate)
-- > import Control.DeepSeq
-- >
-- > main = do
-- >   result <- evaluate $ force $ pureComputation
-- >   {- 'result' will be fully evaluated at this point -}
-- >   return ()
--
-- /Since: 1.2.0.0/
force :: (NFData a) => a -> a
force x = x `deepseq` x

-- | A class of types that can be fully evaluated.
--
-- /Since: 1.1.0.0/
class NFData a where
    -- | 'rnf' should reduce its argument to normal form (that is, fully
    -- evaluate all sub-components), and then return '()'.
    --
    -- === 'Generic' 'NFData' deriving
    --
    -- Starting with GHC 7.2, you can automatically derive instances
    -- for types possessing a 'Generic' instance.
    --
    -- > {-# LANGUAGE DeriveGeneric #-}
    -- >
    -- > import GHC.Generics (Generic)
    -- > import Control.DeepSeq
    -- >
    -- > data Foo a = Foo a String
    -- >              deriving (Eq, Generic)
    -- >
    -- > instance NFData a => NFData (Foo a)
    -- >
    -- > data Colour = Red | Green | Blue
    -- >               deriving Generic
    -- >
    -- > instance NFData Colour
    --
    -- Starting with GHC 7.10, the example above can be written more
    -- concisely by enabling the new @DeriveAnyClass@ extension:
    --
    -- > {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
    -- >
    -- > import GHC.Generics (Generic)
    -- > import Control.DeepSeq
    -- >
    -- > data Foo a = Foo a String
    -- >              deriving (Eq, Generic, NFData)
    -- >
    -- > data Colour = Red | Green | Blue
    -- >               deriving (Generic, NFData)
    -- >
    --
    -- === Compatibility with previous @deepseq@ versions
    --
    -- Prior to version 1.4.0.0, the default implementation of the 'rnf'
    -- method was defined as
    --
    -- @'rnf' a = 'seq' a ()@
    --
    -- However, starting with @deepseq-1.4.0.0@, the default
    -- implementation is based on @DefaultSignatures@ allowing for
    -- more accurate auto-derived 'NFData' instances. If you need the
    -- previously used exact default 'rnf' method implementation
    -- semantics, use
    --
    -- > instance NFData Colour where rnf x = seq x ()
    --
    -- or alternatively
    --
    -- > {-# LANGUAGE BangPatterns #-}
    -- > instance NFData Colour where rnf !_ = ()
    --
    rnf :: a -> ()

#if __GLASGOW_HASKELL__ >= 702
    default rnf :: (Generic a, GNFData (Rep a)) => a -> ()
    rnf = grnf . from
#endif

instance NFData Int      where rnf !_ = ()
instance NFData Word     where rnf !_ = ()
instance NFData Integer  where rnf !_ = ()
instance NFData Float    where rnf !_ = ()
instance NFData Double   where rnf !_ = ()

instance NFData Char     where rnf !_ = ()
instance NFData Bool     where rnf !_ = ()
instance NFData ()       where rnf !_ = ()

instance NFData Int8     where rnf !_ = ()
instance NFData Int16    where rnf !_ = ()
instance NFData Int32    where rnf !_ = ()
instance NFData Int64    where rnf !_ = ()

instance NFData Word8    where rnf !_ = ()
instance NFData Word16   where rnf !_ = ()
instance NFData Word32   where rnf !_ = ()
instance NFData Word64   where rnf !_ = ()

#if MIN_VERSION_base(4,7,0)
-- |/Since: 1.4.0.0/
instance NFData (Proxy a) where rnf Proxy = ()
#endif

#if MIN_VERSION_base(4,8,0)
-- |/Since: 1.4.0.0/
instance NFData a => NFData (Identity a) where
    rnf = rnf . runIdentity

-- | Defined as @'rnf' = 'absurd'@.
--
-- /Since: 1.4.0.0/
instance NFData Void where
    rnf = absurd

-- |/Since: 1.4.0.0/
instance NFData Natural  where rnf !_ = ()
#endif

-- |/Since: 1.3.0.0/
instance NFData (Fixed a) where rnf !_ = ()

-- |This instance is for convenience and consistency with 'seq'.
-- This assumes that WHNF is equivalent to NF for functions.
--
-- /Since: 1.3.0.0/
instance NFData (a -> b) where rnf !_ = ()

--Rational and complex numbers.

#if __GLASGOW_HASKELL__ >= 711
instance NFData a => NFData (Ratio a) where
#else
instance (Integral a, NFData a) => NFData (Ratio a) where
#endif
  rnf x = rnf (numerator x, denominator x)

#if MIN_VERSION_base(4,4,0)
instance (NFData a) => NFData (Complex a) where
#else
instance (RealFloat a, NFData a) => NFData (Complex a) where
#endif
  rnf (x:+y) = rnf x `seq`
               rnf y `seq`
               ()

instance NFData a => NFData (Maybe a) where
    rnf Nothing  = ()
    rnf (Just x) = rnf x

instance (NFData a, NFData b) => NFData (Either a b) where
    rnf (Left x)  = rnf x
    rnf (Right y) = rnf y

-- |/Since: 1.3.0.0/
instance NFData Data.Version.Version where
    rnf (Data.Version.Version branch tags) = rnf branch `seq` rnf tags

instance NFData a => NFData [a] where
    rnf [] = ()
    rnf (x:xs) = rnf x `seq` rnf xs

-- |/Since: 1.4.0.0/
instance NFData a => NFData (ZipList a) where
    rnf = rnf . getZipList

-- |/Since: 1.4.0.0/
instance NFData a => NFData (Const a b) where
    rnf = rnf . getConst

#if __GLASGOW_HASKELL__ >= 711
instance (NFData a, NFData b) => NFData (Array a b) where
#else
instance (Ix a, NFData a, NFData b) => NFData (Array a b) where
#endif
    rnf x = rnf (bounds x, Data.Array.elems x)

#if MIN_VERSION_base(4,6,0)
-- |/Since: 1.4.0.0/
instance NFData a => NFData (Down a) where
    rnf (Down x) = rnf x
#endif

-- |/Since: 1.4.0.0/
instance NFData a => NFData (Dual a) where
    rnf = rnf . getDual

-- |/Since: 1.4.0.0/
instance NFData a => NFData (First a) where
    rnf = rnf . getFirst

-- |/Since: 1.4.0.0/
instance NFData a => NFData (Last a) where
    rnf = rnf . getLast

-- |/Since: 1.4.0.0/
instance NFData Any where rnf = rnf . getAny

-- |/Since: 1.4.0.0/
instance NFData All where rnf = rnf . getAll

-- |/Since: 1.4.0.0/
instance NFData a => NFData (Sum a) where
    rnf = rnf . getSum

-- |/Since: 1.4.0.0/
instance NFData a => NFData (Product a) where
    rnf = rnf . getProduct

-- |/Since: 1.4.0.0/
instance NFData (StableName a) where
    rnf !_ = () -- assumes `data StableName a = StableName (StableName# a)`

-- |/Since: 1.4.0.0/
instance NFData ThreadId where
    rnf !_ = () -- assumes `data ThreadId = ThreadId ThreadId#`

-- |/Since: 1.4.0.0/
instance NFData Unique where
    rnf !_ = () -- assumes `newtype Unique = Unique Integer`

#if MIN_VERSION_base(4,8,0)
-- | __NOTE__: Only defined for @base-4.8.0.0@ and later
--
-- /Since: 1.4.0.0/
instance NFData TypeRep where
    rnf tyrep = rnfTypeRep tyrep

-- | __NOTE__: Only defined for @base-4.8.0.0@ and later
--
-- /Since: 1.4.0.0/
instance NFData TyCon where
    rnf tycon = rnfTyCon tycon
#endif

----------------------------------------------------------------------------
-- GHC Specifics

#if __GLASGOW_HASKELL__ >= 702
-- |/Since: 1.4.0.0/
instance NFData Fingerprint where
    rnf (Fingerprint _ _) = ()
#endif

----------------------------------------------------------------------------
-- Foreign.C.Types

-- |/Since: 1.4.0.0/
instance NFData CChar where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CSChar where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CUChar where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CShort where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CUShort where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CInt where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CUInt where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CLong where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CULong where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CPtrdiff where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CSize where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CWchar where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CSigAtomic where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CLLong where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CULLong where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CIntPtr where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CUIntPtr where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CIntMax where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CUIntMax where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CClock where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CTime where rnf !_ = ()

#if MIN_VERSION_base(4,4,0)
-- |/Since: 1.4.0.0/
instance NFData CUSeconds where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CSUSeconds where rnf !_ = ()
#endif

-- |/Since: 1.4.0.0/
instance NFData CFloat where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CDouble where rnf !_ = ()

-- NOTE: The types `CFile`, `CFPos`, and `CJmpBuf` below are not
-- newtype wrappers rather defined as field-less single-constructor
-- types.

-- |/Since: 1.4.0.0/
instance NFData CFile where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CFpos where rnf !_ = ()

-- |/Since: 1.4.0.0/
instance NFData CJmpBuf where rnf !_ = ()

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

instance (NFData a, NFData b) => NFData (a,b) where
  rnf (x,y) = rnf x `seq` rnf y

instance (NFData a, NFData b, NFData c) => NFData (a,b,c) where
  rnf (x,y,z) = rnf x `seq` rnf y `seq` rnf z

instance (NFData a, NFData b, NFData c, NFData d) => NFData (a,b,c,d) where
  rnf (x1,x2,x3,x4) = rnf x1 `seq`
                      rnf x2 `seq`
                      rnf x3 `seq`
                      rnf x4

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5) =>
         NFData (a1, a2, a3, a4, a5) where
  rnf (x1, x2, x3, x4, x5) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6) =>
         NFData (a1, a2, a3, a4, a5, a6) where
  rnf (x1, x2, x3, x4, x5, x6) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7) =>
         NFData (a1, a2, a3, a4, a5, a6, a7) where
  rnf (x1, x2, x3, x4, x5, x6, x7) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8) =>
         NFData (a1, a2, a3, a4, a5, a6, a7, a8) where
  rnf (x1, x2, x3, x4, x5, x6, x7, x8) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7 `seq`
                  rnf x8

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8, NFData a9) =>
         NFData (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
  rnf (x1, x2, x3, x4, x5, x6, x7, x8, x9) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7 `seq`
                  rnf x8 `seq`
                  rnf x9


-- |
-- Copyright: (C) 2013 Amgen, Inc.
--
-- Provides a /shallow/ view of a 'SEXP' R value as an algebraic datatype. This
-- is useful to define functions over R values in Haskell with pattern matching.
-- For example:
--
-- @
-- toPair :: SEXP a -> (SomeSEXP, SomeSEXP)
-- toPair (hexp -> List _ (Just car) (Just cdr)) = (SomeSEXP car, SomeSEXP cdr)
-- toPair (hexp -> Lang car (Just cdr)) = (SomeSEXP car, SomeSEXP cdr)
-- toPair s = error $ "Cannot extract pair from object of type " ++ typeOf s
-- @
--
-- (See 'Foreign.R.SomeSEXP' for why we need to use it here.)
--
-- The view is said to be 'shallow' because it only unfolds the head of the
-- R value into an algebraic datatype. In this way, functions producing views
-- can be written non-recursively, hence inlined at all call sites and
-- simplified away. When produced by a view function in a pattern match,
-- allocation of the view can be compiled away and hence producing a view can be
-- done at no runtime cost. In fact, pattern matching on a view in this way is
-- more efficient than using the accessor functions defined in "Foreign.R",
-- because we avoid the overhead of calling one or more FFI functions entirely.
--
-- 'HExp' is the /view/ and 'hexp' is the /view function/ that projects 'SEXP's
-- into 'HExp' views.

{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PolyKinds #-}
#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE RoleAnnotations #-}
#endif
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}

module Language.R.HExp
  ( HExp(..)
  , (===)
  , hexp
  , unhexp
  , vector
  ) where

import Control.Applicative
import Control.Memory.Region (V)
import Control.Monad.R.Class
import qualified Foreign.R      as R
import Foreign.R (SEXP, SomeSEXP(..), SEXPTYPE, withProtected)
import Foreign.R.Constraints
import Internal.Error
import qualified Language.R.Globals as H

import qualified Data.Vector.SEXP as Vector

import Control.Monad ((<=<), guard, void)
import Control.Monad.Primitive ( unsafeInlineIO )
import Data.Int (Int32)
import Data.Word (Word8)
import Data.Complex
import Data.Maybe (isJust)
import Data.Type.Equality (TestEquality(..), (:~:)(Refl))
import GHC.Ptr (Ptr(..))
import Foreign.Storable
import Foreign.C -- for hsc2hs
import Foreign (castPtr)
import Unsafe.Coerce (unsafeCoerce)
-- Fixes redundant import warning >= 7.10 without CPP
import Prelude

#define USE_RINTERNALS
#include <R.h>
#include <Rinternals.h>

#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)

-- Use explicit UNPACK pragmas rather than -funbox-strict-fields in order to get
-- warnings if a field is not unpacked when we expect it to.

-- | A view of R's internal 'SEXP' structure as an algebraic datatype. Because
-- this is in fact a GADT, the use of named record fields is not possible here.
-- Named record fields give rise to functions for whom it is not possible to
-- assign a reasonable type (existentially quantified type variables would
-- escape).
--
-- Note further that Haddock does not currently support constructor comments
-- when using the GADT syntax.
type role HExp phantom nominal
data HExp :: * -> SEXPTYPE -> * where
  -- Primitive types. The field names match those of <RInternals.h>.
  Nil       :: HExp s 'R.Nil
  -- Fields: pname (is Nil for R_UnboundValue), value, internal.
  Symbol    :: (a :∈ ['R.Char, 'R.Nil])
            => SEXP s a
            -> SEXP s b
            -> SEXP s c
            -> HExp s 'R.Symbol
  -- Fields: carval, cdrval, tagval.
  List      :: (R.IsPairList b, c :∈ ['R.Symbol, 'R.Nil])
            => SEXP s a
            -> SEXP s b
            -> SEXP s c
            -> HExp s 'R.List
  -- Fields: frame, enclos, hashtab.
  Env       :: (R.IsPairList a, b :∈ ['R.Env, 'R.Nil], c :∈ ['R.Vector, 'R.Nil])
            => SEXP s a
            -> SEXP s b
            -> SEXP s c
            -> HExp s 'R.Env
  -- Fields: formals, body, env.
  Closure   :: (R.IsPairList a)
            => SEXP s a
            -> SEXP s b
            -> SEXP s 'R.Env
            -> HExp s 'R.Closure
  -- Fields: value, expr, env.
  -- Once an promise has been evaluated, the environment is set to NULL.
  Promise   :: (R.IsExpression b, c :∈ ['R.Env, 'R.Nil])
            => SEXP s a
            -> SEXP s b
            -> SEXP s c
            -> HExp s 'R.Promise
  -- Derived types. These types don't have their own 'struct' declaration in
  -- <Rinternals.h>.
  -- Fields: function, args.
  Lang      :: (R.IsExpression a, R.IsPairList b)
            => SEXP s a
            -> SEXP s b
            -> HExp s 'R.Lang
  -- Fields: offset.
  Special   :: {-# UNPACK #-} !Int32
            -> HExp s 'R.Special
  -- Fields: offset.
  Builtin   :: {-# UNPACK #-} !Int32
            -> HExp s 'R.Builtin
  Char      :: {-# UNPACK #-} !(Vector.Vector 'R.Char Word8)
            -> HExp s 'R.Char
  Logical   :: {-# UNPACK #-} !(Vector.Vector 'R.Logical R.Logical)
            -> HExp s 'R.Logical
  Int       :: {-# UNPACK #-} !(Vector.Vector 'R.Int Int32)
            -> HExp s 'R.Int
  Real      :: {-# UNPACK #-} !(Vector.Vector 'R.Real Double)
            -> HExp s 'R.Real
  Complex   :: {-# UNPACK #-} !(Vector.Vector 'R.Complex (Complex Double))
            -> HExp s 'R.Complex
  String    :: {-# UNPACK #-} !(Vector.Vector 'R.String (SEXP V 'R.Char))
            -> HExp s 'R.String
  -- Fields: pairlist of promises.
  DotDotDot :: (R.IsPairList a)
            => SEXP s a
            -> HExp s 'R.List
  -- Fields: truelength, content.
  Vector    :: {-# UNPACK #-} !Int32
            -> {-# UNPACK #-} !(Vector.Vector 'R.Vector (SomeSEXP V))
            -> HExp s 'R.Vector
  -- Fields: truelength, content.
  Expr      :: {-# UNPACK #-} !Int32
            -> {-# UNPACK #-} !(Vector.Vector 'R.Expr (SomeSEXP V))
            -> HExp s 'R.Expr
  Bytecode  :: HExp s 'R.Bytecode -- TODO
  -- Fields: pointer, protectionValue, tagval
  ExtPtr    :: Ptr ()
            -> SEXP s b
            -> SEXP s 'R.Symbol
            -> HExp s 'R.ExtPtr
  -- Fields: key, value, finalizer, next.
  WeakRef   :: ( a :∈ ['R.Env, 'R.ExtPtr, 'R.Nil]
               , c :∈ ['R.Closure, 'R.Builtin, 'R.Special, 'R.Nil]
               , d :∈ ['R.WeakRef, 'R.Nil] )
            => SEXP s a
            -> SEXP s b
            -> SEXP s c
            -> SEXP s d
            -> HExp s 'R.WeakRef
  Raw       :: {-# UNPACK #-} !(Vector.Vector 'R.Raw Word8)
            -> HExp s 'R.Raw
  -- Fields: tagval.
  S4        :: SEXP s a
            -> HExp s 'R.S4

-- 'Im a hack

instance Eq (HExp s a) where
  (==) = (===)

-- | Heterogeneous equality.
(===) :: TestEquality f => f a -> f b -> Bool
x === y = isJust $ testEquality x y

-- | Wrapper for partially applying a type synonym.
newtype E s a = E (SEXP s a)

instance TestEquality (E s) where
  testEquality (E x@(hexp -> t1)) (E y@(hexp -> t2)) =
      (guard (R.unsexp x == R.unsexp y) >> return (unsafeCoerce Refl)) <|>
      testEquality t1 t2

instance TestEquality (HExp s) where
  testEquality Nil Nil = return Refl
  testEquality (Symbol pname1 value1 internal1) (Symbol pname2 value2 internal2) = do
      void $ testEquality (E pname1) (E pname2)
      void $ testEquality (E value1) (E value2)
      void $ testEquality (E internal1) (E internal2)
      return Refl
  testEquality (List carval1 cdrval1 tagval1) (List carval2 cdrval2 tagval2) = do
      void $ testEquality (E carval1) (E carval2)
      void $ testEquality (E cdrval1) (E cdrval2)
      void $ testEquality (E tagval1) (E tagval2)
      return Refl
  testEquality (Env frame1 enclos1 hashtab1) (Env frame2 enclos2 hashtab2) = do
      void $ testEquality (E frame1) (E frame2)
      void $ testEquality (E enclos1) (E enclos2)
      void $ testEquality (E hashtab1) (E hashtab2)
      return Refl
  testEquality (Closure formals1 body1 env1) (Closure formals2 body2 env2) = do
      void $ testEquality (E formals1) (E formals2)
      void $ testEquality (E body1) (E body2)
      void $ testEquality (E env1) (E env2)
      return Refl
  testEquality (Promise value1 expr1 env1) (Promise value2 expr2 env2) = do
      void $ testEquality (E value1) (E value2)
      void $ testEquality (E expr1) (E expr2)
      void $ testEquality (E env1) (E env2)
      return Refl
  testEquality (Lang carval1 cdrval1) (Lang carval2 cdrval2) = do
      void $ testEquality (E carval1) (E carval2)
      void $ testEquality (E cdrval1) (E cdrval2)
      return Refl
  testEquality (Special offset1) (Special offset2) = do
      guard $ offset1 == offset2
      return Refl
  testEquality (Builtin offset1) (Builtin offset2) = do
      guard $ offset1 == offset2
      return Refl
  testEquality (Char vec1) (Char vec2) = do
      guard $ vec1 == vec2
      return Refl
  testEquality (Int vec1) (Int vec2) = do
      guard $ vec1 == vec2
      return Refl
  testEquality (Real vec1) (Real vec2) = do
      guard $ vec1 == vec2
      return Refl
  testEquality (String vec1) (String vec2) = do
      guard $ vec1 == vec2
      return Refl
  testEquality (Complex vec1) (Complex vec2) = do
      guard $ vec1 == vec2
      return Refl
  testEquality (DotDotDot pairlist1) (DotDotDot pairlist2) = do
      void $ testEquality (E pairlist1) (E pairlist2)
      return Refl
  testEquality (Vector truelength1 vec1) (Vector truelength2 vec2) = do
      let eq (SomeSEXP s1) (SomeSEXP s2) = isJust $ testEquality (E s1) (E s2)
      guard $ truelength1 == truelength2
      guard $ and $ zipWith eq (Vector.toList vec1) (Vector.toList vec2)
      return Refl
  testEquality (Expr truelength1 vec1) (Expr truelength2 vec2) = do
      let eq (SomeSEXP s1) (SomeSEXP s2) = isJust $ testEquality (E s1) (E s2)
      guard $ truelength1 == truelength2
      guard $ and $ zipWith eq (Vector.toList vec1) (Vector.toList vec2)
      return Refl
  testEquality Bytecode Bytecode = return Refl
  testEquality (ExtPtr pointer1 protectionValue1 tagval1) (ExtPtr pointer2 protectionValue2 tagval2) = do
      guard $ castPtr pointer1 == castPtr pointer2
      void $ testEquality (E protectionValue1) (E protectionValue2)
      void $ testEquality (E tagval1) (E tagval2)
      return Refl
  testEquality (WeakRef key1 value1 finalizer1 next1) (WeakRef key2 value2 finalizer2 next2) = do
      void $ testEquality (E key1) (E key2)
      void $ testEquality (E value1) (E value2)
      void $ testEquality (E finalizer1) (E finalizer2)
      void $ testEquality (E next1) (E next2)
      return Refl
  testEquality (Raw vec1) (Raw vec2) = do
      guard $ vec1 == vec2
      return Refl
  testEquality (S4 tagval1) (S4 tagval2) = do
      void $ testEquality (E tagval1) (E tagval2)
      return Refl
  testEquality _ _ = Nothing

instance Storable (HExp s a) where
  sizeOf _ = #{size SEXPREC}
  alignment _ = #{alignment SEXPREC}
  poke = pokeHExp
  peek = peekHExp . R.SEXP
  {-# INLINE peek #-}

{-# INLINE peekHExp #-}
peekHExp :: SEXP s a -> IO (HExp s a)
peekHExp s = do
    let coerce :: IO (HExp s a) -> IO (HExp s b)
        coerce = unsafeCoerce

        -- (:∈) constraints are impossible to respect in 'peekHExp', because
        -- R doesn't tell us statically the form of the SEXPREC referred to by
        -- a pointer. So in this function only, we pretend all constrained
        -- fields actually always contain fields of form ANYSXP. This has no
        -- operational significance - it's only a way to bypass what's
        -- impossible to prove.
        coerceAny :: SEXP s a -> SEXP s 'R.Any -- '
        coerceAny = R.unsafeCoerce

        sptr = R.unsexp s

    case R.typeOf s of
      R.Nil       -> coerce $ return Nil
      R.Symbol    -> coerce $
        Symbol    <$> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.symsxp.pname} sptr)
                  <*> (R.sexp <$> #{peek SEXPREC, u.symsxp.value} sptr)
                  <*> (R.sexp <$> #{peek SEXPREC, u.symsxp.internal} sptr)
      R.List      -> coerce $
        List      <$> (R.sexp <$> #{peek SEXPREC, u.listsxp.carval} sptr)
                  <*> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.listsxp.cdrval} sptr)
                  <*> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.listsxp.tagval} sptr)
      R.Env       -> coerce $
        Env       <$> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.envsxp.frame} sptr)
                  <*> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.envsxp.enclos} sptr)
                  <*> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.envsxp.hashtab} sptr)
      R.Closure   -> coerce $
        Closure   <$> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.closxp.formals} sptr)
                  <*> (R.sexp <$> #{peek SEXPREC, u.closxp.body} sptr)
                  <*> (R.sexp <$> #{peek SEXPREC, u.closxp.env} sptr)
      R.Promise   -> coerce $
        Promise   <$> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.promsxp.value} sptr)
                  <*> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.promsxp.expr} sptr)
                  <*> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.promsxp.env} sptr)
      R.Lang      -> coerce $
        Lang      <$> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.listsxp.carval} sptr)
                  <*> (coerceAny <$> R.sexp <$> #{peek SEXPREC, u.listsxp.cdrval} sptr)
      R.Special   -> coerce $
        Special   <$> (fromIntegral <$> (#{peek SEXPREC, u.primsxp.offset} sptr :: IO CInt))
      R.Builtin   -> coerce $
        Builtin   <$> (fromIntegral <$> (#{peek SEXPREC, u.primsxp.offset} sptr :: IO CInt))
      R.Char      -> unsafeCoerce $ Char    (Vector.unsafeFromSEXP (unsafeCoerce s))
      R.Logical   -> unsafeCoerce $ Logical (Vector.unsafeFromSEXP (unsafeCoerce s))
      R.Int       -> unsafeCoerce $ Int     (Vector.unsafeFromSEXP (unsafeCoerce s))
      R.Real      -> unsafeCoerce $ Real    (Vector.unsafeFromSEXP (unsafeCoerce s))
      R.Complex   -> unsafeCoerce $ Complex (Vector.unsafeFromSEXP (unsafeCoerce s))
      R.String    -> unsafeCoerce $ String  (Vector.unsafeFromSEXP (unsafeCoerce s))
      R.DotDotDot -> unimplemented $ "peekHExp: " ++ show (R.typeOf s)
      R.Vector    -> coerce $
        Vector    <$> (fromIntegral <$> (#{peek VECTOR_SEXPREC, vecsxp.truelength} sptr :: IO CInt))
                  <*> pure (Vector.unsafeFromSEXP (unsafeCoerce s))
      R.Expr      -> coerce $
        Expr      <$> (fromIntegral <$> (#{peek VECTOR_SEXPREC, vecsxp.truelength} sptr :: IO CInt))
                  <*> pure (Vector.unsafeFromSEXP (unsafeCoerce s))
      R.Bytecode  -> coerce $ return Bytecode
      R.ExtPtr    -> coerce $
        ExtPtr    <$> (castPtr <$> #{peek SEXPREC, u.listsxp.carval} sptr)
                  <*> (R.sexp <$> #{peek SEXPREC, u.listsxp.cdrval} sptr)
                  <*> (R.sexp <$> #{peek SEXPREC, u.listsxp.tagval} sptr)
      R.WeakRef   -> coerce $
        WeakRef   <$> (coerceAny <$> R.sexp <$>
                       peekElemOff (castPtr $ R.unsafeSEXPToVectorPtr s) 0)
                  <*> (R.sexp <$>
                       peekElemOff (castPtr $ R.unsafeSEXPToVectorPtr s) 1)
                  <*> (coerceAny <$> R.sexp <$>
                       peekElemOff (castPtr $ R.unsafeSEXPToVectorPtr s) 2)
                  <*> (coerceAny <$> R.sexp <$>
                       peekElemOff (castPtr $ R.unsafeSEXPToVectorPtr s) 3)
      R.Raw       -> unsafeCoerce $ Raw (Vector.unsafeFromSEXP (unsafeCoerce s))
      R.S4        -> coerce $
        S4        <$> (R.sexp <$> #{peek SEXPREC, u.listsxp.tagval} sptr)
      _           -> unimplemented $ "peekHExp: " ++ show (R.typeOf s)

pokeHExp :: Ptr (HExp s a) -> HExp s a -> IO ()
pokeHExp s h = do
    case h of
         Nil -> return ()
         Symbol pname value internal -> do
           #{poke SEXPREC, u.symsxp.pname} s (R.unsexp pname)
           #{poke SEXPREC, u.symsxp.value} s (R.unsexp value)
           #{poke SEXPREC, u.symsxp.internal} s (R.unsexp internal)
         List carval cdrval tagval -> do
           #{poke SEXPREC, u.listsxp.carval} s (R.unsexp carval)
           #{poke SEXPREC, u.listsxp.cdrval} s (R.unsexp cdrval)
           #{poke SEXPREC, u.listsxp.tagval} s (R.unsexp tagval)
         Env frame enclos hashtab -> do
           #{poke SEXPREC, u.envsxp.frame} s (R.unsexp frame)
           #{poke SEXPREC, u.envsxp.enclos} s (R.unsexp enclos)
           #{poke SEXPREC, u.envsxp.hashtab} s (R.unsexp hashtab)
         Closure formals body env -> do
           #{poke SEXPREC, u.closxp.formals} s (R.unsexp formals)
           #{poke SEXPREC, u.closxp.body} s (R.unsexp body)
           #{poke SEXPREC, u.closxp.env} s (R.unsexp env)
         Promise value expr env -> do
           #{poke SEXPREC, u.promsxp.value} s (R.unsexp value)
           #{poke SEXPREC, u.promsxp.expr} s (R.unsexp expr)
           #{poke SEXPREC, u.promsxp.env} s (R.unsexp env)
         Lang carval cdrval -> do
           #{poke SEXPREC, u.listsxp.carval} s (R.unsexp carval)
           #{poke SEXPREC, u.listsxp.cdrval} s (R.unsexp cdrval)
         Special offset -> do
           #{poke SEXPREC, u.primsxp.offset} s (fromIntegral offset :: CInt)
         Builtin offset -> do
           #{poke SEXPREC, u.primsxp.offset} s (fromIntegral offset :: CInt)
         Char _vc        -> unimplemented "pokeHExp"
         Logical  _vt    -> unimplemented "pokeHExp"
         Int  _vt        -> unimplemented "pokeHExp"
         Real _vt        -> unimplemented "pokeHExp"
         String _vt      -> unimplemented "pokeHExp"
         Complex _vt     -> unimplemented "pokeHExp"
         Vector _v _     -> unimplemented "pokeHExp"
         Bytecode        -> unimplemented "pokeHExp"
         ExtPtr _ _ _    -> unimplemented "pokeHExp"
         WeakRef _ _ _ _ -> unimplemented "pokeHExp"
         Raw     _       -> unimplemented "pokeHExp"
         S4      _       -> unimplemented "pokeHExp"
         DotDotDot _     -> unimplemented "pokeHExp"
         Expr _ _        -> unimplemented "pokeHExp"

-- | A view function projecting a view of 'SEXP' as an algebraic datatype, that
-- can be analyzed through pattern matching.
hexp :: SEXP s a -> HExp s a
hexp = unsafeInlineIO . peek . R.unSEXP
{-# INLINE hexp #-}

-- | Inverse hexp view to the real structure, note that for scalar types
-- hexp will allocate new SEXP, and @unhexp . hexp@ is not an identity function.
-- however for vector types it will return original SEXP.
unhexp :: MonadR m => HExp (Region m) a -> m (SEXP (Region m) a)
unhexp   Nil = return $ R.release H.nilValue
unhexp s@(Symbol{}) = io $
  withProtected (R.allocSEXP R.SSymbol)
                (\x -> poke (R.unSEXP x) s >> return x)
unhexp (List carval cdrval tagval) = acquire <=< io $ do
  rc <- R.protect carval
  rd <- R.protect cdrval
  rt <- R.protect tagval
  z  <- R.cons rc rd
  #{poke SEXPREC, u.listsxp.tagval} (R.unsexp z) (R.unsexp rt)
  R.unprotect 3
  return z
unhexp (Lang carval cdrval) = acquire <=< io $ do
    carval' <- R.protect carval
    cdrval' <- R.protect cdrval
    x <- R.allocSEXP R.SLang
    R.setCar x (R.release carval')
    R.setCdr x (R.release cdrval')
    R.unprotect 2
    return x
unhexp s@(Env{})     = io $
    withProtected (R.allocSEXP R.SEnv)
                  (\x -> poke (R.unSEXP x) s >> return x)
unhexp s@(Closure{}) = io $
    withProtected (R.allocSEXP R.SClosure)
                  (\x -> poke (R.unSEXP x) s >> return x)
unhexp s@(Special{}) = io $
    withProtected (R.allocSEXP R.SSpecial)
                  (\x -> poke (R.unSEXP x) s >> return x)
unhexp s@(Builtin{}) = io $
    withProtected (R.allocSEXP R.SBuiltin)
                  (\x -> poke (R.unSEXP x) s >> return x)
unhexp s@(Promise{}) = io $
    withProtected (R.allocSEXP R.SPromise)
                  (\x -> poke (R.unSEXP x) s >> return x)
unhexp  (Bytecode{}) = unimplemented "unhexp"
unhexp (Real vt)     = return $ Vector.unsafeToSEXP vt
unhexp (Logical vt)  = return $ Vector.unsafeToSEXP vt
unhexp (Int vt)      = return $ Vector.unsafeToSEXP vt
unhexp (Complex vt)  = return $ Vector.unsafeToSEXP vt
unhexp (Vector _ vt) = return $ Vector.unsafeToSEXP vt
unhexp (Char vt)     = return $ Vector.unsafeToSEXP vt
unhexp (String vt)   = return $ Vector.unsafeToSEXP vt
unhexp (Raw vt)      = return $ Vector.unsafeToSEXP vt
unhexp S4{}          = unimplemented "unhexp"
unhexp (Expr _ vt)   = return $ Vector.unsafeToSEXP vt
unhexp WeakRef{}     = error "unhexp does not support WeakRef, use Foreign.R.mkWeakRef instead."
unhexp DotDotDot{}   = unimplemented "unhexp"
unhexp ExtPtr{}      = unimplemented "unhexp"

-- | Project the vector out of 'SEXP's.
vector :: R.IsVector a => SEXP s a -> Vector.Vector a (Vector.ElemRep V a)
vector (hexp -> Char vec)     = vec
vector (hexp -> Logical vec)  = vec
vector (hexp -> Int vec)      = vec
vector (hexp -> Real vec)     = vec
vector (hexp -> Complex vec)  = vec
vector (hexp -> String vec)   = vec
vector (hexp -> Vector _ vec) = vec
vector (hexp -> Expr _ vec)   = vec
vector s = violation "vector" $ show (R.typeOf s) ++ " unexpected vector type."


{-# LANGUAGE TupleSections ,ViewPatterns ,NoMonomorphismRestriction ,BangPatterns ,ScopedTypeVariables #-}
module Main
where
{- Test performance of encoding against other packages -}

{-# LANGUAGE MultiParamTypeClasses ,DeriveGeneric ,DeriveDataTypeable ,ScopedTypeVariables ,GADTs ,NoMonomorphismRestriction ,DeriveGeneric ,DefaultSignatures ,TemplateHaskell ,TypeFamilies ,FlexibleContexts ,CPP #-}

-- cabal update; cabal install binary binary-bits cereal buffer-builder bytes bytestring bits

{-
Compile:
cd /Users/titto/workspace/quid2;cabal install

Run plain, measure time externally:
cd /Users/titto/workspace/quid2;cabal install;time /Users/titto/workspace/quid2/.cabal-sandbox/bin/benchsmall

cd /Users/titto/workspace/quid2;cabal install;time /Users/titto/workspace/quid2/.cabal-sandbox/bin/benchsmall +RTS -sstderr -h;hp2ps -c benchsmall

Profiling
cd /Users/titto/workspace/quid2;cabal install --enable-executbitEncoder :: Int -> Encoding -> L.ByteString
bitEncoder numBits (Writer op) = L.fromStrict $ bitEncoderStrict numBits op
able-profiling -p;/Users/titto/workspace/quid2/.cabal-sandbox/bin/benchsmall +RTS -ph -sstderr;cat benchsmall.prof;hp2ps -c benchsmall;profiteur benchsmall.prof;open file:///Users/titto/workspace/quid2/benchsmall.prof.eUnsigned64 :: Word64 -> Encodinghtml

Benchmarking
cd /Users/titto/workspace/quid2;cabal install;/Users/titto/workspace/quid2/.cabal-sandbo# - store-0.4.1
# - store-core-0.4
x/bin/benchsmall

Benchmarking using cbor test suite, see LEGGIMI

Profiling using eventlog:
cd /Users/titto/workspace/quid2;cabal install;time /Users/titto/workspace/quid2/.cabal-sandbox/bin/benchs-- mall +RTS -l;ghc-event-- let v = [1::Word64 .. 4000000]
  -- evaluate $ force' (NF v)
  -- putStrLn . commas . length $ v

  s-analyze benchsmall.eventlog;cat benchsmall.totals.txt

-}

{-
Decoding
|               | ln2 |
| binary        | 23  |
| BitEncoderE   | 23  |

DecM
|                    | treeN μs         | ln2 μs | ln3 large ms | tree3 ms| tuple μs | One ns
| new-binary Custom  | 76               |
| binary 0.7.2.2     | 48               |  83    | 150         | 177
| cereal 0.4.1.1     | 58               |        |
| quid2 "binary-bits"| 87               |        |  271          | 426
| .. getBoolFast     | 78         wordsT = ("words",wordsV)
wordsV = (18::Word,33::Word8,1230::Word16,9990::Word32,1231232::Word64)
      |        |
| .. Custom        -ddump-opt-cmm  |       -ddump-opt-cmm           |        |
| .. DECODER_BITS    | 50               |        | 256:156-306   | 282:248-312
| .. "binary-strict" | 370              |        | 1052          | 1275
| .. Cstm BitDecoder
| DEC [1]            | 41               | 123    | 95            | 167
| DEC [2]            | [42]             | 88     | [60]          | 167
| DEC [3]            | 40               | [78]   | 132/60        | [163]
| .. DEC1            | 73               | 10     | 232:152-268   | 209:181-232
| .. runDec3         |                  |        | 256:153-300!  | 235:213-250
| .. runDec33        |                  |        | 261:194-304!  | 249:221-273
| .. runDec2         |                  |        | 266           | 238
| .. runDec22        |                  |        | 236:157-279   | 220:213-234
| .. DEC2 custom     |                  |        | 225           | 387
| .. .. Strict       | 56               | 12     |

[1] -DDEC=2 -D__INLINE -DDECODER_DATA -DGOCASES=0 -DDECODER_QUID2

[2] -DDEC=2 -D__INLINE -DDECODER_PRIM -DGOCASES=0 -DDECODER_QUID2

[3] -DDEC=2 -D__INLINE -DDECODER_GETTER -DGOCASES=0 -DDECODER_QUID2

EncDec
|                    | treeN μs| ln2 μs  | ln3 ms | IO ln3 ms | tuple μs | One ns
| new-binary Custom  | 91      | 240     | 25     |  15      | 1.7     | 388
| binary 0.7.2.2     | 57      | 164     | 16-17  |  7-8     | 1       | 562
| .. 0.7.2.3-0.7.4.0 |         |         | !105!  |
| cereal             | 70      | 190     | 16     |  8-9     | 1.2     | 493
| BitEncoderD        | 82      | 239     | 18     |  13-14   | 1.2     | 458
| BitEncoderE Custom | 74      | 201     | 18     |          | 1.2     | 439
| BitEncoderE        | 88      | 248     | 20     |          | 1.5     | 528
| BitEncoderF        |                   | 19

Enc
|                    | treeN | ln2   | ln3 ms | tuple    | One
| new-binary Custom  | 28    | 67    | 3.5    |  655     | 223
| binary 0.7.2.2     | 29    | 89-92 | 4.5    |  563-592 | 315
| cereal             | 28    | 81    | 4      |  551     | 335
| BitEncoderD        | [26]  | 69-75 | 3.8    |  357     | 224
| BitEncoderD Custom | 22-24 | 63-64 | 3.1    |  357     | 224
| BitEncoderE        | 30    | 82    | 4.3    |  585     | 242
| !BitEncoderF       | 27    | [65]  | [3.2]  |  444     | 220
| .. Custom          | 24-25 | [51]  | [2.5]  |  371     | 224
| .. Custom Strict   | 21    | 63    | [10.19]|  353     | 218
| ..Cst toBitBuilderE| 80    | [54]  | [2.86] |  431     | 214

|           | tstEnc lBool | tstEnc lN2 | tstEncodeDecode lBool | tstEncodeDecode lN2 | tstDec lN2
new-binary  | 6.8          | 65-69      | 22.7                  | 232-237             |
binary      |              | 86-88      | 13.7                  | 161-169
binary custom |            | 83-85
cereal      |              | 80-82          | 15.7              | 185-190
ByteBuilder |              | 78            | 20.8               | 236
Data.Binary.Quid2 BitEnc   | 135-141             |
.. BitEncoderF Custom       | 55-56            |
.. BitEncoderE              | 59-60                             | 230                  | 165
.. BitEncoderE Custom       | 51-53        |                    | 160-195              | 136
.. ByteEncoderF             | 121-135      |
.. ByteEncoderF Custom      | 55           |
Byte        |              | 158           | 35                  | 397-413
Byte2       |              | 187           | 37.5                | 412
Bit2 (Coding 64) | 20.8    |               |
Bit2 (Coding 8)  | 22      |               |
Bit  (BitPut orig) | 15-17 | 384           | 55                   | 831-851
Bit3 (BitPut 8)    | 14-17 | 220                                  | 664-690
Bit3 (BitPut 64)   | 15-18 | 242
-}

-- ghc -O2 --make Bench;./Bench
import           Control.DeepSeq
import Criterion.Main
import Criterion.IO
import Criterion.Types
import Types
import Test.Data
import           Test.Data.Values
import PkgBinary
import qualified PkgBinary as B
-- import PkgCereal
import qualified PkgCereal as CC
import PkgCBOR
import qualified PkgCBOR as C
import PkgFlat
import qualified PkgFlat as F
import PkgStore
import qualified PkgStore as S
import qualified Data.Binary.Serialise.CBOR as CBOR
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as BS
import qualified Data.Text as T
import Control.Exception
import Control.Monad
import Control.Applicative
--import System.Directory
import Debug.Trace -- (traceEventIO)
import           Criterion.IO
import           Criterion.Types
-- import           Statistics.Resampling.Bootstrap
import qualified Data.Map as M
import qualified Data.Flat as F
import qualified Data.Flat.Encoder as F
import System.Directory
import Report
import Weigh

event label =
  bracket_ (traceEventIO $ "START " ++ label)
           (traceEventIO $ "STOP "  ++ label)

t = mainBench

-- tl1 = [tstLen PkgBinary tree1
--       ,tstLen PkgBinary tree2
--       ,tstLen PkgBinary lBool
--       --,tstLen PkgBinary lN
--       ]

-- tl2 = [--tstLen PkgFlat tree1
--       -- ,tstLen PkgFlat tree2
--       tstLen PkgFlat lBool
--       --,tstLen PkgFlat lN
--       ]

l = [tstSize tupleT,tstSize tupleBools,tstSize tupleWords,tstSize arr0, tstSize arr1, tstSize asciiStrT,tstSize unicodeStrT,tstSize unicodeTextT , tstSize lN3T, tstSize treeNLargeT]
-- [("tuple",(8.0,3.0,3.0)),("tupleBools",(7.0,4.5,4.5)),("tupleWord",(1.5555555555555556,3.5555555555555554,3.5555555555555554)),("[Bool]",(3.999992000032,4.000015999936,4.000015999936)),("[Word]",(1.3416352722052283,4.691580498057688,4.691580498057688)),("asciiStr",(0.8888925432066282,0.8888952098709245,3.555559506169328)),("unicodeStr",(0.9322290145814176,0.932230773922345,2.345792594816747)),("unicodeText",(0.9960948808600285,0.9960967607312449,1.2532524905160498)),("lN3",(9.41174726647702,4.70587363323851,4.70587363323851)),("tree3",(10.909087272727273,5.454543636363637,5.454543636363637))]
-- tstSize :: (CBOR.Serialise a, Flat a) => (String, a) -> (String,Double)
tstSize nv@(n,v) = (n,) $ (tstLen PkgCBOR v,tstLen PkgBinary v,tstLen PkgStore v)

tstLen:: (Serialize c a, Flat a1) => (a1 -> c a) -> a1 -> Double
tstLen k v = let l0 = lser PkgFlat v
                 l1 = lser k v
             in (l1 / l0)

-- lser :: (Serialize c1 a1) => (a -> c1 a1) -> a -> Double
lser k = fromIntegral . Prelude.length . ser . k

-- main = mainWeight
main = mainB

{-# RULES "cl1" forall a. cl [a] = 1 ; #-}
{-# RULES "cl2" forall a b. cl [a,b] = 2 ; #-}

{-# INLINE [0] cl #-}
-- {-# NOINLINE cl #-}
cl :: [a] -> Int
cl l = error "BAD" -- length l

yv = cl [2,4]
xv = yv + cl [2]

-- main = mainEvents
mainB = do
  forceCafs

  prints
  mainBench

  --mainProfile
  -- mainAlternatives

prints = do
  -- plf treeNLargeT
  -- -- plf treeNLargeT >> plf treeNNNLargeT >>
  -- plf nativeListT

  -- print (yv,xv)
  -- print $ pt carT

  print $ F.getSize Three
  print $ F.getSize (Leaf Three)
  print $ F.getSize (treeNLarge)
  print $ F.getSize (treeNNNLarge)
  print $ F.getSize (nativeList)

  -- print $ B.unpack (F.flat v1)
  -- print $ B.unpack (F.flat v2)
  -- print $ B.unpack (F.flat t33)
  -- print $ [33] == B.unpack (F.flat v1)
  -- print $ [89] == B.unpack (F.flat v2)
  -- print $ [220,221,25] == B.unpack (F.flat t33)

  print $ 1175000 == B.length (F.flat treeNNNLarge)
  print $ 550000 == B.length (F.flat treeNLarge)
  print $ 2125001== B.length (F.flat nativeList)
  print $ (B.length (F.flat unicodeTextT),B.length (F.flat unicodeTextUTF8T),B.length (F.flat unicodeStrT))
  pp car1
  -- ),B.length (serialize PkgStore car1))
  -- print $ 1 == B.length (F.flat v2)
  -- print $ 3 == B.length (F.flat t33)
  -- print $ 10 == B.length (F.flat wordsV)
  -- print $ 67 == B.length (F.flat car1)
  -- --print F.eee
  print $ ("flat",encodeOnly PkgFlat car1,"store",encodeOnly PkgStore car1,"cbor",encodeOnly PkgCBOR car1)

  pp (Node (Leaf One) (Leaf Two))
  pp ((One,Two,Three),(One,Two,Three),(One,Two,Three))
  pp t33
  pp (asN33 4)
  pp v1
  pp v2
  pp [Five,Five,Five]
  pp "aaa"
  pp vw
  pp wordsV
  --nprint (F.encode (undefined::Various))
    where pp v = print (v,F.encode v) --  F.<> F.eFiller)

mainWeight = do
  forceCafs
  mainWith $ do
    --ww nativeListT
    ww treeNLargeT
    --ww wordsT

  pp nativeListT
  pp treeNLargeT
  pp wordsT
  pp unicodeStrT
  --pp unicodeTextUTF8T

  where
    ww o = do
      weightT "store" PkgStore o
      weightT "binary" PkgBinary o
      -- weightT "cbor" PkgCBOR o
      weightT "flat" PkgFlat o

pp o = do
  pl "store" PkgStore o
  pl "binary" PkgBinary o
  pl "flat" PkgFlat o

plf = pl "flat" PkgFlat

pl kname k (n,v) = putStrLn (unwords ["Len serialise",kname,n,commas $ encodeOnly k v])
weightT kname k (n,v) = func (unwords ["serialise",kname,n]) (encodeOnly k) v

encodeOnly k = B.length . serialize . k

mainEvents = mainAlternatives

-- #define PKG_BINARY

mainProfile = mapM_ (\_ -> enc treeNT) [1..1000] -- mapM_ (\_ -> enc (0x34::Word) >> enc tree1 >> enc tree2) [1..10]
  where enc = evaluate . B.length . serialize . PkgFlat -- PkgBit2

mainAlternatives = dec_ tupleT >> dec_ tupleBools >> dec_ arr0 >> dec_ arr1 >> dec_ asciiStrT >> dec_ unicodeStrT >> dec_ lN3T >> dec_ treeNLargeT -- dec_ sbs >> dec_ lbs >>
  where
    -- dec1 = evaluate . and . Prelude.map (\_ -> des) $ [1..1]
    -- des = let (Right (PkgFlat a)) = deserialize PkgFlat.serlN2 in (a == lN2)
    dec_ dt@(n,_) = event (Prelude.concat [testName,"_",n]) $ (mapM (\_ -> d dt) [1..1])
#ifdef PKG_BINARY
    d = op "binary" PkgBinary
#elif PKG_QUID2
    d = op "quid2" PkgFlat
#elif PKG_STORE
    d = op "store" PkgStore
#elif PKG_CBOR
    d = op "cbor" PkgCBOR
#endif
#if OP_DEC
    testName = "dec"
    op = decM
#elif OP_ENC
    testName = "enc"
    op _ pkg v = (evaluate . B.length . serialize . pkg $ v)
#elif OP_ENCDEC
    testName = "encDec"
    op = encDecM
#endif

workDir = "."

mainBench = do
  mainBench_ (reportsFile workDir)
  ms <- updateMeasures_ workDir

  printMeasuresDiff ms
  -- printMeasuresAll ms
  printMeasuresCurrent ms

--mainBench = defaultMainWith (defaultConfigFilePath {
mainBench_ jsonReportFile = defaultMainWith (defaultConfig {jsonFile= Just jsonReportFile}) (
  concat [
   --tstDec carT
   --tstDec nativeListT
   --,tstDec treeNLargeT
   --,tstDec treeNNNLargeT
   --,tstDec wordsT,tstDec words0T
   --,tstDec vwT,tstDec vfT,tstDec viT
   -- ,tstDec v2T
   -- -- ,tstDec charT
   -- ,tstDec unicharT
   -- ,tstDec lN2T
   -- -- --,tstDec lN3T
   -- -- flat fails to complete:
   --tstDec treeN33LargeT
   tstDec mapT--,tstDec seqNT
   -- ,tstDec asciiStrT
   --,tstDec unicodeStrT
   --,tstDec unicodeTextT
   --,tstDec unicodeTextUTF8T
   -- --,tstDec sbs,tstDec lbs
   --,tstDec shortbs
   ]

   -- ++ [
   --    tstMaxSize treeNLargeT
   --    ,tstMaxSize treeNNNLargeT,tstMaxSize nativeListT
   --    ,tstMaxSize wordsT,tstMaxSize words0T
   --    ,tstMaxSize vwT,tstMaxSize vfT,tstMaxSize viT
   --    ,tstMaxSize carT,tstMaxSize seqNT
   -- ]
     -- -- ,tstEnc viiT,,tstEnc intsT
  -- ,tstEnc sbs,tstEnc lbs --,tstEnc shortbs

  --,tstEnc treeN33LargeT
  --,tstEnc floatT,tstEnc doubleT
  --   ++ join [tstDec carT
  --           --,tstDec wordsT,tstDec vwT
  --           --,tstDec lN3T,tstDec treeNLargeT,tstDec lN2T
  --
  --]
  )

{-
   tstEnc (0x34::Word)
  ,tstEnc (0x1289::Word)
  ,tstEnc (0x221289::Word)
  ,tstEnc (0x55221289::Word)
  ,tstEnc (0x1233456712345533::Word)

  ,tstEnc ((-120)::Int)
  ,tstEnc ((-1203321312)::Int)

   tstEnc (3.4512312::Float)
  ,tstEnc (-0.4511231232312::Double)

  ,tstEnc 'z'
  ,tstEnc '中'

  -- sequences
  ,tstEnc hl1
  ,tstEnc hl2
  ,tstEnc hl3

  ,tstEnc s1
  ,tstEnc s2
  ,tstEnc s3
  ,tstEnc s4

  ,tstEnc t1
  ,tstEnc t2
  ,tstEnc t3
  ,tstEnc t4

  ,tstEnc b1
  ,tstEnc b2
  -- ,tstEnc lb1
  -- ,tstEnc lb2

  -- generic
  -- ,tstEnc True
  -- ,tstEnc ('a','b',('c','d',('e','f','g')))
-}
  --

  -- tstEnc treeNT,tstEnc treeNLargeT,tstEnc lN2T,tstEnc lN3T

  -- ,tstEnc oneT

  -- recursive structure  tstEnc lBool

  -- ,tstEnc tree2

  --
  -- ,tstDecM lN2T
  -- tstEncDecM lN2T,tstEncDecM lN3T
  -- tstEncDecM treeNT,tstEncDecM treeNLargeT,tstEncDecM lN2T,tstEncDecM lN3T,
  -- tstDecM treeNT,tstDecM lN2T,tstDecM lN3T,tstDecM treeNLargeT

  -- tstEncDecM tuple0T,tstEncDecM tupleT,
  -- tstEncDecM word8T,tstEncDecM int8T
  --tstEncDecM word64T,tstEncDecM int64T,tstEncDecM integerT,

  --tstEnc carT
  -- ,tstEnc floatT,tstEnc doubleT,tstEnc floatsT,tstEnc floatsUnaT,tstEnc vfT

  -- tstEnc sbs,tstEnc lbs
  --,tstEnc shortbs
  --,tstEnc wordsT,tstEnc vwT
  --,tstEnc intsT,tstEnc viT,tstEnc viiT
  --tstEnc charT,tstEnc unicharT
  -- ,tstEnc nativeListT,tstEnc unicodeStrT,tstEnc treeNLargeT
   -- ,tstEnc lN3T
  --,tstEnc asciiStrT

  -- ,tstEnc unicodeTextT

  -- ,tstEnc treeN33LargeT
  --,tstEnc lN3T

    -- tstEnc v2T,
 -- tstEnc t33T,
 -- tstEnc treeVariousT
 -- ,tstEnc treeNT

  --tstEnc carT,tstEnc floatsT,tstEnc tupleT,tstEnc tupleBools,tstEnc tupleWords,tstEnc arr0, tstEnc arr1, tstEnc asciiStrT,tstEnc unicodeStrT,tstEnc unicodeTextT , tstEnc lN3T,
  --tstEncDec floatT,tstEncDec doubleT,tstEncDec tupleT,tstEncDec tupleBools,tstEncDec tupleWords,tstEncDec arr0, tstEncDec arr1, tstEncDec asciiStrT,tstEncDec unicodeStrT,tstEncDec unicodeTextT , tstEncDec lN3T, tstEncDec treeNLargeT
  -- tstEncDecM tupleT,tstEncDecM tupleBools,tstEncDecM tupleWords,tstEncDecM arr0, tstEncDecM arr1, tstEncDecM asciiStrT,tstEncDecM unicodeStrT,tstEncDecM unicodeTextT , tstEncDecM lN3T, tstEncDecM treeNLargeT
  --tstEncDecM treeNT,tstEncDecM treeNLargeT,tstEncDecM lN2T,tstEncDecM lN3T
  -- ,tstDecM treeNT,tstDecM treeNLargeT,tstDecM lN2T,tstDecM lN3T
  -- ,tstDecM treeNLargeT

  --tstED lN3T,tstED treeNLargeT

  --,tstEncDecM treeNT
{-
  ,tstEncDec treeN
  ,tstEncDec lN2
  ,tstEncDec lN3
  ,tstEncDec (Two,One,(Five,Three,(Three,(),Two)))
  ,tstEncDec One
-}
 -- ,tstEncodeDecode "BEPkg" BEPkg,  tstEncodeDecode "PkgCBOR" PkgCBOR
{-
  ,tstEncodeDecode "PkgBinary" PkgBinary
  -- ,tstEncodeDecode "PkgCereal" PkgCereal
  ,tstEncodeDecode "PkgFlat" PkgFlat
  -- ,tstEncodeDecode "PkgByte" PkgByte
  -- ,tstEncodeDecode "PkgByte2" PkgByte2
  -- ,tstEncodeDecode "PkgBit" PkgBit
  -- ,tstEncodeDecode "PkgBit2" PkgBit2
-}
{-
  ,tstEncodeDeep "BEPkg" BEPkg BEPkg
  ,tstEncodeDeep "PkgBinary" PkgBinary PkgBinary
  ,tstEq
-}
                                                               --(join [
tstED t = bgroup ("tstEncDecsM") [tstEnc t
                                 --,tstEncM t
                                 ,tstDecM t
                                 ,tstEncDecM t,tstEncDec t]

tstEncDecM lv@(vn,v) =
  bgroup ("tstEncDecM") [
              tst "quid2" PkgFlat
             ,tst "cbor" PkgCBOR
             -- ,tst "new-binary" BEPkg
             ,tst "binary" PkgBinary
             ,tst "store" PkgStore
             --,tst "cereal" PkgCereal
             ]
      where
        tst n c = bench (unwords[n,vn]) $ nfIO (encDecM n c lv)

df n vn = Prelude.concat[workDir,"/benchmarks/data/tstEncDec-",vn,"-",n]

encDecM n c (vn,v) = do
          let f = df n vn
          B.writeFile f . serialize . c $ v
          rs <- deserialize . B.fromStrict <$> BS.readFile f
          -- print rs
          let Right r = rs
          when (r /= c v) $ dataErr f
          -- r <- BS.readFile f
          -- evaluate (BS.length r)
          -- evaluate (B.length . serialize . c $ v)

decM n c (vn,v) = do
          let f = df n vn
          Right r <- deserialize . B.fromStrict <$> BS.readFile f
          when (r /= c v) $ dataErr f

dataErr f = error . unwords $ ["Data mismatch on",f]

tstEncM (vn,v) =
  bgroup ("tstEncM") [
              tst "quid2" PkgFlat
             -- tst "new-binary" BEPkg
             ,tst "binary" PkgBinary
             --,tst "cereal" PkgCereal
             ]
      where
        tst n c = bench (unwords[n,vn]) $ nfIO (rw n c)
        rw n c = do
          let f = df n vn
          removeFile f
          B.writeFile f . serialize . c $ v
          -- Right r <- deserialize . B.fromChunks . (:[]) <$> BS.readFile f
          -- when (r /= c v) $ print "Data mismatch"
          r <- BS.readFile f
          evaluate (BS.length r)
          -- print $ BS.length r
          -- evaluate (B.length . serialize . c $ v)

tstDecM d@(vn,v) =
  bgroup ("tstDecM") [
              tst "quid2" PkgFlat
             -- ,tst "new-binary" BEPkg
             ,tst "cbor" PkgCBOR
             ,tst "binary" PkgBinary
--             ,tst "binary-strict" PkgBinaryStrict
             --,tst "cereal" PkgCereal
             ]
      where
        tst n c = bench (unwords[n,vn]) $ nfIO (decM n c d)
{-
        rw n c = do
          let f =
          Right r <- deserialize . B.fromStrict <$> BS.readFile f
          when (r /= c v) $ print "Data mismatch"
          -- r <- BS.readFile f
          -- when (BS.length r < 0) $ print "Data mismatch"
-}

tstEncDec (vn,v) = let nm s = unwords[s,vn] -- unwords [s,Prelude.take 400 $ show v]
 in bgroup ("tstEncDec") [
  bench (nm "flat")   $ nf (encodeInverseOfDecode PkgFlat) v
  ,bench (nm "cbor") $ nf (encodeInverseOfDecode PkgCBOR) v
  ,bench (nm "binary") $ nf (encodeInverseOfDecode PkgBinary) v
  ,bench (nm "store") $ nf (encodeInverseOfDecode PkgStore) v
  --,bench (nm "cereal")     $ nf (encodeInverseOfDecode PkgCereal) v
  ]

encodeInverseOfDecode k v = let x = k v
                                Right r = (deserialize . serialize) x
                            in x == r

tstEncE (vn,v) =
  let nm s = Prelude.concat [vn,"-",s] -- unwords [s,Prelude.take 400 $ show v]
  in bgroup ("tstEnc") [
    --bench (nm "store")     $ nf (encodeOnly PkgStore) v
    --,bench (nm "binary")     $ nf (encodeOnly PkgBinary) v
    --,bench (nm "cbor")     $ nf (encodeOnly PkgCBOR) v
    bench (nm "flat")  $ nf (encodeOnly PkgFlat) v
    ]
  where encodeOnly k = B.length . serialize . k

-- tstDec :: forall b. (S.Store b, F.Flat b,Eq b) => (String, b) -> Benchmark

tstMaxSize (vn,v) =
  let nm s = Prelude.concat [vn,"-",s] -- unwords [s,Prelude.take 400 $ show v]
  in bgroup ("tstMaxSize") [
    bench (nm "flatClassSizeSimple")  $ nf (F.getSize) v
    --,bench (nm "store")  $ nf (S.getSize) v
    ]
  where encodeOnly k = B.length . serialize . k

tstEnc (vname,obj) =
  let nm s = Prelude.concat [vname,"-",s]
  in bgroup ("tstEnc") $ map (\(pkg,_,s,d) -> bench (nm pkg) $ nf (L.length . s) obj) pkgs

tstDec (vname,obj) =
  let nm s = Prelude.concat [vname,"-",s] -- unwords [s,Prelude.take 400 $ show v]
  in [
     bgroup ("tstEncDec") $ map (\(_,pkg,s,d) -> bench (nm pkg) $ nf (\obj -> d (s obj) == Right obj) obj) pkgs
     ,bgroup ("tstEnc") $ map (\(pkg,_,s,d) -> bench (nm pkg) $ nf (B.length . s) obj) pkgs

     --bgroup ("tstDec") $ map (\(_,pkg,s,d) -> env (return $! s obj) $ (\bs -> bench (nm pkg) $ nfIO ((Right obj ==) <$> (return . force . d) bs))) pkgs
     -- in [bgroup ("tstEncDec") $ map (\(pkg,s,d) -> bench (nm pkg) $ nf (\obj -> d (s obj) == Right obj) obj) pkgs
     --,bgroup ("tstDec") $ map (\(pkg,s,d) -> env (return $ s obj) $ (\bs -> bench (nm pkg) $ nf (\obj -> Right obj == d bs) obj)) pkgs
     --,bgroup ("tstDec") $ map (\(pkg,s,d) -> env (return $ s obj) $ (\bs -> bench (nm pkg) $ nfIO ((Right obj ==) <$> return (d bs)))) pkgs
      --bgroup ("tstDec") $ map (\(_,pkg,s,d) -> env (return $ s obj) $ (\bs -> bench (nm pkg) $ whnfIO ((Right obj ==) <$>  (return . force . d $ bs)))) pkgs
     --,bench ("tstEq/"++nm "any") $ nf (\o -> o == o) obj
     ]

pt (n,v) = map (\(_,pkg,s,d) -> Right v == d (s v)) pkgs

--pkgs :: (CC.Serialize a ,C.Serialise a,S.Store a,B.Binary a,F.Flat a) => [(String,String,a -> L.ByteString,L.ByteString -> Either String a)]
-- pkgs = [S.sd,B.sd,C.sd,CC.sd,F.sd]

-- pkgs :: (C.Serialise a) => [(String,String,a -> L.ByteString,L.ByteString -> Either String a)]
-- pkgs = [C.sd]

-- pkgs :: (C.Serialise a,S.Store a,B.Binary a,F.Flat a) => [(String,String,a -> L.ByteString,L.ByteString -> Either String a)]
-- pkgs = [S.sd,B.sd,C.sd,F.sd]

pkgs :: (B.Binary a,S.Store a,F.Flat a) => [(String,String,a -> L.ByteString,L.ByteString -> Either String a)]
pkgs = [S.sd,F.sd]

-- pkgs :: (F.Flat a) => [(String,String,a -> L.ByteString,L.ByteString -> Either String a)]
-- pkgs = [F.sd]

tstEncodeDeep name k1 k2 = bgroup ("serialize " ++ name) [
   bench "tree1"  $ nf (encodeOnly k1) tree1
  ,bench "tree2" $ nf (encodeOnly k2) tree2
  ]
  where encodeOnly k = B.length . serialize . k

tstDec2 = bgroup ("tstDec2") [
  bench "lN2-binary" $ nf (\v -> let Right (PkgBinary a) = deserialize PkgBinary.serlN2 in a == v) lN2
  ,bench "lN2-flat" $ nf (\v -> let Right (PkgFlat a) = deserialize PkgFlat.serlN2 in a == v) lN2
  ]

tstEncodeDecode name k1 = bgroup ("serialize+deserialise " ++ name) [
  -- bench "tree1" $ whnf (encodeInverseOfDecode k1) tree1
  --,bench "tree2" $ whnf (encodeInverseOfDecode k2) tree2
   -- ,bench "car1" $ whnf encodeInverseOfDecode car1
   bench "lN2" $ nf (encodeInverseOfDecode k1) lN2
  ,bench "lN3" $ nf (encodeInverseOfDecode k1) lN3
  -- bench "treeN" $ nf (encodeInverseOfDecode k1) treeN
  ]

-- dec p b v = let (Right p) = deserialize b in (unPkg p == v)

-- encodeInverseOfDecode :: (Serialize a, Eq a) => (t -> a) -> t -> Bool
{-
tstEq = bgroup ("equal") [
  bench "lBool" $ whnf eq lBool
  ,bench "tree1" $ whnf eq tree1
  ,bench "tree2" $ whnf eq tree2
  ,bench "car1" $ whnf eq car1
  ]
-}

eq v = (v == v) == True


module StructureKit.Prelude
  ( module Exports,
    guarded,
    mapCoercible,
    mapCoercible2,
    traverseCoercible,
    showBin,
    showBinFinite,

    -- * --
    BVec,
    UVec,
  )
where

import Control.Applicative as Exports hiding (WrappedArrow (..))
import Control.Arrow as Exports hiding (first, second)
import Control.Category as Exports
import Control.Concurrent as Exports
import Control.DeepSeq as Exports
import Control.Exception as Exports
import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_)
import Control.Monad.Fail as Exports
import Control.Monad.Fix as Exports hiding (fix)
import Control.Monad.IO.Class as Exports
import Control.Monad.Primitive as Exports
import Control.Monad.ST as Exports
import Control.Monad.Trans.Class as Exports
import Control.Monad.Trans.Cont as Exports hiding (callCC, shift)
import Control.Monad.Trans.Except as Exports (Except, ExceptT (ExceptT), catchE, except, mapExcept, mapExceptT, runExcept, runExceptT, throwE, withExcept, withExceptT)
import Control.Monad.Trans.Maybe as Exports
import Control.Monad.Trans.Reader as Exports (Reader, ReaderT (ReaderT), ask, mapReader, mapReaderT, runReader, runReaderT, withReader, withReaderT)
import Control.Monad.Trans.State.Strict as Exports (State, StateT (StateT), evalState, evalStateT, execState, execStateT, mapState, mapStateT, runState, runStateT, withState, withStateT)
import Control.Monad.Trans.Writer.Strict as Exports (Writer, WriterT (..), execWriter, execWriterT, mapWriter, mapWriterT, runWriter)
import Data.Bifunctor as Exports
import Data.Bits as Exports
import Data.Bool as Exports
import Data.ByteString as Exports (ByteString)
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 hiding (toList)
import Data.Function as Exports hiding (id, (.))
import Data.Functor as Exports
import Data.Functor.Compose as Exports
import Data.Functor.Identity as Exports
import Data.Group as Exports
import Data.Hashable as Exports (Hashable (hash, hashWithSalt))
import Data.IORef as Exports
import Data.Int as Exports
import Data.IntMap.Strict as Exports (IntMap)
import Data.IntSet as Exports (IntSet)
import Data.Ix as Exports
import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, filter, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, map, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, singleton, sortOn, sum, uncons)
import Data.List.NonEmpty as Exports (NonEmpty (..))
import Data.Maybe as Exports hiding (catMaybes, mapMaybe)
import Data.Monoid as Exports hiding (Alt)
import Data.Ord as Exports
import Data.Primitive as Exports hiding (alignment, sizeOf)
import Data.Proxy as Exports
import Data.Ratio as Exports
import Data.STRef as Exports
import Data.Semigroup as Exports hiding (First (..), Last (..))
import Data.String as Exports
import Data.String.ToString as Exports (ToString (..))
import Data.Text as Exports (Text)
import Data.Traversable as Exports
import Data.Tuple as Exports
import Data.Unique as Exports
import qualified Data.Vector as BVec
import qualified Data.Vector.Unboxed as UVec
import Data.Version as Exports
import Data.Void as Exports
import Data.Word as Exports
import Debug.Trace as Exports
import DeferredFolds.Unfoldr as Exports (Unfoldr (..))
import Deque.Strict as Exports (Deque)
import Foreign.ForeignPtr as Exports
import Foreign.Ptr as Exports
import Foreign.StablePtr as Exports
import Foreign.Storable as Exports
import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)
import GHC.Exts as Exports (IsList (..), groupWith, inline, lazy, sortWith)
import GHC.Generics as Exports (Generic)
import GHC.IO.Exception as Exports
import GHC.OverloadedLabels as Exports
import Numeric as Exports hiding (showBin)
import System.Environment as Exports
import System.Exit as Exports
import System.IO as Exports (Handle, hClose)
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, readP_to_S, readS_to_P)
import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec)
import Text.Printf as Exports (hPrintf, printf)
import Text.Read as Exports (Read (..), readEither, readMaybe)
import Unsafe.Coerce as Exports
import Witherable as Exports
import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, filter, foldl, foldl1, foldr, foldr1, id, map, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.))

guarded :: Alternative f => (a -> Bool) -> a -> f a
guarded pred x = if pred x then pure x else empty

mapCoercible :: Coercible a b => (a -> a) -> b -> b
mapCoercible mapper =
  coerce . mapper . coerce

mapCoercible2 :: Coercible f g => (g a -> g b) -> f a -> f b
mapCoercible2 mapper =
  coerce . mapper . coerce

traverseCoercible :: (Coercible a b, Functor f) => (a -> f a) -> b -> f b
traverseCoercible f =
  fmap coerce . f . coerce

showBin :: (Integral a, Show a) => a -> String
showBin a = showIntAtBase 2 intToDigit a ""

showBinFinite :: (Integral a, Show a, FiniteBits a) => a -> String
showBinFinite a =
  let str = showBin a
      len = length str
      rem = finiteBitSize a - len
      pad = replicate rem '0'
   in pad <> str

type BVec = BVec.Vector

type UVec = UVec.Vector


module Main (main) where

import Data.Complex
import Data.HDF5
import qualified Data.Vector.Storable as V
import System.Directory
import Test.Hspec
import Prelude hiding (withFile)

anyH5Exception :: Selector H5Exception
anyH5Exception = const True

main :: IO ()
main = hspec $ do
  describe "Files" $ do
    it "opens an existing file" $ do
      doesFileExist "test/reading_test.h5" `shouldReturn` True
      _ <- withFile "test/reading_test.h5" ReadOnly (\_ -> return ())
      return ()
    it "throws an exceptions when file does not exist" $ do
      withFile "test/not_there.h5" ReadOnly (\_ -> return ()) `shouldThrow` anyH5Exception
    it "truncates a file if it already exists" $ do
      copyFile "test/reading_test.h5" "test/truncate_test.h5"
      _ <- withFile "test/truncate_test.h5" WriteTruncate (\_ -> return ())
      isSmaller <- (<) <$> getFileSize "test/truncate_test.h5" <*> getFileSize "test/reading_test.h5"
      isSmaller `shouldBe` True
      removeFile "test/truncate_test.h5"
    it "appends to a file if it already exists" $ do
      copyFile "test/reading_test.h5" "test/append_test.h5"
      _ <- withFile "test/append_test.h5" WriteAppend (\_ -> return ())
      isSame <- (==) <$> getFileSize "test/append_test.h5" <*> getFileSize "test/reading_test.h5"
      isSame `shouldBe` True
      removeFile "test/append_test.h5"
    it "creates a file if it does not exist" $ do
      doesFileExist "test/a_non_existant_file.h5" `shouldReturn` False
      _ <- withFile "test/a_non_existant_file.h5" WriteTruncate (\_ -> return ())
      doesFileExist "test/a_non_existant_file.h5" `shouldReturn` True
      removeFile "test/a_non_existant_file.h5"
  describe "Datasets" $ do
    it "writes strided datasets" $ do
      (matrix :: TemporaryStridedMatrix Float) <-
        withFile' "test/strided_test_file.h5" WriteTruncate $ \g -> do
          writeDataset g "A" $ TemporaryStridedMatrix (2, 3) 4 (V.fromList [(1 :: Float) .. 8])
          openDataset @Text g "A" >>= readDataset
      matrix `shouldBe` (TemporaryStridedMatrix (2, 3) 3 (V.fromList [1, 2, 3, 5, 6, 7]))
      removeFile "test/strided_test_file.h5"
    it "writes complex datasets" $ do
      xs <-
        withFile' "test/complex_test_file.h5" WriteTruncate $ \g -> do
          writeDataset g "A" $ [((1 :: Double) :+ 2), ((-5) :+ 0.1)]
          openDataset @Text g "A" >>= readDataset
      xs `shouldBe` [((1 :: Double) :+ 2), ((-5) :+ 0.1)]
      removeFile "test/complex_test_file.h5"

-- removeFile "test/strided_test_file.h5"


module Main ( main ) where

import Prelude hiding (catch)

import Control.Exception.Extensible (ArithException (..))
import Control.Monad.Catch          as MC

import Control.Monad (liftM, when)

import Control.Concurrent      (forkIO)
import Control.Concurrent.MVar

import qualified Data.Complex as Complex

import System.Directory
import System.Exit
import System.FilePath
import System.IO

import qualified TEST_A
import qualified TEST_B

import           Test.HUnit ((@?), (@?=))
import qualified Test.HUnit as HUnit

import Language.Haskell.Interpreter

test_reload_modified :: TestCase
test_reload_modified = TestCase "reload_modified" [mod_file] $ do
                            liftIO $ writeFile mod_file mod_v1
                            f_v1 <- get_f
                            --
                            liftIO $ writeFile mod_file mod_v2
                            f_v2 <- get_f
                            --
                            liftIO $ (f_v1 5, f_v2 5) @?= (5, 6)
    --
    where mod_name = "TEST_ReloadModified"
          mod_file = mod_name ++ ".hs"
          --
          mod_v1   = unlines ["module " ++ mod_name,
                              "where",
                              "f :: Int -> Int",
                              "f = id"]
          mod_v2   = unlines ["module " ++ mod_name,
                              "where",
                              "f :: Int -> Int",
                              "f = (1 +)"]
          --
          get_f    =  do loadModules [mod_file]
                         setTopLevelModules [mod_name]
                         r <- interpret "f" (as :: Int -> Int)
                         return r

test_lang_exts :: TestCase
test_lang_exts = TestCase "lang_exts" [mod_file] $ do
                      liftIO $ writeFile mod_file "data T where T :: T"
                      fails do_load @@? "first time, it shouldn't load"
                      --
                      set [languageExtensions := [GADTs]]
                      succeeds do_load @@? "now, it should load"
                      --
                      set [languageExtensions := []]
                      fails do_load @@? "it shouldn't load, again"
    --
    where mod_name = "TEST_LangExts"
          mod_file = mod_name ++ ".hs"
          --
          do_load  = loadModules [mod_name]

test_work_in_main :: TestCase
test_work_in_main = TestCase "work_in_main" [mod_file] $ do
                        liftIO $ writeFile mod_file "f = id"
                        loadModules [mod_file]
                        setTopLevelModules ["Main"]
                        setImportsQ [("Prelude",Nothing),
                                       ("Data.Maybe", Just "Mb")]
                        --
                        typeOf "f $ (1 + 1 :: Int)" @@?= "Int"
                        eval "f . Mb.fromJust $ Just [1,2]" @@?= "[1,2]"
                        interpret "f $ 1 == 2" infer @@?= False
    --
    where mod_file     = "TEST_WorkInMain.hs"

test_priv_syms_in_scope :: TestCase
test_priv_syms_in_scope = TestCase "private_syms_in_scope" [mod_file] $ do
                               -- must set to True, otherwise won't work with
                               -- ghc 6.8
                               set [installedModulesInScope := True]
                               liftIO $ writeFile mod_file mod_text
                               loadModules [mod_file]
                               setTopLevelModules ["T"]
                               typeChecks "g" @@? "g is hidden"
    where mod_text = unlines ["module T(f) where", "f = g", "g = id"]
          mod_file = "TEST_PrivateSymbolsInScope.hs"

test_comments_in_expr :: TestCase
test_comments_in_expr = TestCase "comments_in_expr" [] $ do
                            setImports ["Prelude"]
                            let expr = "length $ concat [[1,2],[3]] -- bla"
                            typeChecks expr @@? "comment on expression"
                            _ <- eval expr
                            _ <- interpret expr (as :: Int)
                            return ()

test_qual_import :: TestCase
test_qual_import = TestCase "qual_import" [] $ do
                           setImportsQ [("Prelude", Nothing),
                                        ("Data.Map", Just "M")]
                           typeChecks "null []" @@? "Unqual null"
                           typeChecks "M.null M.empty" @@? "Qual null"
                           return ()

test_basic_eval :: TestCase
test_basic_eval = TestCase "basic_eval" [] $ do
                           eval "()" @@?= "()"

test_eval_layout :: TestCase
test_eval_layout = TestCase "eval_layout" [] $ do
                           eval layout_expr @@?= "10"
    where layout_expr = unlines $ ["let x = let y = 10",
                                   "        in y",
                                   "in x"]

test_show_in_scope :: TestCase
test_show_in_scope = TestCase "show_in_scope" [] $ do
                       setImports ["Prelude"]
                       eval "show ([] :: String)" @@?= show (show "")

test_installed_not_in_scope :: TestCase
test_installed_not_in_scope = TestCase "installed_not_in_scope" [] $ do
                                b <- get installedModulesInScope
                                succeeds action @@?= b
                                set [installedModulesInScope := False]
                                fails action @@? "now must be out of scope"
                                set [installedModulesInScope := True]
                                succeeds action @@? "must be in scope again"
    where action = typeOf "Data.Map.singleton"

test_search_path :: TestCase
test_search_path =
    TestCase "search_path" files $ do
           liftIO setup
           fails (loadModules [mod_1]) @@? "mod_1 should not be in path (1)"
           fails (loadModules [mod_2]) @@? "mod_2 should not be in path (1)"
           --
           set [searchPath := [dir_1]]
           succeeds (loadModules [mod_1]) @@? "mod_1 should be in path (2)"
           fails    (loadModules [mod_2]) @@? "mod_2 should not be in path (2)"
           --
           set [searchPath := [dir_2]]
           fails    (loadModules [mod_1]) @@? "mod_1 should not be in path (3)"
           succeeds (loadModules [mod_2]) @@? "mod_2 should be in path (3)"
           --
           set [searchPath := [dir_1,dir_2]]
           succeeds (loadModules [mod_1]) @@? "mod_1 should be in path (4)"
           succeeds (loadModules [mod_2]) @@? "mod_2 should be in path (4)"
    where dir_1  = "search_path_test_dir_1"
          mod_1  = "M1"
          file_1 = dir_1 </> mod_1 <.> "hs"
          dir_2  = "search_path_test_dir_2"
          mod_2  = "M2"
          file_2 = dir_2 </> mod_2 <.> "hs"
          files  = [file_1, file_2, dir_1, dir_2]
          setup  = do createDirectory dir_1
                      createDirectory dir_2
                      writeFile file_1 $
                         unlines ["module " ++ mod_1,
                                  "where",
                                  "x :: Int",
                                  "x = 42"]
                      writeFile file_2 $
                         unlines ["module " ++ mod_2,
                                  "where",
                                  "y :: Bool",
                                  "y = False"]

test_search_path_dot :: TestCase
test_search_path_dot =
    TestCase "search_path_dot" [mod_file, dir] $ do
           liftIO setup
           succeeds (loadModules [mod1]) @@? "mod1 must be initially in path"
           set [searchPath := [dir]]
           succeeds (loadModules [mod1]) @@? "mod1 must be still in path"
    --
    where dir      = "search_path_dot_dir"
          mod1     = "M1"
          mod_file = mod1 <.> "hs"
          setup    = do createDirectory dir
                        writeFile mod_file $
                           unlines ["x :: Int", "x = 42"]

test_catch :: TestCase
test_catch = TestCase "catch" [] $ do
        setImports ["Prelude"]
        succeeds (action `catch` handler) @@? "catch failed"
    where handler DivideByZero = return "catched"
          handler e = throwM e
          action = do s <- eval "1 `div` 0 :: Int"
                      return $! s

test_only_one_instance :: TestCase
test_only_one_instance = TestCase "only_one_instance" [] $ do
    liftIO $ do
        r <- newEmptyMVar
        let concurrent = runInterpreter (liftIO $ putMVar r False)
                          `catch` \MultipleInstancesNotAllowed ->
                                    do liftIO $ putMVar r True
                                       return $ Right ()
        _ <- forkIO $ concurrent >> return ()
        readMVar r @?  "concurrent instance did not fail"

test_interpret_respects_imports :: TestCase
test_interpret_respects_imports = TestCase "interpret_respects_imports" [] $ do
  setImportsQ [("Prelude", Just "FooBar"), ("Data.Complex", Nothing)]
  interpret "()" (as :: ()) @@?= ()
  interpret "FooBar.True" (as :: Bool) @@?= True
  interpret "1 :+ 2" (as :: Complex.Complex Double) @@?= (1 Complex.:+ 2)

test_interpret_module_duplication_with_Main :: TestCase
test_interpret_module_duplication_with_Main =
  TestCase "interpret_module_duplication_with_Main" [mod_file] $ do
    liftIO setup
    loadModules [mod_file]
    setTopLevelModules ["Main"]
    interpret "1 :+ 2" (as :: Complex.Complex Double) @@?= (1 Complex.:+ 2)
  where
    mod_name = "TEST_MOD_DUPE"
    mod_file = mod_name <.> "hs"
    setup = writeFile mod_file $
            unlines [ "module Main where"
                    , "import Data.Complex"]

test_interpret_resolve_type_name_collision :: TestCase
test_interpret_resolve_type_name_collision =
  TestCase "interpret_resolve_type_name_collision" [] $ do
    loadModules [mod_file_1, mod_file_2]
    setImportsQ [(mod_name_1, Just "A"), (mod_name_2, Just "B")]
    interpret "A.TEST_A" (as :: TEST_A.Dat) @@?= TEST_A.TEST_A
    interpret "B.TEST_B" (as :: TEST_B.Dat) @@?= TEST_B.TEST_B
  where
    mod_name_1 = "TEST_A"
    mod_name_2 = "TEST_B"
    mod_file_1 = "unit-tests" </> mod_name_1 <.> "hs"
    mod_file_2 = "unit-tests" </> mod_name_2 <.> "hs"

test_interpret_canonicalize_type_correctly :: TestCase
test_interpret_canonicalize_type_correctly =
  TestCase "interpret_canonicalize_types_correctly" [] $ do
    interpret "[]" (as :: [()]) @@?= ([] :: [()])
    (interpret "(():)" (as :: [()] -> [()]) <*> pure [])
      @@?= [()]
    interpret "(1,2,3)" (as :: (Int, Double, Float))
      @@?= (1,2,3)

tests :: [TestCase]
tests = [test_reload_modified
        ,test_lang_exts
        ,test_work_in_main
        ,test_comments_in_expr
        ,test_qual_import
        ,test_basic_eval
        ,test_eval_layout
        ,test_show_in_scope
        ,test_installed_not_in_scope
        ,test_priv_syms_in_scope
        ,test_search_path
        ,test_search_path_dot
        ,test_catch
        ,test_only_one_instance
        ,test_interpret_respects_imports
        ,test_interpret_resolve_type_name_collision
        ,test_interpret_module_duplication_with_Main
        ,test_interpret_canonicalize_type_correctly
        ]

main :: IO ()
main = do -- run the tests...
          c  <- runTests False tests
          -- then run again, but with sandboxing on...
          c' <- runTests True tests
          --
          let failures  = HUnit.errors c  + HUnit.failures c +
                          HUnit.errors c' + HUnit.failures c'
              exit_code
                  | failures > 0 = ExitFailure failures
                  | otherwise    = ExitSuccess
          exitWith exit_code
       -- `catch` (\_ -> exitWith (ExitFailure $ -1))

printInterpreterError :: InterpreterError -> IO ()
printInterpreterError = hPutStrLn stderr . show

setSandbox :: Interpreter ()
setSandbox = set [installedModulesInScope := False]

(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)
f >=> g = \a -> f a >>= g

(@@?) :: (HUnit.AssertionPredicable p, MonadIO m) => m p -> String -> m ()
p @@? msg = do b <- p; liftIO (b @? msg)

(@@?=) :: (Eq a, Show a, MonadIO m) => m a -> a -> m ()
m_a @@?= b = do a <- m_a; liftIO (a @?= b)

fails :: (MonadCatch m, MonadIO m) => m a -> m Bool
fails action = (action >> return False) `catchIE` (\_ -> return True)
  where
    catchIE :: MonadCatch m => m a -> (InterpreterError -> m a) -> m a
    catchIE = MC.catch

succeeds :: (MonadCatch m, MonadIO m) => m a -> m Bool
succeeds = liftM not . fails

data TestCase = TestCase String [FilePath] (Interpreter ())

runTests :: Bool -> [TestCase] -> IO HUnit.Counts
runTests sandboxed = HUnit.runTestTT . HUnit.TestList . map build
    where build (TestCase title tmps test) = HUnit.TestLabel title $
                                                 HUnit.TestCase test_case
            where test_case = go `finally` clean_up
                  clean_up = mapM_ removeIfExists tmps
                  go       = do r <- runInterpreter
                                            (when sandboxed setSandbox >> test)
                                either (printInterpreterError >=> (fail . show))
                                       return r
                  removeIfExists f = do existsF <- doesFileExist f
                                        if existsF
                                          then removeFile f
                                          else
                                            do existsD <- doesDirectoryExist f
                                               when existsD $
                                                  removeDirectory f


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}

module Network.NTP where

import           Control.Applicative ((<$>))
import           Control.Concurrent (forkIO)
import           Control.Concurrent.STM.TChan
import           Control.Exception (IOException, bracket, handle)
import           Control.Monad.IO.Class
import           Control.Monad.Loops (unfoldM)
import           Control.Monad.STM (atomically)
import           Control.Monad.State
import           Data.Bits (shiftR, shiftL, (.|.), (.&.))
import qualified Data.ByteString as B
import           Data.IORef
import           Data.Int (Int64)
import           Data.Maybe (listToMaybe)
import           Data.Serialize (encode, decode)
import qualified Data.Time.Clock as T
import qualified Data.Vector.Generic as Generic
import qualified Data.Vector.Generic.Mutable as MGeneric
import qualified Data.Vector.Unboxed as U
import           Data.Word (Word32, Word64)
import           Network.Socket hiding (send, sendTo, recv, recvFrom)
import           Network.Socket.ByteString
import qualified Statistics.Function as S
import qualified Statistics.Sample as S

import           Network.NTP.Types hiding (Server)
import           System.Counter
import           Text.PrefixSI

--import           Debug.Trace
--import           Text.Printf (printf)

------------------------------------------------------------------------
-- NTP Monad

newtype NTP a = NTP { runNTP :: StateT NTPData IO a }
    deriving (Functor, Monad, MonadIO, MonadState NTPData)

data NTPData = NTPData {
      ntpSocket   :: Socket
    , ntpIncoming :: TChan AddrPacket
    , ntpRunning  :: IORef Bool
    }

data AddrPacket = AddrPacket ClockIndex SockAddr Packet
type Logger = String -> IO ()

withNTP :: Logger -> NTP a -> IO a
withNTP writeLog =
    fmap fst . withSocketsDo . bracket create destroy . runStateT . runNTP
  where
    create = do
        ntpSocket   <- initSocket
        ntpIncoming <- newTChanIO
        ntpRunning  <- newIORef True

        let enqueue = atomically . writeTChan ntpIncoming
            receiveLoop = do
              pkt <- receive ntpSocket
              ok  <- readIORef ntpRunning
              if ok then either writeLog enqueue pkt >> receiveLoop
                    else return ()

        -- start receive packet loop
        forkIO receiveLoop

        return NTPData{..}

    destroy NTPData{..} = do
        writeIORef ntpRunning False
        sClose ntpSocket

    initSocket = do
        sock <- socket AF_INET Datagram defaultProtocol
        bindSocket sock (SockAddrInet 0 0)
        return sock

------------------------------------------------------------------------
-- Clock

type ClockIndex = Int64
type ClockDiff  = Int64
type ClockDiffD = Double
type Seconds    = Double

data Clock = Clock {
      clockTime0      :: Time
    , clockIndex0     :: ClockIndex
    , clockFrequency  :: Double
    , clockPrecision  :: Word64
    }

-- | Initializes a 'Clock' based on the high precision counter.
initCounterClock :: Logger -> IO Clock
initCounterClock logger = do
    logger "Analyzing high precision counter..."

    counter <- analyzeCounter

    let clockFrequency = fromIntegral (cntFrequency counter)
        clockPrecision = cntPrecision counter
        freq = clockFrequency
        prec = fromIntegral clockPrecision / freq

    logger ("Frequency = " ++ showFreq freq)
    logger ("Precision = " ++ showTime prec)

    clockTime0  <- fromUTCTime <$> T.getCurrentTime
    clockIndex0 <- getCurrentIndex

    return Clock{..}

-- | Gets the current time according to the high res counter.
getCurrentIndex :: IO ClockIndex
getCurrentIndex = fromIntegral <$> readCounter

-- | Gets the current time according to the 'Clock'.
getCurrentTime :: Clock -> IO Time
getCurrentTime clock = clockTime clock <$> getCurrentIndex

-- | Gets the time at the given index.
clockTime :: Clock -> ClockIndex -> Time
clockTime Clock{..} index = clockTime0 `add` fromSeconds off
  where
    off  = diff / freq
    -- TODO: Unsigned subtract breaks when index is earlier than clockIndex0.
    --       This is the case for servers which have not responded for a while
    --       as we continually move clockIndex0 forward using adjustOrigin.
    diff = fromIntegral (index - clockIndex0)
    freq = clockFrequency

-- | Gets the index at the given time.
clockIndex :: Clock -> Time -> ClockIndex
clockIndex Clock{..} time = clockIndex0 + round (diff * freq)
  where
    diff = toSeconds (time `sub` clockTime0)
    freq = clockFrequency

-- | Gets a clock difference in seconds
fromDiff :: Clock -> ClockDiff -> Seconds
fromDiff Clock{..} d = fromIntegral d / clockFrequency

adjustFrequency :: Double -- ^ the drift rate in seconds/second
                -> Clock -> Clock
adjustFrequency adj c = c
    { clockFrequency = (1 - adj) * clockFrequency c }

adjustOffset :: Seconds -- ^ the offset in seconds
             -> Clock -> Clock
adjustOffset adj c = c
    { clockTime0 = clockTime0 c `add` fromSeconds adj }

adjustOrigin :: ClockIndex -- ^ the new clockIndex0
             -> Clock -> Clock
adjustOrigin newIndex0 c = c
    { clockTime0  = clockTime c newIndex0
    , clockIndex0 = newIndex0 }

setFrequency :: Double -> Clock -> Clock
setFrequency freq c = c { clockFrequency = freq }

------------------------------------------------------------------------
-- Server

data Server = Server {
      svrHostName     :: HostName
    , svrSockAddr     :: SockAddr
    , svrRawSamples   :: U.Vector Sample
    , svrMinRoundtrip :: ClockDiff
    , svrBaseError    :: ClockDiff
    , svrStratum      :: Int
    , svrRefId        :: B.ByteString
    , svrRefAddr      :: HostAddress
    , svrClock        :: Clock
    }

svrName :: Server -> String
svrName svr | host /= addr = host ++ " (" ++ addr ++ ")"
            | otherwise    = host
  where
    host = svrHostName svr
    addr = (takeWhile (/= ':') . show . svrSockAddr) svr

svrAddr :: Server -> HostAddress
svrAddr Server{..} = case svrSockAddr of
    (SockAddrInet _ addr) -> addr
    _                     -> error "svrAddr: unexpected non-IPv4 address"

-- | Resolves a list of IP addresses registered for the specified
-- hostname and creates 'Server' instances for each of them.
resolveServer :: Clock -> HostName -> IO (Maybe Server)
resolveServer clock host = ioErrorToNothing $
    listToMaybe . map (mkServer . addrAddress) <$> getHostAddrInfo
  where
    mkServer addr = Server host addr U.empty 0 0 0 B.empty 0 clock

    getHostAddrInfo = getAddrInfo hints (Just host) (Just "ntp")

    hints = Just defaultHints { addrFamily     = AF_INET
                              , addrSocketType = Datagram }

    ioErrorToNothing = handle (\(_ :: IOException) -> return Nothing)

transmit :: Server -> NTP ()
transmit Server{..} = do
    NTPData{..} <- get
    liftIO $ do
        now <- fromIntegral <$> getCurrentIndex
        let msg = (encode . requestMsg . Time) now
        sendAllTo ntpSocket msg svrSockAddr

receive :: Socket -> IO (Either String AddrPacket)
receive sock = handleIOErrors $ do
    (bs, addr) <- recvFrom sock 128
    t          <- getCurrentIndex
    return $ case decode bs of
        Left err  -> Left err
        Right pkt -> Right (AddrPacket t addr pkt)
  where
    handleIOErrors = handle (\(e :: IOException) -> return (Left (show e)))

updateServers :: [Server] -> NTP [(Server, Bool)]
updateServers svrs = do
    NTPData{..} <- get
    liftIO $ do
        pkts <- unfoldM (tryReadChan ntpIncoming)
        return $ map (update pkts) (zip svrs (repeat False))
  where
    update :: [AddrPacket] -> (Server, Bool) -> (Server, Bool)
    update = fconcat . map go
      where
        go (AddrPacket t addr pkt) (svr, up)
          | addr == svrSockAddr svr = (updateServer svr t pkt, True)
          | otherwise               = (svr, up)

    fconcat :: [a -> a] -> a -> a
    fconcat = foldl (.) id

    tryReadChan chan = atomically $ do
        empty <- isEmptyTChan chan
        if empty then return Nothing
                 else Just <$> readTChan chan

updateServer :: Server -> ClockIndex -> Packet -> Server
updateServer svr t4 p@Packet{..} =
    adjustClock svr
    { svrRawSamples   = samples
    , svrMinRoundtrip = round minRoundtrip
    , svrBaseError    = round (3 * stdDevRoundtrip)
    , svrStratum      = fromIntegral ntpStratum
    , svrRefId        = decodeRefId p
    , svrRefAddr      = byteSwap32 ntpRefId
    }
  where
    newSample = (fromIntegral (unTime ntpT1), ntpT2, ntpT3, t4)

    -- force the evaluation of the last sample in the list
    -- to avoid building up lots of unevaluated thunks
    samples = U.take maxSamples (newSample `U.cons` svrRawSamples svr)

    minRoundtrip    = U.head bestRoundtrips
    stdDevRoundtrip = S.stdDev bestRoundtrips

    -- Trim roundtrips so that outliers due to network congestion are
    -- not included in our quality weights.
    roundtrips     = U.map (fromIntegral . roundtrip) samples
    bestRoundtrips = (U.take half . S.partialSort half) roundtrips
    half           = (U.length roundtrips + 1) `div` 2

byteSwap32 :: Word32 -> Word32
byteSwap32 n = a .|. b .|. c .|. d
  where
    a = n `shiftR` 24
    b = (n `shiftL` 8) .&. 0x00ff0000
    c = (n `shiftR` 8) .&. 0x0000ff00
    d = n `shiftL` 24

maxSamples :: Int
maxSamples = max phaseSamples freqSamples

freqSamples :: Int
freqSamples = round (1000 * samplesPerSecond)

phaseSamples :: Int
phaseSamples = round (50 * samplesPerSecond)

samplesPerSecond :: Double
samplesPerSecond = 0.5

adjustClock :: Server -> Server
adjustClock svr@Server{..} = svr { svrClock = adjust svrClock }
  where
    adjust = if isNaN phase then id else adjustOffset phase
           . if isNaN freq  then id else adjustFrequency freq
           . adjustOrigin earliestTime

    earliestTime = time1 (U.last svrRawSamples)

    phase  = S.meanWeighted (U.take phaseSamples weightedOffsets)

    (_, freq) = linearRegression (U.take freqSamples times)
                                 (U.take freqSamples weightedOffsets)

    weightedOffsets = U.zip offsets weights
    times   = U.map (fromDiff svrClock . (\x -> time4 x - earliestTime)) svrRawSamples
    offsets = U.map (toSeconds . offset svrClock) svrRawSamples
    weights = U.map (quality svrClock svr) svrRawSamples

------------------------------------------------------------------------
-- Sample Type

type Sample = (ClockIndex, Time, Time, ClockIndex)

time1 :: Sample -> ClockIndex
time1 (x,_,_,_) = x

time2 :: Sample -> Time
time2 (_,x,_,_) = x

time3 :: Sample -> Time
time3 (_,_,x,_) = x

time4 :: Sample -> ClockIndex
time4 (_,_,_,x) = x

deriving instance MGeneric.MVector U.MVector Time
deriving instance Generic.Vector U.Vector Time
deriving instance U.Unbox Time

------------------------------------------------------------------------
-- Sample Functions

offset :: Clock -> Sample -> Duration
offset clock sample = remoteTime sample `sub` localTime clock sample

localTime :: Clock -> Sample -> Time
localTime clock (t1,_,_,t4) = clockTime clock (t1 + (t4 - t1) `div` 2)

remoteTime :: Sample -> Time
remoteTime (_,t2,t3,_) = mid t2 t3

networkDelay :: Clock -> Sample -> Duration
networkDelay clock sample = total - server
  where
    total  = fromSeconds (fromDiff clock (roundtrip sample))
    server = serverDelay sample

roundtrip :: Sample -> ClockDiff
roundtrip (t1,_,_,t4) = t4 - t1

serverDelay :: Sample -> Duration
serverDelay (_,t2,t3,_) = t3 `sub` t2

quality :: Clock -> Server -> Sample -> Double
quality clock svr s = exp (-x*x)
  where
    x = sampleError / baseError

    sampleError = currentError clock svr s
    baseError   = fromDiff clock (svrBaseError svr)

initialError :: Clock -> Server -> Sample -> Seconds
initialError clock Server{..} s = fromDiff clock (roundtrip s - svrMinRoundtrip)

-- TODO could be more accurate if we calculated estimated frequency error
currentError :: Clock -> Server -> Sample -> Seconds
currentError clock svr s = initial + drift * age
  where
    initial = initialError clock svr s

    age = fromDiff clock (currentTime - sampleTime)
    currentTime = time4 (U.head (svrRawSamples svr))
    sampleTime  = time4 s

    drift = 1 / 10000000 -- 0.1 ppm

------------------------------------------------------------------------
-- Vector/Statistics Utils

-- | Maps a functions over a list and turns it in to a vector.
vector :: (a -> Double) -> [a] -> U.Vector Double
vector f = U.fromList . map f

-- | Simple linear regression between 2 samples.
--   Takes two vectors Y={yi} and X={xi} and returns
--   (alpha, beta, r*r) such that Y = alpha + beta*X
linearRegression :: S.Sample -> S.WeightedSample -> (Double, Double)
linearRegression xs ys = (alpha, beta)
  where
    !c     = U.sum (U.zipWith (*) (U.map (subtract mx) xs) (U.map (subtract my . fst) ys)) / (n-1)
    !r     = c / (sx * sy)
    !mx    = S.mean xs
    !my    = S.meanWeighted ys
    !sx    = S.stdDev xs
    !sy    = sqrt (S.varianceWeighted ys)
    !n     = fromIntegral (U.length xs)
    !beta  = r * sy / sx
    !alpha = my - beta * mx
{-# INLINE linearRegression #-}