{-# LANGUAGE BangPatterns, CPP, MagicHash,
             ScopedTypeVariables, UnliftedFFITypes, DeriveDataTypeable,
             DefaultSignatures, FlexibleContexts, TypeFamilies,
             MultiParamTypeClasses, CApiFFI #-}

{-# LANGUAGE Trustworthy #-}

#if __GLASGOW_HASKELL__ >= 801
{-# LANGUAGE PolyKinds #-} -- For TypeRep instances
#endif

{-# OPTIONS_GHC -fno-warn-deprecations #-}

------------------------------------------------------------------------
-- |
-- Module      :  Data.Hashable.Class
-- Copyright   :  (c) Milan Straka 2010
--                (c) Johan Tibell 2011
--                (c) Bryan O'Sullivan 2011, 2012
-- SPDX-License-Identifier : BSD-3-Clause
-- Maintainer  :  johan.tibell@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-- This module defines a class, 'Hashable', for types that can be
-- converted to a hash value.  This class exists for the benefit of
-- hashing-based data structures.  The module provides instances for
-- most standard types.

module Data.Hashable.Class
    (
      -- * Computing hash values
      Hashable(..)
    , Hashable1(..)
    , Hashable2(..)

      -- ** Support for generics
    , genericHashWithSalt
    , genericLiftHashWithSalt
    , GHashable(..)
    , HashArgs(..)
    , Zero
    , One

      -- * Creating new instances
    , hashUsing
    , hashPtr
    , hashPtrWithSalt
    , hashByteArray
    , hashByteArrayWithSalt
    , defaultHashWithSalt
      -- * Higher Rank Functions
    , hashWithSalt1
    , hashWithSalt2
    , defaultLiftHashWithSalt
    -- * Caching hashes
    , Hashed
    , hashed
    , unhashed
    , mapHashed
    , traverseHashed
    ) where

import Control.Applicative (Const(..))
import Control.Exception (assert)
import Control.DeepSeq (NFData(rnf))
import Data.Bits (shiftL, shiftR, xor)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Unsafe as B
import Data.Complex (Complex(..))
import Data.Int (Int8, Int16, Int32, Int64)
import Data.List (foldl')
import Data.Ratio (Ratio, denominator, numerator)
import qualified Data.Text as T
import qualified Data.Text.Array as TA
import qualified Data.Text.Internal as T
import qualified Data.Text.Lazy as TL
import Data.Version (Version(..))
import Data.Word (Word8, Word16, Word32, Word64)
import Foreign.C (CString)
import Foreign.Marshal.Utils (with)
import Foreign.Ptr (Ptr, FunPtr, IntPtr, WordPtr, castPtr, castFunPtrToPtr, ptrToIntPtr)
import Foreign.Storable (alignment, peek, sizeOf)
import GHC.Base (ByteArray#)
import GHC.Conc (ThreadId(..))
import GHC.Prim (ThreadId#)
import System.IO.Unsafe (unsafeDupablePerformIO)
import System.Mem.StableName
import Data.Unique (Unique, hashUnique)

-- As we use qualified F.Foldable, we don't get warnings with newer base
import qualified Data.Foldable as F

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

#if MIN_VERSION_base(4,7,0)
import Data.Fixed (Fixed(..))
#else
import Data.Fixed (Fixed)
import Unsafe.Coerce (unsafeCoerce)
#endif

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

import GHC.Generics

#if   MIN_VERSION_base(4,10,0)
import Type.Reflection (Typeable, TypeRep, SomeTypeRep(..))
import Type.Reflection.Unsafe (typeRepFingerprint)
import GHC.Fingerprint.Type(Fingerprint(..))
#elif MIN_VERSION_base(4,8,0)
import Data.Typeable (typeRepFingerprint, Typeable, TypeRep)
import GHC.Fingerprint.Type(Fingerprint(..))
#else
import Data.Typeable.Internal (Typeable, TypeRep (..))
import GHC.Fingerprint.Type(Fingerprint(..))
#endif

import Foreign.C.Types (CInt(..))

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

#if MIN_VERSION_base(4,7,0)
import Data.Bits (finiteBitSize)
#else
import Data.Bits (bitSize)
#endif

#if !(MIN_VERSION_bytestring(0,10,0))
import qualified Data.ByteString.Lazy.Internal as BL  -- foldlChunks
#endif

#if MIN_VERSION_bytestring(0,10,4)
import qualified Data.ByteString.Short.Internal as BSI
#endif

#ifdef VERSION_ghc_bignum
import GHC.Num.BigNat (BigNat (..))
import GHC.Num.Integer (Integer (..))
import GHC.Num.Natural (Natural (..))
import GHC.Exts (Int (..), sizeofByteArray#)
#endif

#ifdef VERSION_integer_gmp

# if MIN_VERSION_integer_gmp(1,0,0)
#  define MIN_VERSION_integer_gmp_1_0_0
# endif

import GHC.Exts (Int(..))
import GHC.Integer.GMP.Internals (Integer(..))
# if defined(MIN_VERSION_integer_gmp_1_0_0)
import GHC.Exts (sizeofByteArray#)
import GHC.Integer.GMP.Internals (BigNat(BN#))
# endif
#endif

#if MIN_VERSION_base(4,8,0)
import Data.Void (Void, absurd)
import GHC.Exts (Word(..))
#ifndef VERSION_ghc_bignum
import GHC.Natural (Natural(..))
#endif
#endif

#if MIN_VERSION_base(4,9,0)
import qualified Data.List.NonEmpty as NE
import Data.Semigroup
import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),showsUnaryWith)

import Data.Functor.Compose (Compose(..))
import qualified Data.Functor.Product as FP
import qualified Data.Functor.Sum as FS
#endif

import Data.String (IsString(..))

#if MIN_VERSION_base(4,9,0)
import Data.Kind (Type)
#else
#define Type *
#endif

#ifdef HASHABLE_RANDOM_SEED
import System.IO.Unsafe (unsafePerformIO)
#endif

#include "MachDeps.h"

infixl 0 `hashWithSalt`

------------------------------------------------------------------------
-- * Computing hash values

#ifdef HASHABLE_RANDOM_SEED
initialSeed :: Word64
initialSeed = unsafePerformIO initialSeedC
{-# NOINLINE initialSeed #-}

foreign import capi "HsHashable.h hs_hashable_init" initialSeedC :: IO Word64
#endif

-- | A default salt used in the implementation of 'hash'.
defaultSalt :: Int
#ifdef HASHABLE_RANDOM_SEED
defaultSalt = hashWithSalt defaultSalt' initialSeed
#else
defaultSalt = defaultSalt'
#endif
{-# INLINE defaultSalt #-}

defaultSalt' :: Int
#if WORD_SIZE_IN_BITS == 64
defaultSalt' = -3750763034362895579 -- 14695981039346656037 :: Int64
#else
defaultSalt' = -2128831035 -- 2166136261 :: Int32
#endif
{-# INLINE defaultSalt' #-}

-- | The class of types that can be converted to a hash value.
--
-- Minimal implementation: 'hashWithSalt'.
--
-- /Note:/ the hash is not guaranteed to be stable across
-- library versions, operating systems or architectures.
-- For stable hashing use named hashes: SHA256, CRC32 etc.
--
-- If you are looking for 'Hashable' instance in @time@ package,
-- check [time-compat](https://hackage.haskell.org/package/time-compat)
--
class Hashable a where
    -- | Return a hash value for the argument, using the given salt.
    --
    -- The general contract of 'hashWithSalt' is:
    --
    --  * If two values are equal according to the '==' method, then
    --    applying the 'hashWithSalt' method on each of the two values
    --    /must/ produce the same integer result if the same salt is
    --    used in each case.
    --
    --  * It is /not/ required that if two values are unequal
    --    according to the '==' method, then applying the
    --    'hashWithSalt' method on each of the two values must produce
    --    distinct integer results. However, the programmer should be
    --    aware that producing distinct integer results for unequal
    --    values may improve the performance of hashing-based data
    --    structures.
    --
    --  * This method can be used to compute different hash values for
    --    the same input by providing a different salt in each
    --    application of the method. This implies that any instance
    --    that defines 'hashWithSalt' /must/ make use of the salt in
    --    its implementation.
    --
    --  * 'hashWithSalt' may return negative 'Int' values.
    --
    hashWithSalt :: Int -> a -> Int

    -- | Like 'hashWithSalt', but no salt is used. The default
    -- implementation uses 'hashWithSalt' with some default salt.
    -- Instances might want to implement this method to provide a more
    -- efficient implementation than the default implementation.
    hash :: a -> Int
    hash = hashWithSalt defaultSalt

    default hashWithSalt :: (Generic a, GHashable Zero (Rep a)) => Int -> a -> Int
    hashWithSalt = genericHashWithSalt
    {-# INLINE hashWithSalt #-}

-- | Generic 'hashWithSalt'.
--
-- @since 1.3.0.0
genericHashWithSalt :: (Generic a, GHashable Zero (Rep a)) => Int -> a -> Int
genericHashWithSalt = \salt -> ghashWithSalt HashArgs0 salt . from
{-# INLINE genericHashWithSalt #-}

data Zero
data One

data family HashArgs arity a :: Type
data instance HashArgs Zero a = HashArgs0
newtype instance HashArgs One  a = HashArgs1 (Int -> a -> Int)

-- | The class of types that can be generically hashed.
class GHashable arity f where
    ghashWithSalt :: HashArgs arity a -> Int -> f a -> Int

class Hashable1 t where
    -- | Lift a hashing function through the type constructor.
    liftHashWithSalt :: (Int -> a -> Int) -> Int -> t a -> Int

    default liftHashWithSalt :: (Generic1 t, GHashable One (Rep1 t)) => (Int -> a -> Int) -> Int -> t a -> Int
    liftHashWithSalt = genericLiftHashWithSalt
    {-# INLINE liftHashWithSalt #-}

-- | Generic 'liftHashWithSalt'.
--
-- @since 1.3.0.0
genericLiftHashWithSalt :: (Generic1 t, GHashable One (Rep1 t)) => (Int -> a -> Int) -> Int -> t a -> Int
genericLiftHashWithSalt = \h salt -> ghashWithSalt (HashArgs1 h) salt . from1
{-# INLINE genericLiftHashWithSalt #-}

class Hashable2 t where
    -- | Lift a hashing function through the binary type constructor.
    liftHashWithSalt2 :: (Int -> a -> Int) -> (Int -> b -> Int) -> Int -> t a b -> Int

-- | Lift the 'hashWithSalt' function through the type constructor.
--
-- > hashWithSalt1 = liftHashWithSalt hashWithSalt
hashWithSalt1 :: (Hashable1 f, Hashable a) => Int -> f a -> Int
hashWithSalt1 = liftHashWithSalt hashWithSalt

-- | Lift the 'hashWithSalt' function through the type constructor.
--
-- > hashWithSalt2 = liftHashWithSalt2 hashWithSalt hashWithSalt
hashWithSalt2 :: (Hashable2 f, Hashable a, Hashable b) => Int -> f a b -> Int
hashWithSalt2 = liftHashWithSalt2 hashWithSalt hashWithSalt

-- | Lift the 'hashWithSalt' function halfway through the type constructor.
-- This function makes a suitable default implementation of 'liftHashWithSalt',
-- given that the type constructor @t@ in question can unify with @f a@.
defaultLiftHashWithSalt :: (Hashable2 f, Hashable a) => (Int -> b -> Int) -> Int -> f a b -> Int
defaultLiftHashWithSalt h = liftHashWithSalt2 hashWithSalt h

-- | Since we support a generic implementation of 'hashWithSalt' we
-- cannot also provide a default implementation for that method for
-- the non-generic instance use case. Instead we provide
-- 'defaultHashWith'.
defaultHashWithSalt :: Hashable a => Int -> a -> Int
defaultHashWithSalt salt x = salt `combine` hash x

-- | Transform a value into a 'Hashable' value, then hash the
-- transformed value using the given salt.
--
-- This is a useful shorthand in cases where a type can easily be
-- mapped to another type that is already an instance of 'Hashable'.
-- Example:
--
-- > data Foo = Foo | Bar
-- >          deriving (Enum)
-- >
-- > instance Hashable Foo where
-- >     hashWithSalt = hashUsing fromEnum
--
-- @since 1.2.0.0
hashUsing :: (Hashable b) =>
             (a -> b)           -- ^ Transformation function.
          -> Int                -- ^ Salt.
          -> a                  -- ^ Value to transform.
          -> Int
hashUsing f salt x = hashWithSalt salt (f x)
{-# INLINE hashUsing #-}

instance Hashable Int where
    hash = id
    hashWithSalt = defaultHashWithSalt

instance Hashable Int8 where
    hash = fromIntegral
    hashWithSalt = defaultHashWithSalt

instance Hashable Int16 where
    hash = fromIntegral
    hashWithSalt = defaultHashWithSalt

instance Hashable Int32 where
    hash = fromIntegral
    hashWithSalt = defaultHashWithSalt

instance Hashable Int64 where
    hash n
#if MIN_VERSION_base(4,7,0)
        | finiteBitSize (undefined :: Int) == 64 = fromIntegral n
#else
        | bitSize (undefined :: Int) == 64 = fromIntegral n
#endif
        | otherwise = fromIntegral (fromIntegral n `xor`
                                   (fromIntegral n `shiftR` 32 :: Word64))
    hashWithSalt = defaultHashWithSalt

instance Hashable Word where
    hash = fromIntegral
    hashWithSalt = defaultHashWithSalt

instance Hashable Word8 where
    hash = fromIntegral
    hashWithSalt = defaultHashWithSalt

instance Hashable Word16 where
    hash = fromIntegral
    hashWithSalt = defaultHashWithSalt

instance Hashable Word32 where
    hash = fromIntegral
    hashWithSalt = defaultHashWithSalt

instance Hashable Word64 where
    hash n
#if MIN_VERSION_base(4,7,0)
        | finiteBitSize (undefined :: Int) == 64 = fromIntegral n
#else
        | bitSize (undefined :: Int) == 64 = fromIntegral n
#endif
        | otherwise = fromIntegral (n `xor` (n `shiftR` 32))
    hashWithSalt = defaultHashWithSalt

instance Hashable () where
    hash = fromEnum
    hashWithSalt = defaultHashWithSalt

instance Hashable Bool where
    hash = fromEnum
    hashWithSalt = defaultHashWithSalt

instance Hashable Ordering where
    hash = fromEnum
    hashWithSalt = defaultHashWithSalt

instance Hashable Char where
    hash = fromEnum
    hashWithSalt = defaultHashWithSalt

#if defined(MIN_VERSION_integer_gmp_1_0_0) || defined(VERSION_ghc_bignum)
instance Hashable BigNat where
    hashWithSalt salt (BN# ba) = hashByteArrayWithSalt ba 0 numBytes salt
                                 `hashWithSalt` size
      where
        size     = numBytes `quot` SIZEOF_HSWORD
        numBytes = I# (sizeofByteArray# ba)
#endif

#if MIN_VERSION_base(4,8,0)
instance Hashable Natural where
# if defined(VERSION_ghc_bignum)
    hash (NS n)   = hash (W# n)
    hash (NB bn)  = hash (BN# bn)

    hashWithSalt salt (NS n)  = hashWithSalt salt (W# n)
    hashWithSalt salt (NB bn) = hashWithSalt salt (BN# bn)
# else
# if defined(MIN_VERSION_integer_gmp_1_0_0)
    hash (NatS# n)   = hash (W# n)
    hash (NatJ# bn)  = hash bn

    hashWithSalt salt (NatS# n)   = hashWithSalt salt (W# n)
    hashWithSalt salt (NatJ# bn)  = hashWithSalt salt bn
# else
    hash (Natural n) = hash n

    hashWithSalt salt (Natural n) = hashWithSalt salt n
# endif
# endif
#endif

instance Hashable Integer where
#if defined(VERSION_ghc_bignum)
    hash (IS n)  = I# n
    hash (IP bn) = hash (BN# bn)
    hash (IN bn) = negate (hash (BN# bn))

    hashWithSalt salt (IS n)  = hashWithSalt salt (I# n)
    hashWithSalt salt (IP bn) = hashWithSalt salt (BN# bn)
    hashWithSalt salt (IN bn) = negate (hashWithSalt salt (BN# bn))
#else
#if defined(VERSION_integer_gmp)
# if defined(MIN_VERSION_integer_gmp_1_0_0)
    hash (S# n)   = (I# n)
    hash (Jp# bn) = hash bn
    hash (Jn# bn) = negate (hash bn)

    hashWithSalt salt (S# n)   = hashWithSalt salt (I# n)
    hashWithSalt salt (Jp# bn) = hashWithSalt salt bn
    hashWithSalt salt (Jn# bn) = negate (hashWithSalt salt bn)
# else
    hash (S# int) = I# int
    hash n@(J# size# byteArray)
        | n >= minInt && n <= maxInt = fromInteger n :: Int
        | otherwise = let size = I# size#
                          numBytes = SIZEOF_HSWORD * abs size
                      in hashByteArrayWithSalt byteArray 0 numBytes defaultSalt
                         `hashWithSalt` size
      where minInt = fromIntegral (minBound :: Int)
            maxInt = fromIntegral (maxBound :: Int)

    hashWithSalt salt (S# n) = hashWithSalt salt (I# n)
    hashWithSalt salt n@(J# size# byteArray)
        | n >= minInt && n <= maxInt = hashWithSalt salt (fromInteger n :: Int)
        | otherwise = let size = I# size#
                          numBytes = SIZEOF_HSWORD * abs size
                      in hashByteArrayWithSalt byteArray 0 numBytes salt
                         `hashWithSalt` size
      where minInt = fromIntegral (minBound :: Int)
            maxInt = fromIntegral (maxBound :: Int)
# endif
#else
    hashWithSalt salt = foldl' hashWithSalt salt . go
      where
        go n | inBounds n = [fromIntegral n :: Int]
             | otherwise   = fromIntegral n : go (n `shiftR` WORD_SIZE_IN_BITS)
        maxInt = fromIntegral (maxBound :: Int)
        inBounds x = x >= fromIntegral (minBound :: Int) && x <= maxInt
#endif
#endif

instance Hashable a => Hashable (Complex a) where
    {-# SPECIALIZE instance Hashable (Complex Double) #-}
    {-# SPECIALIZE instance Hashable (Complex Float)  #-}
    hash (r :+ i) = hash r `hashWithSalt` i
    hashWithSalt = hashWithSalt1
instance Hashable1 Complex where
    liftHashWithSalt h s (r :+ i) = s `h` r `h` i

#if MIN_VERSION_base(4,9,0)
-- Starting with base-4.9, numerator/denominator don't need 'Integral' anymore
instance Hashable a => Hashable (Ratio a) where
#else
instance (Integral a, Hashable a) => Hashable (Ratio a) where
#endif
    {-# SPECIALIZE instance Hashable (Ratio Integer) #-}
    hash a = hash (numerator a) `hashWithSalt` denominator a
    hashWithSalt s a = s `hashWithSalt` numerator a `hashWithSalt` denominator a

-- | __Note__: prior to @hashable-1.3.0.0@, @hash 0.0 /= hash (-0.0)@
--
-- The 'hash' of NaN is not well defined.
--
-- @since 1.3.0.0
instance Hashable Float where
    hash x
        | x == -0.0 || x == 0.0 = 0 -- see note in 'Hashable Double'
        | isIEEE x =
            assert (sizeOf x >= sizeOf (0::Word32) &&
                    alignment x >= alignment (0::Word32)) $
            hash ((unsafeDupablePerformIO $ with x $ peek . castPtr) :: Word32)
        | otherwise = hash (show x)
    hashWithSalt = defaultHashWithSalt

-- | __Note__: prior to @hashable-1.3.0.0@, @hash 0.0 /= hash (-0.0)@
--
-- The 'hash' of NaN is not well defined.
--
-- @since 1.3.0.0
instance Hashable Double where
    hash x
        | x == -0.0 || x == 0.0 = 0 -- s.t. @hash -0.0 == hash 0.0@ ; see #173
        | isIEEE x =
            assert (sizeOf x >= sizeOf (0::Word64) &&
                    alignment x >= alignment (0::Word64)) $
            hash ((unsafeDupablePerformIO $ with x $ peek . castPtr) :: Word64)
        | otherwise = hash (show x)
    hashWithSalt = defaultHashWithSalt

-- | A value with bit pattern (01)* (or 5* in hexa), for any size of Int.
-- It is used as data constructor distinguisher. GHC computes its value during
-- compilation.
distinguisher :: Int
distinguisher = fromIntegral $ (maxBound :: Word) `quot` 3
{-# INLINE distinguisher #-}

instance Hashable a => Hashable (Maybe a) where
    hash Nothing = 0
    hash (Just a) = distinguisher `hashWithSalt` a
    hashWithSalt = hashWithSalt1

instance Hashable1 Maybe where
    liftHashWithSalt _ s Nothing = s `combine` 0
    liftHashWithSalt h s (Just a) = s `combine` distinguisher `h` a

instance (Hashable a, Hashable b) => Hashable (Either a b) where
    hash (Left a)  = 0 `hashWithSalt` a
    hash (Right b) = distinguisher `hashWithSalt` b
    hashWithSalt = hashWithSalt1

instance Hashable a => Hashable1 (Either a) where
    liftHashWithSalt = defaultLiftHashWithSalt

instance Hashable2 Either where
    liftHashWithSalt2 h _ s (Left a) = s `combine` 0 `h` a
    liftHashWithSalt2 _ h s (Right b) = s `combine` distinguisher `h` b

instance (Hashable a1, Hashable a2) => Hashable (a1, a2) where
    hash (a1, a2) = hash a1 `hashWithSalt` a2
    hashWithSalt = hashWithSalt1

instance Hashable a1 => Hashable1 ((,) a1) where
    liftHashWithSalt = defaultLiftHashWithSalt

instance Hashable2 (,) where
    liftHashWithSalt2 h1 h2 s (a1, a2) = s `h1` a1 `h2` a2

instance (Hashable a1, Hashable a2, Hashable a3) => Hashable (a1, a2, a3) where
    hash (a1, a2, a3) = hash a1 `hashWithSalt` a2 `hashWithSalt` a3
    hashWithSalt = hashWithSalt1

instance (Hashable a1, Hashable a2) => Hashable1 ((,,) a1 a2) where
    liftHashWithSalt = defaultLiftHashWithSalt

instance Hashable a1 => Hashable2 ((,,) a1) where
    liftHashWithSalt2 h1 h2 s (a1, a2, a3) =
      (s `hashWithSalt` a1) `h1` a2 `h2` a3

instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4) =>
         Hashable (a1, a2, a3, a4) where
    hash (a1, a2, a3, a4) = hash a1 `hashWithSalt` a2
                            `hashWithSalt` a3 `hashWithSalt` a4
    hashWithSalt = hashWithSalt1

instance (Hashable a1, Hashable a2, Hashable a3) => Hashable1 ((,,,) a1 a2 a3) where
    liftHashWithSalt = defaultLiftHashWithSalt

instance (Hashable a1, Hashable a2) => Hashable2 ((,,,) a1 a2) where
    liftHashWithSalt2 h1 h2 s (a1, a2, a3, a4) =
      (s `hashWithSalt` a1 `hashWithSalt` a2) `h1` a3 `h2` a4

instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4, Hashable a5)
      => Hashable (a1, a2, a3, a4, a5) where
    hash (a1, a2, a3, a4, a5) =
        hash a1 `hashWithSalt` a2 `hashWithSalt` a3
        `hashWithSalt` a4 `hashWithSalt` a5
    hashWithSalt = hashWithSalt1

instance (Hashable a1, Hashable a2, Hashable a3,
          Hashable a4) => Hashable1 ((,,,,) a1 a2 a3 a4) where
    liftHashWithSalt = defaultLiftHashWithSalt

instance (Hashable a1, Hashable a2, Hashable a3)
      => Hashable2 ((,,,,) a1 a2 a3) where
    liftHashWithSalt2 h1 h2 s (a1, a2, a3, a4, a5) =
      (s `hashWithSalt` a1 `hashWithSalt` a2
         `hashWithSalt` a3) `h1` a4 `h2` a5

instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4, Hashable a5,
          Hashable a6) => Hashable (a1, a2, a3, a4, a5, a6) where
    hash (a1, a2, a3, a4, a5, a6) =
        hash a1 `hashWithSalt` a2 `hashWithSalt` a3
        `hashWithSalt` a4 `hashWithSalt` a5 `hashWithSalt` a6
    hashWithSalt = hashWithSalt1

instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4,
          Hashable a5) => Hashable1 ((,,,,,) a1 a2 a3 a4 a5) where
    liftHashWithSalt = defaultLiftHashWithSalt

instance (Hashable a1, Hashable a2, Hashable a3,
          Hashable a4) => Hashable2 ((,,,,,) a1 a2 a3 a4) where
    liftHashWithSalt2 h1 h2 s (a1, a2, a3, a4, a5, a6) =
      (s `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` a3
         `hashWithSalt` a4) `h1` a5 `h2` a6

instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4, Hashable a5,
          Hashable a6, Hashable a7) =>
         Hashable (a1, a2, a3, a4, a5, a6, a7) where
    hash (a1, a2, a3, a4, a5, a6, a7) =
        hash a1 `hashWithSalt` a2 `hashWithSalt` a3
        `hashWithSalt` a4 `hashWithSalt` a5 `hashWithSalt` a6 `hashWithSalt` a7
    hashWithSalt s (a1, a2, a3, a4, a5, a6, a7) =
        s `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` a3
        `hashWithSalt` a4 `hashWithSalt` a5 `hashWithSalt` a6 `hashWithSalt` a7

instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4, Hashable a5, Hashable a6) => Hashable1 ((,,,,,,) a1 a2 a3 a4 a5 a6) where
    liftHashWithSalt = defaultLiftHashWithSalt

instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4,
          Hashable a5) => Hashable2 ((,,,,,,) a1 a2 a3 a4 a5) where
    liftHashWithSalt2 h1 h2 s (a1, a2, a3, a4, a5, a6, a7) =
      (s `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` a3
         `hashWithSalt` a4 `hashWithSalt` a5) `h1` a6 `h2` a7

instance Hashable (StableName a) where
    hash = hashStableName
    hashWithSalt = defaultHashWithSalt

-- Auxillary type for Hashable [a] definition
data SPInt = SP !Int !Int

instance Hashable a => Hashable [a] where
    {-# SPECIALIZE instance Hashable [Char] #-}
    hashWithSalt = hashWithSalt1

instance Hashable1 [] where
    liftHashWithSalt h salt arr = finalise (foldl' step (SP salt 0) arr)
      where
        finalise (SP s l) = hashWithSalt s l
        step (SP s l) x   = SP (h s x) (l + 1)

instance Hashable B.ByteString where
    hashWithSalt salt bs = unsafeDupablePerformIO $
                           B.unsafeUseAsCStringLen bs $ \(p, len) ->
                           hashPtrWithSalt p (fromIntegral len) salt

instance Hashable BL.ByteString where
    hashWithSalt = BL.foldlChunks hashWithSalt

#if MIN_VERSION_bytestring(0,10,4)
instance Hashable BSI.ShortByteString where
    hashWithSalt salt sbs@(BSI.SBS ba) =
        hashByteArrayWithSalt ba 0 (BSI.length sbs) salt
#endif

instance Hashable T.Text where
    hashWithSalt salt (T.Text arr off len) =
        hashByteArrayWithSalt (TA.aBA arr) (off `shiftL` 1) (len `shiftL` 1)
        salt

instance Hashable TL.Text where
    hashWithSalt = TL.foldlChunks hashWithSalt

-- | Compute the hash of a ThreadId.
hashThreadId :: ThreadId -> Int
hashThreadId (ThreadId t) = hash (fromIntegral (getThreadId t) :: Int)

-- this cannot be capi, as GHC panics.
foreign import ccall unsafe "rts_getThreadId" getThreadId
    :: ThreadId# -> CInt

instance Hashable ThreadId where
    hash = hashThreadId
    hashWithSalt = defaultHashWithSalt

instance Hashable (Ptr a) where
    hashWithSalt salt p = hashWithSalt salt $ ptrToIntPtr p

instance Hashable (FunPtr a) where
    hashWithSalt salt p = hashWithSalt salt $ castFunPtrToPtr p

instance Hashable IntPtr where
    hash n = fromIntegral n
    hashWithSalt = defaultHashWithSalt

instance Hashable WordPtr where
    hash n = fromIntegral n
    hashWithSalt = defaultHashWithSalt

----------------------------------------------------------------------------
-- Fingerprint & TypeRep instances

-- | @since 1.3.0.0
instance Hashable Fingerprint where
    hash (Fingerprint x _) = fromIntegral x
    hashWithSalt = defaultHashWithSalt
    {-# INLINE hash #-}

#if MIN_VERSION_base(4,10,0)

hashTypeRep :: Type.Reflection.TypeRep a -> Int
hashTypeRep tr =
    let Fingerprint x _ = typeRepFingerprint tr in fromIntegral x

instance Hashable Type.Reflection.SomeTypeRep where
    hash (Type.Reflection.SomeTypeRep r) = hashTypeRep r
    hashWithSalt = defaultHashWithSalt
    {-# INLINE hash #-}

instance Hashable (Type.Reflection.TypeRep a) where
    hash = hashTypeRep
    hashWithSalt = defaultHashWithSalt
    {-# INLINE hash #-}

#else

-- | Compute the hash of a TypeRep, in various GHC versions we can do this quickly.
hashTypeRep :: TypeRep -> Int
{-# INLINE hashTypeRep #-}
#if   MIN_VERSION_base(4,8,0)
-- Fingerprint is just the MD5, so taking any Int from it is fine
hashTypeRep tr = let Fingerprint x _ = typeRepFingerprint tr in fromIntegral x
#else
-- Fingerprint is just the MD5, so taking any Int from it is fine
hashTypeRep (TypeRep (Fingerprint x _) _ _) = fromIntegral x
#endif

instance Hashable TypeRep where
    hash = hashTypeRep
    hashWithSalt = defaultHashWithSalt
    {-# INLINE hash #-}

#endif

----------------------------------------------------------------------------

#if MIN_VERSION_base(4,8,0)
instance Hashable Void where
    hashWithSalt _ = absurd
#endif

-- | Compute a hash value for the content of this pointer.
hashPtr :: Ptr a      -- ^ pointer to the data to hash
        -> Int        -- ^ length, in bytes
        -> IO Int     -- ^ hash value
hashPtr p len = hashPtrWithSalt p len defaultSalt

-- | Compute a hash value for the content of this pointer, using an
-- initial salt.
--
-- This function can for example be used to hash non-contiguous
-- segments of memory as if they were one contiguous segment, by using
-- the output of one hash as the salt for the next.
hashPtrWithSalt :: Ptr a   -- ^ pointer to the data to hash
                -> Int     -- ^ length, in bytes
                -> Int     -- ^ salt
                -> IO Int  -- ^ hash value
hashPtrWithSalt p len salt =
    fromIntegral `fmap` c_hashCString (castPtr p) (fromIntegral len)
    (fromIntegral salt)

foreign import capi unsafe "HsHashable.h hashable_fnv_hash" c_hashCString
#if WORD_SIZE_IN_BITS == 64
    :: CString -> Int64 -> Int64 -> IO Word64
#else
    :: CString -> Int32 -> Int32 -> IO Word32
#endif

-- | Compute a hash value for the content of this 'ByteArray#',
-- beginning at the specified offset, using specified number of bytes.
hashByteArray :: ByteArray#  -- ^ data to hash
              -> Int         -- ^ offset, in bytes
              -> Int         -- ^ length, in bytes
              -> Int         -- ^ hash value
hashByteArray ba0 off len = hashByteArrayWithSalt ba0 off len defaultSalt
{-# INLINE hashByteArray #-}

-- | Compute a hash value for the content of this 'ByteArray#', using
-- an initial salt.
--
-- This function can for example be used to hash non-contiguous
-- segments of memory as if they were one contiguous segment, by using
-- the output of one hash as the salt for the next.
hashByteArrayWithSalt
    :: ByteArray#  -- ^ data to hash
    -> Int         -- ^ offset, in bytes
    -> Int         -- ^ length, in bytes
    -> Int         -- ^ salt
    -> Int         -- ^ hash value
hashByteArrayWithSalt ba !off !len !h =
    fromIntegral $ c_hashByteArray ba (fromIntegral off) (fromIntegral len)
    (fromIntegral h)

#if __GLASGOW_HASKELL__ >= 802
foreign import capi unsafe "HsHashable.h hashable_fnv_hash_offset" c_hashByteArray
#else
foreign import ccall unsafe "hashable_fnv_hash_offset" c_hashByteArray
#endif
#if WORD_SIZE_IN_BITS == 64
    :: ByteArray# -> Int64 -> Int64 -> Int64 -> Word64
#else
    :: ByteArray# -> Int32 -> Int32 -> Int32 -> Word32
#endif

-- | Combine two given hash values.  'combine' has zero as a left
-- identity.
combine :: Int -> Int -> Int
combine h1 h2 = (h1 * 16777619) `xor` h2

instance Hashable Unique where
    hash = hashUnique
    hashWithSalt = defaultHashWithSalt

instance Hashable Version where
    hashWithSalt salt (Version branch tags) =
        salt `hashWithSalt` branch `hashWithSalt` tags

#if MIN_VERSION_base(4,7,0)
instance Hashable (Fixed a) where
    hashWithSalt salt (MkFixed i) = hashWithSalt salt i
-- Using hashWithSalt1 would cause needless constraint
instance Hashable1 Fixed where
    liftHashWithSalt _ salt (MkFixed i) = hashWithSalt salt i
#else
instance Hashable (Fixed a) where
    hashWithSalt salt x = hashWithSalt salt (unsafeCoerce x :: Integer)
#endif

#if MIN_VERSION_base(4,8,0)
instance Hashable a => Hashable (Identity a) where
    hashWithSalt = hashWithSalt1
instance Hashable1 Identity where
    liftHashWithSalt h salt (Identity x) = h salt x
#endif

-- Using hashWithSalt1 would cause needless constraint
instance Hashable a => Hashable (Const a b) where
    hashWithSalt salt (Const x) = hashWithSalt salt x

instance Hashable a => Hashable1 (Const a) where
    liftHashWithSalt = defaultLiftHashWithSalt

instance Hashable2 Const where
    liftHashWithSalt2 f _ salt (Const x) = f salt x

#if MIN_VERSION_base(4,7,0)
instance Hashable (Proxy a) where
    hash _ = 0
    hashWithSalt s _ = s

instance Hashable1 Proxy where
    liftHashWithSalt _ s _ = s
#endif

-- instances formerly provided by 'semigroups' package
#if MIN_VERSION_base(4,9,0)
instance Hashable a => Hashable (NE.NonEmpty a) where
    hashWithSalt p (a NE.:| as) = p `hashWithSalt` a `hashWithSalt` as

-- | @since 1.3.1.0
instance Hashable1 NE.NonEmpty where
    liftHashWithSalt h salt (a NE.:| as) = liftHashWithSalt h (h salt a) as

instance Hashable a => Hashable (Min a) where
    hashWithSalt p (Min a) = hashWithSalt p a

-- | @since 1.3.1.0
instance Hashable1 Min where liftHashWithSalt h salt (Min a) = h salt a

instance Hashable a => Hashable (Max a) where
    hashWithSalt p (Max a) = hashWithSalt p a

-- | @since 1.3.1.0
instance Hashable1 Max where liftHashWithSalt h salt (Max a) = h salt a

-- | __Note__: Prior to @hashable-1.3.0.0@ the hash computation included the second argument of 'Arg' which wasn't consistent with its 'Eq' instance.
--
-- @since 1.3.0.0
instance Hashable a => Hashable (Arg a b) where
    hashWithSalt p (Arg a _) = hashWithSalt p a

instance Hashable a => Hashable (First a) where
    hashWithSalt p (First a) = hashWithSalt p a

-- | @since 1.3.1.0
instance Hashable1 First where liftHashWithSalt h salt (First a) = h salt a

instance Hashable a => Hashable (Last a) where
    hashWithSalt p (Last a) = hashWithSalt p a

-- | @since 1.3.1.0
instance Hashable1 Last where liftHashWithSalt h salt (Last a) = h salt a

instance Hashable a => Hashable (WrappedMonoid a) where
    hashWithSalt p (WrapMonoid a) = hashWithSalt p a

-- | @since 1.3.1.0
instance Hashable1 WrappedMonoid where liftHashWithSalt h salt (WrapMonoid a) = h salt a

#if !MIN_VERSION_base(4,16,0)
instance Hashable a => Hashable (Option a) where
    hashWithSalt p (Option a) = hashWithSalt p a

-- | @since 1.3.1.0
instance Hashable1 Option where liftHashWithSalt h salt (Option a) = liftHashWithSalt h salt a
#endif
#endif

-- instances for @Data.Functor.{Product,Sum,Compose}@, present
-- in base-4.9 and onward.
#if MIN_VERSION_base(4,9,0)
-- | In general, @hash (Compose x) ≠ hash x@. However, @hashWithSalt@ satisfies
-- its variant of this equivalence.
instance (Hashable1 f, Hashable1 g, Hashable a) => Hashable (Compose f g a) where
    hashWithSalt = hashWithSalt1

instance (Hashable1 f, Hashable1 g) => Hashable1 (Compose f g) where
    liftHashWithSalt h s = liftHashWithSalt (liftHashWithSalt h) s . getCompose

instance (Hashable1 f, Hashable1 g) => Hashable1 (FP.Product f g) where
    liftHashWithSalt h s (FP.Pair a b) = liftHashWithSalt h (liftHashWithSalt h s a) b

instance (Hashable1 f, Hashable1 g, Hashable a) => Hashable (FP.Product f g a) where
    hashWithSalt = hashWithSalt1

instance (Hashable1 f, Hashable1 g) => Hashable1 (FS.Sum f g) where
    liftHashWithSalt h s (FS.InL a) = liftHashWithSalt h (s `combine` 0) a
    liftHashWithSalt h s (FS.InR a) = liftHashWithSalt h (s `combine` distinguisher) a

instance (Hashable1 f, Hashable1 g, Hashable a) => Hashable (FS.Sum f g a) where
    hashWithSalt = hashWithSalt1
#endif

-- | A hashable value along with the result of the 'hash' function.
data Hashed a = Hashed a {-# UNPACK #-} !Int
  deriving (Typeable)

-- | Wrap a hashable value, caching the 'hash' function result.
hashed :: Hashable a => a -> Hashed a
hashed a = Hashed a (hash a)

-- | Unwrap hashed value.
unhashed :: Hashed a -> a
unhashed (Hashed a _) = a

-- | Uses precomputed hash to detect inequality faster
instance Eq a => Eq (Hashed a) where
  Hashed a ha == Hashed b hb = ha == hb && a == b

instance Ord a => Ord (Hashed a) where
  Hashed a _ `compare` Hashed b _ = a `compare` b

instance Show a => Show (Hashed a) where
  showsPrec d (Hashed a _) = showParen (d > 10) $
    showString "hashed" . showChar ' ' . showsPrec 11 a

instance Hashable (Hashed a) where
  hashWithSalt = defaultHashWithSalt
  hash (Hashed _ h) = h

-- This instance is a little unsettling. It is unusal for
-- 'liftHashWithSalt' to ignore its first argument when a
-- value is actually available for it to work on.
instance Hashable1 Hashed where
  liftHashWithSalt _ s (Hashed _ h) = defaultHashWithSalt s h

instance (IsString a, Hashable a) => IsString (Hashed a) where
  fromString s = let r = fromString s in Hashed r (hash r)

instance F.Foldable Hashed where
  foldr f acc (Hashed a _) = f a acc

instance NFData a => NFData (Hashed a) where
  rnf = rnf . unhashed

-- | 'Hashed' cannot be 'Functor'
mapHashed :: Hashable b => (a -> b) -> Hashed a -> Hashed b
mapHashed f (Hashed a _) = hashed (f a)

-- | 'Hashed' cannot be 'Traversable'
traverseHashed :: (Hashable b, Functor f) => (a -> f b) -> Hashed a -> f (Hashed b)
traverseHashed f (Hashed a _) = fmap hashed (f a)

-- instances for @Data.Functor.Classes@ higher rank typeclasses
-- in base-4.9 and onward.
#if MIN_VERSION_base(4,9,0)
instance Eq1 Hashed where
  liftEq f (Hashed a ha) (Hashed b hb) = ha == hb && f a b

instance Ord1 Hashed where
  liftCompare f (Hashed a _) (Hashed b _) = f a b

instance Show1 Hashed where
  liftShowsPrec sp _ d (Hashed a _) = showsUnaryWith sp "hashed" d a
#endif


-- |
-- Module      : BattleHack.Lenses
-- Description :
-- Copyright   : (c) Jonatan H Sundqvist, 2015
-- License     : MIT
-- Maintainer  : Jonatan H Sundqvist
-- Stability   : experimental
-- Portability : POSIX

-- Created September 12 2015

--------------------------------------------------------------------------------------------------------------------------------------------
-- GHC pragmas
--------------------------------------------------------------------------------------------------------------------------------------------
{-# LANGUAGE Rank2Types #-}

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
module BattleHack.Lenses where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
-- import Control.Monad
import Control.Lens
import Data.Functor ((<$>))
import Data.Complex
import qualified Data.Set as S

import BattleHack.Types

--------------------------------------------------------------------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------------------------------------------------------------------
-- Operators -------------------------------------------------------------------------------------------------------------------------------
-- |
-- TODO: Infix declaration
(-->) :: b -> Getting a b a -> a
(-->) = (^.)

infix 8 --> -- Slightly lower precedence than the '.' operator

-- AppState --------------------------------------------------------------------------------------------------------------------------------
-- |
piano :: Lens AppState AppState PianoSettings PianoSettings
piano f s = (\new -> s { _piano=new }) <$> f (_piano s)

bindings :: Lens AppState AppState KeyMap KeyMap
bindings f s = (\new -> s { _bindings=new }) <$> f (_bindings s)

inputstate :: Lens AppState AppState InputState InputState
inputstate f s = (\new -> s { _inputstate=new }) <$> f (_inputstate s)

animation :: Lens AppState AppState AnimationData AnimationData
animation f s = (\new -> s { _animation=new }) <$> f (_animation s)

-- source :: Lens AppState AppState Source Source
-- source f s = (\new -> s { _source=new }) <$> f (_source s)

-- claviature :: Lens AppState AppState Claviature Claviature
-- claviature f s = (\new -> s { _claviature=new }) <$> f (_claviature s)

-- AnimationData ---------------------------------------------------------------------------------------------------------------------------
frame :: Lens AnimationData AnimationData Int Int
frame f s = (\new -> s { _frame=new }) <$> f (_frame s)

fps :: Lens AnimationData AnimationData Int Int
fps f s = (\new -> s { _fps=new }) <$> f (_fps s)

-- InputState ------------------------------------------------------------------------------------------------------------------------------
-- |
mouse :: Lens InputState InputState Vector Vector
mouse f s = (\new -> s { _mouse=new }) <$> f (_mouse s)

keyboard :: Lens InputState InputState (S.Set String) (S.Set String)
keyboard f s = (\new -> s { _keyboard=new }) <$> f (_keyboard s)

-- PianoSettings ---------------------------------------------------------------------------------------------------------------------------
-- |
origin :: Lens PianoSettings PianoSettings Vector Vector
origin f s = (\new -> s { _origin=new }) <$> f (_origin s)

-- |
keysize :: Lens PianoSettings PianoSettings Vector Vector
keysize f s = (\new -> s { _keysize=new }) <$> f (_keysize s)

-- |
indent :: Lens PianoSettings PianoSettings Number Number
indent f s = (\new -> s { _indent=new }) <$> f (_indent s)

-- |
mid :: Lens PianoSettings PianoSettings Number Number
mid f s = (\new -> s { _mid=new }) <$> f (_mid s)

-- |
active :: Lens PianoSettings PianoSettings (Maybe Int) (Maybe Int)
active f s = (\new -> s { _active=new }) <$> f (_active s)

-- |
keys :: Lens PianoSettings PianoSettings [Bool] [Bool]
keys f s = (\new -> s { _keys=new }) <$> f (_keys s)

-- Vectors ---------------------------------------------------------------------------------------------------------------------------------
-- | Focuses on the real part (X-component) of a vector.
-- TODO: Real part as vector (eg. x:+y -> x:+0), ditto for imag
real :: Lens (Complex a) (Complex a) a a
real f (x:+y) = (:+y) <$> f x

-- | Focuses on the imaginary part (Y-component) of a vector.
imag :: Lens (Complex a) (Complex a) a a
imag f (x:+y) = (x:+) <$> f y

-- | Like real, except the new type is also a vector.
-- TODO: Better name (?)
real' :: Num n => Lens (Complex n) (Complex n) (Complex n) (Complex n)
real' f (x:+_) = id <$> f (x:+0)

-- | Like imag, except the new type is also a vector.
-- TODO: Better name (?)
imag' :: Num n => Lens (Complex n) (Complex n) (Complex n) (Complex n)
imag' f (_:+y) = id <$> f (0:+y)


{-# LANGUAGE FlexibleContexts #-}
module LearnHaskDA.Chapter8 where
import Numeric.LinearAlgebra as LA
import Data.List as L
import Data.HashMap.Strict as HM
import qualified LearnHaskDA.Chapter4 as Ch4
import qualified LearnHaskDA.Chapter6 as Ch6
import qualified LearnHaskDA.Chapter7 as Ch7 (Counts, MyWord, clean, frequency, wordFrequencyByFst)

import Test.QuickCheck -- This is not imported by the book (and that is a bad sign: the book talk almost nothing about code testing)
import Data.Function (on)

test140 = do
    tweetsEnglish <- Ch4.queryDatabase "tweets.sql" "SELECT user, message FROM tweets WHERE language='en'"
    let tweets = Ch4.readTwoColumns 0 1 tweetsEnglish :: [(String, String)]
    let freqTable = Ch7.frequency tweets
    print $ HM.size freqTable
    let uniqueTweets = keys freqTable
    let cleanedTweets = L.map (\(user, mess) -> (user, Ch7.clean mess)) uniqueTweets
    let wordFrequency = Ch7.frequency $ concatMap snd cleanedTweets
    return (cleanedTweets, wordFrequency)

test141 = do
    (cleanedTweets, wordFrequency) <- test140
    let topWords = take 25 $ sortBy (\(_, c1) (_, c2) -> compare c2 c1) $ HM.toList wordFrequency
    return topWords

test142 = do
    (cleanedTweets, wordFrequency) <- test140
    let notStopWords = L.filter (\(word, _) -> notElem word stopWords) (HM.toList wordFrequency)
    let topWords = take 25 . L.map fst $ sortBy (\(_, c1) (_, c2) -> compare c2 c1) notStopWords
    return topWords

stopWords :: [String]
stopWords = ["", "a", "about", "above", "above", "across", "after",
  "afterwards", "again", "against", "all", "almost", "alone", "along",
  "already", "also", "although", "always", "am", "among", "amongst",
  "amoungst", "amount", "an", "and", "another", "any", "anyhow",
  "anyone", "anything", "anyway", "anywhere", "are", "around", "as",
  "at", "back", "be", "became", "because", "become", "becomes",
  "becoming", "been", "before", "beforehand", "behind", "being",
  "below", "beside", "besides", "between", "beyond", "bill", "both",
  "bottom", "but", "by", "call", "can", "cannot", "cant", "co", "con",
  "could", "couldnt", "cry", "de", "describe", "detail", "do", "done",
  "dont", "down", "due", "during", "each", "eg", "eight", "either",
  "eleven", "else", "elsewhere", "empty", "enough", "etc", "even",
  "ever", "every", "everyone", "everything", "everywhere", "except",
  "few", "fifteen", "fifty", "fill", "find", "fire", "first", "five",
  "for", "former", "formerly", "forty", "found", "four", "from",
  "front", "full", "further", "get", "give", "go", "got", "had", "has",
  "hasnt", "have", "he", "hence", "her", "here", "hereafter", "hereby",
  "herein", "hereupon", "hers", "herself", "him", "himself", "his",
  "how", "however", "https", "hundred", "i", "ie", "if", "im", "in", "inc",
  "indeed", "interest", "into", "is", "it", "its", "itself", "just",
  "keep", "last", "latter", "latterly", "least", "less", "ltd", "made",
  "many", "may", "me", "meanwhile", "might", "mill", "mine", "more",
  "moreover", "most", "mostly", "move", "much", "must", "my", "myself",
  "name", "namely", "neither", "need", "never", "nevertheless",
  "next", "nine", "no", "nobody", "none", "noone", "nor", "not",
  "nothing", "now", "nowhere", "of", "off", "often", "on", "once",
  "one", "only", "onto", "or", "other", "others", "otherwise", "our",
  "ours", "ourselves", "out", "over", "own", "part", "per", "perhaps",
  "please", "put", "rather", "re", "same", "see", "seem", "seemed",
  "seeming", "seems", "serious", "several", "she", "should", "show",
  "side", "since", "sincere", "six", "sixty", "so", "some", "somehow",
  "someone", "something", "sometime", "sometimes", "somewhere", "still",
  "such", "system", "take", "ten", "than", "that", "the", "their",
  "them", "themselves", "then", "thence", "there", "thereafter",
  "thereby", "therefore", "therein", "thereupon", "these", "they",
  "thick", "thin", "third", "this", "those", "though", "three",
  "through", "throughout", "thru", "thus", "to", "together", "too",
  "top", "toward", "towards", "twelve", "twenty", "two", "un", "under",
  "until", "up", "upon", "us", "very", "via", "want", "was", "we",
  "well", "were", "what", "whatever", "when", "whence", "whenever",
  "where", "whereafter", "whereas", "whereby", "wherein", "whereupon",
  "wherever", "whether", "which", "while", "whither", "who", "whoever",
  "whole", "whom", "whose", "why", "will", "with", "within", "without",
  "would", "yet", "you", "your", "youre", "yours", "yourself",
  "yourselves", "rt", "mt", "u"]

bookTopWords = ["like", "amp", "day", "good", "new", "love", "time", "follow", "great",
  "today", "make", "lot", "people", "video", "know", "life", "happy",
  "look", "think", "girl", "win", "photo", "way", "little", "really"]

myTopWords = ["amp","day","new","like","love","good","great","video",
              "make","win","follow","life","pill","today","happy","time",
              "chance","photo","posted","birthday","lot","brain","know",
              "limitless","think"]

topWords = bookTopWords

-- page 143
type UserName = String
type UserWordCount = [[Double]]
test143 :: IO (HashMap UserName (Ch7.Counts Ch7.MyWord), UserWordCount)
test143 = do
    (cleanedTweets, wordFrequency) <- test140
    let wordFrequencyByUser = Ch7.wordFrequencyByFst cleanedTweets
    let getFrequencyOfWordByUser user word = fromIntegral $ (HM.lookupDefault 0 word (wordFrequencyByUser HM.! user)) :: Double
    let allUsers = keys wordFrequencyByUser
    let wordMatrix = L.map (\user -> L.map (getFrequencyOfWordByUser user) topWords) allUsers
    return (wordFrequencyByUser, wordMatrix)

----------------

test150 = do
    homeRecord <- Ch4.queryDatabase "winloss.sql" "SELECT homeTeam, SUM(homescore > awayscore), SUM(homescore), COUNT(*) FROM winloss GROUP BY homeTeam;"
    awayRecord <- Ch4.queryDatabase "winloss.sql" "SELECT awayTeam, SUM(awayscore > homescore), SUM(awayscore), COUNT(*) FROM winloss GROUP BY awayTeam;"
    let totalWins     = zipWith (+) (Ch4.readDoubleColumn homeRecord 1) (Ch4.readDoubleColumn awayRecord 1)
    let totalRuns     = zipWith (+) (Ch4.readDoubleColumn homeRecord 2) (Ch4.readDoubleColumn awayRecord 2)
    let totalGames    = zipWith (+) (Ch4.readDoubleColumn homeRecord 3) (Ch4.readDoubleColumn awayRecord 3)
    let winPercentage = zipWith (/) totalWins totalGames
    let runsPerGame   = zipWith (/) totalRuns totalGames
    let baseball      = L.map (\(a,b) -> [a,b]) $ zip winPercentage runsPerGame
    let p@(baseballMean, baseballCovMatrix) = meanCov $ fromLists baseball
    return p

-- eigSH :: Field t => Herm t -> (Vector Double, Matrix t)
test151 = do
  (baseballMean, baseballCovMatrix) <- test150
  let p@(baseballEvalues, baseballEvectors) = eigSH (sym baseballCovMatrix)
  return p

-- page 154
-- principalComponentAnalysis :: [[Double]] -> Integer -> Matrix Double
principalComponentAnalysis records top = featureVectors <> topOrderedEvectors
-- Some unnecessary tr in the book:
--    tr $ mul (tr topOrderedEvectors) (tr featureVectors)
  where  featureVectors  = fromLists records
         (_, covMatrix)  = meanCov featureVectors
         (_, evectors)   = eigSH (trustSym covMatrix)
         topOrderedEvectors = takeColumns (fromInteger top) evectors

{-
-- Done: pull request for hmatrix changing the type of meanCov to use Herm
https://github.com/albertoruiz/hmatrix/pull/157
https://github.com/albertoruiz/hmatrix/blob/master/packages/base/src/Internal/Container.hs

meanCovH :: Matrix Double -> (Vector Double, Herm Double)
meanCovH x = (med, cov) where
    r    = rows x
    k    = 1 / fromIntegral r
    med  = konst k r <> x
    meds = konst 1 r `outer` med
    xc   = x - meds
    cov  = scale (recip (fromIntegral (r-1))) (mTm xc)
-}

-- let pcaMatrix = principalComponentAnalysis wordMatrix 5

-- euclideanDistanceSqrdFromRow :: Matrix Double -> Int -> Vector Double
euclideanDistanceSqrdFromRow :: (Num t, Num (Vector t), Container Vector t) => Matrix t -> Int -> Vector t
euclideanDistanceSqrdFromRow records row = sumOfSquaresVector
  where
    d = cols records
    n = rows records
    theRow = subMatrix (row, 0) (1, d) records
    copyMatrix = repmat theRow n 1
    diffMatrix      = records    - copyMatrix  -- Pointwise operation
    diffSqrdMatrix  = diffMatrix * diffMatrix  -- Pointwise operation
    sumOfSquaresVector = sum $ toColumns diffSqrdMatrix

orderBookSimplified :: Eq a => [a] -> [a] -> [Int]
orderBookSimplified unsorted = concatMap (`L.elemIndices` unsorted)

test156' :: Ord a => [a] -> [Int]
test156' xs = orderBookSimplified xs (nub $ sort xs)

-- Much faster (better complexity):
test156 :: Ord a => [a] -> [Int]
test156 = L.map snd . sort . (`zip` [0..])

qc156 xs = test156 xs == test156' xs

findClosestFeaturesToRow :: Matrix Double -> Int -> Int -> [Int]
findClosestFeaturesToRow records row knn = take knn orderOfFeatures
  where  orderOfFeatures = test156 sumOfSquares
         sumOfSquares    = LA.toList $ euclideanDistanceSqrdFromRow records row

-- The users "most active" in the common words: [8225,15747,556, 1044, 1517, 2133]

test157 = do
  (tab, wordMatrix) <- test143
  let pcaMatrix = principalComponentAnalysis wordMatrix 5
  return (tab, findClosestFeaturesToRow pcaMatrix 8225 6)

----------------------------------------------------------------
{-
  Experiment to locate a few users with many words in the tweets database:
  (tab, close) <- test157
  let s = HM.map HM.size tab
  sortBy (compare `on` snd) (HM.toList s)

Top users (at one point):

("WindowMouse",60),("kellyboy1977",62),("cassidyhanft",72),("love_the_rock2",80),("Gvccizay",81),("revraamess",97)]

-}


{-# LANGUAGE CPP                 #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TupleSections       #-}
-- |
-- Module:      : Data.Array.Accelerate.Examples.Internal.Codespeed
-- Copyright    : [2014..2020] Trevor L. McDonell
-- License      : BSD3
--
-- Maintainer   : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability    : experimental
-- Portability  : non-portable (GHC extensions)
--

module Data.Array.Accelerate.Examples.Internal.Codespeed
  where

import Data.Array.Accelerate.Error
import Data.Array.Accelerate.Examples.Internal.TH
import Data.Array.Accelerate.Examples.Internal.ParseArgs

import Data.Aeson
import Data.Char
import Data.Text                                        ( Text )
import Data.Label
import Data.Monoid
import Control.Monad
import Criterion.Types                                  ( Report(..), SampleAnalysis(..), Regression(..) )
import Statistics.Resampling.Bootstrap                  ( Estimate(..), scale )
import Network.HTTP                                     ( simpleHTTP, postRequestWithBody, Response(..) )
import Network.HTTP.Types                               ( urlEncode )
import System.IO
import qualified Data.ByteString.Char8                  as BS
import qualified Data.ByteString.Lazy.Char8             as BL
import qualified Data.Map                               as Map
import qualified Data.Text

data Sample = Sample
  {
    sampleName          :: String       -- benchmark name
  , sampleTime          :: Estimate     -- sample result (via OLS regression)
  , sampleRSquare       :: Estimate     -- R^2 goodness-of-fit estimate of regression
  , sampleMean          :: Estimate     -- result mean
  , sampleStdDev        :: Estimate     -- standard deviation
  , sampleUnits         :: Unit
  }

data Unit = Unit
  {
    unitName            :: String       -- e.g. seconds
  , unitType            :: String       -- description of the unit, e.g. Time
  , lessIsMore          :: Bool         -- so python, much philosophical
  }

-- Treat a sample as being in milliseconds
--
ms :: Sample -> Sample
ms Sample{..} =
  Sample { sampleTime           = scale 1000 sampleTime
         , sampleRSquare        = scale 1000 sampleRSquare
         , sampleMean           = scale 1000 sampleMean
         , sampleStdDev         = scale 1000 sampleStdDev
         , sampleUnits          = Unit { unitName   = "ms"
                                       , unitType   = "Time"
                                       , lessIsMore = True }
         , ..
         }

-- Extract benchmark information from the Criterion report
--
-- TODO: Extract any other regressions present in the report into separate
--       samples, e.g. GC statistics
--
sample :: Report -> Sample
sample Report{..} = ms $ Sample
  { sampleName          = reportName
  , sampleTime          = regIters
  , sampleRSquare       = regRSquare
  , sampleMean          = anMean
  , sampleStdDev        = anStdDev
  , sampleUnits         = error "sample has no unit assigned"
  }
  where
    SampleAnalysis{..}  = reportAnalysis
    Regression{..}      = head anRegress
    regIters            = case Map.lookup "iters" regCoeffs of
                            Nothing -> $internalError "sample" "no benchmark result found"
                            Just t  -> t

-- Encode a sample to a JSON value suitable for upload to codespeed
--
toValue :: Options -> Sample -> Value
toValue opt Sample{..} = object
  [ "commitid"          .= $(_HEAD)
  , "branch"            .= $(_BRANCH)
  , "project"           .= ("accelerate-examples" :: Text)
  , "executable"        .= get optVariant opt
  , "environment"       .= get optHostname opt
  , "benchmark"         .= sampleName
  , "result_value"      .= estPoint sampleTime
  , "min"               .= estLowerBound sampleTime
  , "max"               .= estUpperBound sampleTime
  , "std_dev"           .= estPoint sampleStdDev
  , "units"             .= unitName sampleUnits
  , "units_title"       .= unitType sampleUnits
  , "lessismore"        .= lessIsMore sampleUnits
  ]

-- Upload a set of criterion reports to the codespeed server
--
uploadReports :: Options -> [Report] -> IO ()
uploadReports opt reports =
  when upload $ do
    putStr ("Uploading results to " ++ server ++ " ... ") >> hFlush stdout
    rsp <- simpleHTTP $ postRequestWithBody url contentType content
    case rsp of
      Left err -> do
        putStrLn "failed"
        hPutStrLn stderr (show err)

      Right Response{..} ->
        case rspCode of
          (2,0,2) -> putStrLn "Ok"
          (a,b,c) -> do putStrLn $ map intToDigit [a,b,c] ++ ' ' : rspReason
                        hPutStrLn stderr rspBody
  where
    (upload, server)    = maybe (False, undefined) (True,) (get optCodespeed opt)

    contentType         = "application/x-www-form-urlencoded"
    url                 = server <> "/result/add/json/"
    payload             = "json=" <> encode (map (toValue opt . sample) reports)
    content             = BS.unpack . urlEncode False $ BL.toStrict payload


module Fungine.Render.Component
  ( render
  )
where

import Fungine.Prelude
import Fungine.Component
import Fungine.Graphics.Geometry as G
import Graphics.Rendering.OpenGL.GL.CoordTrans as GLC hiding (Matrix)
import Graphics.Rendering.OpenGL hiding (Matrix)
import qualified Data.Map as M
import qualified Data.Vector.Storable as VS
import Codec.Picture
import Fungine.Error
import Numeric.LinearAlgebra
import Foreign.Storable (sizeOf)
import Foreign.Ptr
import Data.Text (pack)
import Paths_fungine

-- TODO error handling
loadImage :: UIInfo -> FilePath -> IO (CanError UIInfo)
loadImage info fp = do
  p <- getDataDir
  i <- readImage (p ++ "/textures/" ++ fp)
  case (uiFreeBuffers info, i) of
    (_       , Left e    ) -> pure (Fungine.Error.Error (pack e))
    ((b : bs), Right dyni) -> do
      let (Image w h v) = convertRGBA8 dyni
      textureBinding Texture2D $= Just (TextureObject (fromIntegral b))
      VS.unsafeWith v $ \ptr -> texImage2D
        Texture2D
        NoProxy
        0
        RGBA8
        (TextureSize2D (fromIntegral w) (fromIntegral h))
        0
        (PixelData RGBA UnsignedByte ptr)
      pure $ Success $ info
        { uiLoads       = M.insert
          (UIImage fp)
          (UILoadedImage ((w, h), TextureObject (fromIntegral b)))
          (uiLoads info)
        , uiFreeBuffers = bs
        }
    ([], _) -> pure $ Fungine.Error.Error "out of free buffers for ui texture binding"

loadUITextures :: UIInfo -> UIComponent e -> IO (CanError UIInfo)
loadUITextures info c = case (M.lookup (uiRenderable c) (uiLoads info), uiRenderable c) of
  (Nothing, UINoRender  ) -> go (Success info) (uiChildren c)
  (Nothing, UIText _    ) -> go (Success info) (uiChildren c)
  (Nothing, (UIImage fp)) -> do
    img <- loadImage info fp
    go img (uiChildren c)
  (Just r, re) -> go (Success info { uiLoads = M.insert re r (uiLoads info) }) (uiChildren c)
 where
  go (Fungine.Error.Error t    ) _          = pure $ Fungine.Error.Error t
  go (Success             info') []         = pure $ Success info'
  go (Success             info') (cc : ccs) = do
    info'' <- loadUITextures info' cc
    go info'' ccs

returnUnusedBuffers :: UIInfo -> CanError UIInfo -> IO (CanError UIInfo)
returnUnusedBuffers old (Success new) =
  let mp = M.difference (uiLoads old) (uiLoads new)
  in
    do
      let objs = catMaybes $ M.foldr (\r m -> getObjectName r : m) [] mp
      pure $ Success $ new { uiFreeBuffers = objs ++ uiFreeBuffers new }

 where
  getObjectName (UILoadedImage (_, TextureObject i)) = Just i
  getObjectName _ = Nothing

returnUnusedBuffers _ (Fungine.Error.Error t) = pure $ Fungine.Error.Error t

collectEvents :: CanError UIInfo -> UIComponent e -> [e]
collectEvents _ _ = [] -- TODO actually collect events

render :: UIInfo -> UIComponent e -> IO (CanError (UIInfo, [e]))
render info c = do
  blend $= Enabled
  blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
  -- generate a scale matrix based on center of screen
  let (x, y) = rectangleTopLeft $ uiBounds info
  let (w, h) = rectangleDim $ uiBounds info
  let
    view =
      tr
        $                        (G.scale3 (2 / w) (2 / h) 1)
        Numeric.LinearAlgebra.<> (G.translate (Point3d (x - w / 2) (y + h / 2) 0))
  info'  <- loadUITextures info c
  info'' <- returnUnusedBuffers info info'
  ce     <- renderComponent info'' view c
  whenError ce putStrLn -- TODO better error handling
  pure $ fmap (\i -> (i, collectEvents info'' c)) ce

-- TODO clean this function up, too long
renderComponent :: CanError UIInfo -> Matrix Float -> UIComponent e -> IO (CanError UIInfo)
renderComponent (Fungine.Error.Error t) _ _ = pure $ Fungine.Error.Error t
renderComponent (Success info) view c = -- TODO use view matrix
  let
    rot    = G.rotate (uiRotation c) (Point3d 0 0 1) -- TODO use rot
    (w, h) = rectangleDim (uiRectangle c info)
    (x, y) = rectangleTopLeft (uiRectangle c info)
    verts =
      [ x + w
      , negate (y + h)
      , 1
      , 0
      , 0
      , 0
      , 0
      , 1
      , 1
      , 0
      , 0
      , 1 -- x,y,z,r,g,b,a,uv1,uv2,norm
      , x + w
      , negate y
      , 1
      , 0
      , 0
      , 0
      , 0
      , 1
      , 0
      , 0
      , 0
      , 1
      , x
      , negate y
      , 1
      , 0
      , 0
      , 0
      , 0
      , 0
      , 0
      , 0
      , 0
      , 1
      , x
      , negate (y + h)
      , 1
      , 0
      , 0
      , 0
      , 0
      , 0
      , 1
      , 0
      , 0
      , 1
      ] :: [Float]
    shapes = [0, 1, 3, 1, 2, 3] :: [Word32]
    tx     = M.lookup (uiRenderable c) (uiLoads info)
  in case tx of
    Just (UILoadedImage (_, tobj)) -> do
      currentProgram $= Just (uiShader info)
      vao <- genObjectName
      vbo <- genObjectName
      ebo <- genObjectName
      bindVertexArrayObject $= Just vao
      bindBuffer ArrayBuffer $= Just vbo
      VS.unsafeWith (VS.fromList verts) $ \ptr ->
        bufferData ArrayBuffer
          $= (fromIntegral (length verts * sizeOf (0 :: Float)), ptr, DynamicDraw)
      bindBuffer ElementArrayBuffer $= Just ebo
      VS.unsafeWith (VS.fromList shapes) $ \ptr ->
        bufferData ElementArrayBuffer
          $= (fromIntegral (length shapes * sizeOf (0 :: Word32)), ptr, DynamicDraw)
      vertexAttribPointer (AttribLocation 0)
        $= ( ToFloat
           , VertexArrayDescriptor 3 Float (fromIntegral (12 * sizeOf (0 :: Float))) nullPtr
           )
      vertexAttribArray (AttribLocation 0) $= Enabled
      vertexAttribPointer (AttribLocation 1)
        $= ( ToFloat
           , VertexArrayDescriptor
             4
             Float
             (fromIntegral (12 * sizeOf (0 :: Float)))
             (plusPtr nullPtr (3 * sizeOf (0 :: Float)))
           )
      vertexAttribArray (AttribLocation 1) $= Enabled
      vertexAttribPointer (AttribLocation 2)
        $= ( ToFloat
           , VertexArrayDescriptor
             2
             Float
             (fromIntegral (12 * sizeOf (0 :: Float)))
             (plusPtr nullPtr (7 * sizeOf (0 :: Float)))
           )
      vertexAttribArray (AttribLocation 2) $= Enabled
      vertexAttribPointer (AttribLocation 3)
        $= ( ToFloat
           , VertexArrayDescriptor
             3
             Float
             (fromIntegral (12 * sizeOf (0 :: Float)))
             (plusPtr nullPtr (9 * sizeOf (0 :: Float)))
           )
      vertexAttribArray (AttribLocation 3) $= Enabled
      activeTexture $= TextureUnit 0
      textureBinding Texture2D $= Just tobj
      textureWrapMode Texture2D S $= (Repeated, Repeat)
      textureWrapMode Texture2D T $= (Repeated, Repeat)
      textureFilter Texture2D $= ((Linear', Nothing), Linear')

      mx  <- newMatrix ColumnMajor (VS.toList $ flatten view) :: IO (GLmatrix GLfloat)
      uni <- uniformLocation (uiShader info) "transform"
      uniform uni $= mx
      drawElements Triangles 6 UnsignedInt nullPtr
      foldM
        (\info' ch -> renderComponent info' view ch)
        (Success info { uiBounds = uiRectangle c info })
        (uiChildren c)
    _ -> case uiRenderable c of
      UINoRender -> foldM
        (\info' ch -> renderComponent info' view ch)
        (Success info { uiBounds = uiRectangle c info })
        (uiChildren c)
      _ -> return $ Fungine.Error.Error "could not find texture"