{-# LANGUAGE CPP, FlexibleContexts #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE Trustworthy #-}

#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif

#if MIN_VERSION_base(4,8,0)
#define HAS_NATURAL
#define HAS_VOID
#endif

#if MIN_VERSION_base(4,7,0)
#define HAS_FIXED_CONSTRUCTOR
#endif

-----------------------------------------------------------------------------
-- |
-- Module      : Data.Binary.Class
-- Copyright   : Lennart Kolmodin
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Lennart Kolmodin <kolmodin@gmail.com>
-- Stability   : unstable
-- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances
--
-- Typeclass and instances for binary serialization.
--
-----------------------------------------------------------------------------

module Data.Binary.Class (

    -- * The Binary class
      Binary(..)

    -- * Support for generics
    , GBinaryGet(..)
    , GBinaryPut(..)

    ) where

import Data.Word
import Data.Bits
import Data.Int
import Data.Complex (Complex(..))
#ifdef HAS_VOID
import Data.Void
#endif

import Data.Binary.Put
import Data.Binary.Get

#if ! MIN_VERSION_base(4,8,0)
import Control.Applicative
import Data.Monoid (mempty)
#endif
import qualified Data.Monoid as Monoid
import Data.Monoid ((<>))
#if MIN_VERSION_base(4,8,0)
import Data.Functor.Identity (Identity (..))
#endif
#if MIN_VERSION_base(4,9,0)
import qualified Data.List.NonEmpty as NE
import qualified Data.Semigroup     as Semigroup
#endif
import Control.Monad

import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Builder.Prim as Prim

import Data.List    (unfoldr, foldl')

-- And needed for the instances:
#if MIN_VERSION_base(4,10,0)
import Type.Reflection
import Type.Reflection.Unsafe
import Data.Kind (Type)
import GHC.Exts (RuntimeRep(..), VecCount, VecElem)
#endif
import qualified Data.ByteString as B
#if MIN_VERSION_bytestring(0,10,4)
import qualified Data.ByteString.Short as BS
#endif
import qualified Data.Map        as Map
import qualified Data.Set        as Set
import qualified Data.IntMap     as IntMap
import qualified Data.IntSet     as IntSet
import qualified Data.Ratio      as R

import qualified Data.Tree as T

import Data.Array.Unboxed

import GHC.Generics

#ifdef HAS_NATURAL
import Numeric.Natural
#endif

import qualified Data.Fixed as Fixed

--
-- This isn't available in older Hugs or older GHC
--
import qualified Data.Sequence as Seq
import qualified Data.Foldable as Fold

import GHC.Fingerprint

import Data.Version (Version(..))

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

-- Factored into two classes because this makes GHC optimize the
-- instances faster.  This doesn't matter for builds of binary,
-- but it matters a lot for end-users who write 'instance Binary T'.
-- See also: https://ghc.haskell.org/trac/ghc/ticket/9630
class GBinaryPut f where
    gput :: f t -> Put

class GBinaryGet f where
    gget :: Get (f t)

-- | The 'Binary' class provides 'put' and 'get', methods to encode and
-- decode a Haskell value to a lazy 'ByteString'. It mirrors the 'Read' and
-- 'Show' classes for textual representation of Haskell types, and is
-- suitable for serialising Haskell values to disk, over the network.
--
-- For decoding and generating simple external binary formats (e.g. C
-- structures), Binary may be used, but in general is not suitable
-- for complex protocols. Instead use the 'Put' and 'Get' primitives
-- directly.
--
-- Instances of Binary should satisfy the following property:
--
-- > decode . encode == id
--
-- That is, the 'get' and 'put' methods should be the inverse of each
-- other. A range of instances are provided for basic Haskell types.
--
class Binary t where
    -- | Encode a value in the Put monad.
    put :: t -> Put
    -- | Decode a value in the Get monad
    get :: Get t

    -- | Encode a list of values in the Put monad.
    -- The default implementation may be overridden to be more efficient
    -- but must still have the same encoding format.
    putList :: [t] -> Put
    putList = defaultPutList

    default put :: (Generic t, GBinaryPut (Rep t)) => t -> Put
    put = gput . from

    default get :: (Generic t, GBinaryGet (Rep t)) => Get t
    get = to `fmap` gget

{-# INLINE defaultPutList #-}
defaultPutList :: Binary a => [a] -> Put
defaultPutList xs = put (length xs) <> mapM_ put xs

------------------------------------------------------------------------
-- Simple instances

#ifdef HAS_VOID
-- Void never gets written nor reconstructed since it's impossible to have a
-- value of that type

-- | /Since: 0.8.0.0/
instance Binary Void where
    put     = absurd
    get     = mzero
#endif

-- The () type need never be written to disk: values of singleton type
-- can be reconstructed from the type alone
instance Binary () where
    put ()  = mempty
    get     = return ()

-- Bools are encoded as a byte in the range 0 .. 1
instance Binary Bool where
    put     = putWord8 . fromIntegral . fromEnum
    get     = getWord8 >>= toBool
      where
        toBool 0 = return False
        toBool 1 = return True
        toBool c = fail ("Could not map value " ++ show c ++ " to Bool")

-- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2
instance Binary Ordering where
    put     = putWord8 . fromIntegral . fromEnum
    get     = getWord8 >>= toOrd
      where
        toOrd 0 = return LT
        toOrd 1 = return EQ
        toOrd 2 = return GT
        toOrd c = fail ("Could not map value " ++ show c ++ " to Ordering")

------------------------------------------------------------------------
-- Words and Ints

-- Words8s are written as bytes
instance Binary Word8 where
    put     = putWord8
    {-# INLINE putList #-}
    putList xs =
        put (length xs)
        <> putBuilder (Prim.primMapListFixed Prim.word8 xs)
    get     = getWord8

-- Words16s are written as 2 bytes in big-endian (network) order
instance Binary Word16 where
    put     = putWord16be
    {-# INLINE putList #-}
    putList xs =
        put (length xs)
        <> putBuilder (Prim.primMapListFixed Prim.word16BE xs)
    get     = getWord16be

-- Words32s are written as 4 bytes in big-endian (network) order
instance Binary Word32 where
    put     = putWord32be
    {-# INLINE putList #-}
    putList xs =
        put (length xs)
        <> putBuilder (Prim.primMapListFixed Prim.word32BE xs)
    get     = getWord32be

-- Words64s are written as 8 bytes in big-endian (network) order
instance Binary Word64 where
    put     = putWord64be
    {-# INLINE putList #-}
    putList xs =
        put (length xs)
        <> putBuilder (Prim.primMapListFixed Prim.word64BE xs)
    get     = getWord64be

-- Int8s are written as a single byte.
instance Binary Int8 where
    put     = putInt8
    {-# INLINE putList #-}
    putList xs =
        put (length xs)
        <> putBuilder (Prim.primMapListFixed Prim.int8 xs)
    get     = getInt8

-- Int16s are written as a 2 bytes in big endian format
instance Binary Int16 where
    put     = putInt16be
    {-# INLINE putList #-}
    putList xs =
        put (length xs)
        <> putBuilder (Prim.primMapListFixed Prim.int16BE xs)
    get     = getInt16be

-- Int32s are written as a 4 bytes in big endian format
instance Binary Int32 where
    put     = putInt32be
    {-# INLINE putList #-}
    putList xs =
        put (length xs)
        <> putBuilder (Prim.primMapListFixed Prim.int32BE xs)
    get     = getInt32be

-- Int64s are written as a 8 bytes in big endian format
instance Binary Int64 where
    put     = putInt64be
    {-# INLINE putList #-}
    putList xs =
        put (length xs)
        <> putBuilder (Prim.primMapListFixed Prim.int64BE xs)
    get     = getInt64be

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

-- Words are are written as Word64s, that is, 8 bytes in big endian format
instance Binary Word where
    put     = putWord64be . fromIntegral
    {-# INLINE putList #-}
    putList xs =
        put (length xs)
        <> putBuilder (Prim.primMapListFixed Prim.word64BE (map fromIntegral xs))
    get     = liftM fromIntegral getWord64be

-- Ints are are written as Int64s, that is, 8 bytes in big endian format
instance Binary Int where
    put     = putInt64be . fromIntegral
    {-# INLINE putList #-}
    putList xs =
        put (length xs)
        <> putBuilder (Prim.primMapListFixed Prim.int64BE (map fromIntegral xs))
    get     = liftM fromIntegral getInt64be

------------------------------------------------------------------------
--
-- Portable, and pretty efficient, serialisation of Integer
--

-- Fixed-size type for a subset of Integer
type SmallInt = Int32

-- Integers are encoded in two ways: if they fit inside a SmallInt,
-- they're written as a byte tag, and that value.  If the Integer value
-- is too large to fit in a SmallInt, it is written as a byte array,
-- along with a sign and length field.

instance Binary Integer where

    {-# INLINE put #-}
    put n | n >= lo && n <= hi =
        putBuilder (Prim.primFixed (Prim.word8 Prim.>*< Prim.int32BE) (0, fromIntegral n))
     where
        lo = fromIntegral (minBound :: SmallInt) :: Integer
        hi = fromIntegral (maxBound :: SmallInt) :: Integer

    put n =
        putWord8 1
        <> put sign
        <> put (unroll (abs n))         -- unroll the bytes
     where
        sign = fromIntegral (signum n) :: Word8

    {-# INLINE get #-}
    get = do
        tag <- get :: Get Word8
        case tag of
            0 -> liftM fromIntegral (get :: Get SmallInt)
            _ -> do sign  <- get
                    bytes <- get
                    let v = roll bytes
                    return $! if sign == (1 :: Word8) then v else - v

-- | /Since: 0.8.0.0/
#ifdef HAS_FIXED_CONSTRUCTOR
instance Binary (Fixed.Fixed a) where
  put (Fixed.MkFixed a) = put a
  get = Fixed.MkFixed `liftM` get
#else
instance forall a. Fixed.HasResolution a => Binary (Fixed.Fixed a) where
  -- Using undefined :: Maybe a as a proxy, as Data.Proxy is introduced only in base-4.7
  put x = put (truncate (x * fromInteger (Fixed.resolution (undefined :: Maybe a))) :: Integer)
  get = (\x -> fromInteger x / fromInteger (Fixed.resolution (undefined :: Maybe a))) `liftM` get
#endif

--
-- Fold and unfold an Integer to and from a list of its bytes
--
unroll :: (Integral a, Bits a) => a -> [Word8]
unroll = unfoldr step
  where
    step 0 = Nothing
    step i = Just (fromIntegral i, i `shiftR` 8)

roll :: (Integral a, Bits a) => [Word8] -> a
roll   = foldl' unstep 0 . reverse
  where
    unstep a b = a `shiftL` 8 .|. fromIntegral b

#ifdef HAS_NATURAL
-- Fixed-size type for a subset of Natural
type NaturalWord = Word64

-- | /Since: 0.7.3.0/
instance Binary Natural where
    {-# INLINE put #-}
    put n | n <= hi =
        putWord8 0
        <> put (fromIntegral n :: NaturalWord)  -- fast path
     where
        hi = fromIntegral (maxBound :: NaturalWord) :: Natural

    put n =
        putWord8 1
        <> put (unroll (abs n))         -- unroll the bytes

    {-# INLINE get #-}
    get = do
        tag <- get :: Get Word8
        case tag of
            0 -> liftM fromIntegral (get :: Get NaturalWord)
            _ -> do bytes <- get
                    return $! roll bytes
#endif

{-

--
-- An efficient, raw serialisation for Integer (GHC only)
--

-- TODO  This instance is not architecture portable.  GMP stores numbers as
-- arrays of machine sized words, so the byte format is not portable across
-- architectures with different endianness and word size.

import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy)
import GHC.Base     hiding (ord, chr)
import GHC.Prim
import GHC.Ptr (Ptr(..))
import GHC.IOBase (IO(..))

instance Binary Integer where
    put (S# i)    = putWord8 0 >> put (I# i)
    put (J# s ba) = do
        putWord8 1
        put (I# s)
        put (BA ba)

    get = do
        b <- getWord8
        case b of
            0 -> do (I# i#) <- get
                    return (S# i#)
            _ -> do (I# s#) <- get
                    (BA a#) <- get
                    return (J# s# a#)

instance Binary ByteArray where

    -- Pretty safe.
    put (BA ba) =
        let sz   = sizeofByteArray# ba   -- (primitive) in *bytes*
            addr = byteArrayContents# ba
            bs   = unsafePackAddress (I# sz) addr
        in put bs   -- write as a ByteString. easy, yay!

    -- Pretty scary. Should be quick though
    get = do
        (fp, off, n@(I# sz)) <- liftM toForeignPtr get      -- so decode a ByteString
        assert (off == 0) $ return $ unsafePerformIO $ do
            (MBA arr) <- newByteArray sz                    -- and copy it into a ByteArray#
            let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe?
            withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n)
            freezeByteArray arr

-- wrapper for ByteArray#
data ByteArray = BA  {-# UNPACK #-} !ByteArray#
data MBA       = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld)

newByteArray :: Int# -> IO MBA
newByteArray sz = IO $ \s ->
  case newPinnedByteArray# sz s of { (# s', arr #) ->
  (# s', MBA arr #) }

freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
freezeByteArray arr = IO $ \s ->
  case unsafeFreezeByteArray# arr s of { (# s', arr' #) ->
  (# s', BA arr' #) }

-}

instance (Binary a,Integral a) => Binary (R.Ratio a) where
    put r = put (R.numerator r) <> put (R.denominator r)
    get = liftM2 (R.%) get get

instance Binary a => Binary (Complex a) where
    {-# INLINE put #-}
    put (r :+ i) = put (r, i)
    {-# INLINE get #-}
    get = (\(r,i) -> r :+ i) <$> get

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

-- Char is serialised as UTF-8
instance Binary Char where
    put = putCharUtf8
    putList str = put (length str) <> putStringUtf8 str
    get = do
        let getByte = liftM (fromIntegral :: Word8 -> Int) get
            shiftL6 = flip shiftL 6 :: Int -> Int
        w <- getByte
        r <- case () of
                _ | w < 0x80  -> return w
                  | w < 0xe0  -> do
                                    x <- liftM (xor 0x80) getByte
                                    return (x .|. shiftL6 (xor 0xc0 w))
                  | w < 0xf0  -> do
                                    x <- liftM (xor 0x80) getByte
                                    y <- liftM (xor 0x80) getByte
                                    return (y .|. shiftL6 (x .|. shiftL6
                                            (xor 0xe0 w)))
                  | otherwise -> do
                                x <- liftM (xor 0x80) getByte
                                y <- liftM (xor 0x80) getByte
                                z <- liftM (xor 0x80) getByte
                                return (z .|. shiftL6 (y .|. shiftL6
                                        (x .|. shiftL6 (xor 0xf0 w))))
        getChr r
      where
        getChr w
          | w <= 0x10ffff = return $! toEnum $ fromEnum w
          | otherwise = fail "Not a valid Unicode code point!"

------------------------------------------------------------------------
-- Instances for the first few tuples

instance (Binary a, Binary b) => Binary (a,b) where
    {-# INLINE put #-}
    put (a,b)           = put a <> put b
    {-# INLINE get #-}
    get                 = liftM2 (,) get get

instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
    {-# INLINE put #-}
    put (a,b,c)         = put a <> put b <> put c
    {-# INLINE get #-}
    get                 = liftM3 (,,) get get get

instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
    {-# INLINE put #-}
    put (a,b,c,d)       = put a <> put b <> put c <> put d
    {-# INLINE get #-}
    get                 = liftM4 (,,,) get get get get

instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where
    {-# INLINE put #-}
    put (a,b,c,d,e)     = put a <> put b <> put c <> put d <> put e
    {-# INLINE get #-}
    get                 = liftM5 (,,,,) get get get get get

--
-- and now just recurse:
--

instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f)
        => Binary (a,b,c,d,e,f) where
    {-# INLINE put #-}
    put (a,b,c,d,e,f)   = put (a,(b,c,d,e,f))
    {-# INLINE get #-}
    get                 = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f)

instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g)
        => Binary (a,b,c,d,e,f,g) where
    {-# INLINE put #-}
    put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g))
    {-# INLINE get #-}
    get                 = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g)

instance (Binary a, Binary b, Binary c, Binary d, Binary e,
          Binary f, Binary g, Binary h)
        => Binary (a,b,c,d,e,f,g,h) where
    {-# INLINE put #-}
    put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h))
    {-# INLINE get #-}
    get                   = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h)

instance (Binary a, Binary b, Binary c, Binary d, Binary e,
          Binary f, Binary g, Binary h, Binary i)
        => Binary (a,b,c,d,e,f,g,h,i) where
    {-# INLINE put #-}
    put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i))
    {-# INLINE get #-}
    get                     = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i)

instance (Binary a, Binary b, Binary c, Binary d, Binary e,
          Binary f, Binary g, Binary h, Binary i, Binary j)
        => Binary (a,b,c,d,e,f,g,h,i,j) where
    {-# INLINE put #-}
    put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j))
    {-# INLINE get #-}
    get                       = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j)

------------------------------------------------------------------------
-- Container types

#if MIN_VERSION_base(4,8,0)
instance Binary a => Binary (Identity a) where
  put (Identity x) = put x
  get = Identity <$> get
#endif

instance Binary a => Binary [a] where
    put = putList
    get = do n <- get :: Get Int
             getMany n

-- | 'getMany n' get 'n' elements in order, without blowing the stack.
getMany :: Binary a => Int -> Get [a]
getMany n = go [] n
 where
    go xs 0 = return $! reverse xs
    go xs i = do x <- get
                 -- we must seq x to avoid stack overflows due to laziness in
                 -- (>>=)
                 x `seq` go (x:xs) (i-1)
{-# INLINE getMany #-}

instance (Binary a) => Binary (Maybe a) where
    put Nothing  = putWord8 0
    put (Just x) = putWord8 1 <> put x
    get = do
        w <- getWord8
        case w of
            0 -> return Nothing
            _ -> liftM Just get

instance (Binary a, Binary b) => Binary (Either a b) where
    put (Left  a) = putWord8 0 <> put a
    put (Right b) = putWord8 1 <> put b
    get = do
        w <- getWord8
        case w of
            0 -> liftM Left  get
            _ -> liftM Right get

------------------------------------------------------------------------
-- ByteStrings (have specially efficient instances)

instance Binary B.ByteString where
    put bs = put (B.length bs)
             <> putByteString bs
    get    = get >>= getByteString

--
-- Using old versions of fps, this is a type synonym, and non portable
--
-- Requires 'flexible instances'
--
instance Binary ByteString where
    put bs = put (fromIntegral (L.length bs) :: Int)
             <> putLazyByteString bs
    get    = get >>= getLazyByteString

#if MIN_VERSION_bytestring(0,10,4)
instance Binary BS.ShortByteString where
   put bs = put (BS.length bs)
            <> putShortByteString bs
   get = get >>= fmap BS.toShort . getByteString
#endif

------------------------------------------------------------------------
-- Maps and Sets

instance (Binary a) => Binary (Set.Set a) where
    put s = put (Set.size s) <> mapM_ put (Set.toAscList s)
    get   = liftM Set.fromDistinctAscList get

instance (Binary k, Binary e) => Binary (Map.Map k e) where
    put m = put (Map.size m) <> mapM_ put (Map.toAscList m)
    get   = liftM Map.fromDistinctAscList get

instance Binary IntSet.IntSet where
    put s = put (IntSet.size s) <> mapM_ put (IntSet.toAscList s)
    get   = liftM IntSet.fromDistinctAscList get

instance (Binary e) => Binary (IntMap.IntMap e) where
    put m = put (IntMap.size m) <> mapM_ put (IntMap.toAscList m)
    get   = liftM IntMap.fromDistinctAscList get

------------------------------------------------------------------------
-- Queues and Sequences

--
-- This is valid Hugs, but you need the most recent Hugs
--

instance (Binary e) => Binary (Seq.Seq e) where
    put s = put (Seq.length s) <> Fold.mapM_ put s
    get = do n <- get :: Get Int
             rep Seq.empty n get
      where rep xs 0 _ = return $! xs
            rep xs n g = xs `seq` n `seq` do
                           x <- g
                           rep (xs Seq.|> x) (n-1) g

------------------------------------------------------------------------
-- Floating point

instance Binary Double where
    put d = put (decodeFloat d)
    get   = do
        x <- get
        y <- get
        return $! encodeFloat x y

instance Binary Float where
    put f = put (decodeFloat f)
    get   =  do
        x <- get
        y <- get
        return $! encodeFloat x y

------------------------------------------------------------------------
-- Trees

instance (Binary e) => Binary (T.Tree e) where
    put (T.Node r s) = put r <> put s
    get = liftM2 T.Node get get

------------------------------------------------------------------------
-- Arrays

instance (Binary i, Ix i, Binary e) => Binary (Array i e) where
    put a =
        put (bounds a)
        <> put (rangeSize $ bounds a) -- write the length
        <> mapM_ put (elems a)        -- now the elems.
    get = do
        bs <- get
        n  <- get                  -- read the length
        xs <- getMany n            -- now the elems.
        return (listArray bs xs)

--
-- The IArray UArray e constraint is non portable. Requires flexible instances
--
instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where
    put a =
        put (bounds a)
        <> put (rangeSize $ bounds a) -- now write the length
        <> mapM_ put (elems a)
    get = do
        bs <- get
        n  <- get
        xs <- getMany n
        return (listArray bs xs)

------------------------------------------------------------------------
-- Fingerprints

-- | /Since: 0.7.6.0/
instance Binary Fingerprint where
    put (Fingerprint x1 x2) = put x1 <> put x2
    get = do
        x1 <- get
        x2 <- get
        return $! Fingerprint x1 x2

------------------------------------------------------------------------
-- Version

-- | /Since: 0.8.0.0/
instance Binary Version where
    put (Version br tags) = put br <> put tags
    get = Version <$> get <*> get

------------------------------------------------------------------------
-- Data.Monoid datatypes

-- | /Since: 0.8.4.0/
instance Binary a => Binary (Monoid.Dual a) where
  get = fmap Monoid.Dual get
  put = put . Monoid.getDual

-- | /Since: 0.8.4.0/
instance Binary Monoid.All where
  get = fmap Monoid.All get
  put = put . Monoid.getAll

-- | /Since: 0.8.4.0/
instance Binary Monoid.Any where
  get = fmap Monoid.Any get
  put = put . Monoid.getAny

-- | /Since: 0.8.4.0/
instance Binary a => Binary (Monoid.Sum a) where
  get = fmap Monoid.Sum get
  put = put . Monoid.getSum

-- | /Since: 0.8.4.0/
instance Binary a => Binary (Monoid.Product a) where
  get = fmap Monoid.Product get
  put = put . Monoid.getProduct

-- | /Since: 0.8.4.0/
instance Binary a => Binary (Monoid.First a) where
  get = fmap Monoid.First get
  put = put . Monoid.getFirst

-- | /Since: 0.8.4.0/
instance Binary a => Binary (Monoid.Last a) where
  get = fmap Monoid.Last get
  put = put . Monoid.getLast

#if MIN_VERSION_base(4,8,0)
-- | /Since: 0.8.4.0/
instance Binary (f a) => Binary (Monoid.Alt f a) where
  get = fmap Monoid.Alt get
  put = put . Monoid.getAlt
#endif

#if MIN_VERSION_base(4,9,0)
------------------------------------------------------------------------
-- Data.Semigroup datatypes

-- | /Since: 0.8.4.0/
instance Binary a => Binary (Semigroup.Min a) where
  get = fmap Semigroup.Min get
  put = put . Semigroup.getMin

-- | /Since: 0.8.4.0/
instance Binary a => Binary (Semigroup.Max a) where
  get = fmap Semigroup.Max get
  put = put . Semigroup.getMax

-- | /Since: 0.8.4.0/
instance Binary a => Binary (Semigroup.First a) where
  get = fmap Semigroup.First get
  put = put . Semigroup.getFirst

-- | /Since: 0.8.4.0/
instance Binary a => Binary (Semigroup.Last a) where
  get = fmap Semigroup.Last get
  put = put . Semigroup.getLast

-- | /Since: 0.8.4.0/
instance Binary a => Binary (Semigroup.Option a) where
  get = fmap Semigroup.Option get
  put = put . Semigroup.getOption

-- | /Since: 0.8.4.0/
instance Binary m => Binary (Semigroup.WrappedMonoid m) where
  get = fmap Semigroup.WrapMonoid get
  put = put . Semigroup.unwrapMonoid

-- | /Since: 0.8.4.0/
instance (Binary a, Binary b) => Binary (Semigroup.Arg a b) where
  get                     = liftM2 Semigroup.Arg get get
  put (Semigroup.Arg a b) = put a <> put b

------------------------------------------------------------------------
-- Non-empty lists

-- | /Since: 0.8.4.0/
instance Binary a => Binary (NE.NonEmpty a) where
  get = fmap NE.fromList get
  put = put . NE.toList
#endif

------------------------------------------------------------------------
-- Typeable/Reflection

#if MIN_VERSION_base(4,10,0)

-- $typeable-instances
--
-- 'Binary' instances for GHC's "Type.Reflection", "Data.Typeable", and
-- kind-system primitives are only provided with @base-4.10.0@ (shipped with GHC
-- 8.2.1). In prior GHC releases some of these instances were provided by
-- 'GHCi.TH.Binary' in the @ghci@ package.
--
-- These include instances for,
--
-- * 'VecCount'
-- * 'VecElem'
-- * 'RuntimeRep'
-- * 'KindRep'
-- * 'TypeLitSort'
-- * 'TyCon'
-- * 'TypeRep'
-- * 'SomeTypeRep' (also known as 'Data.Typeable.TypeRep')
--

-- | @since 0.8.5.0. See #typeable-instances#
instance Binary VecCount where
    put = putWord8 . fromIntegral . fromEnum
    get = toEnum . fromIntegral <$> getWord8

-- | @since 0.8.5.0. See #typeable-instances#
instance Binary VecElem where
    put = putWord8 . fromIntegral . fromEnum
    get = toEnum . fromIntegral <$> getWord8

-- | @since 0.8.5.0. See #typeable-instances#
instance Binary RuntimeRep where
    put (VecRep a b)    = putWord8 0 >> put a >> put b
    put (TupleRep reps) = putWord8 1 >> put reps
    put (SumRep reps)   = putWord8 2 >> put reps
    put LiftedRep       = putWord8 3
    put UnliftedRep     = putWord8 4
    put IntRep          = putWord8 5
    put WordRep         = putWord8 6
    put Int64Rep        = putWord8 7
    put Word64Rep       = putWord8 8
    put AddrRep         = putWord8 9
    put FloatRep        = putWord8 10
    put DoubleRep       = putWord8 11
#if __GLASGOW_HASKELL__ >= 807
    put Int8Rep         = putWord8 12
    put Word8Rep        = putWord8 13
    put Int16Rep        = putWord8 14
    put Word16Rep       = putWord8 15
#endif

    get = do
        tag <- getWord8
        case tag of
          0  -> VecRep <$> get <*> get
          1  -> TupleRep <$> get
          2  -> SumRep <$> get
          3  -> pure LiftedRep
          4  -> pure UnliftedRep
          5  -> pure IntRep
          6  -> pure WordRep
          7  -> pure Int64Rep
          8  -> pure Word64Rep
          9  -> pure AddrRep
          10 -> pure FloatRep
          11 -> pure DoubleRep
#if __GLASGOW_HASKELL__ >= 807
          12 -> pure Int8Rep
          13 -> pure Word8Rep
          14 -> pure Int16Rep
          15 -> pure Word16Rep
#endif
          _  -> fail "GHCi.TH.Binary.putRuntimeRep: invalid tag"

-- | @since 0.8.5.0. See #typeable-instances#
instance Binary TyCon where
    put tc = do
        put (tyConPackage tc)
        put (tyConModule tc)
        put (tyConName tc)
        put (tyConKindArgs tc)
        put (tyConKindRep tc)
    get = mkTyCon <$> get <*> get <*> get <*> get <*> get

-- | @since 0.8.5.0. See #typeable-instances#
instance Binary KindRep where
    put (KindRepTyConApp tc k) = putWord8 0 >> put tc >> put k
    put (KindRepVar bndr) = putWord8 1 >> put bndr
    put (KindRepApp a b) = putWord8 2 >> put a >> put b
    put (KindRepFun a b) = putWord8 3 >> put a >> put b
    put (KindRepTYPE r) = putWord8 4 >> put r
    put (KindRepTypeLit sort r) = putWord8 5 >> put sort >> put r

    get = do
        tag <- getWord8
        case tag of
          0 -> KindRepTyConApp <$> get <*> get
          1 -> KindRepVar <$> get
          2 -> KindRepApp <$> get <*> get
          3 -> KindRepFun <$> get <*> get
          4 -> KindRepTYPE <$> get
          5 -> KindRepTypeLit <$> get <*> get
          _ -> fail "GHCi.TH.Binary.putKindRep: invalid tag"

-- | @since 0.8.5.0. See #typeable-instances#
instance Binary TypeLitSort where
    put TypeLitSymbol = putWord8 0
    put TypeLitNat = putWord8 1
    get = do
        tag <- getWord8
        case tag of
          0 -> pure TypeLitSymbol
          1 -> pure TypeLitNat
          _ -> fail "GHCi.TH.Binary.putTypeLitSort: invalid tag"

putTypeRep :: TypeRep a -> Put
-- Special handling for TYPE, (->), and RuntimeRep due to recursive kind
-- relations.
-- See Note [Mutually recursive representations of primitive types]
putTypeRep rep  -- Handle Type specially since it's so common
  | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)
  = put (0 :: Word8)
putTypeRep (Con' con ks) = do
    put (1 :: Word8)
    put con
    put ks
putTypeRep (App f x) = do
    put (2 :: Word8)
    putTypeRep f
    putTypeRep x
putTypeRep (Fun arg res) = do
    put (3 :: Word8)
    putTypeRep arg
    putTypeRep res
putTypeRep _ = fail "GHCi.TH.Binary.putTypeRep: Impossible"

getSomeTypeRep :: Get SomeTypeRep
getSomeTypeRep = do
    tag <- get :: Get Word8
    case tag of
        0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)
        1 -> do con <- get :: Get TyCon
                ks <- get :: Get [SomeTypeRep]
                return $ SomeTypeRep $ mkTrCon con ks
        2 -> do SomeTypeRep f <- getSomeTypeRep
                SomeTypeRep x <- getSomeTypeRep
                case typeRepKind f of
                  Fun arg res ->
                      case arg `eqTypeRep` typeRepKind x of
                        Just HRefl -> do
                            case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
                                Just HRefl -> return $ SomeTypeRep $ mkTrApp f x
                                _ -> failure "Kind mismatch" []
                        _ -> failure "Kind mismatch"
                             [ "Found argument of kind:      " ++ show (typeRepKind x)
                             , "Where the constructor:       " ++ show f
                             , "Expects an argument of kind: " ++ show arg
                             ]
                  _ -> failure "Applied non-arrow type"
                       [ "Applied type: " ++ show f
                       , "To argument:  " ++ show x
                       ]
        3 -> do SomeTypeRep arg <- getSomeTypeRep
                SomeTypeRep res <- getSomeTypeRep
                case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of
                  Just HRefl ->
                      case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
                        Just HRefl -> return $ SomeTypeRep $ Fun arg res
                        Nothing -> failure "Kind mismatch" []
                  Nothing -> failure "Kind mismatch" []
        _ -> failure "Invalid SomeTypeRep" []
  where
    failure description info =
        fail $ unlines $ [ "GHCi.TH.Binary.getSomeTypeRep: "++description ]
                      ++ map ("    "++) info

instance Typeable a => Binary (TypeRep (a :: k)) where
    put = putTypeRep
    get = do
        SomeTypeRep rep <- getSomeTypeRep
        case rep `eqTypeRep` expected of
          Just HRefl -> pure rep
          Nothing    -> fail $ unlines
                        [ "GHCi.TH.Binary: Type mismatch"
                        , "    Deserialized type: " ++ show rep
                        , "    Expected type:     " ++ show expected
                        ]
     where expected = typeRep :: TypeRep a

instance Binary SomeTypeRep where
    put (SomeTypeRep rep) = putTypeRep rep
    get = getSomeTypeRep
#endif


{-# LANGUAGE NoImplicitPrelude #-}
module BaseCompat (
  module X
) where

import Intro as X

import Control.Applicative as X
import Control.Arrow as X hiding (first, second)
import Control.Category as X
import Control.Concurrent as X
import Control.Exception as X
import Control.Exception.Base as X
import Control.Monad as X hiding (fail)
import Control.Monad.Fix as X
import Control.Monad.IO.Class as X
import Control.Monad.ST as X
import Control.Monad.ST.Unsafe as X
import Control.Monad.Zip as X
import Data.Bifunctor as X
import Data.Bits as X
import Data.Bool as X
import Data.Char as X
import Data.Coerce as X
import Data.Complex as X
import Data.Data as X
import Data.Dynamic as X
import Data.Either as X
import Data.Eq as X
import Data.Fixed as X
import Data.Foldable as X
import Data.Function as X hiding ((.), id)
import Data.Functor as X
import Data.Functor.Classes as X
import Data.Functor.Compose as X
import Data.Functor.Identity as X
import Data.IORef as X
import Data.Int as X
import Data.Ix as X
import Data.List as X hiding (scanl1, scanr1, map, cycle, head, init, last, tail)
import Data.Maybe as X
import Data.Monoid as X hiding (First(..), Last(..), (<>))
import Data.Ord as X
import Data.Proxy as X
import Data.Ratio as X
import Data.STRef as X
import Data.Semigroup as X
import Data.String as X
import Data.Traversable as X
import Data.Tuple as X
import Data.Type.Bool as X
import Data.Type.Coercion as X
import Data.Type.Equality as X hiding (trans, sym)
import Data.Unique as X
import Data.Version as X
import Data.Void as X
import Data.Word as X
import Numeric as X
import Numeric.Natural as X
import Prelude as X hiding ((.), id, map, putChar, putStrLn, putStr, getContents, getLine, print, getChar, appendFile, readFile, writeFile, fail, show, undefined, scanl1, scanr1, cycle, head, init, last, tail)
import System.CPUTime as X
import System.Console.GetOpt as X hiding (Option)
import System.Environment as X
import System.Exit as X
import System.IO as X hiding (putChar, putStrLn, putStr, getContents, getLine, print, getChar, appendFile, readFile, writeFile)
import System.IO.Error as X
import System.IO.Unsafe as X
import System.Info as X
import System.Mem as X
import System.Mem.StableName as X
import System.Mem.Weak as X
import System.Timeout as X
import Text.ParserCombinators.ReadP as X hiding (get, (+++), optional, (<++), look, pfail, many, choice, option)
import Text.ParserCombinators.ReadPrec as X hiding (get, (+++), lift)
import Text.Printf as X
import Text.Read as X hiding (readMaybe, get, lift, EOF, (+++))
import Text.Show as X hiding (show)
import Unsafe.Coerce as X
import Control.Monad.Fail as X hiding (fail)
import Data.Kind as X


module Main where

import Data.Monoid
import Options.Applicative.Simple

import Statistics
import Convert

-- | Helper for lifting pure parsing functions into ReadM monad
readMPure :: String -- ^ Name of argument for pretty error message
  -> (String -> Maybe a) -- ^ Function that parses the argument
  -> ReadM a -- ^ Optparse parser monad
readMPure desc f = do
  s <- str
  case f s of
    Nothing -> fail $ "Unknown " ++ desc ++ " " ++ s
    Just v -> return v

-- | How to parse ConvertFormat
convertFormatR :: ReadM ConvertFormat
convertFormatR = readMPure "format" readConvertFormat

-- | How to parse BlpFormat
blpFormatR :: ReadM BlpFormat
blpFormatR = readMPure "blp format" readBlpFormat

main :: IO ()
main = do
  (_,runCmd) <- simpleOptions ver headerDesc desc (pure ()) $ do
    addCommand "convert" "Converts given blp or folder with blps to PNG" convertFiles $ (<*>) helper $ ConvertOptions
      <$> strArgument (metavar "INPUT_PATH" <> help "input file or directory (batch mode)")
      <*> strArgument (metavar "OUTPUT_PATH" <> help "output file name or directory (need explicit format option)")
      <*> option convertFormatR (long "input-format" <> short 'i' <> value UnspecifiedFormat <> help "Input file format, if not specified tries to infer from input file name. Values: blp png jpg tiff gif bmp.")
      <*> option convertFormatR (long "format" <> short 'f' <> value UnspecifiedFormat <> help "Output file format, if not specified tries to infer from output file name. Values: blp png jpg tiff gif bmp.")
      <*> option auto (long "quality" <> short 'q' <> value 90 <> help "Quality level for formats with lossy compression (default 90)")
      <*> fmap not (switch (long "notPreserveStructure" <> short 'p' <> help "Will not produce subfolders while batch converting" ))
      <*> switch (long "shallow" <> short 's' <> help "Not look into subfolders while batch converting")
      <*> option blpFormatR (long "blpFormat" <> short 'b' <> value BlpJpeg <> help "Specifies what BLP internal format to use when converting to BLP. Values: jpg uncompressedWithAlpha uncompressedWithoutAlpha")
      <*> option auto (long "min-mipmap-size" <> value 1 <> help "Minimum size of mimmap side to include in resulted BLP file")
    addCommand "stats" "Collects statistics about BLP images in folder and saves examples of BLP's for each sample" (uncurry collectStatistics) $ (<*>) helper $ (,)
      <$> strArgument (metavar "DIRECTORY" <> help "Input folder that stores blps (subfolders are processed)")
      <*> strArgument (metavar "OUTPUT_PATH" <> help "Here blp samples would be stored")
  runCmd
  where
    ver = "0.1.0.0"
    headerDesc = ""
    desc = "Converting BLP1 Warcraft III format to/from PNG, JPEG, TGA, TIFF, BMP, GIF"


module Statistics.Report
    ( reportTxFate
    ) where

import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import           System.IO (hPutStrLn)

import           Statistics.Block (TxFate (..))
import           Types
import           Universum

reportTxFate :: FilePath -> Map TxHash TxFate -> IO ([TxHash], [TxHash], [TxHash])
reportTxFate f m = withFile f WriteMode $ \h -> do
    let total = M.size m
        m'    = M.filter isFork m
        fork  = M.size m'
        m''   = M.filter isChain m
        chain = M.size m''
        m'''  = M.filter isLost m
        lost  = M.size m'''
        chains = fst <$> M.toList m''
        forks  = fst <$> M.toList m'
        losts  = fst <$> M.toList m''
    hPutStrLn h $ "total transactions: " ++ show total
    hPutStrLn h $ "in blockchain: " ++ show chain
    hPutStrLn h $ "in fork: " ++ show fork
    hPutStrLn h $ "lost: " ++ show lost
    hPutStrLn h ""
    hPutStrLn h "transactions in blockchain:"
    for_ (M.toList m'') $ \(tx, InBlockChain _ hash _) ->
        hPutStrLn h $ toString tx ++ ": " ++ toString (T.take 6 hash)
    hPutStrLn h ""
    hPutStrLn h "transactions in fork:"
    for_ (M.toList m') $ \(tx, InFork s) ->
        hPutStrLn h $ toString tx ++ ": " ++ toString (unwords $ map (T.take 6 . snd) $ S.toList s)
    hPutStrLn h ""
    hPutStrLn h "lost transactions:"
    for_ (M.toList m''') $ \(tx, InNoBlock) ->
        hPutStrLn h (toString tx)
    return (chains, forks, losts)

isFork :: TxFate -> Bool
isFork (InFork _) = True
isFork _          = False

isLost :: TxFate -> Bool
isLost InNoBlock = True
isLost _         = False

isChain :: TxFate -> Bool
isChain (InBlockChain{}) = True
isChain _                = False


-- Copyright (c) Facebook, Inc. and its affiliates.

{-# LANGUAGE DefaultSignatures #-}
module Foreign.CPP.Addressable
  ( Addressable(..)
  , Addressable1(..)
  ) where

import Data.Complex (Complex)
import Data.Ratio (Ratio)
import Data.Functor.Const (Const)
import Data.Functor.Identity (Identity)
import Foreign hiding (sizeOf, alignment)
import Foreign.C.Types
import qualified Foreign.Storable as Storable
import GHC.Fingerprint (Fingerprint)
import System.Posix.Types

class Addressable a where
  -- | Computes the storage requirements (in bytes) of the argument.
  -- The value of the argument is not used.
  sizeOf :: a -> Int
  default sizeOf :: Storable a => a -> Int
  sizeOf = Storable.sizeOf

  -- | Computes the alignment constraint of the argument. An alignment
  -- constraint @x@ is fulfilled by any address divisible by @x@.
  -- The value of the argument is not used.
  alignment :: a -> Int
  default alignment :: Storable a => a -> Int
  alignment = Storable.alignment

class Addressable1 f where
  sizeOf1 :: f a -> Int
  alignment1 :: f a -> Int

instance Addressable Bool
instance Addressable Char
instance Addressable Double
instance Addressable Float
instance Addressable Int
instance Addressable Int8
instance Addressable Int16
instance Addressable Int32
instance Addressable Int64
instance Addressable Word
instance Addressable Word8
instance Addressable Word16
instance Addressable Word32
instance Addressable Word64
instance Addressable ()
instance Addressable Fingerprint
instance Addressable CUIntMax
instance Addressable CIntMax
instance Addressable CUIntPtr
instance Addressable CIntPtr
instance Addressable CSUSeconds
instance Addressable CUSeconds
instance Addressable CTime
instance Addressable CClock
instance Addressable CSigAtomic
instance Addressable CWchar
instance Addressable CSize
instance Addressable CPtrdiff
instance Addressable CDouble
instance Addressable CFloat
instance Addressable CULLong
instance Addressable CLLong
instance Addressable CULong
instance Addressable CLong
instance Addressable CUInt
instance Addressable CInt
instance Addressable CUShort
instance Addressable CShort
instance Addressable CUChar
instance Addressable CSChar
instance Addressable CChar
instance Addressable IntPtr
instance Addressable WordPtr
instance Addressable Fd
instance Addressable CRLim
instance Addressable CTcflag
instance Addressable CSpeed
instance Addressable CCc
instance Addressable CUid
instance Addressable CNlink
instance Addressable CGid
instance Addressable CSsize
instance Addressable CPid
instance Addressable COff
instance Addressable CMode
instance Addressable CIno
instance Addressable CDev
instance (Storable a, Integral a) => Addressable (Ratio a)
instance Addressable (StablePtr a)
instance Addressable (Ptr a)
instance Addressable (FunPtr a)
instance Storable a => Addressable (Complex a)
instance Storable a => Addressable (Identity a)
instance Storable a => Addressable (Const a b)


{-# LANGUAGE Haskell2010 #-}
import Control.Monad
import Data.Array
import Data.Bits
import Data.Char
import Data.Complex
import Data.Int
import Data.Ix
import Data.List
import Data.Maybe
import Data.Ratio
import Data.Word
import Foreign
import Foreign.C
import Foreign.C.Error
import Foreign.C.String
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Marshal
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Marshal.Error
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.StablePtr
import Foreign.Storable
import Numeric
import Prelude
import System.Environment
import System.Exit
import System.IO
import System.IO.Error

main :: IO ()
main = return ()


-- Copyright 2016 TensorFlow authors.
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
-- | Rendering of TensorFlow operations as Haskell functions.

module TensorFlow.OpGen
  ( OpGenFlags(..)
  , docOpList
  , flagParser)
  where

import Prelude hiding (head, tail)

import Control.Monad (guard)
import Data.Char (toLower, toUpper)
import Data.Foldable (toList)
import Data.Maybe (fromMaybe, maybeToList)
import Data.ProtoLens (def, showMessage)
import Data.List.NonEmpty (NonEmpty((:|)), head)
import qualified Data.List.NonEmpty as NE
import Lens.Family2 ((^.), (.~), (&), view)
import Options.Applicative (Parser, help, long, strOption, value)
import Proto.Tensorflow.Core.Framework.OpDef
  ( OpList
  , OpDef
  , OpDef'ArgDef
  , attr
  , description
  , inputArg
  , name
  , numberAttr
  , op
  , outputArg
  , summary
  , type'
  , typeAttr
  )
import Proto.Tensorflow.Core.Framework.Types (DataType(..))
import System.FilePath (takeBaseName)
import TensorFlow.OpGen.AttrVal
  (AttrDef
  , AttrCase(..)
  , AttrTemplate(..)
  , Template
  , attrDef
  , attrOriginal
  , attrTemplate
  , templateDefault
  , templateRestrictions
  )
import Text.PrettyPrint.Mainland
  ( Doc
  , (<>)
  , (<+>)
  , (</>)
  , (<+/>)
  , brackets
  , comma
  , commasep
  , dquotes
  , empty
  , enclose
  , flatten
  , folddoc
  , hang
  , indent
  , int
  , parens
  , sep
  , stack
  , strictText
  , tuple
  )
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Semigroup as Semigroup
import Data.Text (Text)

data OpGenFlags = OpGenFlags
     { outputFile :: String
     , prefix :: String
     , excludeList :: String
     }

flagParser :: Parser OpGenFlags
flagParser = OpGenFlags
     <$> strOption (mconcat [ long "output"
                            , help "File to write."
                            ])
     <*> strOption (mconcat [ long "prefix"
                            , help "Haskell package prefix to use"
                            ])
     <*> strOption (mconcat [ long "exclude_list"
                            , value ""
                            , help "Comma separated Ops names to ignore"
                            ])

docOpList :: OpGenFlags -> OpList -> Doc
docOpList flags opList =
  stack [ "{-# LANGUAGE ConstraintKinds #-}"
        , "{-# LANGUAGE DataKinds #-}"
        , "{-# LANGUAGE FlexibleInstances #-}"
        , "{-# LANGUAGE OverloadedStrings #-}"
        , "{-# LANGUAGE RankNTypes #-}"
        , "{-# LANGUAGE ScopedTypeVariables #-}"
        , "module" <+> strictText moduleName <+> "where"
        , empty
        , imports
        , empty
        , folddoc (\x y -> x </> empty </> y)
                  (map renderDef $
                   filter (not . flip elem exclusions . view name) $
                   toList $ opList ^. op)
        ]
  where moduleName =
            Text.pack (prefix flags) <> "." <> camelCase
             -- Discards the optional trailing _op_lib
            (fromMaybe shortName (Text.stripSuffix "_op_lib" shortName))
        shortName = Text.pack (takeBaseName $ outputFile flags)
        exclusions = Text.splitOn "," $ Text.pack $ excludeList flags

camelCase s = Text.concat $ map upCase
                          $ filter (/= "ops")
                          $ Text.splitOn "_" s

-- | Upper-case the given text.
upCase :: Text -> Text
upCase = forceCase toUpper

-- | Lower-case the given name, and prevent it from overlapping with a reserved
-- Haskell name.
lowCase :: Text -> Text
lowCase = replaceReservedName . forceCase toLower

forceCase :: (Char -> Char) -> Text -> Text
forceCase convert s = maybe "" (\(c, cs) -> Text.cons (convert c) cs)
                      (Text.uncons s)

imports = stack [
      "import Data.ByteString (ByteString)"
    , "import Data.Complex (Complex)"
    , "import Data.Int (Int8, Int16, Int32, Int64)"
    , "import Data.Word (Word8, Word16)"
    , "import Lens.Family2 ((.~), (&))"
    , "import TensorFlow.Build"
    , "import TensorFlow.BuildOp"
    , "import TensorFlow.Tensor"
    , "import TensorFlow.Types"
      ]

renderDef :: OpDef -> Doc
renderDef d =
  stack [
      haddocks
    , n <+> "::" <+> hang 0 (typeSig d)
    , n <+> hang 0 args <+> "|" <+> funcGuard <+> "=" </>  -- args are indented
            -- the body needs to be indented wrt the name
            indent indentation functionBody
    , extras  -- just for debug
    ]
  where
    n = strictText $ fixOpName (d ^. name)
    args = sep $ [hsName | (_, hsName) <- mandatoryAttrs] ++ tensorArgs
    tensorArgs = [strictText $ lowCase (a ^. name) | a <- d ^. inputArg]
    fixOpName = lowCase
    funcGuard = "eqLengthGuard" <+> brackets (commasep entries)
      where
        entries =
            [ parens $ quotedText nAttr <> comma <+>
              brackets (commasep $ toList $
              NE.map renderTensorName tensorNames)
            | (nAttr, tensorNames) <- Map.toList $ numberAttrMap d
            ]
        renderTensorName x = parens $ quotedText x <> comma <+>
                             "length" <+> strictText x
    -- Uses hang 0 to align the argument vertically on multiple lines.
    functionBody = buildFunction <+> parens (hang 0 (stack buildOpParts))
                                 </> indent indentation (sep tensorArgs)
    buildFunction
        | null outputListsSizes = "buildOp"
        | otherwise = "buildListOp" <+> brackets (commasep outputListsSizes)
    outputListsSizes = [ strictText numberAttrName
                       | o <- d ^. outputArg
                       , let numberAttrName = o ^. numberAttr
                       , not (Text.null numberAttrName) &&
                         numberAttrName `Map.member` mandatoryAttrMap d
                       ]
    buildOpParts =
        "opDef" <+> quotedText (d ^. name) :
        -- Renders tensor arguments.
        [ "& opAttr" <+> quotedText tfName <+>
          ".~ tensorType (undefined ::" <+> strictText hsName <> ")"
        | (tfName, (hsName, _)) <- Map.toList typeMap
        ] ++
        -- Renders mandatory attributes as function parameters.
        [ "& opAttr" <+> dquotes tfName <+> ".~" <+> hsName
        | (tfName, hsName) <- mandatoryAttrs
        ] ++
        -- Renders sizes of tensor list types having number_attr.
        [ "& opAttr" <+> quotedText nAttr <+> ".~" <+>
          "(fromIntegral (length" <+> strictText (head tensorNames) <> ") :: Int64)"
        | (nAttr, tensorNames) <- Map.toList $ numberAttrMap d
        ]
    mandatoryAttrs = [(strictText tf, strictText hs)
                     | (tf, (hs, _, _)) <- Map.toList (mandatoryAttrMap d)
                     ]
    haddocks = "-- |" <+> multilineComment (d ^. summary) (d ^. description)
    extras = enclose "{-\n" "\n-}" $
             strictText $ Text.pack $
             showMessage ((def :: OpDef)
                          & inputArg .~ (d ^. inputArg)
                          & outputArg .~ (d ^. outputArg)
                          & attr .~ (d ^. attr))
    typeMap = opDefTypeMap d

-- | Makes a quoted string doc out of the given text value.
quotedText :: Text.Text -> Doc
quotedText = dquotes . strictText

-- | typeSig renders the type signature of the given OpDef.
typeSig :: OpDef -> Doc
typeSig d =
    foralls <+> constraints <+/>
    signatureFold (mandatoryAttrInputs ++ tensorInputs ++ [outputs])
  where
    foralls | Map.null typeMap = empty
            | otherwise =
              "forall"
              <+> sep (refTypes ++ map (strictText . fst) (Map.elems typeMap))
              <+> "."
    constraints | Map.null typeMap = empty
                | otherwise =
                  tuple (concatMap
                         (\(t, aDef) ->
                           "TensorType" <+> strictText t
                           : maybeToList (oneOfRestrictions aDef t))
                         (Map.elems typeMap)) <+> "=>"
    tensorInputs = zipWith tensorArg refTypes (d ^. inputArg)
    refTypes = map (\x -> "v" <> int x) [1..length (d ^. inputArg)]
    tensorArg refType arg = wrapArg refType arg <+>
                            hang 0 ("-- ^" <+> argComment arg)
    -- Argument type is a list of tensors if number_attr is set;
    -- otherwise it's a single Tensor.
    wrapArg refType arg =
        if Text.null (arg ^. numberAttr) then typ else brackets typ
      where typ = tensorType refType arg
    tensorType refType arg =
      "Tensor" <+> refType <+> maybe directType strictText indirectType
      where
        indirectType = fmap fst (Map.lookup (arg ^. typeAttr) typeMap)
        directType = dtTypeToDoc (arg ^. type')
    outputs =
      case d ^. outputArg of
        []  -> "ControlNode"
        [o] -> wrappedOutput o <+> "-- ^" <+> argComment o
        os  -> renderTupleResult os
    wrappedOutput = wrapArg "Value"
    -- Tuple result case is rendered differently to give
    -- individual elements their own comments.
    renderTupleResult os =
        stack $ [ tuple (map wrappedOutput os)
                , flatten commentSummary
                ] ++ map commentDetails os
      where
        commentSummary = "-- ^" <+> tuple [bold (o ^. name) | o <- os]
        commentDetails o =
          stack [ "--"
                , "-- *" <+> argComment o
                ]
    signatureFold = folddoc (\x y -> x </> "->" <+> y)
    mandatoryAttrInputs = [
      dtTypeToDoc dtType <+>
          hang 0 ("-- ^" <+> argComment' tfName descr)
      | (tfName, (_, dtType, descr)) <- Map.toList $ mandatoryAttrMap d]
    typeMap = opDefTypeMap d

-- | Returns the type restriction for the given tensor type if the
-- set of allowed types is not empty (i.e. restricted).
oneOfRestrictions :: AttrDef -> Text -> Maybe Doc
oneOfRestrictions aDef tName = do
    typs <- onAttrType (^. templateRestrictions) aDef
    guard $ not $ null typs
    let typeList = commasep $ map strictText $
                   Set.toList $ Set.fromList $
                   map dtTypeToHaskell typs
    return $ "OneOf" <+> "'" <> brackets typeList <+> strictText tName

-- | Identifies the attributes used as tensor cardinalities. In such
-- cases a list of tensors is supplied as an input_arg. The number of
-- such inputs is communicated as a separate opAttr.
-- The result key is TensorFlow attribute name and the value is the
-- tensor names which have number_attr set to the result key.
numberAttrMap :: OpDef -> Map.Map Text.Text (NonEmpty Text.Text)
numberAttrMap d = Map.fromListWith (Semigroup.<>) [
    (nAttr, replaceReservedName (inp ^. name) :| [])
    | inp <- d ^. inputArg
    , nAttr <- [inp ^. numberAttr]
    , not (Text.null nAttr)
    ]

argComment :: OpDef'ArgDef -> Doc
argComment arg = argComment' (arg ^. name) (arg ^. description)

argComment' :: Text.Text -> Text.Text -> Doc
argComment' argName argDesc =
    bold argName <> splitMultilineText (":" <+>) argDesc

bold :: Text.Text -> Doc
bold n = strictText ("__" <> n <> "__")

opDefTypeMap :: OpDef -> Map.Map Text.Text (Text.Text, AttrDef)
opDefTypeMap d =
    Map.fromList [(n, (lowCase n, a)) | (n, a) <- attrList d, isType a]

attrList :: OpDef -> [(Text.Text, AttrDef)]
attrList d = [(a ^. name, attrDef a) | a <- d ^. attr]

isType :: AttrDef -> Bool
isType = fromMaybe False . onAttrType (const True)

-- | Applies the given function to the data type. Is this a Prism?
onAttrType :: (Template DataType -> a) -> AttrDef -> Maybe a
onAttrType f x = case x ^. attrTemplate of
    AttrSingle (AttrType a) -> Just (f a)
    _ -> Nothing

-- | mandatoryAttrMap contains the attributes chosen by
-- isMandatoryAttr, excluding those which are derived from list of
-- tensor arguments. The key is the TF name of the attribute. The
-- value tuple is (haskell name, TF type, attribute comment).
mandatoryAttrMap :: OpDef -> Map.Map Text.Text (Text.Text, DataType, Text.Text)
mandatoryAttrMap d =
    Map.fromList [ (n, (lowCase n, dtType, a ^. attrOriginal.description))
                 | (n, a) <- attrList d
                 , Just dtType <- [isMandatoryAttr a]
                 -- Excludes the attributes rendered as list lengths.
                 , n `Map.notMember` numberAttrMap d
                 ]

-- | Inspects the attribute and if it is one of the implemented
-- non-tensor values lacking default, then returns Just the TF type.
isMandatoryAttr :: AttrDef -> Maybe DataType
isMandatoryAttr x =
   case x ^. attrTemplate of
     AttrSingle (AttrBool y)  -> noDefault DT_BOOL y
     AttrSingle (AttrInt64 y) -> noDefault DT_INT64 y
     AttrSingle (AttrFloat y) -> noDefault DT_FLOAT y
     _ -> Nothing
   where
     noDefault typ y = maybe (Just typ) (const Nothing) (y ^. templateDefault)

dtTypeToDoc :: DataType -> Doc
dtTypeToDoc = strictText . dtTypeToHaskell

-- NOTE: The cases of this function should be kept in sync with
-- TensorFlow.Types.AllTensorTypes.
dtTypeToHaskell :: DataType -> Text.Text
dtTypeToHaskell DT_BOOL = "Bool"
dtTypeToHaskell DT_BFLOAT16 = "Data.Word.Word16"
dtTypeToHaskell DT_COMPLEX128 = "(Data.Complex.Complex Double)"
dtTypeToHaskell DT_COMPLEX64 = "(Data.Complex.Complex Float)"
dtTypeToHaskell DT_DOUBLE = "Double"
dtTypeToHaskell DT_FLOAT = "Float"
dtTypeToHaskell DT_INT16 = "Data.Int.Int16"
dtTypeToHaskell DT_INT32 = "Data.Int.Int32"
dtTypeToHaskell DT_INT64 = "Data.Int.Int64"
dtTypeToHaskell DT_INT8 = "Data.Int.Int8"
dtTypeToHaskell DT_QINT32 = "Data.Int.Int32"  -- TODO(gnezdo): make unique
dtTypeToHaskell DT_QINT8 = "Data.Word.Word8"  -- TODO(gnezdo): make unique
dtTypeToHaskell DT_QINT16 = "Data.Int.Int16"  -- TODO(gnezdo): make unique
dtTypeToHaskell DT_QUINT16 = "Data.Word.Word16"  -- TODO(gnezdo): make unique
dtTypeToHaskell DT_QUINT8 = "Data.Word.Word8"  -- TODO(gnezdo): make unique
dtTypeToHaskell DT_STRING = "Data.ByteString.ByteString"
dtTypeToHaskell DT_UINT16 = "Data.Word.Word16"
dtTypeToHaskell DT_HALF = "Data.Word.Word16"  -- TODO(gnezdo): make unique
dtTypeToHaskell DT_UINT8 = "Data.Word.Word8"
dtTypeToHaskell x =
    Text.pack $ "Unsupported type in dtTypeToHaskell: " ++ show x

-- | haddockComment escapes TensorFlow doc strings into haddock.
-- TODO(gnezdo): deal with the markup.
haddockComment :: Text.Text -> Doc
haddockComment = strictText

multilineComment :: Text.Text -> Text.Text -> Doc
multilineComment summary' detail =
    haddockComment summary' </>
    splitMultilineText insertParagraphAndComment detail
  where insertParagraphAndComment x = "--" </> "--" <+> x

-- | Converts the given multi-line detail string into
-- a multi-line haddock. Applies the given lead to the
-- first line. Returns an empty document for empty detail.
splitMultilineText :: (Doc -> Doc) -> Text.Text -> Doc
splitMultilineText lead detail =
  case Text.lines detail of
    [] -> empty
    (l : ls) -> stack $ lead (haddockComment l)
                      : map (("--" <+>) . haddockComment) ls

replaceReservedName :: Text -> Text
replaceReservedName n
    | n `Set.member` reservedKeywords = n <> "'"
    | otherwise = n

indentation = 4

reservedKeywords :: Set.Set Text
reservedKeywords = Set.fromList $
    -- Haskell2010 keywords:
    -- https://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-180002.4
    -- We don't include keywords that are allowed to be variable names,
    -- in particular: "as", "forall", and "hiding".
    [ "case"
    , "class"
    , "data"
    , "default"
    , "deriving"
    , "do"
    , "else"
    , "foreign"
    , "if"
    , "import"
    , "in"
    , "infix"
    , "infixl"
    , "infixr"
    , "instance"
    , "let"
    , "module"
    , "newtype"
    , "of"
    , "then"
    , "type"
    , "where"
    ]
    ++  -- Nonstandard extensions
    [ "mdo"   -- RecursiveDo
    , "rec"   -- Arrows, RecursiveDo
    , "proc"  -- Arrows
    ]


module Task (
writeTask,
readTask
) where
import System.IO.Strict as Strict
import System.IO
import InputParser
import Statistics

writeTask :: String -> [String] -> [Line] -> IO ()
writeTask filename info lns =
    let
        statistics = collectStat lns
        errorLine (Line position (Error text))
            = [concat ["ERROR: ", recordSourceText position, " - ", text]]
        errorLine _ = []
    in do
        outFile <- openFile filename WriteMode
        _ <- mapM (hPutStrLn outFile) info
        _ <- sequence $ hPutStrLn outFile <$> statistics
        _ <- sequence $ hPutStrLn outFile <$> (lns >>= errorLine)
        hClose outFile

readTask :: String -> IO [String]
readTask path = do
        result <- lines <$> Strict.readFile path
        return $ length result `seq` result --read whole file to allow its overwriting


{-# LANGUAGE CApiFFI #-}

-- {-# LANGUAGE QuasiQuotes #-}
-- {-# LANGUAGE TemplateHaskell #-}

module LatticeSymmetries
  ( ls_hs_hdf5_create_dataset_u64,
    ls_hs_hdf5_create_dataset_f32,
    ls_hs_hdf5_create_dataset_f64,
    ls_hs_hdf5_create_dataset_c64,
    ls_hs_hdf5_create_dataset_c128,
    ls_hs_hdf5_write_chunk_u64,
    ls_hs_hdf5_write_chunk_f32,
    ls_hs_hdf5_write_chunk_f64,
    ls_hs_hdf5_write_chunk_c64,
    ls_hs_hdf5_write_chunk_c128,
    ls_hs_hdf5_read_chunk_u64,
    ls_hs_hdf5_read_chunk_f32,
    ls_hs_hdf5_read_chunk_f64,
    ls_hs_hdf5_read_chunk_c64,
    ls_hs_hdf5_read_chunk_c128,
    ls_hs_hdf5_get_dataset_rank,
    ls_hs_hdf5_get_dataset_shape,
  )
  where

import Data.Complex
import qualified Data.HDF5 as H5
import qualified Data.HDF5.Types as H5
import qualified Data.Vector.Storable as V
import Foreign.C.String (CString, peekCString)
import Foreign.C.Types (CUInt (..))
import Foreign.ForeignPtr
import Foreign.Marshal.Array (peekArray, pokeArray)
import Foreign.Ptr (Ptr)
import Foreign.Storable (Storable (..))

  {-
-- | Retrieve textual representation of an error
getErrorMessage ::
  -- | Error code returned by @lattice_symmetries@ library
  Int ->
  -- | Explanation of the error
  IO Text
getErrorMessage c = bracket (ls_error_to_string (fromIntegral c)) ls_destroy_string $ \s ->
  toText <$> peekCString s
-}

  {-
-- | Check the status code returned by @lattice_symmetries@ library. If it
-- indicates an error, 'LatticeSymmetriesException' is thrown.
checkStatus :: (MonadIO m, Integral a) => a -> m ()
checkStatus c
  | c == 0 = return ()
  | otherwise = do
    print =<< liftIO (getErrorMessage c')
    liftIO $ throwIO . LatticeSymmetriesException c' =<< getErrorMessage c'
  where
    c' = fromIntegral c
-}

-- loadRawBasis :: MonadIO m => Text -> m (Ptr Cspin_basis)
-- loadRawBasis path = do
--   r <- liftIO $ decodeFileWithWarnings (toString path)
--   case r of
--     Left e -> throwIO e
--     Right (warnings, (WrappedBasisSpec basisSpec)) -> do
--       mapM_ print warnings
--       toRawBasis basisSpec

-- ls_hs_internal_load_basis_from_yaml :: CString -> IO (Ptr Cspin_basis)
-- ls_hs_internal_load_basis_from_yaml c_str = loadRawBasis . toText =<< peekCString c_str
--
-- foreign export ccall "ls_hs_internal_load_basis_from_yaml"
--   ls_hs_internal_load_basis_from_yaml :: CString -> IO (Ptr Cspin_basis)

{-
isPermutation :: Integral a => NonEmpty a -> Bool
isPermutation xs = and . toList $ NonEmpty.zipWith (==) (NonEmpty.sort xs) (fromList [0 ..])

permuteArray :: Integral a => NonEmpty a -> U.Vector Int -> U.Vector Int
permuteArray permutation xs = (xs U.!!) undefined

computePeriodicity :: Integral a => NonEmpty a -> Int
computePeriodicity = undefined

checkSymmetrySpec :: SymmetrySpec -> Either Text SymmetrySpec
checkSymmetrySpec (SymmetrySpec permutation sector) = do
  when (not . isPermutation $ permutation) $
    Left $ show permutation <> " is not a permutation of " <> show [0 .. length permutation]
  undefined
-}

createDataset ::
  forall a.
  (H5.KnownDatatype a) =>
  CString ->
  CString ->
  CUInt ->
  Ptr Word64 ->
  IO ()
createDataset _fileName _datasetName _dim shapePtr = do
  fileName <- fromString <$> peekCString _fileName
  datasetName <- fromString <$> peekCString _datasetName
  shape <- fmap fromIntegral <$> peekArray (fromIntegral _dim) shapePtr
  H5.withFile fileName H5.WriteAppend $ \file -> do
    exists <- H5.exists file datasetName
    when exists $ H5.delete file datasetName
    void . join $ H5.createEmptyDataset file datasetName <$> H5.ofType @a <*> H5.ofShape shape

ls_hs_hdf5_create_dataset_u64 :: CString -> CString -> CUInt -> Ptr Word64 -> IO ()
ls_hs_hdf5_create_dataset_u64 = createDataset @Word64

ls_hs_hdf5_create_dataset_f32 :: CString -> CString -> CUInt -> Ptr Word64 -> IO ()
ls_hs_hdf5_create_dataset_f32 = createDataset @Double

ls_hs_hdf5_create_dataset_f64 :: CString -> CString -> CUInt -> Ptr Word64 -> IO ()
ls_hs_hdf5_create_dataset_f64 = createDataset @Double

ls_hs_hdf5_create_dataset_c64 :: CString -> CString -> CUInt -> Ptr Word64 -> IO ()
ls_hs_hdf5_create_dataset_c64 = createDataset @(Complex Float)

ls_hs_hdf5_create_dataset_c128 :: CString -> CString -> CUInt -> Ptr Word64 -> IO ()
ls_hs_hdf5_create_dataset_c128 = createDataset @(Complex Double)

-- foreign export ccall "ls_hs_hdf5_create_dataset_u64"
--   ls_hs_hdf5_create_dataset_u64 :: CString -> CString -> CUInt -> Ptr Word64 -> IO ()

-- foreign export ccall "ls_hs_hdf5_create_dataset_f32"
--   ls_hs_hdf5_create_dataset_f32 :: CString -> CString -> CUInt -> Ptr Word64 -> IO ()

-- foreign export ccall "ls_hs_hdf5_create_dataset_f64"
--   ls_hs_hdf5_create_dataset_f64 :: CString -> CString -> CUInt -> Ptr Word64 -> IO ()

-- foreign export ccall "ls_hs_hdf5_create_dataset_c64"
--   ls_hs_hdf5_create_dataset_c64 :: CString -> CString -> CUInt -> Ptr Word64 -> IO ()

-- foreign export ccall "ls_hs_hdf5_create_dataset_c128"
--   ls_hs_hdf5_create_dataset_c128 :: CString -> CString -> CUInt -> Ptr Word64 -> IO ()

writeDatasetChunk ::
  forall a.
  (Storable a, H5.KnownDatatype a) =>
  CString ->
  CString ->
  CUInt ->
  Ptr Word64 ->
  Ptr Word64 ->
  Ptr a ->
  IO ()
writeDatasetChunk _fileName _datasetName _dim _offsetPtr _shapePtr dataPtr = do
  fileName <- fromString <$> peekCString _fileName
  datasetName <- fromString <$> peekCString _datasetName
  let rank = fromIntegral _dim
  offset <- fromList . fmap fromIntegral <$> peekArray rank _offsetPtr
  shape <- fromList . fmap fromIntegral <$> peekArray rank _shapePtr
  let hyperslab = H5.Hyperslab offset (V.replicate rank 1) shape (V.replicate rank 1)
  fp <- newForeignPtr_ dataPtr
  let size = V.product shape
      buffer = V.unsafeFromForeignPtr0 fp size
  H5.withFile fileName H5.WriteAppend $ \file ->
    H5.open file datasetName
      >>= return
        . H5.sliceWithHyperslab hyperslab
      >>= H5.writeSelected buffer

ls_hs_hdf5_write_chunk_u64 ::
  CString -> CString -> CUInt -> Ptr Word64 -> Ptr Word64 -> Ptr Word64 -> IO ()
ls_hs_hdf5_write_chunk_u64 = writeDatasetChunk @Word64

ls_hs_hdf5_write_chunk_f32 ::
  CString -> CString -> CUInt -> Ptr Word64 -> Ptr Word64 -> Ptr Float -> IO ()
ls_hs_hdf5_write_chunk_f32 = writeDatasetChunk @Float

ls_hs_hdf5_write_chunk_f64 ::
  CString -> CString -> CUInt -> Ptr Word64 -> Ptr Word64 -> Ptr Double -> IO ()
ls_hs_hdf5_write_chunk_f64 = writeDatasetChunk @Double

ls_hs_hdf5_write_chunk_c64 ::
  CString -> CString -> CUInt -> Ptr Word64 -> Ptr Word64 -> Ptr (Complex Float) -> IO ()
ls_hs_hdf5_write_chunk_c64 = writeDatasetChunk @(Complex Float)

ls_hs_hdf5_write_chunk_c128 ::
  CString -> CString -> CUInt -> Ptr Word64 -> Ptr Word64 -> Ptr (Complex Double) -> IO ()
ls_hs_hdf5_write_chunk_c128 = writeDatasetChunk @(Complex Double)

-- foreign export ccall "ls_hs_hdf5_write_chunk_u64"
--   ls_hs_hdf5_write_chunk_u64 :: CString -> CString -> CUInt -> Ptr Word64 -> Ptr Word64 -> Ptr Word64 -> IO ()

-- foreign export ccall "ls_hs_hdf5_write_chunk_f64"
--   ls_hs_hdf5_write_chunk_f64 :: CString -> CString -> CUInt -> Ptr Word64 -> Ptr Word64 -> Ptr Double -> IO ()

readDatasetChunk ::
  forall a.
  (Storable a, H5.KnownDatatype a) =>
  CString ->
  CString ->
  CUInt ->
  Ptr Word64 ->
  Ptr Word64 ->
  Ptr a ->
  IO ()
readDatasetChunk _fileName _datasetName _dim _offsetPtr _shapePtr dataPtr = do
  fileName <- fromString <$> peekCString _fileName
  datasetName <- fromString <$> peekCString _datasetName
  let rank = fromIntegral _dim
  offset <- fromList . fmap fromIntegral <$> peekArray rank _offsetPtr
  shape <- fromList . fmap fromIntegral <$> peekArray rank _shapePtr
  let hyperslab = H5.Hyperslab offset (V.replicate rank 1) shape (V.replicate rank 1)
  fp <- newForeignPtr_ dataPtr
  let size = V.product shape
      buffer = V.unsafeFromForeignPtr0 fp size
  H5.withFile fileName H5.WriteAppend $ \file ->
    H5.open file datasetName
      >>= return
        . H5.sliceWithHyperslab hyperslab
      >>= H5.readSelectedInplace buffer

ls_hs_hdf5_read_chunk_u64 ::
  CString -> CString -> CUInt -> Ptr Word64 -> Ptr Word64 -> Ptr Word64 -> IO ()
ls_hs_hdf5_read_chunk_u64 = readDatasetChunk @Word64

ls_hs_hdf5_read_chunk_f32 ::
  CString -> CString -> CUInt -> Ptr Word64 -> Ptr Word64 -> Ptr Float -> IO ()
ls_hs_hdf5_read_chunk_f32 = readDatasetChunk @Float

ls_hs_hdf5_read_chunk_f64 ::
  CString -> CString -> CUInt -> Ptr Word64 -> Ptr Word64 -> Ptr Double -> IO ()
ls_hs_hdf5_read_chunk_f64 = readDatasetChunk @Double

ls_hs_hdf5_read_chunk_c64 ::
  CString -> CString -> CUInt -> Ptr Word64 -> Ptr Word64 -> Ptr (Complex Float) -> IO ()
ls_hs_hdf5_read_chunk_c64 = readDatasetChunk @(Complex Float)

ls_hs_hdf5_read_chunk_c128 ::
  CString -> CString -> CUInt -> Ptr Word64 -> Ptr Word64 -> Ptr (Complex Double) -> IO ()
ls_hs_hdf5_read_chunk_c128 = readDatasetChunk @(Complex Double)

-- foreign export ccall "ls_hs_hdf5_read_chunk_u64"
--   ls_hs_hdf5_read_chunk_u64 :: CString -> CString -> CUInt -> Ptr Word64 -> Ptr Word64 -> Ptr Word64 -> IO ()

-- foreign export ccall "ls_hs_hdf5_read_chunk_f64"
--   ls_hs_hdf5_read_chunk_f64 :: CString -> CString -> CUInt -> Ptr Word64 -> Ptr Word64 -> Ptr Double -> IO ()

ls_hs_hdf5_get_dataset_rank :: CString -> CString -> IO CUInt
ls_hs_hdf5_get_dataset_rank _fileName _datasetName = do
  fileName <- fromString <$> peekCString _fileName
  datasetName <- fromString <$> peekCString _datasetName
  rank <- H5.withFile fileName H5.ReadOnly $ \file ->
    H5.open file datasetName >>= return . H5.datasetRank
  pure (fromIntegral rank)

-- foreign export ccall "ls_hs_hdf5_get_dataset_rank"
--   ls_hs_hdf5_get_dataset_rank :: CString -> CString -> IO CUInt

ls_hs_hdf5_get_dataset_shape :: CString -> CString -> Ptr Word64 -> IO ()
ls_hs_hdf5_get_dataset_shape _fileName _datasetName sizePtr = do
  fileName <- fromString <$> peekCString _fileName
  datasetName <- fromString <$> peekCString _datasetName
  shape <- H5.withFile fileName H5.ReadOnly $ \file ->
    H5.open file datasetName >>= return . H5.datasetShape
  pokeArray sizePtr (fromIntegral <$> shape)

-- foreign export ccall "ls_hs_hdf5_get_dataset_shape"
--   ls_hs_hdf5_get_dataset_shape :: CString -> CString -> Ptr Word64 -> IO ()

-- writeDatasetChunk _fileName _datasetName offset size ptr = do
--   fileName <- fromString <$> peekCString _fileName
--   datasetName <- fromString <$> peekCString _datasetName
--   H5.withFile filename H5.AppendMode $ \file ->
--     H5.open

{-
loadBasisAndHamiltonianFromYAML :: Text -> IO (SpinBasis, Operator)
loadBasisAndHamiltonianFromYAML path = do
  r <- decodeFileWithWarnings (toString path)
  case r of
    Left e -> throwIO e
    Right (warnings, (ConfigSpec basisSpec operatorSpec)) -> do
      mapM_ print warnings
      let basis = mkBasis basisSpec
      return (basis, mkOperator basis operatorSpec)
-}

{-
ls_hs_basis_and_hamiltonian_from_yaml :: CString -> Ptr SpinBasisWrapper -> Ptr OperatorWrapper -> IO ()
ls_hs_basis_and_hamiltonian_from_yaml path basisPtr operatorPtr = do
  (basis, hamiltonian) <- loadBasisAndHamiltonianFromYAML . toText =<< peekCString path
  case basis of
    SpinBasis fp -> withForeignPtr fp $ \rawPtr ->
      poke basisPtr =<< SpinBasisWrapper rawPtr <$> newStablePtr basis
  case hamiltonian of
    Operator fp -> withForeignPtr fp $ \rawPtr ->
      poke operatorPtr =<< OperatorWrapper rawPtr <$> newStablePtr hamiltonian
-}

-- void ls_hs_basis_and_hamiltonian_from_yaml(char const *path,
--                                            ls_hs_spin_basis_v1 *basis,
--                                            ls_hs_operator_v1 *hamiltonian);
-- foreign export ccall "ls_hs_basis_and_hamiltonian_from_yaml"
--   ls_hs_basis_and_hamiltonian_from_yaml :: CString -> Ptr SpinBasisWrapper -> Ptr OperatorWrapper -> IO ()

{-
ls_hs_destroy_spin_basis :: Ptr SpinBasisWrapper -> IO ()
ls_hs_destroy_spin_basis ptr = do
  peek ptr >>= \(SpinBasisWrapper _ stablePtr) -> freeStablePtr stablePtr
  poke ptr $ SpinBasisWrapper nullPtr (castPtrToStablePtr nullPtr)
-}

-- void ls_hs_destroy_spin_basis(ls_hs_spin_basis_v1 *basis);
-- foreign export ccall "ls_hs_destroy_spin_basis"
--   ls_hs_destroy_spin_basis :: Ptr SpinBasisWrapper -> IO ()

{-
ls_hs_destroy_operator :: Ptr OperatorWrapper -> IO ()
ls_hs_destroy_operator ptr = do
  peek ptr >>= \(OperatorWrapper _ stablePtr) -> freeStablePtr stablePtr
  poke ptr $ OperatorWrapper nullPtr (castPtrToStablePtr nullPtr)
-}

-- void ls_hs_destroy_operator(ls_hs_operator_v1 *op);
-- foreign export ccall "ls_hs_destroy_operator"
--   ls_hs_destroy_operator :: Ptr OperatorWrapper -> IO ()

{-
toSymmetry :: SymmetrySpec -> Symmetry
toSymmetry (SymmetrySpec p s) = mkSymmetry p s

mkSymmetry ::
  -- | Permutation
  NonEmpty Int ->
  -- | Symmetry sector
  Int ->
  Symmetry
mkSymmetry !permutation !sector
  | any (< 0) permutation =
    error $
      "invalid permutation: " <> show permutation <> "; indices must be non-negative"
  | sector < 0 =
    error $
      "invalid sector: " <> show sector <> "; expected a non-negative number"
  | otherwise = System.IO.Unsafe.unsafePerformIO $ do
    ptr <- mkObject $ \ptrPtr ->
      withArrayLen (fromIntegral <$> toList permutation) $ \n permutationPtr ->
        ls_create_symmetry ptrPtr (fromIntegral n) permutationPtr (fromIntegral sector)
    Symmetry <$> newForeignPtr ls_destroy_symmetry ptr
-}

{-
mkSymmetryGroup ::
  -- | Symmetry generators
  [Symmetry] ->
  SymmetryGroup
mkSymmetryGroup symmetries = System.IO.Unsafe.unsafePerformIO $ do
  ptr <- liftIO . mkObject $ \ptrPtr ->
    withSymmetries symmetries $ \n symmetriesPtr ->
      ls_create_group ptrPtr (fromIntegral n) symmetriesPtr
  fmap SymmetryGroup . liftIO $ newForeignPtr ls_destroy_group ptr

mkRawBasis ::
  (MonadIO m, MonadThrow m) =>
  -- | Symmetry group
  SymmetryGroup ->
  -- | Number of spins
  Int ->
  -- | Hamming weight
  Maybe Int ->
  -- | Spin inversion
  Maybe Int ->
  m SpinBasis
mkRawBasis !(SymmetryGroup g) !numberSpins !hammingWeight !spinInversion = do
  when (numberSpins <= 0) . throwIO . SpinEDException $
    "invalid number of spins: " <> show numberSpins <> "; expected a positive number"
  hammingWeight' <- case hammingWeight of
    Just x -> do
      when (x < 0) . throwIO . SpinEDException $
        "invalid Hamming weight: " <> show x <> "; expected a non-negative number"
      return $ fromIntegral x
    Nothing -> return (-1)
  spinInversion' <- case spinInversion of
    Just x -> do
      when (x /= 1 && x /= -1) . throwIO . SpinEDException $
        "invalid value for spin inversion: " <> show x <> "; expected either -1 or +1"
      return $ fromIntegral x
    Nothing -> return 0
  ptr <- liftIO . mkObject $ \ptrPtr ->
    withForeignPtr g $ \groupPtr ->
      ls_create_spin_basis ptrPtr groupPtr (fromIntegral numberSpins) hammingWeight' spinInversion'
  SpinBasis <$> liftIO (newForeignPtr ls_destroy_spin_basis ptr)
-}

{-
mkFlatBasis :: BasisSpec -> FlatSpinBasis
mkFlatBasis spec = System.IO.Unsafe.unsafePerformIO $ do
  flatBasisPtr <- alloca $ \basisPtrPtr ->
    withForeignPtr normalBasis $ \normalBasisPtr -> do
      checkStatus =<< ls_convert_to_flat_spin_basis basisPtrPtr normalBasisPtr
      peek basisPtrPtr
  FlatSpinBasis <$> newForeignPtr ls_destroy_flat_spin_basis flatBasisPtr
  where
    (SpinBasis normalBasis) = mkBasis spec

mkBasis :: BasisSpec -> SpinBasis
mkBasis (BasisSpec numberSpins hammingWeight spinInversion symmetries)
  | numberSpins > 64 =
    error $
      "invalid number_spins: " <> show numberSpins <> "; exact diagonalization is not feasible "
        <> "for systems larger than 64 spins"
  | otherwise =
    let symmetryGroup = mkSymmetryGroup (toSymmetry <$> symmetries)
     in System.IO.Unsafe.unsafePerformIO $
          mkRawBasis symmetryGroup numberSpins hammingWeight spinInversion
-}

{-
mkInteraction :: InteractionSpec -> Interaction
mkInteraction (InteractionSpec matrix sites) =
  System.IO.Unsafe.unsafePerformIO $
    mkInteraction' matrix sites

mkOperator :: SpinBasis -> OperatorSpec -> Operator
mkOperator basis (OperatorSpec _ interactions) =
  mkRawOperator basis $
    mkInteraction <$> interactions
-}

{-
mkRawOperator :: SpinBasis -> NonEmpty Interaction -> Operator
mkRawOperator (SpinBasis basis) terms = System.IO.Unsafe.unsafePerformIO $ do
  (code, ptr) <- liftIO $
    alloca $ \ptrPtr -> do
      c <- withInteractions (toList terms) $ \n interactionsPtr ->
        withForeignPtr basis $ \basisPtr ->
          ls_create_operator ptrPtr basisPtr (fromIntegral n) interactionsPtr
      if c == 0
        then (,) <$> pure c <*> peek ptrPtr
        else pure (c, nullPtr)
  checkStatus code
  fmap Operator . liftIO $ newForeignPtr ls_destroy_operator ptr

withInteractions :: [Interaction] -> (Int -> Ptr (Ptr Cinteraction) -> IO a) -> IO a
withInteractions xs func = withManyForeignPtr pointers func
  where
    pointers = (\(Interaction p) -> p) <$> xs
-}

{-
toMatrix ::
  (Monad m, Show r, Real r) =>
  -- | Expected dimension @n@ of the matrix
  Int ->
  -- | Square @matrix@ of dimension @n@
  [[Complex r]] ->
  -- | Row-major representation of @matrix@
  m (Vector (Complex Double))
toMatrix !dim !rows = do
  when (length rows /= dim) . impureThrow . SpinEDException $
    "invalid matrix: " <> show rows <> "; expected a square matrix of dimension " <> show dim
  when (any ((/= dim) . length) rows) . impureThrow . SpinEDException $
    "invalid matrix: " <> show rows <> "; expected a square matrix of dimension " <> show dim
  return . V.fromList . fmap (fmap (fromRational . toRational)) . concat $ rows

type CreateInteraction = Ptr (Ptr Cinteraction) -> Ptr (Complex Double) -> CUInt -> Ptr CUShort -> IO CInt

class MakeInteraction a where
  mkInteraction' :: (MonadIO m, MonadThrow m, Show r, Real r) => [[Complex r]] -> [a] -> m Interaction

instance MakeInteraction Int where
  mkInteraction' matrix sites =
    toMatrix 2 matrix >>= \matrix' ->
      unsafeMkInteraction ls_create_interaction1 (length sites) matrix' sites'
    where
      sites' = V.fromList sites

instance MakeInteraction (Int, Int) where
  mkInteraction' matrix sites =
    toMatrix 4 matrix >>= \matrix' ->
      unsafeMkInteraction ls_create_interaction2 (length sites) matrix' sites'
    where
      sites' = V.fromList $ sites >>= \(x₁, x₂) -> [x₁, x₂]

instance MakeInteraction (Int, Int, Int) where
  mkInteraction' matrix sites =
    toMatrix 8 matrix >>= \matrix' ->
      unsafeMkInteraction ls_create_interaction3 (length sites) matrix' sites'
    where
      sites' = V.fromList $ sites >>= \(x₁, x₂, x₃) -> [x₁, x₂, x₃]

instance MakeInteraction (Int, Int, Int, Int) where
  mkInteraction' matrix sites =
    toMatrix 16 matrix >>= \matrix' ->
      unsafeMkInteraction ls_create_interaction4 (length sites) matrix' sites'
    where
      sites' = V.fromList $ sites >>= \(x₁, x₂, x₃, x₄) -> [x₁, x₂, x₃, x₄]

instance MakeInteraction [Int] where
  mkInteraction' _ [] =
    throwIO . SpinEDException $
      "zero-point interactions (i.e. constant factors) are not supported"
  mkInteraction' matrix rows@(r : _) = case n of
    1 -> mkInteraction' matrix =<< mapM match1 rows
    2 -> mkInteraction' matrix =<< mapM match2 rows
    3 -> mkInteraction' matrix =<< mapM match3 rows
    4 -> mkInteraction' matrix =<< mapM match4 rows
    _ ->
      throwIO . SpinEDException $
        "currently only 1-, 2-, 3-, and 4-point interactions are supported, but received n="
          <> show n
    where
      n = length r
      match1 [x₁] = return x₁
      match1 _ = throwIO failure
      match2 [x₁, x₂] = return (x₁, x₂)
      match2 _ = throwIO failure
      match3 [x₁, x₂, x₃] = return (x₁, x₂, x₃)
      match3 _ = throwIO failure
      match4 [x₁, x₂, x₃, x₄] = return (x₁, x₂, x₃, x₄)
      match4 _ = throwIO failure
      failure =
        SpinEDException $
          "invalid sites: " <> show rows <> "; expected an array of length-" <> show n <> " tuples"
-}

{-
unsafeMkInteraction ::
  (MonadIO m, MonadThrow m) =>
  CreateInteraction ->
  Int ->
  Vector (Complex Double) ->
  Vector Int ->
  m Interaction
unsafeMkInteraction ffiCreate numberSites matrix sites = do
  when (V.any (< 0) sites) . throwIO . SpinEDException $
    "site indices must be all non-negative numbers"
  (code, ptr) <- liftIO $
    alloca $ \ptrPtr -> do
      c <- V.unsafeWith matrix $ \matrixPtr ->
        V.unsafeWith (V.map fromIntegral sites) $ \sitesPtr ->
          ffiCreate ptrPtr matrixPtr (fromIntegral numberSites) sitesPtr
      if c == 0
        then (,) <$> pure c <*> peek ptrPtr
        else pure (c, nullPtr)
  checkStatus code
  fmap Interaction . liftIO $ newForeignPtr ls_destroy_interaction ptr
-}

{-
-- | Extension of 'withForeignPtr' to lists of 'ForeignPtr's.
withManyForeignPtr :: [ForeignPtr a] -> (Int -> Ptr (Ptr a) -> IO b) -> IO b
withManyForeignPtr xs func = loop [] xs
  where
    loop acc (y : ys) = withForeignPtr y $ \y' -> loop (y' : acc) ys
    loop acc [] = withArrayLen (reverse acc) func

withSymmetries :: [Symmetry] -> (Int -> Ptr (Ptr CSymmetry) -> IO a) -> IO a
withSymmetries xs func = withManyForeignPtr pointers func
  where
    pointers = (\(Symmetry p) -> p) <$> xs

mkObject :: (Ptr (Ptr a) -> IO CInt) -> IO (Ptr a)
mkObject f = alloca $ \ptrPtr -> f ptrPtr >>= checkStatus >> peek ptrPtr
-}

  {-
foreign import ccall unsafe "lattice_symmetries/lattice_symmetries.h ls_error_to_string"
  ls_error_to_string :: CInt -> IO CString

foreign import capi unsafe "lattice_symmetries/lattice_symmetries.h ls_destroy_string"
  ls_destroy_string :: CString -> IO ()

foreign import capi unsafe "lattice_symmetries/lattice_symmetries.h ls_enable_logging"
  ls_enable_logging :: IO ()

foreign import capi unsafe "lattice_symmetries/lattice_symmetries.h ls_disable_logging"
  ls_disable_logging :: IO ()

foreign import capi unsafe "lattice_symmetries/lattice_symmetries.h ls_create_symmetry"
  ls_create_symmetry :: Ptr (Ptr CSymmetry) -> CUInt -> Ptr CUInt -> CUInt -> IO CInt

foreign import capi unsafe "lattice_symmetries/lattice_symmetries.h &ls_destroy_symmetry"
  ls_destroy_symmetry :: FunPtr (Ptr CSymmetry -> IO ())

foreign import ccall unsafe "lattice_symmetries/lattice_symmetries.h ls_create_group"
  ls_create_group :: Ptr (Ptr CGroup) -> CUInt -> Ptr (Ptr CSymmetry) -> IO CInt

foreign import capi unsafe "lattice_symmetries/lattice_symmetries.h &ls_destroy_group"
  ls_destroy_group :: FunPtr (Ptr CGroup -> IO ())

foreign import capi unsafe "lattice_symmetries/lattice_symmetries.h ls_get_group_size"
  ls_get_group_size :: Ptr CGroup -> IO CUInt

foreign import ccall unsafe "lattice_symmetries/lattice_symmetries.h ls_create_spin_basis"
  ls_create_spin_basis :: Ptr (Ptr Cspin_basis) -> Ptr CGroup -> CUInt -> CInt -> CInt -> IO CInt

foreign import ccall unsafe "lattice_symmetries/lattice_symmetries.h &ls_destroy_spin_basis"
  ls_destroy_spin_basis :: FunPtr (Ptr Cspin_basis -> IO ())

foreign import ccall safe "lattice_symmetries/lattice_symmetries.h ls_build"
  ls_build :: Ptr Cspin_basis -> IO CInt

foreign import ccall safe "lattice_symmetries/lattice_symmetries.h ls_build_unsafe"
  ls_build_unsafe :: Ptr Cspin_basis -> Word64 -> Ptr Word64 -> IO CInt

foreign import ccall unsafe "lattice_symmetries/lattice_symmetries.h ls_get_number_states"
  ls_get_number_states :: Ptr Cspin_basis -> Ptr Word64 -> IO CInt

{- ORMOLU_DISABLE -}
foreign import capi unsafe "lattice_symmetries/lattice_symmetries.h ls_flat_spin_basis_state_info"
  ls_flat_spin_basis_state_info :: Ptr CFlatSpinBasis -> Word64 -> Ptr () -> Ptr () ->
                                   Ptr (Complex Double) -> Ptr Double -> IO ()
{- ORMOLU_ENABLE -}

foreign import capi unsafe "lattice_symmetries/lattice_symmetries.h ls_convert_to_flat_spin_basis"
  ls_convert_to_flat_spin_basis :: Ptr (Ptr CFlatSpinBasis) -> Ptr Cspin_basis -> IO CInt

foreign import capi unsafe "lattice_symmetries/lattice_symmetries.h &ls_destroy_flat_spin_basis"
  ls_destroy_flat_spin_basis :: FunPtr (Ptr CFlatSpinBasis -> IO ())

foreign import capi unsafe "lattice_symmetries/lattice_symmetries.h ls_create_interaction1"
  ls_create_interaction1 :: Ptr (Ptr Cinteraction) -> Ptr (Complex Double) -> CUInt -> Ptr CUShort -> IO CInt

foreign import capi unsafe "lattice_symmetries/lattice_symmetries.h ls_create_interaction2"
  ls_create_interaction2 :: Ptr (Ptr Cinteraction) -> Ptr (Complex Double) -> CUInt -> Ptr CUShort -> IO CInt

foreign import capi unsafe "lattice_symmetries/lattice_symmetries.h ls_create_interaction3"
  ls_create_interaction3 :: Ptr (Ptr Cinteraction) -> Ptr (Complex Double) -> CUInt -> Ptr CUShort -> IO CInt

foreign import capi unsafe "lattice_symmetries/lattice_symmetries.h ls_create_interaction4"
  ls_create_interaction4 :: Ptr (Ptr Cinteraction) -> Ptr (Complex Double) -> CUInt -> Ptr CUShort -> IO CInt

foreign import capi unsafe "lattice_symmetries/lattice_symmetries.h ls_interaction_is_real"
  ls_interaction_is_real :: Ptr () -> IO CBool

foreign import capi unsafe "lattice_symmetries/lattice_symmetries.h &ls_destroy_interaction"
  ls_destroy_interaction :: FunPtr (Ptr Cinteraction -> IO ())

foreign import ccall unsafe "lattice_symmetries/lattice_symmetries.h ls_create_operator"
  ls_create_operator :: Ptr (Ptr Coperator) -> Ptr Cspin_basis -> CUInt -> Ptr (Ptr Cinteraction) -> IO CInt

foreign import ccall unsafe "lattice_symmetries/lattice_symmetries.h &ls_destroy_operator"
  ls_destroy_operator :: FunPtr (Ptr Coperator -> IO ())
-}


module Vulkyrie.Vulkan.Default.RenderPass
  ( createPrivateAttachments
  , createRenderPass
  , createRenderPassBeginInfo
  ) where

import           Data.Bits
import           Graphics.Vulkan
import           Graphics.Vulkan.Core_1_0
import           Graphics.Vulkan.Marshal.Create
import           Graphics.Vulkan.Marshal.Create.DataFrame
import           Numeric.Vector

import           Vulkyrie.Program
import           Vulkyrie.Program.Foreign
import           Vulkyrie.Resource
import           Vulkyrie.Vulkan.Engine
import           Vulkyrie.Vulkan.Image

  -- The colorOut is manually passed as last attachment to the renderpass and has 1 sample.
  -- If samples = 1bit then colorOut is used as the color attachment, otherwise
  -- colorOut is used as the resolve attachment.
  --
  -- => order of attachments has to be: depth, color, maybe resolve

-- | Create attachments that are only internally needed by the renderpass, in the expected order.
createPrivateAttachments :: EngineCapability
                         -> VkExtent2D
                         -> VkFormat
                         -> VkSampleCountFlagBits
                         -> Resource ([(VkSemaphore, VkPipelineStageBitmask a)], [VkImageView])
createPrivateAttachments cap extent imgFormat samples = Resource $ do
  let msaaOn = samples /= VK_SAMPLE_COUNT_1_BIT
  fmap unzip . sequence $
    [auto $ createDepthAttImgView cap extent samples]
    <> [auto $ createColorAttImgView cap imgFormat extent samples | msaaOn]

-- | Attachment order: Private attachments first, followed by one color output attachment having 1 sample.
createRenderPass :: VkDevice
                 -> VkFormat
                 -> VkFormat
                 -> VkSampleCountFlagBits
                 -> VkImageLayout
                 -> MetaResource VkRenderPass
createRenderPass dev colorFormat depthFormat samples colorOutFinalLayout =
  let msaaOn = samples /= VK_SAMPLE_COUNT_1_BIT
      finalColorLayout =
        if msaaOn then
          VK_IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL
        else
          colorOutFinalLayout
      depthAttachment = createVk @VkAttachmentDescription
        $  set @"flags" VK_ZERO_FLAGS
        &* set @"format" depthFormat
        &* set @"samples" samples
        &* set @"loadOp" VK_ATTACHMENT_LOAD_OP_CLEAR
        &* set @"storeOp" VK_ATTACHMENT_STORE_OP_DONT_CARE
        &* set @"stencilLoadOp" VK_ATTACHMENT_LOAD_OP_DONT_CARE
        &* set @"stencilStoreOp" VK_ATTACHMENT_STORE_OP_DONT_CARE
        &* set @"initialLayout" VK_IMAGE_LAYOUT_UNDEFINED
        &* set @"finalLayout" VK_IMAGE_LAYOUT_DEPTH_STENCIL_ATTACHMENT_OPTIMAL

      colorAttachment = createVk @VkAttachmentDescription
        $  set @"flags" VK_ZERO_FLAGS
        &* set @"format" colorFormat
        &* set @"samples" samples
        &* set @"loadOp" VK_ATTACHMENT_LOAD_OP_CLEAR
        &* set @"storeOp" VK_ATTACHMENT_STORE_OP_STORE
        &* set @"stencilLoadOp" VK_ATTACHMENT_LOAD_OP_DONT_CARE
        &* set @"stencilStoreOp" VK_ATTACHMENT_STORE_OP_DONT_CARE
        &* set @"initialLayout" VK_IMAGE_LAYOUT_UNDEFINED
        &* set @"finalLayout" finalColorLayout

      -- this is needed when msaaOn
      resolveAttachment = createVk @VkAttachmentDescription
        $  set @"flags" VK_ZERO_FLAGS
        &* set @"format" colorFormat
        &* set @"samples" VK_SAMPLE_COUNT_1_BIT
        &* set @"loadOp" VK_ATTACHMENT_LOAD_OP_DONT_CARE
        &* set @"storeOp" VK_ATTACHMENT_STORE_OP_STORE
        &* set @"stencilLoadOp" VK_ATTACHMENT_LOAD_OP_DONT_CARE
        &* set @"stencilStoreOp" VK_ATTACHMENT_STORE_OP_DONT_CARE
        &* set @"initialLayout" VK_IMAGE_LAYOUT_UNDEFINED
        -- resolve attachment used => it is the color output
        &* set @"finalLayout" colorOutFinalLayout

      -- subpasses and attachment references
      depthAttachmentRef = createVk @VkAttachmentReference
        $  set @"attachment" 0
        &* set @"layout" VK_IMAGE_LAYOUT_DEPTH_STENCIL_ATTACHMENT_OPTIMAL

      colorAttachmentRef = createVk @VkAttachmentReference
        $  set @"attachment" 1
        &* set @"layout" VK_IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL

      resolveAttachmentRef = createVk @VkAttachmentReference
        $  set @"attachment" 2
        &* set @"layout" VK_IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL

      subpass = createVk @VkSubpassDescription
        $  set @"pipelineBindPoint" VK_PIPELINE_BIND_POINT_GRAPHICS
        &* set @"colorAttachmentCount" 1
        &* setVkRef @"pColorAttachments" colorAttachmentRef
        &* setVkRef @"pDepthStencilAttachment" depthAttachmentRef
        &* ( if msaaOn then
               setVkRef @"pResolveAttachments" resolveAttachmentRef
             else
               set @"pResolveAttachments" VK_NULL
           )
        &* set @"pPreserveAttachments" VK_NULL
        &* set @"pInputAttachments" VK_NULL

      -- subpass dependencies
      dependency = createVk @VkSubpassDependency
        $  set @"srcSubpass" VK_SUBPASS_EXTERNAL
        &* set @"dstSubpass" 0
        &* set @"srcStageMask" VK_PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
        &* set @"srcAccessMask" VK_ZERO_FLAGS
        &* set @"dstStageMask" VK_PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
        &* set @"dstAccessMask"
            (   VK_ACCESS_COLOR_ATTACHMENT_READ_BIT
            .|. VK_ACCESS_COLOR_ATTACHMENT_WRITE_BIT )

      -- render pass
      rpCreateInfo = createVk @VkRenderPassCreateInfo
        $  set @"sType" VK_STRUCTURE_TYPE_RENDER_PASS_CREATE_INFO
        &* set @"pNext" VK_NULL
        &* setListCountAndRef @"attachmentCount" @"pAttachments"
            ([depthAttachment, colorAttachment] <> [resolveAttachment | msaaOn])
        &* set @"subpassCount" 1
        &* setVkRef @"pSubpasses" subpass
        &* set @"dependencyCount" 1
        &* setVkRef @"pDependencies" dependency

  in metaResource
       (\rp -> liftIO $ vkDestroyRenderPass dev rp VK_NULL) $
       withVkPtr rpCreateInfo $ \rpciPtr -> allocaPeek $
         runVk . vkCreateRenderPass dev rpciPtr VK_NULL

createRenderPassBeginInfo :: VkRenderPass -> VkFramebuffer -> VkExtent2D -> VkRenderPassBeginInfo
createRenderPassBeginInfo renderPass framebuffer extent =
  createVk @VkRenderPassBeginInfo
      $  set @"sType" VK_STRUCTURE_TYPE_RENDER_PASS_BEGIN_INFO
      &* set @"pNext" VK_NULL
      &* set @"renderPass" renderPass
      &* set @"framebuffer" framebuffer
      &* setVk @"renderArea"
          (  setVk @"offset"
              ( set @"x" 0 &* set @"y" 0 )
          &* set @"extent" extent
          )
      &* setListCountAndRef @"clearValueCount" @"pClearValues"
          -- This needs to fit the renderpass attachments. Clear values for
          -- attachments that don't use VK_ATTACHMENT_LOAD_OP_CLEAR in loadOp or
          -- stencilLoadOp are ignored.
          [ createVk @VkClearValue
             $ setVk @"depthStencil"
             -- this needs to fit pipeline settings regarding depth, including depthCompareOp
             $  set @"depth" 1.0
             &* set @"stencil" 0
          , createVk @VkClearValue
             $ setVk @"color"
             $ setVec @"float32" (vec4 0 0 0.2 1)
          ]