{-# LANGUAGE CPP                       #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE MonoLocalBinds            #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE StandaloneDeriving        #-}
{-# LANGUAGE UndecidableInstances      #-}

-- {-# LANGUAGE IncoherentInstances    #-}
-- |Flat Instances for common, primitive and abstract data types for which instances cannot be automatically derived
module Data.Flat.Instances
  ( sizeMap
  , encodeMap
  , decodeMap
  , sizeSequence
  , encodeSequence
  , decodeSequence
  ) where

-- import Data.Function (trampoline)
import qualified Data.ByteString       as B
import qualified Data.ByteString.Lazy  as L
import qualified Data.ByteString.Short as SBS
import           Data.Char
import           Data.Containers       (ContainerKey, IsMap, MapValue,
                                        mapFromList, mapToList)
import           Data.Flat.Class
import           Data.Flat.Decoder
import           Data.Flat.Encoder

--import           Data.Flat.Size        (arrayBits)
-- import qualified Data.DList                    as DL
import           Data.Flat.Types
import qualified Data.Foldable         as F

import           Data.MonoTraversable
import           Data.Sequences        as S
import qualified Data.Sequences        as S

import qualified Data.Complex          as B
import qualified Data.Ratio            as B
import qualified Data.Text             as T
import           Prelude               hiding (mempty)

import qualified Data.IntMap           as M
import qualified Data.Map              as M

-- containers
import qualified Data.Tree             as C

import           Data.List
import qualified Data.Sequence         as S
#if MIN_VERSION_base(4,9,0)
import qualified Data.List.NonEmpty    as B
#else
-- import           GHC.Generics
deriving instance Generic (B.Complex a)

deriving instance Generic (C.Tree a)
#endif
-- #ifdef ETA_VERSION
-- import Data.Function(trampoline)
-- import GHC.IO(trampolineIO)
-- #else
-- trampoline = id
-- trampolineIO = id
-- #endif
-- Instances for the base library
-- "7 elements tuples ought to be enough for anybody" (Bill Gates - apocryphal)
instance {-# OVERLAPPABLE #-} (Flat a, Flat b) => Flat (a, b)

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

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

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

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

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

instance Flat () where
  encode _ = mempty
  size _ = (+) 0
  decode = pure ()

instance Flat Bool where
  encode = eBool
  size = sBool
  decode = dBool

instance Flat Char where
  size = sChar
  encode = eChar
  decode = dChar

instance Flat a => Flat (B.Complex a)

instance (Flat a, Flat b) => Flat (Either a b)

instance Flat Int8 where
  encode = eInt8
  decode = dInt8
  size = sInt8

instance Flat Int16 where
  size = sInt16
  encode = eInt16
  decode = dInt16

instance Flat Int32 where
  size = sInt32
  encode = eInt32
  decode = dInt32

instance Flat Int64 where
  size = sInt64
  encode = eInt64
  decode = dInt64

instance Flat Int where
  size = sInt
  encode = eInt
  decode = dInt

-- Generic list instance (stack overflows with ETA, see https://github.com/typelead/eta/issues/901)
-- instance {-# OVERLAPPABLE #-} Flat a => Flat [a]
instance {-# OVERLAPPABLE #-} Flat a => Flat [a] -- where
  --size [] n = n+1
  --size (h:t) n = trampoline size t (trampoline size h (n+1))
  -- size = sizeListWith size -- foldl' (\n e -> ) n
  -- encode = error "BAD"
  -- encode = trampoline . encodeListWith encode
  -- decode = decodeListWith decode

sizeListWith siz l n = foldl' (\n e -> 1 + n + siz e 0) n l

-- For better encoding/decoding performance, it is useful to declare instances of concrete list types.
-- As this one for example:
instance {-# OVERLAPPING #-} Flat [Char]
#if MIN_VERSION_base(4,9,0)
instance {-# OVERLAPPABLE #-} Flat a => Flat (B.NonEmpty a)
#else

#endif
instance Flat a => Flat (Maybe a)

instance (Integral a, Flat a) => Flat (B.Ratio a) where
  size a = size (B.numerator a, B.denominator a)
  encode a = encode (B.numerator a, B.denominator a)
  decode = uncurry (B.%) <$> decode

instance Flat Word8 where
  encode = eWord8
  decode = dWord8
  size = sWord8

instance Flat Word16 where
  encode = eWord16
  decode = dWord16
  size = sWord16

instance Flat Word32 where
  encode = eWord32
  decode = dWord32
  size = sWord32

instance Flat Word64 where
  encode = eWord64
  decode = dWord64
  size = sWord64

instance Flat Word where
  size = sWord
  encode = eWord
  decode = dWord

instance Flat Natural where
  size = sNatural
  encode = eNatural
  decode = dNatural

instance Flat Integer where
  size = sInteger
  encode = eInteger
  decode = dInteger

instance Flat Float where
  size = sFloat
  encode = eFloat
  decode = dFloat

instance Flat Double where
  size = sDouble
  encode = eDouble
  decode = dDouble

-- Instances for the text library
instance Flat T.Text where
  size = sUTF8Max
  encode = eUTF8
  decode = dUTF8

instance Flat UTF8Text where
  size (UTF8Text t) = sUTF8Max t
  encode (UTF8Text t) = eUTF8 t
  decode = UTF8Text <$> dUTF8
#ifndef ghcjs_HOST_OS
instance Flat UTF16Text where
  size (UTF16Text t) = sUTF16 t
  encode (UTF16Text t) = eUTF16 t
  decode = UTF16Text <$> dUTF16
#endif
-- Instances for the bytestring library
instance Flat B.ByteString where
  encode = eBytes
  size = sBytes
  decode = dByteString

instance Flat L.ByteString where
  encode = eLazyBytes
  size = sLazyBytes
  decode = dLazyByteString

instance Flat SBS.ShortByteString where
  encode = eShortBytes
  size = sShortBytes
  decode = dShortByteString

-- TODO Instances for the array library
-- Instances for the dlist? library
-- Constructors not in scope
-- deriving instance Generic (DL.DList a)
-- instance Flat a => Flat (DL.DList a)
-- TODO Instances for the vector library
-- Instances for the mono-traversable library
{-|
Maps are defined as a list of (Key,Value) tuples:

Map = List (Key,Value)

List a = Nil | Cons a (List a)
-}
-- instance {-# OVERLAPPABLE #-} (Flat (ContainerKey r), Flat (MapValue r), IsMap r) => Flat r where
--   size = sizeMap
--   encode = encodeMap
--   decode = decodeMap
{-| Calculate the size of a map by adding:
* the sizes of all the entries (Key,Value)
* plus 1 bit per entry (corresponding to the List's Cons)
* plus 1 bit for the final Nil.
-}
sizeMap :: (Flat (ContainerKey r), Flat (MapValue r), IsMap r) => Size r
sizeMap m acc =
  F.foldl' (\acc' (k, v) -> size k (size v (acc' + 1))) (acc + 1) . mapToList $
  m

{-# INLINE sizeMap #-}
{-# INLINE encodeMap #-}
-- |Encode an instance of IsMap, as a list of (Key,Value) tuples
encodeMap ::
     (Flat (ContainerKey map), Flat (MapValue map), IsMap map)
  => map
  -> Encoding
encodeMap = encodeListWith (\(k, v) -> encode k <> encode v) . mapToList

-- encodeMap = go . mapToList
--   where
--     go []     = eFalse
--     go ((!x,!y):xs) = eTrue <> encode x <> encode y <> go xs
{-# INLINE decodeMap #-}
-- |Decode an instance of IsMap, as a list of (Key,Value) tuples
decodeMap ::
     (Flat (ContainerKey map), Flat (MapValue map), IsMap map) => Get map
decodeMap = mapFromList <$> decodeListWith ((,) <$> decode <*> decode)

{-|
Sequences are defined as Arrays:

Array v = A0
        | A1 v (Array v)
        | A2 v v (Array v)
        ...
        | A255 ... (Array v)

In practice, this means that the sequence is encoded as a sequence of blocks of up to 255 elements, with every block preceded by the count of the elements in the block and a final 0-length block.

For example, the sequence of Word8 values 11, 22 and 33 is encoded as the byte sequence:
[3,11,22,33,0]
-}
newtype AsList a =
  AsList
    { unList :: a
    }

-- instance (IsSequence r, Flat (Element r), IsSequence r) => Flat (AsList r) where
--     size (AsList a) = size (toList a)
--     encode (AsList a) = encode (toList a)
--     decode = AsList . fromList <$> decode
newtype AsArray a =
  AsArray
    { unArray :: a
    }

instance (IsSequence r, Flat (Element r)) => Flat (AsArray r) where
  size (AsArray a) = sizeSequence a
  encode (AsArray a) = encodeSequence a
  decode = AsArray <$> decodeSequence

instance {-# OVERLAPPABLE #-} (Flat (Element r), IsSequence r) => Flat r where
  size = sizeSequence
  encode = encodeSequence
  decode = decodeSequence

-- |Calculate size of an instance of IsSequence as the sum:
-- * of the size of all the elements
-- * plus the size of the array constructors (1 byte every 255 elements plus one final byte)
sizeSequence ::
     (IsSequence mono, Flat (Element mono)) => mono -> NumBits -> NumBits
sizeSequence s acc = ofoldl' (flip size) acc s + arrayBits (olength s)

{-# INLINE sizeSequence #-}
-- |Encode an instance of IsSequence, as an array
encodeSequence :: (Flat (Element mono), IsSequence mono) => mono -> Encoding
encodeSequence = encodeArrayWith encode . otoList

{-# INLINE encodeSequence #-}
-- |Decode an instance of IsSequence, as an array
decodeSequence :: (Flat (Element b), IsSequence b) => Get b
decodeSequence = fromList <$> decodeArrayWith decode

{-# INLINE decodeSequence #-}
-- Instances for the containers library
instance (Generic a, Flat a) => Flat (C.Tree a)

instance (Generic a, Flat a) => Flat (C.Forest a)

-- deriving instance Generic (C.Tree a)
instance (Flat a, Flat b, Ord a) => Flat (M.Map a b) where
  size = sizeMap
  encode = encodeMap
  decode = decodeMap

instance Flat a => Flat (M.IntMap a) where
  size = sizeMap
  encode = encodeMap
  decode = decodeMap
-- instance Flat a => Flat (S.Seq a) where
--  size = sizeSequence
--  encode = encodeSequence
--  decode = decodeSequence


{-# LANGUAGE StaticPointers #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Control.Distributed.Closure.Static where

import Control.Distributed.Closure hiding (Static(..))
import Data.Binary
import Type.Reflection

import qualified Control.Concurrent
import qualified Data.ByteString
import qualified Data.ByteString.Lazy
import qualified Data.ByteString.Short
import qualified Data.Complex
import qualified Data.Int
import qualified Data.IntSet
import qualified Data.Maybe
import qualified Data.Monoid
import qualified Data.Semigroup
import qualified Data.Version
import qualified Data.Void
import qualified Data.Word
import qualified GHC.Exts
import qualified GHC.Fingerprint.Type
import qualified Numeric.Natural
import qualified Type.Reflection.Unsafe

class (c, Typeable c) => Static c where
  -- dict :: Dict c
  -- dict = Dict
  closureDict :: Closure (Dict c)
  closureDictStatic :: Closure (Dict (Static c))

instance (Static c1, Static c2, Typeable c1, Typeable c2, (c1, c2)) =>
         Static (c1, c2) where
  closureDict = static dict `cap` closureDict `cap` closureDict
    where dict :: Dict c3 -> Dict c4 -> Dict (c3, c4)
          dict Dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic `cap` closureDictStatic
    where dict :: Dict (Static c3) -> Dict (Static c4) -> Dict (Static (c3, c4))
          dict Dict Dict = Dict

-- Static Binary and Static Typeable instances for basic types

instance Static (Binary ()) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Data.ByteString.ByteString) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Data.ByteString.Lazy.ByteString) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Data.ByteString.Short.ShortByteString) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Data.Int.Int16) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Data.Int.Int32) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Data.Int.Int64) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Data.Int.Int8) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Data.IntSet.IntSet) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Data.Monoid.All) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Data.Monoid.Any) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Data.Word.Word16) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Data.Word.Word32) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Data.Word.Word64) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Data.Word.Word8) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Data.Version.Version) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Data.Void.Void) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary GHC.Exts.RuntimeRep) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary GHC.Exts.VecCount) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary GHC.Exts.VecElem) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary GHC.Fingerprint.Type.Fingerprint) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Numeric.Natural.Natural) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Prelude.Bool) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Prelude.Char) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Prelude.Double) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Prelude.Float) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Prelude.Int) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Prelude.Integer) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Prelude.Ordering) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Prelude.Word) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Type.Reflection.SomeTypeRep) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Type.Reflection.TyCon) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Type.Reflection.Unsafe.KindRep) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Binary Type.Reflection.Unsafe.TypeLitSort) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable ()) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Data.ByteString.ByteString) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Data.ByteString.Lazy.ByteString) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Data.ByteString.Short.ShortByteString) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Data.Int.Int16) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Data.Int.Int32) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Data.Int.Int64) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Data.Int.Int8) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Data.IntSet.IntSet) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Data.Monoid.All) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Data.Monoid.Any) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Data.Word.Word16) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Data.Word.Word32) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Data.Word.Word64) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Data.Word.Word8) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Data.Version.Version) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Data.Void.Void) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable GHC.Exts.RuntimeRep) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable GHC.Exts.VecCount) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable GHC.Exts.VecElem) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable GHC.Fingerprint.Type.Fingerprint) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Numeric.Natural.Natural) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Prelude.Bool) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Prelude.Char) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Prelude.Double) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Prelude.Float) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Prelude.Int) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Prelude.Integer) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Prelude.Ordering) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Prelude.Word) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Type.Reflection.SomeTypeRep) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Type.Reflection.TyCon) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Type.Reflection.Unsafe.KindRep) where
  closureDict = static Dict
  closureDictStatic = static Dict

instance Static (Typeable Type.Reflection.Unsafe.TypeLitSort) where
  closureDict = static Dict
  closureDictStatic = static Dict

-- Static Binary and Static Typeable instances for basic type constructors

instance (Static (Typeable a), Static (Binary a)) => Static (Binary [a]) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Binary b) -> Dict (Binary [b])
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic `cap` closureDictStatic
    where dict :: Dict (Static (Typeable b))
               -> Dict (Static (Binary b))
               -> Dict (Static (Binary [b]))
          dict Dict Dict = Dict

instance (Static (Typeable a), Static (Binary a)) =>
         Static (Binary (Data.Complex.Complex a)) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Binary b) -> Dict (Binary (Data.Complex.Complex b))
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic `cap` closureDictStatic
    where dict :: Dict (Static (Typeable b))
               -> Dict (Static (Binary b))
               -> Dict (Static (Binary (Data.Complex.Complex b)))
          dict Dict Dict = Dict

instance (Static (Typeable a), Static (Binary a)) =>
         Static (Binary (Data.Maybe.Maybe a)) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Binary b) -> Dict (Binary (Data.Maybe.Maybe b))
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic `cap` closureDictStatic
    where dict :: Dict (Static (Typeable b))
               -> Dict (Static (Binary b))
               -> Dict (Static (Binary (Data.Maybe.Maybe b)))
          dict Dict Dict = Dict

instance (Static (Typeable a), Static (Binary a)) =>
         Static (Binary (Data.Monoid.Dual a)) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Binary b) -> Dict (Binary (Data.Monoid.Dual b))
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic `cap` closureDictStatic
    where dict :: Dict (Static (Binary b))
               -> Dict (Static (Typeable b))
               -> Dict (Static (Binary (Data.Monoid.Dual b)))
          dict Dict Dict = Dict

instance (Static (Typeable a), Static (Binary a)) =>
         Static (Binary (Data.Monoid.First a)) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Binary b) -> Dict (Binary (Data.Monoid.First b))
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic `cap` closureDictStatic
    where dict :: Dict (Static (Binary b))
               -> Dict (Static (Typeable b))
               -> Dict (Static (Binary (Data.Monoid.First b)))
          dict Dict Dict = Dict

instance (Static (Typeable a), Static (Binary a)) =>
         Static (Binary (Data.Monoid.Last a)) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Binary b) -> Dict (Binary (Data.Monoid.Last b))
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic `cap` closureDictStatic
    where dict :: Dict (Static (Binary b))
               -> Dict (Static (Typeable b))
               -> Dict (Static (Binary (Data.Monoid.Last b)))
          dict Dict Dict = Dict

instance (Static (Typeable a), Static (Binary a)) =>
         Static (Binary (Data.Monoid.Product a)) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Binary b) -> Dict (Binary (Data.Monoid.Product b))
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic `cap` closureDictStatic
    where dict :: Dict (Static (Binary b))
               -> Dict (Static (Typeable b))
               -> Dict (Static (Binary (Data.Monoid.Product b)))
          dict Dict Dict = Dict

instance (Static (Typeable a), Static (Binary a)) =>
         Static (Binary (Data.Monoid.Sum a)) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Binary b) -> Dict (Binary (Data.Monoid.Sum b))
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic `cap` closureDictStatic
    where dict :: Dict (Static (Binary b))
               -> Dict (Static (Typeable b))
               -> Dict (Static (Binary (Data.Monoid.Sum b)))
          dict Dict Dict = Dict

instance (Static (Typeable a), Static (Binary a)) =>
         Static (Binary (Data.Semigroup.Max a)) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Binary b) -> Dict (Binary (Data.Semigroup.Max b))
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic `cap` closureDictStatic
    where dict :: Dict (Static (Typeable b))
               -> Dict (Static (Binary b))
               -> Dict (Static (Binary (Data.Semigroup.Max b)))
          dict Dict Dict = Dict

instance (Static (Typeable a), Static (Binary a)) =>
         Static (Binary (Data.Semigroup.Min a)) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Binary b) -> Dict (Binary (Data.Semigroup.Min b))
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic `cap` closureDictStatic
    where dict :: Dict (Static (Typeable b))
               -> Dict (Static (Binary b))
               -> Dict (Static (Binary (Data.Semigroup.Min b)))
          dict Dict Dict = Dict

instance Static (Typeable a) => Static (Typeable [a]) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Typeable b) -> Dict (Typeable [b])
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic
    where dict :: Dict (Static (Typeable b))
               -> Dict (Static (Typeable [b]))
          dict Dict = Dict

instance Static (Typeable a) =>
         Static (Typeable (Data.Complex.Complex a)) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Typeable b) -> Dict (Typeable (Data.Complex.Complex b))
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic
    where dict :: Dict (Static (Typeable b))
               -> Dict (Static (Typeable (Data.Complex.Complex b)))
          dict Dict = Dict

instance Static (Typeable a) =>
         Static (Typeable (Data.Maybe.Maybe a)) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Typeable b) -> Dict (Typeable (Data.Maybe.Maybe b))
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic
    where dict :: Dict (Static (Typeable b))
               -> Dict (Static (Typeable (Data.Maybe.Maybe b)))
          dict Dict = Dict

instance Static (Typeable a) =>
         Static (Typeable (Data.Monoid.Dual a)) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Typeable b) -> Dict (Typeable (Data.Monoid.Dual b))
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic
    where dict :: Dict (Static (Typeable b))
               -> Dict (Static (Typeable (Data.Monoid.Dual b)))
          dict Dict = Dict

instance Static (Typeable a) =>
         Static (Typeable (Data.Monoid.First a)) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Typeable b) -> Dict (Typeable (Data.Monoid.First b))
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic
    where dict :: Dict (Static (Typeable b))
               -> Dict (Static (Typeable (Data.Monoid.First b)))
          dict Dict = Dict

instance Static (Typeable a) =>
         Static (Typeable (Data.Monoid.Last a)) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Typeable b) -> Dict (Typeable (Data.Monoid.Last b))
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic
    where dict :: Dict (Static (Typeable b))
               -> Dict (Static (Typeable (Data.Monoid.Last b)))
          dict Dict = Dict

instance Static (Typeable a) =>
         Static (Typeable (Data.Monoid.Product a)) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Typeable b) -> Dict (Typeable (Data.Monoid.Product b))
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic
    where dict :: Dict (Static (Typeable b))
               -> Dict (Static (Typeable (Data.Monoid.Product b)))
          dict Dict = Dict

instance Static (Typeable a) =>
         Static (Typeable (Data.Monoid.Sum a)) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Typeable b) -> Dict (Typeable (Data.Monoid.Sum b))
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic
    where dict :: Dict (Static (Typeable b))
               -> Dict (Static (Typeable (Data.Monoid.Sum b)))
          dict Dict = Dict

instance Static (Typeable a) =>
         Static (Typeable (Data.Semigroup.Max a)) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Typeable b) -> Dict (Typeable (Data.Semigroup.Max b))
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic
    where dict :: Dict (Static (Typeable b))
               -> Dict (Static (Typeable (Data.Semigroup.Max b)))
          dict Dict = Dict

instance Static (Typeable a) =>
         Static (Typeable (Data.Semigroup.Min a)) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Typeable b) -> Dict (Typeable (Data.Semigroup.Min b))
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic
    where dict :: Dict (Static (Typeable b))
               -> Dict (Static (Typeable (Data.Semigroup.Min b)))
          dict Dict = Dict

-- Static Typeable without Static Binary instances for basic type constructors

instance Static (Typeable a) =>
         Static (Typeable (Control.Concurrent.MVar a)) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Typeable b)
               -> Dict (Typeable (Control.Concurrent.MVar b))
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic
    where dict :: Dict (Static (Typeable b))
               -> Dict (Static (Typeable (Control.Concurrent.MVar b)))
          dict Dict = Dict

instance Static (Typeable a) => Static (Typeable (Data.Monoid.Endo a)) where
  closureDict = static dict `cap` closureDict
    where dict :: Dict (Typeable b) -> Dict (Typeable (Data.Monoid.Endo b))
          dict Dict = Dict
  closureDictStatic =
    static dict `cap` closureDictStatic
    where dict :: Dict (Static (Typeable b))
               -> Dict (Static (Typeable (Data.Monoid.Endo b)))
          dict Dict = Dict


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLabels #-}

module Lib where

import Control.Applicative
import Prelude

import Data.Maybe
import GI.Gtk
       (widgetShowAll, onWidgetDestroy, setWindowDefaultHeight,
        setWindowDefaultWidth, setWindowTitle, boxPackStart, boxNew,
        frameSetShadowType, aspectFrameNew,
        widgetGetAllocatedHeight, widgetGetAllocatedWidth, onWidgetDraw,
        onWidgetLeaveNotifyEvent, onWidgetMotionNotifyEvent,
        widgetAddEvents, alignmentSetPadding, alignmentNew, rangeSetValue,
        scaleSetDigits, scaleSetValuePos, rangeGetValue,
        afterScaleButtonValueChanged, scaleNewWithRange, containerAdd,
        buttonBoxNew, mainQuit, onButtonActivate,
        toggleButtonGetActive, onToggleButtonToggled, buttonSetUseStock,
        toggleButtonNewWithLabel, onButtonClicked,
        buttonNewWithLabel, widgetQueueDraw, drawingAreaNew,
        windowNew, widgetDestroy, dialogRun, setAboutDialogComments,
        setAboutDialogAuthors, setAboutDialogVersion,
        setAboutDialogProgramName, aboutDialogNew, labelNew, get)
import qualified GI.Gtk as Gtk (DrawingArea(..), unsafeCastTo, Window(..)
                               , builderGetObject, builderAddFromFile, builderNew)
import GI.Cairo
import Control.Monad
import Data.IORef
import Data.List
import Data.Time
import Data.Complex
import Control.Monad.IO.Class (MonadIO(..))
import Graphics.Rendering.Cairo
       (fill, restore, save, stroke, arc, setDash, setLineWidth, rotate, rectangle,
        setSourceRGBA, setSourceRGB, newPath, scale, translate, lineTo,
        moveTo, Render)
import qualified GI.Gtk as GI (init, main)
import GI.GLib (sourceRemove, timeoutAdd)
import GI.Gdk
       (getEventMotionY, getEventMotionX, windowGetHeight,
        windowGetWidth, getEventMotionWindow)
import GI.Gdk.Flags (EventMask(..))
import Control.Monad.Trans.Reader (ReaderT(..))
import GI.Gtk.Enums
       (Orientation(..), WindowType(..), ShadowType(..), PositionType(..))

import Data.Monoid ((<>))
import Data.GI.Base.BasicConversions (gflagsToWord)
import Graphics.Rendering.Cairo.Types (Cairo(..))
import Foreign.Ptr (castPtr)
import Graphics.Rendering.Cairo.Internal (Render(..))

main :: IO ()
main = do

    GI.init Nothing

    builder <- Gtk.builderNew
    Gtk.builderAddFromFile builder "transparent.glade"
    mainWindow <- Gtk.builderGetObject builder "main_window" >>= Gtk.unsafeCastTo Gtk.Window . fromJust
    drawingArea <- Gtk.builderGetObject builder "drawing_area" >>= Gtk.unsafeCastTo Gtk.DrawingArea . fromJust

    screen <- mainWindow `get` #screen
    visual <- #getRgbaVisual screen
    #setVisual mainWindow visual

    onWidgetDraw drawingArea $ \(Context fp) -> withManagedPtr fp $ \p -> (`runReaderT` Cairo (castPtr p)) $ runRender $ do
      w <- liftIO $ fromIntegral <$> widgetGetAllocatedWidth drawingArea
      h <- liftIO $ fromIntegral <$> widgetGetAllocatedHeight drawingArea
      renderBG w h
      return True

    setWindowTitle mainWindow "TransparentHs"
    onWidgetDestroy mainWindow mainQuit
    widgetShowAll mainWindow

    GI.main

renderBG :: Double -> Double -> Render ()
renderBG w h = do
--  save
  setSourceRGBA 0.1953125 0.203125 0 0.6640625
  rectangle 0 0 w h
  fill
--  restore


-- |
-- Module      : SpriteClip.Events
-- Description :
-- Copyright   : (c) Jonatan H Sundqvist, 2015
-- License     : MIT
-- Maintainer  : Jonatan H Sundqvist
-- Stability   : experimental|stable
-- Portability : POSIX (not sure)
--

-- Created September 7 2015

-- TODO | - Encode all logic in types (state machine?)
--        - Preferences and keymaps
--        - Sophisticated command dispatch (eg. composite events, overlapping events)

-- SPEC | -
--        -

--------------------------------------------------------------------------------------------------------------------------------------------
-- GHC Pragmas
--------------------------------------------------------------------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
module SpriteClip.Events (module SpriteClip.Events) where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
import Data.Complex
import Data.Functor
import Data.Char (toLower)
import Data.IORef
import Data.Maybe (fromMaybe)

import qualified Data.Set  as S
import qualified Data.Text as T
import qualified Data.Map  as M

import Text.Printf
import Control.Monad (liftM, when, forM_, forM, unless)

import System.FilePath (takeExtension)

import qualified Graphics.Rendering.Cairo as Cairo --
import           Graphics.UI.Gtk          as Gtk   --

import qualified Southpaw.Interactive.Application     as App
import qualified Southpaw.Cartesian.Plane.BoundingBox as BBox
import Southpaw.Cartesian.Plane.Utilities

import SpriteClip.Types
import SpriteClip.Lenses
import SpriteClip.Render             as Render
import qualified SpriteClip.Commands as Commands

--------------------------------------------------------------------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------------------------------------------------------------------
-- Event configurations --------------------------------------------------------------------------------------------------------------------
-- |
-- widgetAcceptsDNDEvents ::
widgetAcceptsDNDEvents :: WidgetClass self => self -> IO ()
widgetAcceptsDNDEvents widget = do
    dragDestSet widget [DestDefaultMotion, DestDefaultDrop] [ActionCopy]
    -- dragDestAddTextTargets  widget
    -- dragDestAddImageTargets widget
    dragDestAddURITargets   widget

-- |
-- widgetAddDNDListeners ::
widgetAddDNDListeners :: WidgetClass widget => App.App AppState -> widget -> IO ()
widgetAddDNDListeners app widget = do
  widget `on` dragBegin        $ ondragbegin    app
  widget `on` dragMotion       $ ondragmotion   app -- TODO: Why won't this work?
  widget `on` dragDrop         $ ondragdrop     app
  widget `on` dragDataReceived $ ondragreceived app
  return ()

-- Rendering -------------------------------------------------------------------------------------------------------------------------------
-- |
-- TODO: Figure out canvasSize
ondraw :: AppState -> Cairo.Render ()
ondraw = Render.render

-- Animation -------------------------------------------------------------------------------------------------------------------------------
-- |
onanimate :: Gtk.DrawingArea -> IORef AppState -> IO Bool
onanimate cvs stateref = Gtk.widgetQueueDraw cvs >> return True

-- Keyboard --------------------------------------------------------------------------------------------------------------------------------
-- |
onkeydown :: IORef AppState -> EventM EKey Bool
onkeydown stateref = do
  key <- eventKeyName
  appstate <- Cairo.liftIO $ readIORef stateref

  Cairo.liftIO $ unless (S.member key $ appstate^.keys) $ do
    -- TODO: Needs heavy refactoring
    -- TODO: Use foldM (?)
    forM (Commands.dispatch (T.unpack key) (S.map T.unpack . S.insert key $ appstate^.keys) Commands.commands) $ \command -> do
      putStrLn "Running command"
      appstate <- readIORef stateref
      newstate <- command appstate
      writeIORef stateref newstate
      -- newstate <- maybe (return appstate) ($ appstate) $ M.lookup (S.fromList [key]) Commands.commands -- TODO: Factour out
    modifyIORef stateref (keys %~ S.insert (T.toLower key))

  --
  w <- eventWindow
  Cairo.liftIO $ do
    cursor <- cursorNew $ case key of
      "a" -> Pencil
      "b" -> Hand1
      _  -> BlankCursor

    -- children <- containerGetChildren w
    -- widgetGrabFocus
    -- forM_ [w] (liftM (maybe (return ()) (const $ putStrLn "Setting cursor")) . widgetGetWindow)
    forM_ [w] (flip drawWindowSetCursor (Just cursor))

  return True

-- |
onkeyup :: IORef AppState -> EventM EKey Bool
onkeyup stateref = do
  key <- eventKeyName
  Cairo.liftIO $ do
    modifyIORef stateref (keys %~ S.delete (T.toLower key))
    printf "Key %s was released.\n" (T.unpack key)
  return False

-- Mouse -----------------------------------------------------------------------------------------------------------------------------------
-- |
onmousemotion :: IORef AppState -> EventM EMotion Bool
onmousemotion stateref = do
  (mx, my) <- eventCoordinates
  Cairo.liftIO $ modifyIORef stateref (mouse .~ (mx:+my))
  return False

-- |
onmousedown :: IORef AppState -> EventM EButton Bool
onmousedown stateref = do
  -- TODO: Check which button it is
  -- mouse <- Cairo.liftIO $ readIORef cutouts
  (mx, my) <- eventCoordinates
  Cairo.liftIO $ modifyIORef stateref (pin .~ Just (mx:+my))

  -- Flesh out cursor behaviour (ie. grab hand when hover over marker)
  -- Cairo.liftIO $ putStrLn "Setting icon"
  -- w <- eventWindow
  -- cursor <- Cairo.liftIO $ Gtk.cursorNew Gtk.Hand1
  -- Cairo.liftIO $ Gtk.drawWindowSetCursor w Nothing -- (Just cursor)

  return True -- Keep sending motion-notify events

-- |
onmouseup :: IORef AppState -> EventM EButton Bool
onmouseup stateref = do
  (mx, my) <- eventCoordinates
  -- TODO: Flip corners if necessary (no negative sizes)
  -- ((makebox topleft (cutouts ^. _2)) :)
  Cairo.liftIO $ do
    modifyIORef stateref (\s -> maybe s (\click -> s & cutouts %~ (BBox.fromCorners click (mx:+my) :)) (s ^. pin))
    s <- readIORef stateref
    modifyIORef stateref (pin .~ Nothing)

  return True

-- Drag'n'Drop -----------------------------------------------------------------------------------------------------------------------------
-- |
acceptURIDrops :: IO ()
acceptURIDrops = do
  return ()

-- |
acceptImageDrops :: IO ()
acceptImageDrops = do
  return ()

-- |
-- ondragbegin ::
ondragbegin :: App.App state -> DragContext -> IO ()
ondragbegin app context = do
  -- dragSetIconName
  Cairo.liftIO $ putStrLn "Drag begin"
  return ()

-- |
ondragstatus :: App.App state -> DragContext -> Maybe DragAction -> TimeStamp -> IO ()
ondragstatus app context maction timestamp = do
  Cairo.liftIO $ putStrLn "Drag status"
  return ()

-- |
-- ondragmotion ::
ondragmotion :: App.App AppState -> DragContext -> Point -> TimeStamp -> IO Bool
ondragmotion app context pt timestamp = do
  Cairo.liftIO $ putStrLn "Dragging..."
  atom <- atomNew ("String" :: String)
  s <- dragGetData (App._window app) context atom timestamp
  return True

-- |
-- ondragdrop ::
ondragdrop :: App.App state -> DragContext -> Point -> TimeStamp -> IO Bool
ondragdrop app context pt timestamp = do
  putStrLn "Dropping data. Catch!"
  return True

-- |
-- ondatareceived ::
ondragreceived :: App.App AppState -> DragContext -> Point -> InfoId -> TimeStamp -> SelectionDataM ()
ondragreceived app context pos infoid timestamp = do
  Cairo.liftIO $ putStrLn "Receing data..."
  s <- selectionDataGetURIs
  Cairo.liftIO $ print s
  Cairo.liftIO $ maybe
      (putStrLn "Didn't understand the drop")
      (\uris -> Cairo.liftIO $ when (takeExtension (uris !! 0) == ".png") $ do
         newsheet <- Cairo.imageSurfaceCreateFromPNG . drop (length ("file:///" :: String)) $ uris !! 0
         modifyIORef (App._state app) (sheet .~ newsheet)

         (cx:+cy) <- imageSurfaceSize newsheet >>= return . dotmap floor
         windowResize (App._window app) cx cy)
      -- (mapM_ (printf "Understood, here it is: <%s>.\n"))
      (s :: Maybe [String])

-- Size & Position -------------------------------------------------------------------------------------------------------------------------

-- Admin -----------------------------------------------------------------------------------------------------------------------------------
-- |
onrealised :: App.App AppState -> IO ()
onrealised app = do
  putStrLn "On realised"


{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE ExplicitForAll      #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Elescore.Integration.DB
  ( runDBSource
  ) where

import           ClassyPrelude                          hiding (for, forM, head)
import           Data.DateTime                          (toSqlString)
import           Data.Map                               (elems)
import           Network.HTTP.Client                    (Manager)
import           Pipes
import           Pipes.Concurrent
import qualified Pipes.Prelude                          as P
import           Prelude                                (head)

import           Database.SimpleEventStore
import           Elescore.IdTypes
import           Elescore.Integration.Common.Monitoring
import           Elescore.Integration.Common.Types
import           Elescore.Integration.Common.Utils
import           Elescore.Integration.DB.Client
import           Elescore.Integration.DB.Mapping
import           Elescore.Integration.DB.Monitoring
import           Elescore.Integration.DB.Types
import           Statistics.IQR

runDBSource :: MonadIO m => Store -> ApiKey -> Host -> Manager -> m (Source 'DB)
runDBSource store key host mgr = do
  disP <- disruptions store
  fP <- facilities store
  oEvs <- liftIO (readStream store)

  let oState = replayMkSeed dbObjectMonitor . fmap evPayload $ oEvs
      oIds = keys oState
      oP = objects store oEvs

  (output, input) <- liftIO (spawn unbounded)

  (out1, in1) <- liftIO (spawn unbounded)
  (out2, in2) <- liftIO (spawn unbounded)
  (out3, in3) <- liftIO (spawn unbounded)

  liftIO $ do
    void . forkIO . runEffect $ apiP 10 fetchDisruptedFacilities >-> disP >-> toOutput out1
    void . forkIO . runEffect $ apiP 3600 (fetchFacilities Nothing) >-> fP >-> toOutput (output <> out2)
    void . forkIO . runEffect $ fromInput input >-> P.map evPayload >-> stationFilterP oIds >-> fetchStationP 5 >-> oP >-> toOutput out3

  return Source
     { disruptionEvents = in1
     , facilityEvents = in2
     , objectEvents = in3
     }

  where
    stationFilterP :: MonadIO m => [ObjectId] -> Pipe (FacilityEvent 'DB) ObjectId m ()
    stationFilterP = go
      where
        go s = do
          ev <- await
          case ev of
            FacilityAssignedToObject _ oid -> unless (oid `elem` s) (yield oid >> go (oid : s))
            _                              -> return ()
          go s

    fetchStationP :: Int -> Pipe ObjectId Station IO ()
    fetchStationP delay = forever $ do
      oid <- fromObjectId <$> await
      a <- liftIO $ runReaderT (fetchStation oid) (key, mgr, host)
      either print yield a
      waitSeconds delay

    apiP :: Int -> API a -> Producer a IO ()
    apiP delay action = forever $ do
      a <- liftIO $ runReaderT action (key, mgr, host)
      either print yield a
      waitSeconds delay

disruptions :: MonadIO m => Store -> m (Pipe [Facility] (PersistedEvent (DisruptionEvent 'DB)) IO ())
disruptions store = do
  disEvs <- liftIO (readStream store)

  return $ P.map (fmap mkMDisruption)
    >-> monitorP dbDisruptionMonitor (replayMkSeed dbDisruptionMonitor . fmap evPayload $ disEvs)
    >-> eventStoreP store
    >-> eachBefore (chunkBy (toSqlString . evOccurredOn) disEvs)
    >-> disruptedApiFilter
    >-> P.concat
    >-> filterUnknown

facilities :: MonadIO m => Store -> m (Pipe [Facility] (PersistedEvent (FacilityEvent 'DB)) IO ())
facilities store = do
  fEvs <- liftIO (readStream store)

  return $ P.map (fmap mkMFacility)
    >-> monitorP dbFacilityMonitor (replayMkSeed dbFacilityMonitor . fmap evPayload $ fEvs)
    >-> eventStoreP store
    >-> P.concat
    >-> eachBefore fEvs

objects :: Store -> [PersistedEvent (ObjectEvent 'DB)] -> Pipe Station (PersistedEvent (ObjectEvent 'DB)) IO ()
objects store oEvs =
  P.map mkMObject
    >-> monitorSP dbObjectMonitor (replayMkSeed dbObjectMonitor . fmap evPayload $ oEvs)
    >-> eventStoreP store
    >-> P.concat
    >-> eachBefore oEvs

-- | Filters out FaSta API unknown facility states
filterUnknown :: Pipe (PersistedEvent (DisruptionEvent a)) (PersistedEvent (DisruptionEvent a)) IO ()
filterUnknown = for cat $ \ev ->
  case evPayload ev of
    FacilityDisrupted _ r       -> unless (unknownReason r) (yield ev)
    DisruptionReasonUpdated _ r -> unless (unknownReason r) (yield ev)
    _                           -> yield ev

  where
    unknownReason :: Reason -> Bool
    unknownReason MonitoringNotAvailable = True
    unknownReason MonitoringDisrupted    = True
    unknownReason _                      = False

type Disruptions = MonitorState FacilityId MDisruption

disruptedApiFilter :: MonadIO m => Pipe [PersistedEvent (DisruptionEvent 'DB)] [PersistedEvent (DisruptionEvent 'DB)] m ()
disruptedApiFilter = do
  firstEvents <- await
  let initialState = deriveState mempty firstEvents
      initialSample = singletonSample . fromIntegral . length $ initialState
  go initialState initialSample Nothing

  where
    go :: MonadIO m => Disruptions -> Sample -> Maybe (Disruptions, [PersistedEvent (DisruptionEvent 'DB)]) -> Pipe [PersistedEvent (DisruptionEvent 'DB)] [PersistedEvent (DisruptionEvent 'DB)] m ()
    go previousState sample Nothing = do
      nextEvents <- await
      let nextState = deriveState previousState nextEvents
          numberOfDisruptions = fromIntegral (length nextState)

      if isResidual numberOfDisruptions sample
        then do
        liftIO (putStrLn $ (pack . toSqlString . evOccurredOn $ head nextEvents) <> " Residual detected: " <> tshow (length previousState) <> " -> " <> tshow numberOfDisruptions)
        go previousState sample (Just (nextState, nextEvents))
        else yield nextEvents >> go nextState (addSample numberOfDisruptions sample) Nothing
    go lastKnownGoodState sample (Just (previousState, accumulatedEvents)) = do
      nextEvents <- await
      let nextState = deriveState previousState nextEvents
          numberOfDisruptions = fromIntegral (length nextState)
      if isResidual numberOfDisruptions sample
        then go lastKnownGoodState sample (Just (nextState, accumulatedEvents ++ nextEvents))
        else do
        putStrLn $ (pack . toSqlString . evOccurredOn $ head nextEvents) <> " Back to normal: " <> tshow (length lastKnownGoodState) <> " -> " <> tshow numberOfDisruptions
        yield (compensateApiDisruption lastKnownGoodState nextState (accumulatedEvents ++ nextEvents))
        go nextState (addSample numberOfDisruptions sample) Nothing

    addSample :: Double -> Sample -> Sample
    addSample a = restrictSampleSize 1000 . insertSample' a

    deriveState = foldl' (flip applyEvent)

    applyEvent :: PersistedEvent (DisruptionEvent 'DB) -> Disruptions -> Disruptions
    applyEvent = apply dbDisruptionMonitor . evPayload

    -- | from all happened events, take the latest one that was supposed to be happening
    compensateApiDisruption :: Disruptions -> Disruptions -> [PersistedEvent (DisruptionEvent 'DB)] -> [PersistedEvent (DisruptionEvent 'DB)]
    compensateApiDisruption d1 d2 evs =
      let (_, events) = calculateChanges dbDisruptionMonitor d1 (elems d2)
          reversedEvents = reverse evs
      in foldl' (\acc ev -> acc ++ maybe mempty pure (find ((==) ev . evPayload) reversedEvents)) [] events

chunkBy :: Eq b => (a -> b) -> [a] -> [[a]]
chunkBy _  [] = []
chunkBy f (x:xs) =
  let (_, as, res) = foldl' doChunk (f x, [x], []) xs
  in reverse (reverse as : res)
  where
    doChunk (b, as, ass) a =
      if f a == b
      then (b, a : as, ass)
      else (f a, [a], reverse as : ass)


{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE OverloadedStrings #-}
module ML.Gym.Gym
    ( Gym (..)
    , GymResult (..)
    , GymObservation
    , initGym
    , resetGym
    , stepGymRandom
    , stepGymRenderRandom
    , stepGym
    , stepGymRender
    , setMaxEpisodeSteps
    , getMaxEpisodeSteps
    , getElapsedSteps
    ) where

import           ML.Gym.Data
import           ML.Gym.DType
import           ML.Gym.Range
import           ML.Gym.Shape
import           ML.Gym.Space
import           ML.Gym.Util

import qualified Control.Exception        as E
import           Control.Monad            (void, when)
import qualified CPython                  as Py
import qualified CPython.Constants        as Py
import qualified CPython.Protocols.Object as Py
import qualified CPython.Types            as Py
import qualified CPython.Types.Exception  as Py
import qualified CPython.Types.Module     as Py
import qualified Data.ByteString          as BS
import           Data.Complex             (Complex)
import           Data.Maybe               (fromMaybe)
import qualified Data.Text                as T
import           System.Environment       (getArgs, getProgName)
import           System.Exit
import           System.IO
import           System.Random            (randomRIO)

type GymEnv = Py.SomeObject
type GymModule = Py.Module
type GymObservation = GymData
type GymActionSpace = GymSpace
type GymObservationSpace = GymSpace

data Gym = Gym
  { name             :: !T.Text
  , gym              :: !GymModule
  , env              :: !GymEnv
  , actionSpace      :: !GymActionSpace
  , observationSpace :: !GymObservationSpace
  }

instance Show Gym where
  show (Gym n _ _ acts obs) = T.unpack n ++  "; Action Space: " ++ show acts ++ "; Observation Space: " ++ show obs

data GymResult = GymResult
  { observation :: !GymObservation
  , reward      :: !Double
  , episodeDone :: !Bool
  } deriving (Show, Eq)

-------------------- Init --------------------

getActionSpace :: GymEnv -> IO GymActionSpace
getActionSpace gEnv = do
  actSpace <- python $ Py.getAttribute gEnv =<< Py.toUnicode "action_space"
  toGymSpace actSpace

getObservationSpace :: GymEnv -> IO GymObservationSpace
getObservationSpace gEnv = do
  obsSpace <- python $ Py.getAttribute gEnv =<< Py.toUnicode "observation_space"
  toGymSpace obsSpace

-- | Initializes the gym environment. It also resets the environment, s.t. `stepGym` can be called immediately.
initGym :: T.Text -> IO (GymObservation, Gym)
initGym envName = do
  name <- getProgName
  args <- getArgs
  -- putStrLn $ "Called: " ++ name  ++ " " ++ unwords args
  Py.initialize
  res <- Py.isInitialized
  version <- Py.getVersion
  -- putStrLn $ "Initialized python: " ++ show res ++ "; Version: " ++ show version
  Py.setArgv (T.pack name <> "-" <> envName) (map T.pack args)
  -- putStrLn "Arguments set"
  gGym <- python $ Py.importModule "gym"
  -- putStrLn "Module imported"
  pyName <- Py.toUnicode envName
  -- putStrLn "Calling make"
  gEnv <- python $ Py.callMethodArgs gGym "make" [Py.toObject pyName]
  -- putStrLn "Createing action and observation space make"
  gActSpace <- getActionSpace gEnv
  gObsSpace <- getObservationSpace gEnv
  -- putStrLn "Resetting environment"
  gObservation <- python $ Py.callMethodArgs gEnv "reset" []
  obs <- fromMaybe (error "could not convert observation to GymData") <$> python (getGymData gObsSpace gObservation)
  -- putStrLn "Done"
  return (obs, Gym envName gGym gEnv gActSpace gObsSpace)

-------------------- Functions --------------------

-- | Set the maximum number of steps before an episode is finished.
setMaxEpisodeSteps :: Gym -> Integer -> IO ()
setMaxEpisodeSteps gym val = do
  pyVal <- Py.toInteger val
  python $ Py.toUnicode "_max_episode_steps" >>= \attr -> Py.setAttribute (env gym) attr (Py.toObject pyVal)

-- | Get the maximum number of steps before an episode is finished.
getMaxEpisodeSteps :: Gym -> IO (Maybe Integer)
getMaxEpisodeSteps gym = python $ Py.toUnicode "_max_episode_steps" >>= Py.getAttribute (env gym) >>= pyToInteger

-- | Get the number of elapsed steps in this episode.
getElapsedSteps :: Gym -> IO (Maybe Integer)
getElapsedSteps gym = python $ Py.toUnicode "_elapsed_steps" >>= Py.getAttribute (env gym) >>= pyToInteger

-- | Reset the environment.
resetGym :: Gym -> IO GymObservation
resetGym gym = do
  gObs <- python $ Py.callMethodArgs (env gym) "reset" []
  fromMaybe (error "could not convert observation to GymData") <$> python (getGymData (observationSpace gym) gObs)

-- | Take a random step and renders the environment. Also see @stepGymRenderRandom@.
stepGymRandom :: Gym -> IO GymResult
stepGymRandom = stepGymRenderRandom True

-- | Take a random step and specify wether to render the environment or not.
stepGymRenderRandom :: Bool -> Gym -> IO GymResult
stepGymRenderRandom render gym = do
  idx <- randomRIO (0, spaceSize (actionSpace gym) - 1)
  stepGymRender render gym idx

-- | Take a step as specified by the given action index. Renders the environment. See also @stepGymRender@.
stepGym :: Gym -> Integer -> IO GymResult
stepGym = stepGymRender True

-- | Take a step as specified by the given action index. Choose wether to render the environment.
stepGymRender :: Bool -> Gym -> Integer -> IO GymResult
stepGymRender render gym actIdx = do
  when render $ void $ python $ Py.callMethodArgs (env gym) "render" []
  act <- toAction (actionSpace gym) actIdx
  Just tuple <- python $ Py.callMethodArgs (env gym) "step" [Py.toObject act] >>= Py.cast
  [gObs, gReward, gDone, gInfo] <- python $ Py.fromTuple tuple
  obs <- fromMaybe (error "could not convert observation to GymData") <$> python (getGymData (observationSpace gym) gObs)
  rew <- fromMaybe (error "could not convert reward to Double") <$> python (pyToDouble gReward)
  done <- fromMaybe (error "could not convert done falg to Bool") <$> python (pyToBool gDone)
  -- Py.print gDone
  -- void $ python $ Py.print reward stdout
  -- void $ python $ Py.print gDone stdout
  -- void $ python $ Py.print info stdout
  return $ GymResult obs rew done


{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeFamilies        #-}

{-# OPTIONS_GHC -Wno-orphans -Wno-deprecations #-}
-- {-# OPTIONS_GHC -ddump-splices -dsuppress-module-prefixes #-}

-- | This module is a modified version of Generics.SOP.Instances.
-- mostly the same.
module Staged.GHC.Generics.Instances () where

import Staged.GHC.Generics.TH

import Control.Exception
import Data.Char
import Data.Complex
import Data.Data
import Data.Fixed
import Data.Functor.Compose
import qualified Data.Functor.Const
import Data.Functor.Identity
import Data.Functor.Product
import Data.Functor.Sum
import Data.List.NonEmpty
import qualified Data.Monoid
import Data.Ord
import qualified Data.Semigroup
import Data.Version
import Data.Void
import Foreign.C.Error
import Foreign.C.Types
import GHC.ByteOrder
import GHC.Conc
import GHC.ExecutionStack
import GHC.Exts
-- import GHC.Events -- platform-specific, omitted
import GHC.Fingerprint
import GHC.Float
import qualified GHC.Generics
import GHC.IO.Buffer
import GHC.IO.Device
import GHC.IO.Encoding
import GHC.IO.Encoding.Failure
import GHC.IO.Exception
import GHC.IO.Handle
import GHC.RTS.Flags
import qualified GHC.Stack
import GHC.StaticPtr
import GHC.Stats
import System.Console.GetOpt
import System.IO
import Text.Printf
import Text.Read.Lex

-- Types from the Prelude:

-- there is manual instance for this
-- deriveGeneric ''Bool

deriveGeneric ''Ordering
deriveGeneric ''Maybe
deriveGeneric ''Either
deriveGeneric ''()
deriveGeneric ''(,)              -- 2
deriveGeneric ''(,,)
deriveGeneric ''(,,,)
deriveGeneric ''(,,,,)           -- 5
deriveGeneric ''(,,,,,)
-- deriveGeneric ''(,,,,,,)
-- deriveGeneric ''(,,,,,,,)
-- deriveGeneric ''(,,,,,,,,)
-- deriveGeneric ''(,,,,,,,,,)      -- 10
-- deriveGeneric ''(,,,,,,,,,,)
-- deriveGeneric ''(,,,,,,,,,,,)
-- deriveGeneric ''(,,,,,,,,,,,,)
-- deriveGeneric ''(,,,,,,,,,,,,,)
-- deriveGeneric ''(,,,,,,,,,,,,,,) -- 15
-- deriveGeneric ''(,,,,,,,,,,,,,,,)
-- deriveGeneric ''(,,,,,,,,,,,,,,,,)
-- deriveGeneric ''(,,,,,,,,,,,,,,,,,)
-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,)
-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,) -- 20
-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,)
-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,)
-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,)
-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,)
-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,) -- 25
-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,)
-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,)
-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,)
-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,)
-- deriveGeneric ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) -- 30
-- deriveGeneric ''[]

deriveGeneric1 ''Maybe
deriveGeneric1 ''Either
deriveGeneric1 ''(,)              -- 2
deriveGeneric1 ''(,,)
deriveGeneric1 ''(,,,)
deriveGeneric1 ''(,,,,)           -- 5
deriveGeneric1 ''(,,,,,)
deriveGeneric1 ''(,,,,,,)
deriveGeneric1 ''(,,,,,,,)
deriveGeneric1 ''(,,,,,,,,)
deriveGeneric1 ''(,,,,,,,,,)      -- 10
deriveGeneric1 ''(,,,,,,,,,,)
deriveGeneric1 ''(,,,,,,,,,,,)
deriveGeneric1 ''(,,,,,,,,,,,,)
deriveGeneric1 ''(,,,,,,,,,,,,,)
deriveGeneric1 ''(,,,,,,,,,,,,,,) -- 15
deriveGeneric1 ''(,,,,,,,,,,,,,,,)
deriveGeneric1 ''(,,,,,,,,,,,,,,,,)
deriveGeneric1 ''(,,,,,,,,,,,,,,,,,)
deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,)
deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,) -- 20
deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,,)
deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,,,,,,) -- 25
deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,)
deriveGeneric1 ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) -- 30
deriveGeneric1 ''[]

-- Other types from base:

-- From Control.Exception:
deriveGeneric ''IOException
deriveGeneric ''ArithException
deriveGeneric ''ArrayException
deriveGeneric ''AssertionFailed
deriveGeneric ''AsyncException
deriveGeneric ''NonTermination
deriveGeneric ''NestedAtomically
deriveGeneric ''BlockedIndefinitelyOnMVar
deriveGeneric ''BlockedIndefinitelyOnSTM
deriveGeneric ''AllocationLimitExceeded
deriveGeneric ''Deadlock
deriveGeneric ''NoMethodError
deriveGeneric ''PatternMatchFail
deriveGeneric ''RecConError
deriveGeneric ''RecSelError
deriveGeneric ''RecUpdError
deriveGeneric ''ErrorCall
deriveGeneric ''TypeError
deriveGeneric ''MaskingState

-- From Data.Char:
deriveGeneric ''GeneralCategory

-- From Data.Complex:
deriveGeneric ''Complex

-- From Data.Data:
deriveGeneric ''DataRep
deriveGeneric ''Fixity
deriveGeneric ''ConstrRep

-- From Data.Fixed:
deriveGeneric ''Fixed
deriveGeneric ''E0
deriveGeneric ''E1
deriveGeneric ''E2
deriveGeneric ''E3
deriveGeneric ''E6
deriveGeneric ''E9
deriveGeneric ''E12

-- From Data.Functor.Compose
deriveGeneric ''Compose
deriveGeneric1 ''Compose

-- From Data.Functor.Const
deriveGeneric ''Data.Functor.Const.Const
deriveGeneric1 ''Data.Functor.Const.Const

-- From Data.Functor.Identity
deriveGeneric ''Identity
deriveGeneric1 ''Identity

-- From Data.Functor.Product
deriveGeneric ''Product
deriveGeneric1 ''Product

-- From Data.Functor.Sum
deriveGeneric ''Sum
deriveGeneric1 ''Sum

-- From Data.List.NonEmpty
deriveGeneric ''NonEmpty
deriveGeneric1 ''NonEmpty

-- From Data.Monoid:
deriveGeneric ''Data.Monoid.Dual
deriveGeneric ''Data.Monoid.Endo
deriveGeneric ''Data.Monoid.All
deriveGeneric ''Data.Monoid.Any
deriveGeneric ''Data.Monoid.Sum
deriveGeneric ''Data.Monoid.Product
deriveGeneric ''Data.Monoid.First
deriveGeneric ''Data.Monoid.Last
deriveGeneric ''Data.Monoid.Alt

deriveGeneric1 ''Data.Monoid.Dual
-- deriveGeneric1 ''Data.Monoid.Endo
deriveGeneric1 ''Data.Monoid.Sum
deriveGeneric1 ''Data.Monoid.Product
deriveGeneric1 ''Data.Monoid.First
deriveGeneric1 ''Data.Monoid.Last
deriveGeneric1 ''Data.Monoid.Alt

-- From Data.Ord:
deriveGeneric ''Down
deriveGeneric1 ''Down

-- From Data.Proxy:
deriveGeneric ''Proxy
deriveGeneric1 ''Proxy

-- From Data.Semigroup:
deriveGeneric ''Data.Semigroup.Min
deriveGeneric ''Data.Semigroup.Max
deriveGeneric ''Data.Semigroup.First
deriveGeneric ''Data.Semigroup.Last
deriveGeneric ''Data.Semigroup.WrappedMonoid
deriveGeneric ''Data.Semigroup.Option
deriveGeneric ''Data.Semigroup.Arg

deriveGeneric1 ''Data.Semigroup.Min
deriveGeneric1 ''Data.Semigroup.Max
deriveGeneric1 ''Data.Semigroup.First
deriveGeneric1 ''Data.Semigroup.Last
deriveGeneric1 ''Data.Semigroup.WrappedMonoid
deriveGeneric1 ''Data.Semigroup.Option
deriveGeneric1 ''Data.Semigroup.Arg

-- From Data.Version:
deriveGeneric ''Version

-- From Data.Void:
deriveGeneric ''Void

-- From Foreign.C.Error:
deriveGeneric ''Errno

-- From Foreign.C.Types:
deriveGeneric ''CChar
deriveGeneric ''CSChar
deriveGeneric ''CUChar
deriveGeneric ''CShort
deriveGeneric ''CUShort
deriveGeneric ''CInt
deriveGeneric ''CUInt
deriveGeneric ''CLong
deriveGeneric ''CULong
deriveGeneric ''CPtrdiff
deriveGeneric ''CSize
deriveGeneric ''CWchar
deriveGeneric ''CSigAtomic
deriveGeneric ''CLLong
deriveGeneric ''CULLong
deriveGeneric ''CIntPtr
deriveGeneric ''CUIntPtr
deriveGeneric ''CIntMax
deriveGeneric ''CUIntMax
deriveGeneric ''CClock
deriveGeneric ''CTime
deriveGeneric ''CUSeconds
deriveGeneric ''CSUSeconds
deriveGeneric ''CFloat
deriveGeneric ''CDouble

-- From GHC.ByteOrder:
deriveGeneric ''ByteOrder

-- From GHC.Conc:
deriveGeneric ''ThreadStatus
deriveGeneric ''BlockReason

-- From GHC.ExecutionStack:
deriveGeneric ''Location
deriveGeneric ''SrcLoc

-- From GHC.Exts:
deriveGeneric ''RuntimeRep
deriveGeneric ''VecCount
deriveGeneric ''VecElem

-- From GHC.Generics:
deriveGeneric ''GHC.Generics.K1
deriveGeneric ''GHC.Generics.U1
deriveGeneric ''GHC.Generics.V1
deriveGeneric ''GHC.Generics.Par1
deriveGeneric ''GHC.Generics.M1
deriveGeneric ''GHC.Generics.R
deriveGeneric ''GHC.Generics.S
deriveGeneric ''GHC.Generics.D
deriveGeneric ''GHC.Generics.C
deriveGeneric ''(GHC.Generics.:*:)
deriveGeneric ''(GHC.Generics.:+:)
deriveGeneric ''(GHC.Generics.:.:)
deriveGeneric ''GHC.Generics.Associativity
deriveGeneric ''GHC.Generics.DecidedStrictness
deriveGeneric ''GHC.Generics.SourceStrictness
deriveGeneric ''GHC.Generics.SourceUnpackedness
deriveGeneric ''GHC.Generics.Fixity

-- From GHC.IO.Buffer:
deriveGeneric ''Buffer
deriveGeneric ''BufferState

-- From GHC.IO.Device:
deriveGeneric ''IODeviceType

-- From GHC.IO.Encoding:
deriveGeneric ''BufferCodec
deriveGeneric ''CodingProgress

-- From GHC.IO.Encoding.Failure:
deriveGeneric ''CodingFailureMode

-- From GHC.Fingerprint
deriveGeneric ''Fingerprint

-- From GHC.Float
deriveGeneric ''FFFormat

-- From GHC.IO.Exception:
deriveGeneric ''FixIOException
deriveGeneric ''IOErrorType

-- From GHC.IO.Handle:
deriveGeneric ''HandlePosn
deriveGeneric ''LockMode

-- From GHC.RTS.Flags:
deriveGeneric ''RTSFlags
deriveGeneric ''GiveGCStats
deriveGeneric ''GCFlags
deriveGeneric ''ConcFlags
deriveGeneric ''MiscFlags
deriveGeneric ''DebugFlags
deriveGeneric ''DoCostCentres
deriveGeneric ''CCFlags
deriveGeneric ''DoHeapProfile
deriveGeneric ''ProfFlags
deriveGeneric ''DoTrace
deriveGeneric ''TraceFlags
deriveGeneric ''TickyFlags
deriveGeneric ''ParFlags

-- From GHC.Stack:
deriveGeneric ''GHC.Stack.SrcLoc
deriveGeneric ''GHC.Stack.CallStack

-- From GHC.StaticPtr:
deriveGeneric ''StaticPtrInfo

-- From GHC.Stats:
deriveGeneric ''RTSStats
deriveGeneric ''GCDetails

-- From System.Console.GetOpt:

deriveGeneric ''ArgOrder
deriveGeneric ''OptDescr
deriveGeneric ''ArgDescr

-- From System.Exit:

deriveGeneric ''ExitCode

-- From System.IO:

deriveGeneric ''IOMode
deriveGeneric ''BufferMode
deriveGeneric ''SeekMode
deriveGeneric ''Newline
deriveGeneric ''NewlineMode

-- From Text.Printf:

deriveGeneric ''FieldFormat
deriveGeneric ''FormatAdjustment
deriveGeneric ''FormatSign
deriveGeneric ''FormatParse

-- From Text.Read.Lex:

deriveGeneric ''Lexeme
deriveGeneric ''Number

-- Abstract / primitive datatypes (we don't derive Generic for these):
--
-- Ratio
-- Integer
-- ThreadId
-- Chan
-- MVar
-- QSem
-- QSemN
-- DataType
-- Dynamic
-- IORef
-- TypeRep
-- TyCon
-- TypeRepKey
-- KProxy -- not abstract, but intended for kind-level use
-- STRef
-- Unique
-- ForeignPtr
-- CFile
-- CFpos
-- CJmpBuf
-- Pool
-- Ptr
-- FunPtr
-- IntPtr
-- WordPtr
-- StablePtr
-- Char
-- Double
-- Float
-- Int
-- Int8
-- Int16
-- Int32
-- Int64
-- Word
-- Word8
-- Word16
-- Word32
-- Word64
-- IO
-- ST
-- (->)
-- RealWorld
-- Handle
-- HandlePosn
-- TextEncoding
-- StableName
-- Weak
-- ReadP
-- ReadPrec
-- STM
-- TVar
-- Natural
-- Event
-- EventManager
-- CostCentre
-- CostCentreStack
--
-- Datatypes we cannot currently handle:
--
-- SomeException
-- SomeAsyncException
-- Handler
-- Coercion
-- (:~:)


{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

module Lib
    ( createBasicDataLayerIO
    , createConfig
    -- * library functions
    , getZendeskResponses
    , getAttachmentsFromComment
    , inspectAttachment
    , ExtractLogFileFunc
    , ExtractErrorCodeFunc
    , processTicket
    , processTicketSafe
    , processTickets
    , fetchTickets
    , showStatistics
    , filterAnalyzedTickets
    , exportZendeskDataToLocalDB
    -- * Optional
    , fetchTicket
    , fetchTicketComments
    , fetchAgents
    , fetchAndShowTickets
    , fetchAndShowTicketsFrom
    , inspectLocalZipAttachment
    , processTicketsFromTime
    ) where

import           Universum

import           UnliftIO.Async (mapConcurrently)

import           Control.Exception.Safe (Handler (..), catches)
import           Data.Attoparsec.Text.Lazy (eitherResult, parse)
import qualified Data.ByteString.Lazy as BS
import           Data.List (nub)
import           Data.Text (stripEnd)

import           System.Directory (createDirectoryIfMissing)
import           System.IO (BufferMode (..), hSetBuffering)

import           Configuration (defaultConfig)
import           DataSource (App, Attachment (..), AttachmentContent (..), Comment (..),
                             Config (..), DBLayer (..), DataLayer (..), DeletedTicket (..),
                             ExportFromTime (..), IOLayer (..), TicketId (..), TicketInfo (..),
                             TicketStatus (..), TicketTag (..), TicketTags (..), User (..),
                             UserId (..), ZendeskResponse (..), asksDBLayer, asksIOLayer,
                             basicDataLayer, connPoolDBLayer, createProdConnectionPool,
                             renderTicketStatus, runApp)

import           Exceptions (ClassifierExceptions (..), ProcessTicketExceptions (..),
                             ZipFileExceptions (..))
import           Http.Layer (basicHTTPNetworkLayer)
import           Http.Queue (createSchedulerConfig, runScheduler)

import           LogAnalysis.Classifier (extractErrorCodes, extractIssuesFromLogs,
                                         prettyFormatAnalysis, prettyFormatLogReadError,
                                         prettyFormatNoIssues, prettyFormatNoLogs)
import           LogAnalysis.Exceptions (LogAnalysisException (..))
import           LogAnalysis.KnowledgeCSVParser (parseKnowLedgeBase)
import           LogAnalysis.Types (Analysis, ErrorCode (..), Knowledge, LogFile, renderErrorCode,
                                    setupAnalysis)
import           Statistics (showStatistics)
import           System.Environment (getEnv)
import           Util (extractLogsFromZip)

------------------------------------------------------------
-- Functions
------------------------------------------------------------

-- | Create configuration.
createConfig :: IO Config
createConfig = do
    putTextLn "Starting Zendesk classifier!"

    createDirectoryIfMissing True "logs"
    hSetBuffering stdout NoBuffering

    putTextLn "Welcome to Zendesk classifier!"

    filePath    <- getEnv "LCPATH"

    token       <- readFile $ filePath <> "/token"       -- Zendesk token
    assignFile  <- readFile $ filePath <> "/assign_to"   -- Select assignee
    knowledges  <- setupKnowledgebaseEnv $ filePath <> "/knowledge.csv"
    assignTo    <- case readEither assignFile of
        Right agentid -> return agentid
        Left  _       -> throwM FailedToReadAssignFile

    connPool    <- createProdConnectionPool

    pure defaultConfig
        { cfgToken         = stripEnd token
        , cfgAssignTo      = assignTo
        , cfgAgentId       = UserId (fromIntegral assignTo)
        , cfgKnowledgebase = knowledges
        , cfgDBLayer       = connPoolDBLayer connPool
        }

  where
    -- Read CSV file and setup knowledge base
    setupKnowledgebaseEnv :: FilePath -> IO [Knowledge]
    setupKnowledgebaseEnv path = do
        kfile <- toLText <$> readFile path
        let kb = parse parseKnowLedgeBase kfile
        case eitherResult kb of
            Left _   -> throwM FailedToParseKnowledgebase
            Right ks -> return ks

-- | Create basic data layer. Do this ONCE!
createBasicDataLayerIO :: Config -> IO (DataLayer App)
createBasicDataLayerIO config = runApp createBasicDataLayer config
  where
    -- | Create a basic @DataLayer@.
    createBasicDataLayer :: App (DataLayer App)
    createBasicDataLayer = do
        -- for now, we limit the rate-limit to 700/minute, which is lower then
        -- 750/minute, but takes into consideration that other things might be called
        -- at the same time as well.
        shedConfig  <- createSchedulerConfig 700

        -- Run the sheduler which resets the number of requests to 0 every minute.
        _           <- runScheduler shedConfig

        -- create the data layer
        pure $ basicDataLayer (basicHTTPNetworkLayer shedConfig)

-- | The function for exporting Zendesk data to our local DB so
-- we can have faster analysis and runs.
-- We expect that the local database exists and has the correct schema.
exportZendeskDataToLocalDB
    :: DataLayer App
    -> ExportFromTime
    -> App [TicketInfo]
exportZendeskDataToLocalDB dataLayer exportFromTime = do

    deleteAllData               <- asksDBLayer dlDeleteAllData

    notDeletedExportedTickets   <- fetchTicketsExportedFromTime dataLayer exportFromTime

    -- Map concurrently if required.
    allTicketData               <-  mapConcurrently fetchTicketData notDeletedExportedTickets

    -- Clear the data.
    deleteAllData

    -- Save all the data.
    _           <- mapM saveTicketDataToLocalDB allTicketData

    -- TODO(ks): We currently don't download the attachment since that
    -- would take a ton of time and would require probably up to 100Gb of space!
    pure notDeletedExportedTickets
  where
    -- | Get ticket comments and create a sum type out of them.
    fetchTicketData :: TicketInfo -> App (TicketInfo,[Comment])
    fetchTicketData ticket = do

        let getTicketComments       = zlGetTicketComments dataLayer

        -- First fetch comments, FAIL-FAST
        ticketComments              <- getTicketComments $ tiId ticket

        pure (ticket, ticketComments)

-- | Fetch all tickets changed from a specific date.
fetchTicketsExportedFromTime :: DataLayer App -> ExportFromTime -> App [TicketInfo]
fetchTicketsExportedFromTime dataLayer exportFromTime = do

    let listDeletedTickets      = zlListDeletedTickets dataLayer
    let exportTickets           = zlExportTickets dataLayer

    -- Yeah, not sure why this happens. Very weird.
    exportedTickets             <- nub <$> exportTickets exportFromTime

    let filteredTicketIds = filterAnalyzedTickets exportedTickets
    let sortedTicketIds   = sortBy compare filteredTicketIds

    -- Yeah, there is a strange behaviour when we export tickets,
    -- we might get deleted tickets as well.
    deletedTickets              <- listDeletedTickets

    pure . sort $ filter (not . isDeletedTicket deletedTickets) sortedTicketIds
  where
    -- | Filter for deleted tickets.
    isDeletedTicket :: [DeletedTicket] -> TicketInfo -> Bool
    isDeletedTicket dTickets TicketInfo{..} =
        tiId `elem` map dtId dTickets

-- | We are missing an intermediate step here to test and separate.
saveTicketDataToLocalDB :: (TicketInfo,[Comment]) -> App ()
saveTicketDataToLocalDB (ticket, ticketComments) = do

    insertTicketInfo            <- asksDBLayer dlInsertTicketInfo
    insertTicketComments        <- asksDBLayer dlInsertTicketComments
    insertCommentAttachments    <- asksDBLayer dlInsertCommentAttachments

    let ticketId = tiId ticket

    insertTicketInfo ticket

    -- For all the ticket comments
    void $ forM ticketComments $ \ticketComment -> do
        insertTicketComments ticketId ticketComment

        -- For all the ticket comment attachments
        forM (cAttachments ticketComment) $ \ticketAttachment ->
            insertCommentAttachments ticketComment ticketAttachment

    pure ()

-- | 'processTicket' with exception handling
processTicketSafe :: DataLayer App -> TicketId -> App ()
processTicketSafe dataLayer tId = catch (void $ processTicket dataLayer tId)
    -- Print and log any exceptions related to process ticket
    -- TODO(ks): Remove IO from here, return the error.
    (\(e :: ProcessTicketExceptions) -> do
        printText <- asksIOLayer iolPrintText
        printText $ "Error on TicketId " <> show (getTicketId tId) <> ":" <> show e
        -- TODO(hs): Implement concurrent logging
        appendF <- asksIOLayer iolAppendFile
        appendF "./logs/errors.log" (show e <> "\n"))

-- | Process ticket with given 'TicketId'
processTicket :: HasCallStack => DataLayer App -> TicketId -> App ZendeskResponse
processTicket dataLayer tId = do

    -- We see 3 HTTP calls here.
    let getTicketInfo       = zlGetTicketInfo dataLayer
    let getTicketComments   = zlGetTicketComments dataLayer
    let postTicketComment   = zlPostTicketComment dataLayer

    mTicketInfo         <- getTicketInfo tId
    comments            <- getTicketComments tId

    let attachments     = getAttachmentsFromComment comments
    case mTicketInfo of
        Nothing         -> throwM $ TicketInfoNotFound tId
        Just ticketInfo -> do
            zendeskResponse <- getZendeskResponses dataLayer comments attachments ticketInfo

            -- post ticket comment, Carl said this is ok
            postTicketComment ticketInfo zendeskResponse

            pure zendeskResponse

-- | When we want to process all possible tickets.
processTickets :: HasCallStack => DataLayer App -> App [ZendeskResponse]
processTickets dataLayer = do

    printText <- asksIOLayer iolPrintText
    printText "Classifier will start processing tickets"

    -- Fetching all the tickets that needs to be processed
    allTickets <- fetchTickets dataLayer

    printText $ "Number of tickets to be analyzed: " <> show (length allTickets)

    zendeskResponses <- mapM (processTicket dataLayer . tiId) allTickets

    putTextLn "All the tickets has been processed."

    pure zendeskResponses

-- | Fetch all tickets that needs to be analyzed
fetchTickets :: DataLayer App -> App [TicketInfo]
fetchTickets dataLayer = do
    allTickets <- zlListToBeAnalysedTickets dataLayer

    let filteredTickets = sortBy compare $ filterAnalyzedTickets allTickets
    -- Any ticket that has a "to_be_analysed" tag
    pure filteredTickets

-- | Fetch a single ticket with given 'TicketId'
fetchTicket :: DataLayer App -> TicketId -> App (Maybe TicketInfo)
fetchTicket dataLayer ticketId = do
    let getTicketInfo       = zlGetTicketInfo dataLayer
    getTicketInfo ticketId

-- | Fetch comments with given 'TicketId'
fetchTicketComments :: DataLayer App -> TicketId -> App [Comment]
fetchTicketComments dataLayer ticketId = do
    let getTicketComments   = zlGetTicketComments dataLayer
    getTicketComments ticketId

-- | A pure function for fetching 'Attachment' from 'Comment'
getAttachmentsFromComment :: [Comment] -> [Attachment]
getAttachmentsFromComment comments = do
    -- Filter tickets without logs
    let commentsWithAttachments :: [Comment]
        commentsWithAttachments = filter commentHasAttachment comments

    -- Filter out ticket without logs
    let attachments :: [Attachment]
        attachments = concatMap cAttachments commentsWithAttachments

    -- Filter out non-logs
    filter isAttachmentZip attachments

  where
    commentHasAttachment :: Comment -> Bool
    commentHasAttachment comment = length (cAttachments comment) > 0

    -- For readability
    isAttachmentZip :: Attachment -> Bool
    isAttachmentZip attachment = aContentType attachment `elem`
        ["application/zip", "application/x-zip-compressed"]

-- | Inspects the comment, attachment, ticket info and create 'ZendeskResponse'
getZendeskResponses :: DataLayer App -> [Comment] -> [Attachment] -> TicketInfo -> App ZendeskResponse
getZendeskResponses dataLayer comments attachments ticketInfo
    | not (null attachments) = inspectAttachments dataLayer ticketInfo attachments
    | not (null comments)    = responseNoLogs ticketInfo
    | otherwise              = throwM $ CommentAndAttachmentNotFound (tiId ticketInfo)
    -- No attachment, no comments means something is wrong with ticket itself
  where
    -- Create 'ZendeskResponse' stating no logs were found on the ticket
    responseNoLogs :: TicketInfo -> App ZendeskResponse
    responseNoLogs TicketInfo{..} = do
        Config {..} <- ask
        pure ZendeskResponse
                { zrTicketId = tiId
                , zrComment  = prettyFormatNoLogs
                , zrTags     = TicketTags [renderTicketStatus NoLogAttached]
                , zrIsPublic = cfgIsCommentPublic
                }

-- | Inspect the latest attachment
inspectAttachments :: DataLayer App -> TicketInfo -> [Attachment] -> App ZendeskResponse
inspectAttachments dataLayer ticketInfo attachments = do

    config          <- ask
    let getAttachment   = zlGetAttachment dataLayer

    lastAttach      <- handleMaybe . safeHead . reverse . sort $ attachments
    att             <- handleMaybe =<< getAttachment lastAttach
    inspectAttachment config ticketInfo att extractLogsFromZip extractIssuesFromLogs
  where
    handleMaybe :: Maybe a -> App a
    handleMaybe Nothing  = throwM $ AttachmentNotFound (tiId ticketInfo)
    handleMaybe (Just a) = return a

-- This is to enable testing on 'inspectAttachment'
type ExtractLogFileFunc = Int -> LByteString -> Either ZipFileExceptions [LogFile]
type ExtractErrorCodeFunc m = [LogFile] -> Analysis -> m Analysis

-- | Given number of file of inspect, knowledgebase and attachment,
-- analyze the logs and return the results.
inspectAttachment :: (MonadCatch m)
                  => Config
                  -> TicketInfo
                  -> AttachmentContent
                  -> ExtractLogFileFunc
                  -> ExtractErrorCodeFunc m
                  -> m ZendeskResponse
inspectAttachment Config{..} ticketInfo attachment extractLogFileFunc extractIssueFunc =
    flip catches [Handler handleZipFileException, Handler handleLogAnalysisException] $ do

        let analysisEnv = setupAnalysis cfgKnowledgebase
        -- let logFiles    = either throwM id $ extractLogFileFunc cfgNumOfLogsToAnalyze
        --                 $ getAttachmentContent attachment
        logFiles <- either throwM pure $
           extractLogFileFunc cfgNumOfLogsToAnalyze $ getAttachmentContent attachment

        -- Perform analysis
        analysisResult <- extractIssueFunc logFiles analysisEnv
        let errorCodes  = extractErrorCodes analysisResult
        let commentRes  = prettyFormatAnalysis analysisResult ticketInfo

        pure $ mkZendeskResponse commentRes errorCodes
   where
     handleZipFileException :: (Monad m) => ZipFileExceptions -> m ZendeskResponse
     handleZipFileException _ =
        pure $ mkZendeskErrorResponse (prettyFormatLogReadError ticketInfo) SentLogCorrupted

     handleLogAnalysisException :: (MonadThrow m) => LogAnalysisException -> m ZendeskResponse
     handleLogAnalysisException = \case
        LogReadException ->
            pure $ mkZendeskErrorResponse (prettyFormatLogReadError ticketInfo) SentLogCorrupted

        NoKnownIssueFound ->
            pure $ mkZendeskErrorResponse (prettyFormatNoIssues ticketInfo) NoKnownIssue

        (JSONDecodeFailure errorText) -> throwM $ JSONDecodeFailure errorText

     mkZendeskResponse :: Text -> [Text] -> ZendeskResponse
     mkZendeskResponse comment errorCodes = ZendeskResponse
        { zrTicketId = tiId ticketInfo
        , zrComment  = comment
        , zrTags     = TicketTags errorCodes
        , zrIsPublic = cfgIsCommentPublic
        }

     mkZendeskErrorResponse :: Text -> ErrorCode -> ZendeskResponse
     mkZendeskErrorResponse comment errorCode = mkZendeskResponse comment [renderErrorCode errorCode]

-- | Filter tickets
filterAnalyzedTickets :: [TicketInfo] -> [TicketInfo]
filterAnalyzedTickets ticketsInfo =
    filter ticketsFilter ticketsInfo
  where
    ticketsFilter :: TicketInfo -> Bool
    ticketsFilter ticketInfo =
           isTicketOpen ticketInfo
        && isTicketBlacklisted ticketInfo
        && isTicketInGoguenTestnet ticketInfo

    unsolvedTicketStatus :: [TicketStatus]
    unsolvedTicketStatus = map TicketStatus ["new", "open", "hold", "pending"]

    isTicketOpen :: TicketInfo -> Bool
    isTicketOpen TicketInfo{..} = tiStatus `elem` unsolvedTicketStatus

    -- | If we have a ticket we are having issues with...
    isTicketBlacklisted :: TicketInfo -> Bool
    isTicketBlacklisted TicketInfo{..} = tiId `notElem` [TicketId 9377, TicketId 10815, TicketId 15066, TicketId 30849]

    isTicketInGoguenTestnet :: TicketInfo -> Bool
    isTicketInGoguenTestnet TicketInfo{..} = "goguen_testnets" `notElem` getTicketTags tiTags

------------------------------------------------------------
-- Utility functions
------------------------------------------------------------

fetchAgents :: DataLayer App -> App [User]
fetchAgents dataLayer = do
    Config{..}          <- ask

    let listAdminAgents = zlListAdminAgents dataLayer
    printText           <- asksIOLayer iolPrintText

    printText "Fetching Zendesk agents"

    agents              <- listAdminAgents

    mapM_ print agents
    pure agents

-- | Fetch tickets that need to be analyzed and print them on console
fetchAndShowTickets :: DataLayer App -> App ()
fetchAndShowTickets dataLayer = do
    allTickets <- fetchTickets dataLayer

    showTickets allTickets

-- | Fetch and show tickets from a specific time.
fetchAndShowTicketsFrom :: DataLayer App -> ExportFromTime -> App ()
fetchAndShowTicketsFrom dataLayer exportFromTime = do
    allTickets <- fetchTicketsExportedFromTime dataLayer exportFromTime

    showTickets allTickets

-- | Display all the TicketId and its tags
showTickets :: [TicketInfo] -> App ()
showTickets tickets = do
    putTextLn $ "There are " <> show (length tickets) <> " tickets."

    forM_ tickets $ \ticket -> do
        let ticketId   = getTicketId $ tiId ticket
        let ticketTags = (sort . getTicketTags . tiTags) ticket
        putTextLn $ "TicketId: " <> show ticketId <> ", Tags: " <> show ticketTags

-- | Inspection of the local zip.
-- This function prints out the analysis result on the console.
-- Can apply same refactoring as 'inspectAttachment'
inspectLocalZipAttachment :: FilePath -> App ()
inspectLocalZipAttachment filePath =
    flip catches [ Handler $ exceptionHandler @ZipFileExceptions
                 , Handler $ exceptionHandler @LogAnalysisException] $ do
        config          <- ask
        printText       <- asksIOLayer iolPrintText

        -- Read the zip file
        fileContent     <- liftIO $ BS.readFile filePath
        logFiles        <- either throwM pure $ extractLogsFromZip 100 fileContent

        let analysisEnv = setupAnalysis $ cfgKnowledgebase config
        analysisResult  <- extractIssuesFromLogs logFiles analysisEnv

        let errorCodes = extractErrorCodes analysisResult

        printText "Analysis result:"
        void $ mapM (printText . show) analysisResult

        printText "Error codes:"
        void $ mapM printText errorCodes
  where
    exceptionHandler :: (Exception e) => e -> App ()
    exceptionHandler = print

-- | When we want to process all tickets from a specific time onwards.
-- Run in parallel.
processTicketsFromTime :: DataLayer App -> ExportFromTime -> App ()
processTicketsFromTime dataLayer exportFromTime = do

    allTickets          <- fetchTicketsExportedFromTime dataLayer exportFromTime

    putTextLn $ "There are " <> show (length allTickets) <> " tickets."

    mZendeskResponses   <- mapConcurrently (processTicket dataLayer . tiId) allTickets

    -- This is single-threaded.
    mapM_ processSingleTicket mZendeskResponses

    putTextLn "All the tickets has been processed."
  where
    -- | Process a single ticket after they were analyzed.
    processSingleTicket :: ZendeskResponse -> App ()
    processSingleTicket zendeskResponse = do

        -- We first fetch the function from the configuration
        printText           <- asksIOLayer iolPrintText
        appendF             <- asksIOLayer iolAppendFile -- We need to remove this.

        let ticketId = getTicketId $ zrTicketId zendeskResponse

        -- Printing id before inspecting the ticket so that when the process stops by the
        -- corrupted log file, we know which id to blacklist.
        printText $ "Analyzing ticket id: " <> show ticketId

        let tags = getTicketTags $ zrTags zendeskResponse
        forM_ tags $ \tag -> do
            let formattedTicketIdAndTag = show ticketId <> " " <> tag
            printText formattedTicketIdAndTag
            appendF "logs/analysis-result.log" (formattedTicketIdAndTag <> "\n")